allow parentheses and brackets inside account names, as ledger does

This commit is contained in:
Simon Michael 2009-05-25 17:28:41 +00:00
parent fe5498f6c2
commit 568e752484
4 changed files with 30 additions and 33 deletions

View File

@ -23,6 +23,11 @@ accountNameFromComponents = concat . intersperse [acctsepchar]
accountLeafName :: AccountName -> String accountLeafName :: AccountName -> String
accountLeafName = last . accountNameComponents 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 :: AccountName -> Int
accountNameLevel "" = 0 accountNameLevel "" = 0
accountNameLevel a = (length $ filter (==acctsepchar) a) + 1 accountNameLevel a = (length $ filter (==acctsepchar) a) + 1

View File

@ -23,8 +23,10 @@ import Data.Time.Calendar
import Ledger.Utils import Ledger.Utils
import Ledger.Types import Ledger.Types
import Ledger.Dates import Ledger.Dates
import Ledger.AccountName
import Ledger.Amount import Ledger.Amount
import Ledger.LedgerTransaction import Ledger.LedgerTransaction
import Ledger.Posting
import Ledger.Commodity import Ledger.Commodity
import Ledger.TimeLog import Ledger.TimeLog
import Ledger.RawLedger import Ledger.RawLedger
@ -362,43 +364,17 @@ ledgerpostings :: GenParser Char LedgerFileCtx [Posting]
ledgerpostings = many1 $ try ledgerposting ledgerpostings = many1 $ try ledgerposting
ledgerposting :: GenParser Char LedgerFileCtx Posting ledgerposting :: GenParser Char LedgerFileCtx Posting
ledgerposting = many1 spacenonewline >> choice [ normalposting, virtualposting, balancedvirtualposting ] ledgerposting = do
many1 spacenonewline
normalposting :: GenParser Char LedgerFileCtx Posting
normalposting = do
status <- ledgerstatus status <- ledgerstatus
account <- transactionaccountname account <- transactionaccountname
let (ptype, account') = (postingTypeFromAccountName account, unbracket account)
amount <- postingamount amount <- postingamount
many spacenonewline many spacenonewline
comment <- ledgercomment comment <- ledgercomment
restofline restofline
parent <- getParentAccount parent <- getParentAccount
return (Posting status account amount comment RegularPosting) return (Posting status account' amount comment ptype)
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)
-- Qualify with the parent account from parsing context -- Qualify with the parent account from parsing context
transactionaccountname :: GenParser Char LedgerFileCtx AccountName 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 -- | account names may have single spaces inside them, and are terminated by two or more spaces
ledgeraccountname :: GenParser Char st String ledgeraccountname :: GenParser Char st String
ledgeraccountname = do ledgeraccountname = do
accountname <- many1 (accountnamechar <|> singlespace) accountname <- many1 (nonspace <|> singlespace)
return $ striptrailingspace accountname return $ striptrailingspace accountname
where where
singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}) singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})
-- couldn't avoid consuming a final space sometimes, harmless -- couldn't avoid consuming a final space sometimes, harmless
striptrailingspace s = if last s == ' ' then init s else s striptrailingspace s = if last s == ' ' then init s else s
accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace -- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace
<?> "account name character (non-bracket, non-parenthesis, non-whitespace)" -- <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"
postingamount :: GenParser Char st MixedAmount postingamount :: GenParser Char st MixedAmount
postingamount = postingamount =

View File

@ -43,3 +43,9 @@ isBalancedVirtual p = ptype p == BalancedVirtualPosting
hasAmount :: Posting -> Bool hasAmount :: Posting -> Bool
hasAmount = (/= missingamt) . pamount hasAmount = (/= missingamt) . pamount
postingTypeFromAccountName a
| head a == '[' && last a == ']' = BalancedVirtualPosting
| head a == '(' && last a == ')' = VirtualPosting
| otherwise = RegularPosting

View File

@ -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: -- other test tools:
-- http://hackage.haskell.org/cgi-bin/hackage-scripts/package/test-framework -- http://hackage.haskell.org/cgi-bin/hackage-scripts/package/test-framework