allow parentheses and brackets inside account names, as ledger does
This commit is contained in:
		
							parent
							
								
									fe5498f6c2
								
							
						
					
					
						commit
						568e752484
					
				@ -23,6 +23,11 @@ accountNameFromComponents = concat . intersperse [acctsepchar]
 | 
			
		||||
accountLeafName :: AccountName -> String
 | 
			
		||||
accountLeafName = last . accountNameComponents
 | 
			
		||||
 | 
			
		||||
unbracket :: String -> String
 | 
			
		||||
unbracket s
 | 
			
		||||
    | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s
 | 
			
		||||
    | otherwise = s
 | 
			
		||||
 | 
			
		||||
accountNameLevel :: AccountName -> Int
 | 
			
		||||
accountNameLevel "" = 0
 | 
			
		||||
accountNameLevel a = (length $ filter (==acctsepchar) a) + 1
 | 
			
		||||
 | 
			
		||||
@ -23,8 +23,10 @@ import Data.Time.Calendar
 | 
			
		||||
import Ledger.Utils
 | 
			
		||||
import Ledger.Types
 | 
			
		||||
import Ledger.Dates
 | 
			
		||||
import Ledger.AccountName
 | 
			
		||||
import Ledger.Amount
 | 
			
		||||
import Ledger.LedgerTransaction
 | 
			
		||||
import Ledger.Posting
 | 
			
		||||
import Ledger.Commodity
 | 
			
		||||
import Ledger.TimeLog
 | 
			
		||||
import Ledger.RawLedger
 | 
			
		||||
@ -362,43 +364,17 @@ ledgerpostings :: GenParser Char LedgerFileCtx [Posting]
 | 
			
		||||
ledgerpostings = many1 $ try ledgerposting
 | 
			
		||||
 | 
			
		||||
ledgerposting :: GenParser Char LedgerFileCtx Posting
 | 
			
		||||
ledgerposting = many1 spacenonewline >> choice [ normalposting, virtualposting, balancedvirtualposting ]
 | 
			
		||||
 | 
			
		||||
normalposting :: GenParser Char LedgerFileCtx Posting
 | 
			
		||||
normalposting = do
 | 
			
		||||
ledgerposting = do
 | 
			
		||||
  many1 spacenonewline
 | 
			
		||||
  status <- ledgerstatus
 | 
			
		||||
  account <- transactionaccountname
 | 
			
		||||
  let (ptype, account') = (postingTypeFromAccountName account, unbracket account)
 | 
			
		||||
  amount <- postingamount
 | 
			
		||||
  many spacenonewline
 | 
			
		||||
  comment <- ledgercomment
 | 
			
		||||
  restofline
 | 
			
		||||
  parent <- getParentAccount
 | 
			
		||||
  return (Posting status account amount comment RegularPosting)
 | 
			
		||||
 | 
			
		||||
virtualposting :: GenParser Char LedgerFileCtx Posting
 | 
			
		||||
virtualposting = do
 | 
			
		||||
  status <- ledgerstatus
 | 
			
		||||
  char '('
 | 
			
		||||
  account <- transactionaccountname
 | 
			
		||||
  char ')'
 | 
			
		||||
  amount <- postingamount
 | 
			
		||||
  many spacenonewline
 | 
			
		||||
  comment <- ledgercomment
 | 
			
		||||
  restofline
 | 
			
		||||
  parent <- getParentAccount
 | 
			
		||||
  return (Posting status account amount comment VirtualPosting)
 | 
			
		||||
 | 
			
		||||
balancedvirtualposting :: GenParser Char LedgerFileCtx Posting
 | 
			
		||||
balancedvirtualposting = do
 | 
			
		||||
  status <- ledgerstatus
 | 
			
		||||
  char '['
 | 
			
		||||
  account <- transactionaccountname
 | 
			
		||||
  char ']'
 | 
			
		||||
  amount <- postingamount
 | 
			
		||||
  many spacenonewline
 | 
			
		||||
  comment <- ledgercomment
 | 
			
		||||
  restofline
 | 
			
		||||
  return (Posting status account amount comment BalancedVirtualPosting)
 | 
			
		||||
  return (Posting status account' amount comment ptype)
 | 
			
		||||
 | 
			
		||||
-- Qualify with the parent account from parsing context
 | 
			
		||||
transactionaccountname :: GenParser Char LedgerFileCtx AccountName
 | 
			
		||||
@ -407,15 +383,15 @@ transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname
 | 
			
		||||
-- | account names may have single spaces inside them, and are terminated by two or more spaces
 | 
			
		||||
ledgeraccountname :: GenParser Char st String
 | 
			
		||||
ledgeraccountname = do
 | 
			
		||||
    accountname <- many1 (accountnamechar <|> singlespace)
 | 
			
		||||
    accountname <- many1 (nonspace <|> singlespace)
 | 
			
		||||
    return $ striptrailingspace accountname
 | 
			
		||||
    where 
 | 
			
		||||
      singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})
 | 
			
		||||
      -- couldn't avoid consuming a final space sometimes, harmless
 | 
			
		||||
      striptrailingspace s = if last s == ' ' then init s else s
 | 
			
		||||
 | 
			
		||||
accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace
 | 
			
		||||
    <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"
 | 
			
		||||
-- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace
 | 
			
		||||
--     <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"
 | 
			
		||||
 | 
			
		||||
postingamount :: GenParser Char st MixedAmount
 | 
			
		||||
postingamount =
 | 
			
		||||
 | 
			
		||||
@ -43,3 +43,9 @@ isBalancedVirtual p = ptype p == BalancedVirtualPosting
 | 
			
		||||
 | 
			
		||||
hasAmount :: Posting -> Bool
 | 
			
		||||
hasAmount = (/= missingamt) . pamount
 | 
			
		||||
 | 
			
		||||
postingTypeFromAccountName a
 | 
			
		||||
    | head a == '[' && last a == ']' = BalancedVirtualPosting
 | 
			
		||||
    | head a == '(' && last a == ')' = VirtualPosting
 | 
			
		||||
    | otherwise = RegularPosting
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
							
								
								
									
										10
									
								
								Tests.hs
									
									
									
									
									
								
							
							
						
						
									
										10
									
								
								Tests.hs
									
									
									
									
									
								
							@ -141,6 +141,16 @@ hledger: could not balance this transaction, amounts do not add up to zero:
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
--@
 | 
			
		||||
 | 
			
		||||
@
 | 
			
		||||
$ printf "2009-01-01 x\n  a  2\n  b (b) b  -1\n  c\n" | hledger -f - print 2>&1; true
 | 
			
		||||
2009/01/01 x
 | 
			
		||||
    a                                              2
 | 
			
		||||
    b (b) b                                       -1
 | 
			
		||||
    c
 | 
			
		||||
 | 
			
		||||
@
 | 
			
		||||
 | 
			
		||||
-}
 | 
			
		||||
-- other test tools:
 | 
			
		||||
-- http://hackage.haskell.org/cgi-bin/hackage-scripts/package/test-framework
 | 
			
		||||
 | 
			
		||||
		Loading…
	
		Reference in New Issue
	
	Block a user