module Hledger.Read.JournalReader (
reader,
parseJournalWith,
getParentAccount,
journal,
directive,
defaultyeardirective,
historicalpricedirective,
datetime,
accountname,
amountp,
amountp',
mamountp',
emptyline,
tests_Hledger_Read_JournalReader
)
where
import qualified Control.Exception as C
import Control.Monad
import Control.Monad.Error
import Data.Char (isNumber)
import Data.Either (partitionEithers)
import Data.List
import Data.List.Split (wordsBy)
import Data.Maybe
import Data.Time.Calendar
import Data.Time.LocalTime
import Safe (headDef)
import Test.HUnit
import Text.ParserCombinators.Parsec hiding (parse)
import Text.Printf
import System.FilePath
import System.Time (getClockTime)
import Hledger.Data
import Hledger.Utils
import Prelude hiding (readFile)
import Hledger.Utils.UTF8IOCompat (readFile)
reader :: Reader
reader = Reader format detect parse
format :: String
format = "journal"
detect :: FilePath -> String -> Bool
detect f _ = takeExtension f `elem` ['.':format, ".j"]
parse :: Maybe FilePath -> FilePath -> String -> ErrorT String IO Journal
parse _ =
parseJournalWith journal
combineJournalUpdates :: [JournalUpdate] -> JournalUpdate
combineJournalUpdates us = liftM (foldl' (.) id) $ sequence us
parseJournalWith :: (GenParser Char JournalContext (JournalUpdate,JournalContext)) -> FilePath -> String -> ErrorT String IO Journal
parseJournalWith p f s = do
tc <- liftIO getClockTime
tl <- liftIO getCurrentLocalTime
y <- liftIO getCurrentYear
case runParser p nullctx{ctxYear=Just y} f s of
Right (updates,ctx) -> do
j <- updates `ap` return nulljournal
case journalFinalise tc tl f s ctx j of
Right j' -> return j'
Left estr -> throwError estr
Left e -> throwError $ show e
setYear :: Integer -> GenParser tok JournalContext ()
setYear y = updateState (\ctx -> ctx{ctxYear=Just y})
getYear :: GenParser tok JournalContext (Maybe Integer)
getYear = liftM ctxYear getState
setCommodityAndStyle :: (Commodity,AmountStyle) -> GenParser tok JournalContext ()
setCommodityAndStyle cs = updateState (\ctx -> ctx{ctxCommodityAndStyle=Just cs})
getCommodityAndStyle :: GenParser tok JournalContext (Maybe (Commodity,AmountStyle))
getCommodityAndStyle = ctxCommodityAndStyle `fmap` getState
pushParentAccount :: String -> GenParser tok JournalContext ()
pushParentAccount parent = updateState addParentAccount
where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 }
popParentAccount :: GenParser tok JournalContext ()
popParentAccount = do ctx0 <- getState
case ctxAccount ctx0 of
[] -> unexpected "End of account block with no beginning"
(_:rest) -> setState $ ctx0 { ctxAccount = rest }
getParentAccount :: GenParser tok JournalContext String
getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState
addAccountAlias :: (AccountName,AccountName) -> GenParser tok JournalContext ()
addAccountAlias a = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})
getAccountAliases :: GenParser tok JournalContext [(AccountName,AccountName)]
getAccountAliases = liftM ctxAliases getState
clearAccountAliases :: GenParser tok JournalContext ()
clearAccountAliases = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})
journal :: GenParser Char JournalContext (JournalUpdate,JournalContext)
journal = do
journalupdates <- many journalItem
eof
finalctx <- getState
return $ (combineJournalUpdates journalupdates, finalctx)
where
journalItem = choice [ directive
, liftM (return . addTransaction) transaction
, liftM (return . addModifierTransaction) modifiertransaction
, liftM (return . addPeriodicTransaction) periodictransaction
, liftM (return . addHistoricalPrice) historicalpricedirective
, emptyline >> return (return id)
] <?> "journal transaction or directive"
directive :: GenParser Char JournalContext JournalUpdate
directive = do
optional $ char '!'
choice' [
includedirective
,aliasdirective
,endaliasesdirective
,accountdirective
,enddirective
,tagdirective
,endtagdirective
,defaultyeardirective
,defaultcommoditydirective
,commodityconversiondirective
,ignoredpricecommoditydirective
]
<?> "directive"
includedirective :: GenParser Char JournalContext JournalUpdate
includedirective = do
string "include"
many1 spacenonewline
filename <- restofline
outerState <- getState
outerPos <- getPosition
let curdir = takeDirectory (sourceName outerPos)
return $ do filepath <- expandPath curdir filename
txt <- readFileOrError outerPos filepath
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
case runParser journal outerState filepath txt of
Right (ju,_) -> combineJournalUpdates [return $ journalAddFile (filepath,txt), ju] `catchError` (throwError . (inIncluded ++))
Left err -> throwError $ inIncluded ++ show err
where readFileOrError pos fp =
ErrorT $ liftM Right (readFile fp) `C.catch`
\e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException))
journalAddFile :: (FilePath,String) -> Journal -> Journal
journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}
accountdirective :: GenParser Char JournalContext JournalUpdate
accountdirective = do
string "account"
many1 spacenonewline
parent <- accountname
newline
pushParentAccount parent
return $ return id
enddirective :: GenParser Char JournalContext JournalUpdate
enddirective = do
string "end"
popParentAccount
return (return id)
aliasdirective :: GenParser Char JournalContext JournalUpdate
aliasdirective = do
string "alias"
many1 spacenonewline
orig <- many1 $ noneOf "="
char '='
alias <- restofline
addAccountAlias (accountNameWithoutPostingType $ strip orig
,accountNameWithoutPostingType $ strip alias)
return $ return id
endaliasesdirective :: GenParser Char JournalContext JournalUpdate
endaliasesdirective = do
string "end aliases"
clearAccountAliases
return (return id)
tagdirective :: GenParser Char JournalContext JournalUpdate
tagdirective = do
string "tag" <?> "tag directive"
many1 spacenonewline
_ <- many1 nonspace
restofline
return $ return id
endtagdirective :: GenParser Char JournalContext JournalUpdate
endtagdirective = do
(string "end tag" <|> string "pop") <?> "end tag or pop directive"
restofline
return $ return id
defaultyeardirective :: GenParser Char JournalContext JournalUpdate
defaultyeardirective = do
char 'Y' <?> "default year"
many spacenonewline
y <- many1 digit
let y' = read y
failIfInvalidYear y
setYear y'
return $ return id
defaultcommoditydirective :: GenParser Char JournalContext JournalUpdate
defaultcommoditydirective = do
char 'D' <?> "default commodity"
many1 spacenonewline
Amount{..} <- amountp
setCommodityAndStyle (acommodity, astyle)
restofline
return $ return id
historicalpricedirective :: GenParser Char JournalContext HistoricalPrice
historicalpricedirective = do
char 'P' <?> "historical price"
many spacenonewline
date <- try (do {LocalTime d _ <- datetime; return d}) <|> date
many1 spacenonewline
symbol <- commoditysymbol
many spacenonewline
price <- amountp
restofline
return $ HistoricalPrice date symbol price
ignoredpricecommoditydirective :: GenParser Char JournalContext JournalUpdate
ignoredpricecommoditydirective = do
char 'N' <?> "ignored-price commodity"
many1 spacenonewline
commoditysymbol
restofline
return $ return id
commodityconversiondirective :: GenParser Char JournalContext JournalUpdate
commodityconversiondirective = do
char 'C' <?> "commodity conversion"
many1 spacenonewline
amountp
many spacenonewline
char '='
many spacenonewline
amountp
restofline
return $ return id
modifiertransaction :: GenParser Char JournalContext ModifierTransaction
modifiertransaction = do
char '=' <?> "modifier transaction"
many spacenonewline
valueexpr <- restofline
postings <- postings
return $ ModifierTransaction valueexpr postings
periodictransaction :: GenParser Char JournalContext PeriodicTransaction
periodictransaction = do
char '~' <?> "periodic transaction"
many spacenonewline
periodexpr <- restofline
postings <- postings
return $ PeriodicTransaction periodexpr postings
transaction :: GenParser Char JournalContext Transaction
transaction = do
date <- date <?> "transaction"
edate <- optionMaybe (effectivedate date) <?> "effective date"
status <- status <?> "cleared flag"
code <- code <?> "transaction code"
let pdescription = many (noneOf ";\n") >>= return . strip
(description, inlinecomment, inlinetag) <-
try (do many1 spacenonewline
d <- pdescription
(c, m) <- inlinecomment
return (d,c,m))
<|> (newline >> return ("", [], []))
(nextlinecomments, nextlinetags) <- commentlines
let comment = unlines $ inlinecomment ++ nextlinecomments
tags = inlinetag ++ nextlinetags
postings <- postings
return $ txnTieKnot $ Transaction date edate status code description comment tags postings ""
tests_transaction = [
"transaction" ~: do
let s `gives` t = do
let p = parseWithCtx nullctx transaction s
assertBool "transaction parser failed" $ isRight p
let Right t2 = p
same f = assertEqual "" (f t) (f t2)
same tdate
same teffectivedate
same tstatus
same tcode
same tdescription
same tcomment
same ttags
same tpreceding_comment_lines
same tpostings
unlines [
"2012/05/14=2012/05/15 (code) desc ; tcomment1",
" ; tcomment2",
" ; ttag1: val1",
" * a $1.00 ; pcomment1",
" ; pcomment2",
" ; ptag1: val1",
" ; ptag2: val2"
]
`gives`
nulltransaction{
tdate=parsedate "2012/05/14",
teffectivedate=Just $ parsedate "2012/05/15",
tstatus=False,
tcode="code",
tdescription="desc",
tcomment="tcomment1\ntcomment2\n",
ttags=[("ttag1","val1")],
tpostings=[
nullposting{
pstatus=True,
paccount="a",
pamount=Mixed [usd 1],
pcomment="pcomment1\npcomment2\n",
ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")],
ptransaction=Nothing
}
],
tpreceding_comment_lines=""
}
assertParseEqual (parseWithCtx nullctx transaction entry1_str) entry1
assertBool "transaction should not parse just a date"
$ isLeft $ parseWithCtx nullctx transaction "2009/1/1\n"
assertBool "transaction should require some postings"
$ isLeft $ parseWithCtx nullctx transaction "2009/1/1 a\n"
let t = parseWithCtx nullctx transaction "2009/1/1 a ;comment\n b 1\n"
assertBool "transaction should not include a comment in the description"
$ either (const False) ((== "a") . tdescription) t
assertBool "parse transaction with following whitespace line" $
isRight $ parseWithCtx nullctx transaction $ unlines [
"2012/1/1"
," a 1"
," b"
," "
]
]
date :: GenParser Char JournalContext Day
date = do
datestr <- many1 $ choice' [digit, datesepchar]
let dateparts = wordsBy (`elem` datesepchars) datestr
currentyear <- getYear
[y,m,d] <- case (dateparts,currentyear) of
([m,d],Just y) -> return [show y,m,d]
([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"
([y,m,d],_) -> return [y,m,d]
_ -> fail $ "bad date: " ++ datestr
let maybedate = fromGregorianValid (read y) (read m) (read d)
case maybedate of
Nothing -> fail $ "bad date: " ++ datestr
Just date -> return date
<?> "full or partial date"
datetime :: GenParser Char JournalContext LocalTime
datetime = do
day <- date
many1 spacenonewline
h <- many1 digit
let h' = read h
guard $ h' >= 0 && h' <= 23
char ':'
m <- many1 digit
let m' = read m
guard $ m' >= 0 && m' <= 59
s <- optionMaybe $ char ':' >> many1 digit
let s' = case s of Just sstr -> read sstr
Nothing -> 0
guard $ s' >= 0 && s' <= 59
optionMaybe $ do
plusminus <- oneOf "-+"
d1 <- digit
d2 <- digit
d3 <- digit
d4 <- digit
return $ plusminus:d1:d2:d3:d4:""
return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
effectivedate :: Day -> GenParser Char JournalContext Day
effectivedate actualdate = do
char '='
let withDefaultYear d p = do
y <- getYear
let (y',_,_) = toGregorian d in setYear y'
r <- p
when (isJust y) $ setYear $ fromJust y
return r
edate <- withDefaultYear actualdate date
return edate
status :: GenParser Char JournalContext Bool
status = try (do { many spacenonewline; char '*' <?> "status"; return True } ) <|> return False
code :: GenParser Char JournalContext String
code = try (do { many1 spacenonewline; char '(' <?> "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
postings :: GenParser Char JournalContext [Posting]
postings = many1 (try posting) <?> "postings"
posting :: GenParser Char JournalContext Posting
posting = do
many1 spacenonewline
status <- status
many spacenonewline
account <- modifiedaccountname
let (ptype, account') = (accountNamePostingType account, unbracket account)
amount <- spaceandamountormissing
_ <- balanceassertion
_ <- fixedlotprice
many spacenonewline
(inlinecomment, inlinetag) <- inlinecomment
(nextlinecomments, nextlinetags) <- commentlines
let comment = unlines $ inlinecomment ++ nextlinecomments
tags = inlinetag ++ nextlinetags
return (Posting status account' amount comment ptype tags Nothing)
tests_posting = [
"posting" ~: do
let s `gives` p = do
let parse = parseWithCtx nullctx posting s
assertBool "posting parser" $ isRight parse
let Right p2 = parse
same f = assertEqual "" (f p) (f p2)
same pstatus
same paccount
same pamount
same pcomment
same ptype
same ptags
same ptransaction
" expenses:food:dining $10.00 ; a: a a \n ; b: b b \n"
`gives`
(Posting False "expenses:food:dining" (Mixed [usd 10]) "" RegularPosting [("a","a a"), ("b","b b")] Nothing)
assertBool "posting parses a quoted commodity with numbers"
(isRight $ parseWithCtx nullctx posting " a 1 \"DE123\"\n")
,"posting parses balance assertions and fixed lot prices" ~: do
assertBool "" (isRight $ parseWithCtx nullctx posting " a 1 \"DE123\" =$1 { =2.2 EUR} \n")
]
modifiedaccountname :: GenParser Char JournalContext AccountName
modifiedaccountname = do
a <- accountname
prefix <- getParentAccount
let prefixed = prefix `joinAccountNames` a
aliases <- getAccountAliases
return $ accountNameApplyAliases aliases prefixed
accountname :: GenParser Char st AccountName
accountname = do
a <- many1 (nonspace <|> singlespace)
let a' = striptrailingspace a
when (accountNameFromComponents (accountNameComponents a') /= a')
(fail $ "accountname seems ill-formed: "++a')
return a'
where
singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})
striptrailingspace s = if last s == ' ' then init s else s
spaceandamountormissing :: GenParser Char JournalContext MixedAmount
spaceandamountormissing =
try (do
many1 spacenonewline
(Mixed . (:[])) `fmap` amountp <|> return missingmixedamt
) <|> return missingmixedamt
tests_spaceandamountormissing = [
"spaceandamountormissing" ~: do
assertParseEqual (parseWithCtx nullctx spaceandamountormissing " $47.18") (Mixed [usd 47.18])
assertParseEqual (parseWithCtx nullctx spaceandamountormissing "$47.18") missingmixedamt
assertParseEqual (parseWithCtx nullctx spaceandamountormissing " ") missingmixedamt
assertParseEqual (parseWithCtx nullctx spaceandamountormissing "") missingmixedamt
]
amountp :: GenParser Char JournalContext Amount
amountp = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount
tests_amountp = [
"amountp" ~: do
assertParseEqual (parseWithCtx nullctx amountp "$47.18") (usd 47.18)
assertParseEqual (parseWithCtx nullctx amountp "$1.") (usd 1 `withPrecision` 0)
,"amount with unit price" ~: do
assertParseEqual
(parseWithCtx nullctx amountp "$10 @ €0.5")
(usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1))
,"amount with total price" ~: do
assertParseEqual
(parseWithCtx nullctx amountp "$10 @@ €5")
(usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0))
]
amountp' :: String -> Amount
amountp' s = either (error' . show) id $ parseWithCtx nullctx amountp s
mamountp' :: String -> MixedAmount
mamountp' = mixed . amountp'
leftsymbolamount :: GenParser Char JournalContext Amount
leftsymbolamount = do
sign <- optionMaybe $ string "-"
let applysign = if isJust sign then negate else id
c <- commoditysymbol
sp <- many spacenonewline
(q,prec,dec,sep,seppos) <- number
let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos}
p <- priceamount
return $ applysign $ Amount c q p s
<?> "left-symbol amount"
rightsymbolamount :: GenParser Char JournalContext Amount
rightsymbolamount = do
(q,prec,dec,sep,seppos) <- number
sp <- many spacenonewline
c <- commoditysymbol
p <- priceamount
let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos}
return $ Amount c q p s
<?> "right-symbol amount"
nosymbolamount :: GenParser Char JournalContext Amount
nosymbolamount = do
(q,prec,dec,sep,seppos) <- number
p <- priceamount
defcs <- getCommodityAndStyle
let (c,s) = case defcs of
Just (c',s') -> (c',s')
Nothing -> ("", amountstyle{asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos})
return $ Amount c q p s
<?> "no-symbol amount"
commoditysymbol :: GenParser Char JournalContext String
commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) <?> "commodity symbol"
quotedcommoditysymbol :: GenParser Char JournalContext String
quotedcommoditysymbol = do
char '"'
s <- many1 $ noneOf ";\n\""
char '"'
return s
simplecommoditysymbol :: GenParser Char JournalContext String
simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars)
priceamount :: GenParser Char JournalContext Price
priceamount =
try (do
many spacenonewline
char '@'
try (do
char '@'
many spacenonewline
a <- amountp
return $ TotalPrice a)
<|> (do
many spacenonewline
a <- amountp
return $ UnitPrice a))
<|> return NoPrice
balanceassertion :: GenParser Char JournalContext (Maybe Amount)
balanceassertion =
try (do
many spacenonewline
char '='
many spacenonewline
a <- amountp
return $ Just a)
<|> return Nothing
fixedlotprice :: GenParser Char JournalContext (Maybe Amount)
fixedlotprice =
try (do
many spacenonewline
char '{'
many spacenonewline
char '='
many spacenonewline
a <- amountp
many spacenonewline
char '}'
return $ Just a)
<|> return Nothing
number :: GenParser Char JournalContext (Quantity, Int, Char, Char, [Int])
number = do
sign <- optionMaybe $ string "-"
parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.']
let numeric = isNumber . headDef '_'
(_, puncparts) = partition numeric parts
(ok,decimalpoint',separator') =
case puncparts of
[] -> (True, Nothing, Nothing)
[d:""] -> (True, Just d, Nothing)
[_] -> (False, Nothing, Nothing)
_:_:_ -> let (s:ss, d) = (init puncparts, last puncparts)
in if (any ((/=1).length) puncparts
|| any (s/=) ss
|| head parts == s)
then (False, Nothing, Nothing)
else if s == d
then (True, Nothing, Just $ head s)
else (True, Just $ head d, Just $ head s)
when (not ok) (fail $ "number seems ill-formed: "++concat parts)
let (intparts',fracparts') = span ((/= decimalpoint') . Just . head) parts
(intparts, fracpart) = (filter numeric intparts', filter numeric fracparts')
separatorpositions = reverse $ map length $ drop 1 intparts
int = concat $ "":intparts
frac = concat $ "":fracpart
precision = length frac
int' = if null int then "0" else int
frac' = if null frac then "0" else frac
sign' = fromMaybe "" sign
quantity = read $ sign'++int'++"."++frac'
(decimalpoint, separator) = case (decimalpoint', separator') of (Just d, Just s) -> (d,s)
(Just '.',Nothing) -> ('.',',')
(Just ',',Nothing) -> (',','.')
(Nothing, Just '.') -> (',','.')
(Nothing, Just ',') -> ('.',',')
_ -> ('.',',')
return (quantity,precision,decimalpoint,separator,separatorpositions)
<?> "number"
tests_number = [
"number" ~: do
let s `is` n = assertParseEqual (parseWithCtx nullctx number s) n
assertFails = assertBool "" . isLeft . parseWithCtx nullctx number
assertFails ""
"0" `is` (0, 0, '.', ',', [])
"1" `is` (1, 0, '.', ',', [])
"1.1" `is` (1.1, 1, '.', ',', [])
"1,000.1" `is` (1000.1, 1, '.', ',', [3])
"1.00.000,1" `is` (100000.1, 1, ',', '.', [3,2])
"1,000,000" `is` (1000000, 0, '.', ',', [3,3])
"1." `is` (1, 0, '.', ',', [])
"1," `is` (1, 0, ',', '.', [])
".1" `is` (0.1, 1, '.', ',', [])
",1" `is` (0.1, 1, ',', '.', [])
assertFails "1,000.000,1"
assertFails "1.000,000.1"
assertFails "1,000.000.1"
assertFails "1,,1"
assertFails "1..1"
assertFails ".1,"
assertFails ",1."
]
emptyline :: GenParser Char JournalContext ()
emptyline = do many spacenonewline
optional $ (char ';' <?> "comment") >> many (noneOf "\n")
newline
return ()
comment :: GenParser Char JournalContext String
comment = do
many1 $ char ';'
many spacenonewline
c <- many (noneOf "\n")
return $ rstrip c
<?> "comment"
commentline :: GenParser Char JournalContext String
commentline = do
many spacenonewline
c <- comment
optional newline
eof
return c
<?> "comment"
inlinecomment :: GenParser Char JournalContext ([String],[Tag])
inlinecomment = try (do {tag <- tagcomment; newline; return ([], [tag])})
<|> (do {c <- comment; newline; return ([rstrip c], [])})
<|> (newline >> return ([], []))
tests_inlinecomment = [
"inlinecomment" ~: do
let s `gives` r = assertParseEqual (parseWithCtx nullctx inlinecomment s) r
"; comment \n" `gives` (["comment"],[])
";tag: a value \n" `gives` ([],[("tag","a value")])
]
commentlines :: GenParser Char JournalContext ([String],[Tag])
commentlines = do
comortags <- many $ choice' [(liftM Right tagline)
,(do {many1 spacenonewline; c <- comment; newline; return $ Left c })
]
return $ partitionEithers comortags
tests_commentlines = [
"commentlines" ~: do
let s `gives` r = assertParseEqual (parseWithCtx nullctx commentlines s) r
" ; comment 1 \n ; tag1: val1 \n ;comment 2\n;unindented comment\n"
`gives` (["comment 1","comment 2"],[("tag1","val1")])
]
tagline :: GenParser Char JournalContext Tag
tagline = do
many1 spacenonewline
tag <- tagcomment
newline
return tag
tagcomment :: GenParser Char JournalContext Tag
tagcomment = do
many1 $ char ';'
many spacenonewline
name <- many1 $ noneOf ": \t"
char ':'
many spacenonewline
value <- many (noneOf "\n")
return (name, rstrip value)
<?> "tag comment"
tests_tagcomment = [
"tagcomment" ~: do
let s `gives` r = assertParseEqual (parseWithCtx nullctx tagcomment s) r
";tag: a value \n" `gives` ("tag","a value")
]
tests_Hledger_Read_JournalReader = TestList $ concat [
tests_number,
tests_amountp,
tests_spaceandamountormissing,
tests_tagcomment,
tests_inlinecomment,
tests_commentlines,
tests_posting,
tests_transaction,
[
"modifiertransaction" ~: do
assertParse (parseWithCtx nullctx modifiertransaction "= (some value expr)\n some:postings 1\n")
,"periodictransaction" ~: do
assertParse (parseWithCtx nullctx periodictransaction "~ (some period expr)\n some:postings 1\n")
,"directive" ~: do
assertParse (parseWithCtx nullctx directive "!include /some/file.x\n")
assertParse (parseWithCtx nullctx directive "account some:account\n")
assertParse (parseWithCtx nullctx (directive >> directive) "!account a\nend\n")
,"commentline" ~: do
assertParse (parseWithCtx nullctx commentline "; some comment \n")
assertParse (parseWithCtx nullctx commentline " \t; x\n")
assertParse (parseWithCtx nullctx commentline ";x")
,"date" ~: do
assertParse (parseWithCtx nullctx date "2011/1/1")
assertParseFailure (parseWithCtx nullctx date "1/1")
assertParse (parseWithCtx nullctx{ctxYear=Just 2011} date "1/1")
,"datetime" ~: do
let p = do {t <- datetime; eof; return t}
bad = assertParseFailure . parseWithCtx nullctx p
good = assertParse . parseWithCtx nullctx p
bad "2011/1/1"
bad "2011/1/1 24:00:00"
bad "2011/1/1 00:60:00"
bad "2011/1/1 00:00:60"
good "2011/1/1 00:00"
good "2011/1/1 23:59:59"
good "2011/1/1 3:5:7"
let startofday = LocalTime (fromGregorian 2011 1 1) (TimeOfDay 0 0 (fromIntegral 0))
assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00-0800") startofday
assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00+1234") startofday
,"defaultyeardirective" ~: do
assertParse (parseWithCtx nullctx defaultyeardirective "Y 2010\n")
assertParse (parseWithCtx nullctx defaultyeardirective "Y 10001\n")
,"historicalpricedirective" ~:
assertParseEqual (parseWithCtx nullctx historicalpricedirective "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ usd 55)
,"ignoredpricecommoditydirective" ~: do
assertParse (parseWithCtx nullctx ignoredpricecommoditydirective "N $\n")
,"defaultcommoditydirective" ~: do
assertParse (parseWithCtx nullctx defaultcommoditydirective "D $1,000.0\n")
,"commodityconversiondirective" ~: do
assertParse (parseWithCtx nullctx commodityconversiondirective "C 1h = $50.00\n")
,"tagdirective" ~: do
assertParse (parseWithCtx nullctx tagdirective "tag foo \n")
,"endtagdirective" ~: do
assertParse (parseWithCtx nullctx endtagdirective "end tag \n")
assertParse (parseWithCtx nullctx endtagdirective "pop \n")
,"accountname" ~: do
assertBool "accountname parses a normal accountname" (isRight $ parsewith accountname "a:b:c")
assertBool "accountname rejects an empty inner component" (isLeft $ parsewith accountname "a::c")
assertBool "accountname rejects an empty leading component" (isLeft $ parsewith accountname ":b:c")
assertBool "accountname rejects an empty trailing component" (isLeft $ parsewith accountname "a:b:")
,"leftsymbolamount" ~: do
assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1") (usd 1 `withPrecision` 0)
assertParseEqual (parseWithCtx nullctx leftsymbolamount "$-1") (usd (1) `withPrecision` 0)
assertParseEqual (parseWithCtx nullctx leftsymbolamount "-$1") (usd (1) `withPrecision` 0)
,"amount" ~: do
let
assertAmountParse parseresult amount =
(either (const "parse error") showAmountDebug parseresult) ~?= (showAmountDebug amount)
assertAmountParse (parseWithCtx nullctx amountp "1 @ $2")
(num 1 `withPrecision` 0 `at` (usd 2 `withPrecision` 0))
]]
entry1_str = unlines
["2007/01/28 coopportunity"
," expenses:food:groceries $47.18"
," assets:checking $-47.18"
,""
]
entry1 =
txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []
[Posting False "expenses:food:groceries" (Mixed [usd 47.18]) "" RegularPosting [] Nothing,
Posting False "assets:checking" (Mixed [usd (47.18)]) "" RegularPosting [] Nothing] ""