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 :: 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
|
||||||
|
|||||||
@ -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 =
|
||||||
|
|||||||
@ -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
|
||||||
|
|
||||||
|
|||||||
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:
|
-- 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
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user