slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lib: rename and expose more journal file parsers

Browse Source
This commit is contained in:
Simon Michael 2014-02-05 18:55:38 -08:00
parent ac95930b15
commit 5223bc5c41
2 changed files with 35 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
hledger-lib/Hledger/Read.hs
View File

@ -19,11 +19,12 @@ module Hledger.Read (
ensureJournalFileExists, ensureJournalFileExists,
-- * Parsers used elsewhere -- * Parsers used elsewhere
postingp, postingp,
accountname, accountnamep,
amountp, amountp,
amountp', amountp',
mamountp', mamountp',
code, numberp,
codep,
-- * Tests -- * Tests
samplejournal, samplejournal,
tests_Hledger_Read, tests_Hledger_Read,

63
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -26,13 +26,14 @@ module Hledger.Read.JournalReader (
directive, directive,
defaultyeardirective, defaultyeardirective,
historicalpricedirective, historicalpricedirective,
datetime, datetimep,
code, codep,
accountname, accountnamep,
postingp, postingp,
amountp, amountp,
amountp', amountp',
mamountp', mamountp',
numberp,
emptyline emptyline
#ifdef TESTS #ifdef TESTS
-- * Tests -- * Tests
@ -207,7 +208,7 @@ accountdirective :: GenParser Char JournalContext JournalUpdate
accountdirective = do accountdirective = do
string "account" string "account"
many1 spacenonewline many1 spacenonewline
parent <- accountname parent <- accountnamep
newline newline
pushParentAccount parent pushParentAccount parent
return $ return id return $ return id
@ -272,7 +273,7 @@ historicalpricedirective :: GenParser Char JournalContext HistoricalPrice
historicalpricedirective = do historicalpricedirective = do
char 'P' <?> "historical price" char 'P' <?> "historical price"
many spacenonewline many spacenonewline
date <- try (do {LocalTime d _ <- datetime; return d}) <|> date -- a time is ignored date <- try (do {LocalTime d _ <- datetimep; return d}) <|> date -- a time is ignored
many1 spacenonewline many1 spacenonewline
symbol <- commoditysymbol symbol <- commoditysymbol
many spacenonewline many spacenonewline
@ -323,7 +324,7 @@ transaction = do
date <- date <?> "transaction" date <- date <?> "transaction"
edate <- optionMaybe (secondarydate date) <?> "secondary date" edate <- optionMaybe (secondarydate date) <?> "secondary date"
status <- status <?> "cleared flag" status <- status <?> "cleared flag"
code <- code <?> "transaction code" code <- codep <?> "transaction code"
description <- descriptionp >>= return . strip description <- descriptionp >>= return . strip
comment <- try followingcomment <|> (newline >> return "") comment <- try followingcomment <|> (newline >> return "")
let tags = tagsInComment comment let tags = tagsInComment comment
@ -443,8 +444,8 @@ date = do
-- timezone will be ignored; the time is treated as local time. Fewer -- timezone will be ignored; the time is treated as local time. Fewer
-- digits are allowed, except in the timezone. The year may be omitted if -- digits are allowed, except in the timezone. The year may be omitted if
-- a default year has already been set. -- a default year has already been set.
datetime :: GenParser Char JournalContext LocalTime datetimep :: GenParser Char JournalContext LocalTime
datetime = do datetimep = do
day <- date day <- date
many1 spacenonewline many1 spacenonewline
h <- many1 digit h <- many1 digit
@ -487,8 +488,8 @@ secondarydate primarydate = do
status :: GenParser Char JournalContext Bool status :: GenParser Char JournalContext Bool
status = try (do { many spacenonewline; (char '*' <|> char '!') <?> "status"; return True } ) <|> return False status = try (do { many spacenonewline; (char '*' <|> char '!') <?> "status"; return True } ) <|> return False
code :: GenParser Char JournalContext String codep :: GenParser Char JournalContext String
code = try (do { many1 spacenonewline; char '(' <?> "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" codep = try (do { many1 spacenonewline; char '(' <?> "codep"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
-- Parse the following whitespace-beginning lines as postings, posting tags, and/or comments. -- Parse the following whitespace-beginning lines as postings, posting tags, and/or comments.
postings :: GenParser Char JournalContext [Posting] postings :: GenParser Char JournalContext [Posting]
@ -570,7 +571,7 @@ test_postingp = do
-- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect. -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
modifiedaccountname :: GenParser Char JournalContext AccountName modifiedaccountname :: GenParser Char JournalContext AccountName
modifiedaccountname = do modifiedaccountname = do
a <- accountname a <- accountnamep
prefix <- getParentAccount prefix <- getParentAccount
let prefixed = prefix `joinAccountNames` a let prefixed = prefix `joinAccountNames` a
aliases <- getAccountAliases aliases <- getAccountAliases
@ -580,12 +581,12 @@ modifiedaccountname = do
-- them, and are terminated by two or more spaces. They should have one or -- them, and are terminated by two or more spaces. They should have one or
-- more components of at least one character, separated by the account -- more components of at least one character, separated by the account
-- separator char. -- separator char.
accountname :: GenParser Char st AccountName accountnamep :: GenParser Char st AccountName
accountname = do accountnamep = do
a <- many1 (nonspace <|> singlespace) a <- many1 (nonspace <|> singlespace)
let a' = striptrailingspace a let a' = striptrailingspace a
when (accountNameFromComponents (accountNameComponents a') /= a') when (accountNameFromComponents (accountNameComponents a') /= a')
(fail $ "accountname seems ill-formed: "++a') (fail $ "account name seems ill-formed: "++a')
return a' return a'
where where
singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}) singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})
@ -653,7 +654,7 @@ leftsymbolamount = do
let applysign = if isJust sign then negate else id let applysign = if isJust sign then negate else id
c <- commoditysymbol c <- commoditysymbol
sp <- many spacenonewline sp <- many spacenonewline
(q,prec,dec,sep,seppos) <- number (q,prec,dec,sep,seppos) <- numberp
let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos} let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos}
p <- priceamount p <- priceamount
return $ applysign $ Amount c q p s return $ applysign $ Amount c q p s
@ -661,7 +662,7 @@ leftsymbolamount = do
rightsymbolamount :: GenParser Char JournalContext Amount rightsymbolamount :: GenParser Char JournalContext Amount
rightsymbolamount = do rightsymbolamount = do
(q,prec,dec,sep,seppos) <- number (q,prec,dec,sep,seppos) <- numberp
sp <- many spacenonewline sp <- many spacenonewline
c <- commoditysymbol c <- commoditysymbol
p <- priceamount p <- priceamount
@ -671,7 +672,7 @@ rightsymbolamount = do
nosymbolamount :: GenParser Char JournalContext Amount nosymbolamount :: GenParser Char JournalContext Amount
nosymbolamount = do nosymbolamount = do
(q,prec,dec,sep,seppos) <- number (q,prec,dec,sep,seppos) <- numberp
p <- priceamount p <- priceamount
defcs <- getCommodityAndStyle defcs <- getCommodityAndStyle
let (c,s) = case defcs of let (c,s) = case defcs of
@ -744,8 +745,8 @@ fixedlotprice =
-- and separator characters (defaulting to . and ,), and the positions of -- and separator characters (defaulting to . and ,), and the positions of
-- separators (counting leftward from the decimal point, the last is -- separators (counting leftward from the decimal point, the last is
-- assumed to repeat). -- assumed to repeat).
number :: GenParser Char JournalContext (Quantity, Int, Char, Char, [Int]) numberp :: GenParser Char JournalContext (Quantity, Int, Char, Char, [Int])
number = do numberp = do
sign <- optionMaybe $ string "-" sign <- optionMaybe $ string "-"
parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.'] parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.']
let numeric = isNumber . headDef '_' let numeric = isNumber . headDef '_'
@ -781,12 +782,12 @@ number = do
(Nothing, Just ',') -> ('.',',') (Nothing, Just ',') -> ('.',',')
_ -> ('.',',') _ -> ('.',',')
return (quantity,precision,decimalpoint,separator,separatorpositions) return (quantity,precision,decimalpoint,separator,separatorpositions)
<?> "number" <?> "numberp"
#ifdef TESTS #ifdef TESTS
test_number = do test_numberp = do
let s `is` n = assertParseEqual' (parseWithCtx nullctx number s) n let s `is` n = assertParseEqual' (parseWithCtx nullctx numberp s) n
assertFails = assertBool . isLeft . parseWithCtx nullctx number assertFails = assertBool . isLeft . parseWithCtx nullctx numberp
assertFails "" assertFails ""
"0" `is` (0, 0, '.', ',', []) "0" `is` (0, 0, '.', ',', [])
"1" `is` (1, 0, '.', ',', []) "1" `is` (1, 0, '.', ',', [])
@ -893,7 +894,7 @@ date2ValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date2") . fst) ts
{- old hunit tests {- old hunit tests
test_Hledger_Read_JournalReader = TestList $ concat [ test_Hledger_Read_JournalReader = TestList $ concat [
test_number, test_numberp,
test_amountp, test_amountp,
test_spaceandamountormissing, test_spaceandamountormissing,
test_tagcomment, test_tagcomment,
@ -924,8 +925,8 @@ test_Hledger_Read_JournalReader = TestList $ concat [
assertParseFailure (parseWithCtx nullctx date "1/1") assertParseFailure (parseWithCtx nullctx date "1/1")
assertParse (parseWithCtx nullctx{ctxYear=Just 2011} date "1/1") assertParse (parseWithCtx nullctx{ctxYear=Just 2011} date "1/1")
,"datetime" ~: do ,"datetimep" ~: do
let p = do {t <- datetime; eof; return t} let p = do {t <- datetimep; eof; return t}
bad = assertParseFailure . parseWithCtx nullctx p bad = assertParseFailure . parseWithCtx nullctx p
good = assertParse . parseWithCtx nullctx p good = assertParse . parseWithCtx nullctx p
bad "2011/1/1" bad "2011/1/1"
@ -963,11 +964,11 @@ test_Hledger_Read_JournalReader = TestList $ concat [
assertParse (parseWithCtx nullctx endtagdirective "end tag \n") assertParse (parseWithCtx nullctx endtagdirective "end tag \n")
assertParse (parseWithCtx nullctx endtagdirective "pop \n") assertParse (parseWithCtx nullctx endtagdirective "pop \n")
,"accountname" ~: do ,"accountnamep" ~: do
assertBool "accountname parses a normal accountname" (isRight $ parsewith accountname "a:b:c") assertBool "accountnamep parses a normal account name" (isRight $ parsewith accountnamep "a:b:c")
assertBool "accountname rejects an empty inner component" (isLeft $ parsewith accountname "a::c") assertBool "accountnamep rejects an empty inner component" (isLeft $ parsewith accountnamep "a::c")
assertBool "accountname rejects an empty leading component" (isLeft $ parsewith accountname ":b:c") assertBool "accountnamep rejects an empty leading component" (isLeft $ parsewith accountnamep ":b:c")
assertBool "accountname rejects an empty trailing component" (isLeft $ parsewith accountname "a:b:") assertBool "accountnamep rejects an empty trailing component" (isLeft $ parsewith accountnamep "a:b:")
,"leftsymbolamount" ~: do ,"leftsymbolamount" ~: do
assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1") (usd 1 `withPrecision` 0) assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1") (usd 1 `withPrecision` 0)