0f5ee154c4
The journal/timeclock/timedot parsers, instead of constructing (opaque) journal update functions which are later applied to build the journal, now construct the journal directly (by modifying the parser state). This is easier to understand and debug. It also removes any possibility of the journal updates being a space leak. (They weren't, in fact memory usage is now slightly higher, but that will be addressed in other ways.) Also: Journal data and journal parse info have been merged into one type (for now), and field names are more consistent. The ParsedJournal type alias has been added to distinguish being-parsed and finalised journals. Journal is now a monoid. stats: fixed an issue with ordering of include files journal: fixed an issue with ordering of included same-date transactions timeclock: sessions can no longer span file boundaries (unclocked-out sessions will be auto-closed at the end of the file). expandPath now throws a proper IO error (and requires the IO monad).
719 lines
24 KiB
Haskell
719 lines
24 KiB
Haskell
--- * doc
|
|
-- Lines beginning "--- *" are collapsible orgstruct nodes. Emacs users,
|
|
-- (add-hook 'haskell-mode-hook
|
|
-- (lambda () (set-variable 'orgstruct-heading-prefix-regexp "--- " t))
|
|
-- 'orgstruct-mode)
|
|
-- and press TAB on nodes to expand/collapse.
|
|
|
|
{-|
|
|
|
|
A reader for hledger's journal file format
|
|
(<http://hledger.org/MANUAL.html#the-journal-file>). hledger's journal
|
|
format is a compatible subset of c++ ledger's
|
|
(<http://ledger-cli.org/3.0/doc/ledger3.html#Journal-Format>), so this
|
|
reader should handle many ledger files as well. Example:
|
|
|
|
@
|
|
2012\/3\/24 gift
|
|
expenses:gifts $10
|
|
assets:cash
|
|
@
|
|
|
|
Journal format supports the include directive which can read files in
|
|
other formats, so the other file format readers need to be importable
|
|
here. Some low-level journal syntax parsers which those readers also
|
|
use are therefore defined separately in Hledger.Read.Common, avoiding
|
|
import cycles.
|
|
|
|
-}
|
|
|
|
--- * module
|
|
|
|
{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, NoMonoLocalBinds, ScopedTypeVariables, FlexibleContexts, TupleSections #-}
|
|
|
|
module Hledger.Read.JournalReader (
|
|
|
|
--- * exports
|
|
|
|
-- * Reader
|
|
reader,
|
|
|
|
-- * Parsing utils
|
|
genericSourcePos,
|
|
parseAndFinaliseJournal,
|
|
runStringParser,
|
|
rsp,
|
|
runJournalParser,
|
|
rjp,
|
|
runErroringJournalParser,
|
|
rejp,
|
|
|
|
-- * Parsers used elsewhere
|
|
getParentAccount,
|
|
journalp,
|
|
directivep,
|
|
defaultyeardirectivep,
|
|
marketpricedirectivep,
|
|
datetimep,
|
|
datep,
|
|
-- codep,
|
|
-- accountnamep,
|
|
modifiedaccountnamep,
|
|
postingp,
|
|
-- amountp,
|
|
-- amountp',
|
|
-- mamountp',
|
|
-- numberp,
|
|
statusp,
|
|
emptyorcommentlinep,
|
|
followingcommentp,
|
|
accountaliasp
|
|
|
|
-- * Tests
|
|
,tests_Hledger_Read_JournalReader
|
|
|
|
)
|
|
where
|
|
--- * imports
|
|
import Prelude ()
|
|
import Prelude.Compat hiding (readFile)
|
|
import qualified Control.Exception as C
|
|
import Control.Monad
|
|
import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError)
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Monoid
|
|
import Data.Time.Calendar
|
|
import Data.Time.LocalTime
|
|
import Safe
|
|
import Test.HUnit
|
|
#ifdef TESTS
|
|
import Test.Framework
|
|
import Text.Parsec.Error
|
|
#endif
|
|
import Text.Parsec hiding (parse)
|
|
import Text.Printf
|
|
import System.FilePath
|
|
|
|
import Hledger.Data
|
|
import Hledger.Read.Common
|
|
import Hledger.Read.TimeclockReader (timeclockfilep)
|
|
import Hledger.Read.TimedotReader (timedotfilep)
|
|
import Hledger.Utils
|
|
|
|
|
|
--- * reader
|
|
|
|
reader :: Reader
|
|
reader = Reader format detect parse
|
|
|
|
format :: String
|
|
format = "journal"
|
|
|
|
-- | Does the given file path and data look like it might be hledger's journal format ?
|
|
detect :: FilePath -> String -> Bool
|
|
detect f s
|
|
| f /= "-" = takeExtension f `elem` ['.':format, ".j"] -- from a known file name: yes if the extension is this format's name or .j
|
|
| otherwise = regexMatches "(^|\n)[0-9]+.*\n[ \t]+" s -- from stdin: yes if we can see something that looks like a journal entry (digits in column 0 with the next line indented)
|
|
|
|
-- | Parse and post-process a "Journal" from hledger's journal file
|
|
-- format, or give an error.
|
|
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal
|
|
parse _ = parseAndFinaliseJournal journalp
|
|
|
|
--- * parsers
|
|
--- ** journal
|
|
|
|
-- | A journal parser. Accumulates and returns a "ParsedJournal",
|
|
-- which should be finalised/validated before use.
|
|
--
|
|
-- >>> rejp (journalp <* eof) "2015/1/1\n a 0\n"
|
|
-- Right Journal with 1 transactions, 1 accounts
|
|
--
|
|
journalp :: ErroringJournalParser ParsedJournal
|
|
journalp = do
|
|
many addJournalItemP
|
|
eof
|
|
getState
|
|
|
|
-- | A side-effecting parser; parses any kind of journal item
|
|
-- and updates the parse state accordingly.
|
|
addJournalItemP :: ErroringJournalParser ()
|
|
addJournalItemP = do
|
|
-- all journal line types can be distinguished by the first
|
|
-- character, can use choice without backtracking
|
|
choice [
|
|
directivep
|
|
, transactionp >>= modifyState . addTransaction
|
|
, modifiertransactionp >>= modifyState . addModifierTransaction
|
|
, periodictransactionp >>= modifyState . addPeriodicTransaction
|
|
, marketpricedirectivep >>= modifyState . addMarketPrice
|
|
, void emptyorcommentlinep
|
|
, void multilinecommentp
|
|
] <?> "transaction or directive"
|
|
|
|
--- ** directives
|
|
|
|
-- | Parse any journal directive and update the parse state accordingly.
|
|
-- Cf http://hledger.org/manual.html#directives,
|
|
-- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives
|
|
directivep :: ErroringJournalParser ()
|
|
directivep = do
|
|
optional $ char '!'
|
|
choice' [
|
|
includedirectivep
|
|
,aliasdirectivep
|
|
,endaliasesdirectivep
|
|
,accountdirectivep
|
|
,applyaccountdirectivep
|
|
,commoditydirectivep
|
|
,endapplyaccountdirectivep
|
|
,tagdirectivep
|
|
,endtagdirectivep
|
|
,defaultyeardirectivep
|
|
,defaultcommoditydirectivep
|
|
,commodityconversiondirectivep
|
|
,ignoredpricecommoditydirectivep
|
|
]
|
|
<?> "directive"
|
|
|
|
newJournalWithParseStateFrom :: Journal -> Journal
|
|
newJournalWithParseStateFrom j = mempty{
|
|
jparsedefaultyear = jparsedefaultyear j
|
|
,jparsedefaultcommodity = jparsedefaultcommodity j
|
|
,jparseparentaccounts = jparseparentaccounts j
|
|
,jparsealiases = jparsealiases j
|
|
,jparsetransactioncount = jparsetransactioncount j
|
|
,jparsetimeclockentries = jparsetimeclockentries j
|
|
}
|
|
|
|
includedirectivep :: ErroringJournalParser ()
|
|
includedirectivep = do
|
|
string "include"
|
|
many1 spacenonewline
|
|
filename <- restofline
|
|
parentpos <- getPosition
|
|
parentj <- getState
|
|
let childj = newJournalWithParseStateFrom parentj
|
|
(ep :: Either String ParsedJournal) <-
|
|
liftIO $ runExceptT $ do
|
|
let curdir = takeDirectory (sourceName parentpos)
|
|
filepath <- expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename)
|
|
txt <- readFile' filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
|
|
(ep1::Either ParseError ParsedJournal) <-
|
|
runParserT
|
|
(choice' [journalp
|
|
,timeclockfilep
|
|
,timedotfilep
|
|
-- can't include a csv file yet, that reader is special
|
|
])
|
|
childj filepath txt
|
|
either
|
|
(throwError
|
|
. ((show parentpos ++ " in included file " ++ show filename ++ ":\n") ++)
|
|
. show)
|
|
(return . journalAddFile (filepath,txt))
|
|
ep1
|
|
case ep of
|
|
Left e -> throwError e
|
|
Right jchild -> modifyState (\jparent ->
|
|
-- trace ("jparent txns: " ++ show (jtxns jparent)) $ trace ("jchild txns: "++ show (jtxns jchild)) $
|
|
jchild <> jparent)
|
|
|
|
-- | Lift an IO action into the exception monad, rethrowing any IO
|
|
-- error with the given message prepended.
|
|
orRethrowIOError :: IO a -> String -> ExceptT String IO a
|
|
orRethrowIOError io msg =
|
|
ExceptT $
|
|
(Right <$> io)
|
|
`C.catch` \(e::C.IOException) -> return $ Left $ printf "%s:\n%s" msg (show e)
|
|
|
|
accountdirectivep :: ErroringJournalParser ()
|
|
accountdirectivep = do
|
|
string "account"
|
|
many1 spacenonewline
|
|
acct <- accountnamep
|
|
newline
|
|
_ <- many indentedlinep
|
|
modifyState (\j -> j{jaccounts = acct : jaccounts j})
|
|
|
|
indentedlinep = many1 spacenonewline >> (rstrip <$> restofline)
|
|
|
|
-- | Parse a one-line or multi-line commodity directive.
|
|
--
|
|
-- >>> Right _ <- rejp commoditydirectivep "commodity $1.00"
|
|
-- >>> Right _ <- rejp commoditydirectivep "commodity $\n format $1.00"
|
|
-- >>> Right _ <- rejp commoditydirectivep "commodity $\n\n" -- a commodity with no format
|
|
-- >>> Right _ <- rejp commoditydirectivep "commodity $1.00\n format $1.00" -- both, what happens ?
|
|
commoditydirectivep :: ErroringJournalParser ()
|
|
commoditydirectivep = try commoditydirectiveonelinep <|> commoditydirectivemultilinep
|
|
|
|
-- | Parse a one-line commodity directive.
|
|
--
|
|
-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00"
|
|
-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00 ; blah\n"
|
|
commoditydirectiveonelinep :: ErroringJournalParser ()
|
|
commoditydirectiveonelinep = do
|
|
string "commodity"
|
|
many1 spacenonewline
|
|
Amount{acommodity,astyle} <- amountp
|
|
many spacenonewline
|
|
_ <- followingcommentp <|> (eolof >> return "")
|
|
let comm = Commodity{csymbol=acommodity, cformat=Just astyle}
|
|
modifyState (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})
|
|
|
|
-- | Parse a multi-line commodity directive, containing 0 or more format subdirectives.
|
|
--
|
|
-- >>> Right _ <- rejp commoditydirectivemultilinep "commodity $ ; blah \n format $1.00 ; blah"
|
|
commoditydirectivemultilinep :: ErroringJournalParser ()
|
|
commoditydirectivemultilinep = do
|
|
string "commodity"
|
|
many1 spacenonewline
|
|
sym <- commoditysymbolp
|
|
_ <- followingcommentp <|> (eolof >> return "")
|
|
mformat <- lastMay <$> many (indented $ formatdirectivep sym)
|
|
let comm = Commodity{csymbol=sym, cformat=mformat}
|
|
modifyState (\j -> j{jcommodities=M.insert sym comm $ jcommodities j})
|
|
where
|
|
indented = (many1 spacenonewline >>)
|
|
|
|
-- | Parse a format (sub)directive, throwing a parse error if its
|
|
-- symbol does not match the one given.
|
|
formatdirectivep :: CommoditySymbol -> ErroringJournalParser AmountStyle
|
|
formatdirectivep expectedsym = do
|
|
string "format"
|
|
many1 spacenonewline
|
|
pos <- getPosition
|
|
Amount{acommodity,astyle} <- amountp
|
|
_ <- followingcommentp <|> (eolof >> return "")
|
|
if acommodity==expectedsym
|
|
then return astyle
|
|
else parserErrorAt pos $
|
|
printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity
|
|
|
|
applyaccountdirectivep :: ErroringJournalParser ()
|
|
applyaccountdirectivep = do
|
|
string "apply" >> many1 spacenonewline >> string "account"
|
|
many1 spacenonewline
|
|
parent <- accountnamep
|
|
newline
|
|
pushParentAccount parent
|
|
|
|
endapplyaccountdirectivep :: ErroringJournalParser ()
|
|
endapplyaccountdirectivep = do
|
|
string "end" >> many1 spacenonewline >> string "apply" >> many1 spacenonewline >> string "account"
|
|
popParentAccount
|
|
|
|
aliasdirectivep :: ErroringJournalParser ()
|
|
aliasdirectivep = do
|
|
string "alias"
|
|
many1 spacenonewline
|
|
alias <- accountaliasp
|
|
addAccountAlias alias
|
|
|
|
accountaliasp :: Monad m => StringParser u m AccountAlias
|
|
accountaliasp = regexaliasp <|> basicaliasp
|
|
|
|
basicaliasp :: Monad m => StringParser u m AccountAlias
|
|
basicaliasp = do
|
|
-- pdbg 0 "basicaliasp"
|
|
old <- rstrip <$> many1 (noneOf "=")
|
|
char '='
|
|
many spacenonewline
|
|
new <- rstrip <$> anyChar `manyTill` eolof -- don't require a final newline, good for cli options
|
|
return $ BasicAlias old new
|
|
|
|
regexaliasp :: Monad m => StringParser u m AccountAlias
|
|
regexaliasp = do
|
|
-- pdbg 0 "regexaliasp"
|
|
char '/'
|
|
re <- many1 $ noneOf "/\n\r" -- paranoid: don't try to read past line end
|
|
char '/'
|
|
many spacenonewline
|
|
char '='
|
|
many spacenonewline
|
|
repl <- rstrip <$> anyChar `manyTill` eolof
|
|
return $ RegexAlias re repl
|
|
|
|
endaliasesdirectivep :: ErroringJournalParser ()
|
|
endaliasesdirectivep = do
|
|
string "end aliases"
|
|
clearAccountAliases
|
|
|
|
tagdirectivep :: ErroringJournalParser ()
|
|
tagdirectivep = do
|
|
string "tag" <?> "tag directive"
|
|
many1 spacenonewline
|
|
_ <- many1 nonspace
|
|
restofline
|
|
return ()
|
|
|
|
endtagdirectivep :: ErroringJournalParser ()
|
|
endtagdirectivep = do
|
|
(string "end tag" <|> string "pop") <?> "end tag or pop directive"
|
|
restofline
|
|
return ()
|
|
|
|
defaultyeardirectivep :: ErroringJournalParser ()
|
|
defaultyeardirectivep = do
|
|
char 'Y' <?> "default year"
|
|
many spacenonewline
|
|
y <- many1 digit
|
|
let y' = read y
|
|
failIfInvalidYear y
|
|
setYear y'
|
|
|
|
defaultcommoditydirectivep :: ErroringJournalParser ()
|
|
defaultcommoditydirectivep = do
|
|
char 'D' <?> "default commodity"
|
|
many1 spacenonewline
|
|
Amount{..} <- amountp
|
|
restofline
|
|
setDefaultCommodityAndStyle (acommodity, astyle)
|
|
|
|
marketpricedirectivep :: ErroringJournalParser MarketPrice
|
|
marketpricedirectivep = do
|
|
char 'P' <?> "market price"
|
|
many spacenonewline
|
|
date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored
|
|
many1 spacenonewline
|
|
symbol <- commoditysymbolp
|
|
many spacenonewline
|
|
price <- amountp
|
|
restofline
|
|
return $ MarketPrice date symbol price
|
|
|
|
ignoredpricecommoditydirectivep :: ErroringJournalParser ()
|
|
ignoredpricecommoditydirectivep = do
|
|
char 'N' <?> "ignored-price commodity"
|
|
many1 spacenonewline
|
|
commoditysymbolp
|
|
restofline
|
|
return ()
|
|
|
|
commodityconversiondirectivep :: ErroringJournalParser ()
|
|
commodityconversiondirectivep = do
|
|
char 'C' <?> "commodity conversion"
|
|
many1 spacenonewline
|
|
amountp
|
|
many spacenonewline
|
|
char '='
|
|
many spacenonewline
|
|
amountp
|
|
restofline
|
|
return ()
|
|
|
|
--- ** transactions
|
|
|
|
modifiertransactionp :: ErroringJournalParser ModifierTransaction
|
|
modifiertransactionp = do
|
|
char '=' <?> "modifier transaction"
|
|
many spacenonewline
|
|
valueexpr <- restofline
|
|
postings <- postingsp Nothing
|
|
return $ ModifierTransaction valueexpr postings
|
|
|
|
periodictransactionp :: ErroringJournalParser PeriodicTransaction
|
|
periodictransactionp = do
|
|
char '~' <?> "periodic transaction"
|
|
many spacenonewline
|
|
periodexpr <- restofline
|
|
postings <- postingsp Nothing
|
|
return $ PeriodicTransaction periodexpr postings
|
|
|
|
-- | Parse a (possibly unbalanced) transaction.
|
|
transactionp :: ErroringJournalParser Transaction
|
|
transactionp = do
|
|
-- ptrace "transactionp"
|
|
sourcepos <- genericSourcePos <$> getPosition
|
|
date <- datep <?> "transaction"
|
|
edate <- optionMaybe (secondarydatep date) <?> "secondary date"
|
|
lookAhead (spacenonewline <|> newline) <?> "whitespace or newline"
|
|
status <- statusp <?> "cleared status"
|
|
code <- codep <?> "transaction code"
|
|
description <- strip <$> descriptionp
|
|
comment <- try followingcommentp <|> (newline >> return "")
|
|
let tags = commentTags comment
|
|
postings <- postingsp (Just date)
|
|
n <- incrementTransactionCount
|
|
return $ txnTieKnot $ Transaction n sourcepos date edate status code description comment tags postings ""
|
|
|
|
#ifdef TESTS
|
|
test_transactionp = do
|
|
let s `gives` t = do
|
|
let p = parseWithState mempty transactionp s
|
|
assertBool $ isRight p
|
|
let Right t2 = p
|
|
-- same f = assertEqual (f t) (f t2)
|
|
assertEqual (tdate t) (tdate t2)
|
|
assertEqual (tdate2 t) (tdate2 t2)
|
|
assertEqual (tstatus t) (tstatus t2)
|
|
assertEqual (tcode t) (tcode t2)
|
|
assertEqual (tdescription t) (tdescription t2)
|
|
assertEqual (tcomment t) (tcomment t2)
|
|
assertEqual (ttags t) (ttags t2)
|
|
assertEqual (tpreceding_comment_lines t) (tpreceding_comment_lines t2)
|
|
assertEqual (show $ tpostings t) (show $ tpostings t2)
|
|
-- "0000/01/01\n\n" `gives` nulltransaction
|
|
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",
|
|
tdate2=Just $ parsedate "2012/05/15",
|
|
tstatus=Uncleared,
|
|
tcode="code",
|
|
tdescription="desc",
|
|
tcomment=" tcomment1\n tcomment2\n ttag1: val1\n",
|
|
ttags=[("ttag1","val1")],
|
|
tpostings=[
|
|
nullposting{
|
|
pstatus=Cleared,
|
|
paccount="a",
|
|
pamount=Mixed [usd 1],
|
|
pcomment=" pcomment1\n pcomment2\n ptag1: val1\n ptag2: val2\n",
|
|
ptype=RegularPosting,
|
|
ptags=[("ptag1","val1"),("ptag2","val2")],
|
|
ptransaction=Nothing
|
|
}
|
|
],
|
|
tpreceding_comment_lines=""
|
|
}
|
|
unlines [
|
|
"2015/1/1",
|
|
]
|
|
`gives`
|
|
nulltransaction{
|
|
tdate=parsedate "2015/01/01",
|
|
}
|
|
|
|
assertRight $ parseWithState mempty transactionp $ unlines
|
|
["2007/01/28 coopportunity"
|
|
," expenses:food:groceries $47.18"
|
|
," assets:checking $-47.18"
|
|
,""
|
|
]
|
|
|
|
-- transactionp should not parse just a date
|
|
assertLeft $ parseWithState mempty transactionp "2009/1/1\n"
|
|
|
|
-- transactionp should not parse just a date and description
|
|
assertLeft $ parseWithState mempty transactionp "2009/1/1 a\n"
|
|
|
|
-- transactionp should not parse a following comment as part of the description
|
|
let p = parseWithState mempty transactionp "2009/1/1 a ;comment\n b 1\n"
|
|
assertRight p
|
|
assertEqual "a" (let Right p' = p in tdescription p')
|
|
|
|
-- parse transaction with following whitespace line
|
|
assertRight $ parseWithState mempty transactionp $ unlines
|
|
["2012/1/1"
|
|
," a 1"
|
|
," b"
|
|
," "
|
|
]
|
|
|
|
let p = parseWithState mempty transactionp $ unlines
|
|
["2009/1/1 x ; transaction comment"
|
|
," a 1 ; posting 1 comment"
|
|
," ; posting 1 comment 2"
|
|
," b"
|
|
," ; posting 2 comment"
|
|
]
|
|
assertRight p
|
|
assertEqual 2 (let Right t = p in length $ tpostings t)
|
|
#endif
|
|
|
|
--- ** postings
|
|
|
|
-- Parse the following whitespace-beginning lines as postings, posting
|
|
-- tags, and/or comments (inferring year, if needed, from the given date).
|
|
postingsp :: Maybe Day -> ErroringJournalParser [Posting]
|
|
postingsp mdate = many (try $ postingp mdate) <?> "postings"
|
|
|
|
-- linebeginningwithspaces :: Monad m => JournalParser m String
|
|
-- linebeginningwithspaces = do
|
|
-- sp <- many1 spacenonewline
|
|
-- c <- nonspace
|
|
-- cs <- restofline
|
|
-- return $ sp ++ (c:cs) ++ "\n"
|
|
|
|
postingp :: Maybe Day -> ErroringJournalParser Posting
|
|
postingp mtdate = do
|
|
-- pdbg 0 "postingp"
|
|
many1 spacenonewline
|
|
status <- statusp
|
|
many spacenonewline
|
|
account <- modifiedaccountnamep
|
|
let (ptype, account') = (accountNamePostingType account, unbracket account)
|
|
amount <- spaceandamountormissingp
|
|
massertion <- partialbalanceassertionp
|
|
_ <- fixedlotpricep
|
|
many spacenonewline
|
|
(comment,tags,mdate,mdate2) <-
|
|
try (followingcommentandtagsp mtdate) <|> (newline >> return ("",[],Nothing,Nothing))
|
|
return posting
|
|
{ pdate=mdate
|
|
, pdate2=mdate2
|
|
, pstatus=status
|
|
, paccount=account'
|
|
, pamount=amount
|
|
, pcomment=comment
|
|
, ptype=ptype
|
|
, ptags=tags
|
|
, pbalanceassertion=massertion
|
|
}
|
|
|
|
#ifdef TESTS
|
|
test_postingp = do
|
|
let s `gives` ep = do
|
|
let parse = parseWithState mempty (postingp Nothing) s
|
|
assertBool -- "postingp parser"
|
|
$ isRight parse
|
|
let Right ap = parse
|
|
same f = assertEqual (f ep) (f ap)
|
|
same pdate
|
|
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{paccount="expenses:food:dining", pamount=Mixed [usd 10], pcomment=" a: a a \n b: b b \n", ptags=[("a","a a"), ("b","b b")]}
|
|
|
|
" a 1 ; [2012/11/28]\n" `gives`
|
|
("a" `post` num 1){pcomment=" [2012/11/28]\n"
|
|
,ptags=[("date","2012/11/28")]
|
|
,pdate=parsedateM "2012/11/28"}
|
|
|
|
" a 1 ; a:a, [=2012/11/28]\n" `gives`
|
|
("a" `post` num 1){pcomment=" a:a, [=2012/11/28]\n"
|
|
,ptags=[("a","a"), ("date2","2012/11/28")]
|
|
,pdate=Nothing}
|
|
|
|
" a 1 ; a:a\n ; [2012/11/28=2012/11/29],b:b\n" `gives`
|
|
("a" `post` num 1){pcomment=" a:a\n [2012/11/28=2012/11/29],b:b\n"
|
|
,ptags=[("a","a"), ("date","2012/11/28"), ("date2","2012/11/29"), ("b","b")]
|
|
,pdate=parsedateM "2012/11/28"}
|
|
|
|
assertBool -- "postingp parses a quoted commodity with numbers"
|
|
(isRight $ parseWithState mempty (postingp Nothing) " a 1 \"DE123\"\n")
|
|
|
|
-- ,"postingp parses balance assertions and fixed lot prices" ~: do
|
|
assertBool (isRight $ parseWithState mempty (postingp Nothing) " a 1 \"DE123\" =$1 { =2.2 EUR} \n")
|
|
|
|
-- let parse = parseWithState mempty postingp " a\n ;next-line comment\n"
|
|
-- assertRight parse
|
|
-- let Right p = parse
|
|
-- assertEqual "next-line comment\n" (pcomment p)
|
|
-- assertEqual (Just nullmixedamt) (pbalanceassertion p)
|
|
#endif
|
|
|
|
--- * more tests
|
|
|
|
tests_Hledger_Read_JournalReader = TestList $ concat [
|
|
-- test_numberp
|
|
]
|
|
|
|
{- old hunit tests
|
|
|
|
tests_Hledger_Read_JournalReader = TestList $ concat [
|
|
test_numberp,
|
|
test_amountp,
|
|
test_spaceandamountormissingp,
|
|
test_tagcomment,
|
|
test_inlinecomment,
|
|
test_comments,
|
|
test_ledgerDateSyntaxToTags,
|
|
test_postingp,
|
|
test_transactionp,
|
|
[
|
|
"modifiertransactionp" ~: do
|
|
assertParse (parseWithState mempty modifiertransactionp "= (some value expr)\n some:postings 1\n")
|
|
|
|
,"periodictransactionp" ~: do
|
|
assertParse (parseWithState mempty periodictransactionp "~ (some period expr)\n some:postings 1\n")
|
|
|
|
,"directivep" ~: do
|
|
assertParse (parseWithState mempty directivep "!include /some/file.x\n")
|
|
assertParse (parseWithState mempty directivep "account some:account\n")
|
|
assertParse (parseWithState mempty (directivep >> directivep) "!account a\nend\n")
|
|
|
|
,"comment" ~: do
|
|
assertParse (parseWithState mempty comment "; some comment \n")
|
|
assertParse (parseWithState mempty comment " \t; x\n")
|
|
assertParse (parseWithState mempty comment "#x")
|
|
|
|
,"datep" ~: do
|
|
assertParse (parseWithState mempty datep "2011/1/1")
|
|
assertParseFailure (parseWithState mempty datep "1/1")
|
|
assertParse (parseWithState mempty{jpsYear=Just 2011} datep "1/1")
|
|
|
|
,"datetimep" ~: do
|
|
let p = do {t <- datetimep; eof; return t}
|
|
bad = assertParseFailure . parseWithState mempty p
|
|
good = assertParse . parseWithState mempty 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"
|
|
-- timezone is parsed but ignored
|
|
let startofday = LocalTime (fromGregorian 2011 1 1) (TimeOfDay 0 0 (fromIntegral 0))
|
|
assertParseEqual (parseWithState mempty p "2011/1/1 00:00-0800") startofday
|
|
assertParseEqual (parseWithState mempty p "2011/1/1 00:00+1234") startofday
|
|
|
|
,"defaultyeardirectivep" ~: do
|
|
assertParse (parseWithState mempty defaultyeardirectivep "Y 2010\n")
|
|
assertParse (parseWithState mempty defaultyeardirectivep "Y 10001\n")
|
|
|
|
,"marketpricedirectivep" ~:
|
|
assertParseEqual (parseWithState mempty marketpricedirectivep "P 2004/05/01 XYZ $55.00\n") (MarketPrice (parsedate "2004/05/01") "XYZ" $ usd 55)
|
|
|
|
,"ignoredpricecommoditydirectivep" ~: do
|
|
assertParse (parseWithState mempty ignoredpricecommoditydirectivep "N $\n")
|
|
|
|
,"defaultcommoditydirectivep" ~: do
|
|
assertParse (parseWithState mempty defaultcommoditydirectivep "D $1,000.0\n")
|
|
|
|
,"commodityconversiondirectivep" ~: do
|
|
assertParse (parseWithState mempty commodityconversiondirectivep "C 1h = $50.00\n")
|
|
|
|
,"tagdirectivep" ~: do
|
|
assertParse (parseWithState mempty tagdirectivep "tag foo \n")
|
|
|
|
,"endtagdirectivep" ~: do
|
|
assertParse (parseWithState mempty endtagdirectivep "end tag \n")
|
|
assertParse (parseWithState mempty endtagdirectivep "pop \n")
|
|
|
|
,"accountnamep" ~: do
|
|
assertBool "accountnamep parses a normal account name" (isRight $ parsewith accountnamep "a:b:c")
|
|
assertBool "accountnamep rejects an empty inner component" (isLeft $ parsewith accountnamep "a::c")
|
|
assertBool "accountnamep rejects an empty leading component" (isLeft $ parsewith accountnamep ":b:c")
|
|
assertBool "accountnamep rejects an empty trailing component" (isLeft $ parsewith accountnamep "a:b:")
|
|
|
|
,"leftsymbolamountp" ~: do
|
|
assertParseEqual (parseWithState mempty leftsymbolamountp "$1") (usd 1 `withPrecision` 0)
|
|
assertParseEqual (parseWithState mempty leftsymbolamountp "$-1") (usd (-1) `withPrecision` 0)
|
|
assertParseEqual (parseWithState mempty leftsymbolamountp "-$1") (usd (-1) `withPrecision` 0)
|
|
|
|
,"amount" ~: do
|
|
let -- | compare a parse result with an expected amount, showing the debug representation for clarity
|
|
assertAmountParse parseresult amount =
|
|
(either (const "parse error") showAmountDebug parseresult) ~?= (showAmountDebug amount)
|
|
assertAmountParse (parseWithState mempty amountp "1 @ $2")
|
|
(num 1 `withPrecision` 0 `at` (usd 2 `withPrecision` 0))
|
|
|
|
]]
|
|
-}
|