2016-04-23 21:27:39 +03:00
--- * doc
2016-04-28 23:23:20 +03:00
-- Lines beginning "--- *" are collapsible orgstruct nodes. Emacs users,
2016-04-23 03:43:16 +03:00
-- (add-hook 'haskell-mode-hook
2016-04-23 21:27:39 +03:00
-- (lambda () (set-variable 'orgstruct-heading-prefix-regexp "--- " t))
2016-04-23 03:43:16 +03:00
-- 'orgstruct-mode)
2016-04-28 23:23:20 +03:00
-- and press TAB on nodes to expand/collapse.
2016-04-23 03:43:16 +03:00
2008-10-01 04:29:58 +04:00
{- |
2008-10-03 06:28:58 +04:00
2012-03-24 22:08:11 +04:00
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 :
2007-03-12 10:40:33 +03:00
2008-10-01 05:40:32 +04:00
@
2012-03-24 22:08:11 +04:00
2012 \/ 3 \/ 24 gift
expenses : gifts $ 10
assets : cash
2008-10-01 05:40:32 +04:00
@
2008-10-01 04:29:58 +04:00
2016-05-18 05:46:54 +03:00
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.
2007-02-09 04:23:12 +03:00
- }
2007-07-04 16:05:54 +04:00
2016-04-23 21:27:39 +03:00
--- * module
2016-05-07 19:54:01 +03:00
{- # LANGUAGE CPP, RecordWildCards, NamedFieldPuns, NoMonoLocalBinds, ScopedTypeVariables, FlexibleContexts, TupleSections # -}
2016-04-23 03:43:16 +03:00
2010-11-15 10:01:46 +03:00
module Hledger.Read.JournalReader (
2016-04-23 21:27:39 +03:00
2016-04-28 23:23:20 +03:00
--- * exports
2012-03-24 22:08:11 +04:00
-- * Reader
reader ,
2016-04-23 03:43:16 +03:00
-- * Parsing utils
2015-06-29 02:20:28 +03:00
genericSourcePos ,
2016-04-23 03:43:16 +03:00
parseAndFinaliseJournal ,
2016-05-07 02:58:07 +03:00
runStringParser ,
rsp ,
runJournalParser ,
rjp ,
runErroringJournalParser ,
rejp ,
2016-04-23 03:43:16 +03:00
-- * Parsers used elsewhere
2012-03-24 22:08:11 +04:00
getParentAccount ,
2015-10-17 21:51:45 +03:00
journalp ,
directivep ,
defaultyeardirectivep ,
marketpricedirectivep ,
2014-02-06 06:55:38 +04:00
datetimep ,
2016-02-20 02:14:25 +03:00
datep ,
2016-05-23 10:32:55 +03:00
-- codep,
-- accountnamep,
2015-09-25 03:23:52 +03:00
modifiedaccountnamep ,
2014-02-06 01:02:24 +04:00
postingp ,
2016-05-23 10:32:55 +03:00
-- amountp,
-- amountp',
-- mamountp',
-- numberp,
2015-05-16 21:51:35 +03:00
statusp ,
2014-02-27 23:47:36 +04:00
emptyorcommentlinep ,
2015-05-14 22:50:32 +03:00
followingcommentp ,
accountaliasp
2016-05-18 05:46:54 +03:00
2012-03-24 22:08:11 +04:00
-- * Tests
2015-06-11 20:13:27 +03:00
, tests_Hledger_Read_JournalReader
2016-05-18 05:46:54 +03:00
2010-05-31 05:15:18 +04:00
)
2010-03-13 02:46:20 +03:00
where
2016-04-23 21:27:39 +03:00
--- * imports
2015-04-23 10:39:29 +03:00
import Prelude ( )
import Prelude.Compat hiding ( readFile )
2012-03-30 01:19:35 +04:00
import qualified Control.Exception as C
2016-05-23 10:32:55 +03:00
import Control.Monad
import Control.Monad.Except ( ExceptT ( .. ) , liftIO , runExceptT , throwError )
2016-05-07 19:54:01 +03:00
import qualified Data.Map.Strict as M
2016-05-23 10:32:55 +03:00
import Data.Monoid
lib: textification begins! account names
The first of several conversions from String to (strict) Text, hopefully
reducing space and time usage.
This one shows a small improvement, with GHC 7.10.3 and text-1.2.2.1:
hledger -f data/100x100x10.journal stats
string: <<ghc: 39471064 bytes, 77 GCs, 198421/275048 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.001 elapsed), 0.015 MUT (0.020 elapsed), 0.010 GC (0.014 elapsed) :ghc>>
text: <<ghc: 39268024 bytes, 77 GCs, 197018/270840 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.002 elapsed), 0.016 MUT (0.022 elapsed), 0.009 GC (0.011 elapsed) :ghc>>
hledger -f data/1000x100x10.journal stats
string: <<ghc: 318555920 bytes, 617 GCs, 2178997/7134472 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.001 elapsed), 0.129 MUT (0.136 elapsed), 0.067 GC (0.077 elapsed) :ghc>>
text: <<ghc: 314248496 bytes, 612 GCs, 2074045/6617960 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.003 elapsed), 0.137 MUT (0.145 elapsed), 0.067 GC (0.079 elapsed) :ghc>>
hledger -f data/10000x100x10.journal stats
string: <<ghc: 3114763608 bytes, 6026 GCs, 18858950/75552024 avg/max bytes residency (11 samples), 201M in use, 0.000 INIT (0.000 elapsed), 1.331 MUT (1.372 elapsed), 0.699 GC (0.812 elapsed) :ghc>>
text: <<ghc: 3071468920 bytes, 5968 GCs, 14120344/62951360 avg/max bytes residency (9 samples), 124M in use, 0.000 INIT (0.003 elapsed), 1.272 MUT (1.349 elapsed), 0.513 GC (0.578 elapsed) :ghc>>
hledger -f data/100000x100x10.journal stats
string: <<ghc: 31186579432 bytes, 60278 GCs, 135332581/740228992 avg/max bytes residency (13 samples), 1697M in use, 0.000 INIT (0.008 elapsed), 14.677 MUT (15.508 elapsed), 7.081 GC (8.074 elapsed) :ghc>>
text: <<ghc: 30753427672 bytes, 59763 GCs, 117595958/666457240 avg/max bytes residency (14 samples), 1588M in use, 0.000 INIT (0.008 elapsed), 13.713 MUT (13.966 elapsed), 6.220 GC (7.108 elapsed) :ghc>>
2016-05-24 04:16:21 +03:00
-- import Data.Text (Text)
import qualified Data.Text as T
2011-05-28 08:11:44 +04:00
import Data.Time.Calendar
import Data.Time.LocalTime
2016-04-28 23:23:20 +03:00
import Safe
2015-06-11 20:13:27 +03:00
import Test.HUnit
2012-12-06 04:28:23 +04:00
# ifdef TESTS
import Test.Framework
import Text.Parsec.Error
# endif
2014-11-03 08:52:12 +03:00
import Text.Parsec hiding ( parse )
2011-05-28 08:11:44 +04:00
import Text.Printf
2012-03-24 22:08:11 +04:00
import System.FilePath
2010-11-15 10:18:35 +03:00
import Hledger.Data
2016-05-18 05:46:54 +03:00
import Hledger.Read.Common
import Hledger.Read.TimeclockReader ( timeclockfilep )
import Hledger.Read.TimedotReader ( timedotfilep )
2011-05-28 08:11:44 +04:00
import Hledger.Utils
2010-03-13 02:46:20 +03:00
2016-04-23 21:27:39 +03:00
--- * reader
2010-03-13 02:46:20 +03:00
2010-06-25 18:56:48 +04:00
reader :: Reader
reader = Reader format detect parse
format :: String
format = " journal "
2014-05-10 04:55:32 +04:00
-- | Does the given file path and data look like it might be hledger's journal format ?
2010-06-25 18:56:48 +04:00
detect :: FilePath -> String -> Bool
2014-05-10 04:55:32 +04:00
detect f s
2016-02-20 10:02:10 +03:00
| 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)
2010-06-25 18:56:48 +04:00
2010-05-30 23:11:58 +04:00
-- | Parse and post-process a "Journal" from hledger's journal file
2010-05-31 05:15:18 +04:00
-- format, or give an error.
2015-03-29 17:53:23 +03:00
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal
2015-10-17 22:09:03 +03:00
parse _ = parseAndFinaliseJournal journalp
2010-03-13 02:46:20 +03:00
2016-04-23 21:27:39 +03:00
--- * parsers
--- ** journal
2012-03-24 22:08:11 +04:00
2016-05-23 10:32:55 +03:00
-- | 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
2015-10-17 21:51:45 +03:00
journalp = do
2016-05-23 10:32:55 +03:00
many addJournalItemP
2010-11-13 18:03:40 +03:00
eof
2016-05-23 10:32:55 +03:00
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 "
2010-09-23 03:02:19 +04:00
2016-04-23 21:27:39 +03:00
--- ** directives
2016-04-23 03:43:16 +03:00
2016-05-23 10:32:55 +03:00
-- | 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 ()
2015-10-17 21:51:45 +03:00
directivep = do
2011-08-03 03:28:53 +04:00
optional $ char '!'
choice' [
2015-10-17 21:51:45 +03:00
includedirectivep
, aliasdirectivep
, endaliasesdirectivep
, accountdirectivep
2016-04-04 20:18:59 +03:00
, applyaccountdirectivep
2016-05-07 19:54:01 +03:00
, commoditydirectivep
2016-04-04 20:18:59 +03:00
, endapplyaccountdirectivep
2015-10-17 21:51:45 +03:00
, tagdirectivep
, endtagdirectivep
, defaultyeardirectivep
, defaultcommoditydirectivep
, commodityconversiondirectivep
, ignoredpricecommoditydirectivep
2011-08-03 03:28:53 +04:00
]
<?> " directive "
2010-03-13 02:46:20 +03:00
2016-05-23 10:32:55 +03:00
includedirectivep :: ErroringJournalParser ()
2015-10-17 21:51:45 +03:00
includedirectivep = do
2011-08-04 11:49:10 +04:00
string " include "
2010-09-23 01:52:04 +04:00
many1 spacenonewline
2016-05-23 10:32:55 +03:00
filename <- restofline
parentpos <- getPosition
parentj <- getState
let childj = newJournalWithParseStateFrom parentj
2016-05-23 11:02:19 +03:00
( ej :: Either String ParsedJournal ) <-
2016-05-23 10:32:55 +03:00
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 )
2016-05-23 11:02:19 +03:00
( ej1 :: Either ParseError ParsedJournal ) <-
2016-05-23 10:32:55 +03:00
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 )
lib: textification: saved journal source
Slightly worse on small files, better on large ones.
hledger -f data/100x100x10.journal stats
<<ghc: 39305392 bytes, 77 GCs, 196354/268584 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.007 elapsed), 0.014 MUT (0.027 elapsed), 0.011 GC (0.111 elapsed) :ghc>>
<<ghc: 39307728 bytes, 77 GCs, 196909/270248 avg/max bytes residency (3 samples), 2M in use, 0.001 INIT (0.010 elapsed), 0.015 MUT (0.028 elapsed), 0.012 GC (0.116 elapsed) :ghc>>
hledger -f data/1000x1000x10.journal stats
<<ghc: 314285912 bytes, 612 GCs, 2064811/6597608 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.002 elapsed), 0.126 MUT (0.134 elapsed), 0.059 GC (0.069 elapsed) :ghc>>
<<ghc: 314271368 bytes, 612 GCs, 2070227/6628024 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.000 elapsed), 0.137 MUT (0.143 elapsed), 0.059 GC (0.068 elapsed) :ghc>>
hledger -f data/10000x1000x10.journal stats
<<ghc: 3070033264 bytes, 5965 GCs, 12699294/62962464 avg/max bytes residency (10 samples), 124M in use, 0.000 INIT (0.000 elapsed), 1.245 MUT (1.300 elapsed), 0.498 GC (0.558 elapsed) :ghc>>
<<ghc: 3070006752 bytes, 5973 GCs, 12687314/62848920 avg/max bytes residency (10 samples), 124M in use, 0.000 INIT (0.003 elapsed), 1.257 MUT (1.281 elapsed), 0.496 GC (0.554 elapsed) :ghc>>
hledger -f data/100000x1000x10.journal stats
<<ghc: 30753465088 bytes, 59763 GCs, 117723618/666643528 avg/max bytes residency (14 samples), 1589M in use, 0.000 INIT (0.002 elapsed), 12.536 MUT (12.793 elapsed), 5.978 GC (7.155 elapsed) :ghc>>
<<ghc: 30753367256 bytes, 59811 GCs, 117723236/666627528 avg/max bytes residency (14 samples), 1590M in use, 0.001 INIT (0.012 elapsed), 12.923 MUT (13.169 elapsed), 5.981 GC (6.860 elapsed) :ghc>>
2016-05-24 05:24:39 +03:00
( return . journalAddFile ( filepath , T . pack txt ) )
2016-05-23 11:02:19 +03:00
ej1
case ej of
2016-05-23 10:32:55 +03:00
Left e -> throwError e
2016-05-23 11:02:19 +03:00
Right childj -> modifyState ( \ parentj -> childj <> parentj )
-- discard child's parse info, prepend its (reversed) list data, combine other fields
newJournalWithParseStateFrom :: Journal -> Journal
newJournalWithParseStateFrom j = mempty {
jparsedefaultyear = jparsedefaultyear j
, jparsedefaultcommodity = jparsedefaultcommodity j
, jparseparentaccounts = jparseparentaccounts j
, jparsealiases = jparsealiases j
, jparsetransactioncount = jparsetransactioncount j
, jparsetimeclockentries = jparsetimeclockentries j
}
2016-05-23 10:32:55 +03:00
-- | 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 ()
2015-10-17 21:51:45 +03:00
accountdirectivep = do
2016-04-04 20:18:59 +03:00
string " account "
many1 spacenonewline
acct <- accountnamep
newline
2016-05-07 19:54:01 +03:00
_ <- many indentedlinep
2016-05-23 10:32:55 +03:00
modifyState ( \ j -> j { jaccounts = acct : jaccounts j } )
2016-04-04 20:18:59 +03:00
2016-05-18 05:46:54 +03:00
indentedlinep = many1 spacenonewline >> ( rstrip <$> restofline )
2016-05-07 19:54:01 +03:00
2016-05-09 06:56:34 +03:00
-- | 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 ?
2016-05-23 10:32:55 +03:00
commoditydirectivep :: ErroringJournalParser ()
2016-05-09 06:56:34 +03:00
commoditydirectivep = try commoditydirectiveonelinep <|> commoditydirectivemultilinep
-- | Parse a one-line commodity directive.
--
-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00"
-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00 ; blah\n"
2016-05-23 10:32:55 +03:00
commoditydirectiveonelinep :: ErroringJournalParser ()
2016-05-09 06:56:34 +03:00
commoditydirectiveonelinep = do
string " commodity "
many1 spacenonewline
Amount { acommodity , astyle } <- amountp
many spacenonewline
_ <- followingcommentp <|> ( eolof >> return " " )
let comm = Commodity { csymbol = acommodity , cformat = Just astyle }
2016-05-23 10:32:55 +03:00
modifyState ( \ j -> j { jcommodities = M . insert acommodity comm $ jcommodities j } )
2016-05-09 06:56:34 +03:00
-- | Parse a multi-line commodity directive, containing 0 or more format subdirectives.
--
-- >>> Right _ <- rejp commoditydirectivemultilinep "commodity $ ; blah \n format $1.00 ; blah"
2016-05-23 10:32:55 +03:00
commoditydirectivemultilinep :: ErroringJournalParser ()
2016-05-09 06:56:34 +03:00
commoditydirectivemultilinep = do
2016-05-07 19:54:01 +03:00
string " commodity "
many1 spacenonewline
sym <- commoditysymbolp
2016-05-09 06:56:34 +03:00
_ <- followingcommentp <|> ( eolof >> return " " )
2016-05-07 19:54:01 +03:00
mformat <- lastMay <$> many ( indented $ formatdirectivep sym )
let comm = Commodity { csymbol = sym , cformat = mformat }
2016-05-23 10:32:55 +03:00
modifyState ( \ j -> j { jcommodities = M . insert sym comm $ jcommodities j } )
where
indented = ( many1 spacenonewline >> )
2016-05-07 19:54:01 +03:00
-- | 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
2016-05-09 06:56:34 +03:00
_ <- followingcommentp <|> ( eolof >> return " " )
2016-05-07 19:54:01 +03:00
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
2016-05-23 10:32:55 +03:00
applyaccountdirectivep :: ErroringJournalParser ()
2016-04-04 20:18:59 +03:00
applyaccountdirectivep = do
string " apply " >> many1 spacenonewline >> string " account "
2011-08-04 11:49:10 +04:00
many1 spacenonewline
2014-02-06 06:55:38 +04:00
parent <- accountnamep
2011-08-04 11:49:10 +04:00
newline
pushParentAccount parent
2010-03-13 02:46:20 +03:00
2016-05-23 10:32:55 +03:00
endapplyaccountdirectivep :: ErroringJournalParser ()
2016-04-04 20:18:59 +03:00
endapplyaccountdirectivep = do
string " end " >> many1 spacenonewline >> string " apply " >> many1 spacenonewline >> string " account "
2011-08-04 11:49:10 +04:00
popParentAccount
2010-03-13 02:46:20 +03:00
2016-05-23 10:32:55 +03:00
aliasdirectivep :: ErroringJournalParser ()
2015-10-17 21:51:45 +03:00
aliasdirectivep = do
2011-08-04 12:45:18 +04:00
string " alias "
many1 spacenonewline
2015-05-14 22:50:32 +03:00
alias <- accountaliasp
addAccountAlias alias
2011-08-04 12:45:18 +04:00
2016-04-28 23:23:20 +03:00
accountaliasp :: Monad m => StringParser u m AccountAlias
2015-05-14 22:50:32 +03:00
accountaliasp = regexaliasp <|> basicaliasp
2016-04-28 23:23:20 +03:00
basicaliasp :: Monad m => StringParser u m AccountAlias
2015-05-14 22:50:32 +03:00
basicaliasp = do
-- pdbg 0 "basicaliasp"
2016-05-14 08:09:39 +03:00
old <- rstrip <$> many1 ( noneOf " = " )
2015-05-14 22:50:32 +03:00
char '='
many spacenonewline
new <- rstrip <$> anyChar ` manyTill ` eolof -- don't require a final newline, good for cli options
lib: textification begins! account names
The first of several conversions from String to (strict) Text, hopefully
reducing space and time usage.
This one shows a small improvement, with GHC 7.10.3 and text-1.2.2.1:
hledger -f data/100x100x10.journal stats
string: <<ghc: 39471064 bytes, 77 GCs, 198421/275048 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.001 elapsed), 0.015 MUT (0.020 elapsed), 0.010 GC (0.014 elapsed) :ghc>>
text: <<ghc: 39268024 bytes, 77 GCs, 197018/270840 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.002 elapsed), 0.016 MUT (0.022 elapsed), 0.009 GC (0.011 elapsed) :ghc>>
hledger -f data/1000x100x10.journal stats
string: <<ghc: 318555920 bytes, 617 GCs, 2178997/7134472 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.001 elapsed), 0.129 MUT (0.136 elapsed), 0.067 GC (0.077 elapsed) :ghc>>
text: <<ghc: 314248496 bytes, 612 GCs, 2074045/6617960 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.003 elapsed), 0.137 MUT (0.145 elapsed), 0.067 GC (0.079 elapsed) :ghc>>
hledger -f data/10000x100x10.journal stats
string: <<ghc: 3114763608 bytes, 6026 GCs, 18858950/75552024 avg/max bytes residency (11 samples), 201M in use, 0.000 INIT (0.000 elapsed), 1.331 MUT (1.372 elapsed), 0.699 GC (0.812 elapsed) :ghc>>
text: <<ghc: 3071468920 bytes, 5968 GCs, 14120344/62951360 avg/max bytes residency (9 samples), 124M in use, 0.000 INIT (0.003 elapsed), 1.272 MUT (1.349 elapsed), 0.513 GC (0.578 elapsed) :ghc>>
hledger -f data/100000x100x10.journal stats
string: <<ghc: 31186579432 bytes, 60278 GCs, 135332581/740228992 avg/max bytes residency (13 samples), 1697M in use, 0.000 INIT (0.008 elapsed), 14.677 MUT (15.508 elapsed), 7.081 GC (8.074 elapsed) :ghc>>
text: <<ghc: 30753427672 bytes, 59763 GCs, 117595958/666457240 avg/max bytes residency (14 samples), 1588M in use, 0.000 INIT (0.008 elapsed), 13.713 MUT (13.966 elapsed), 6.220 GC (7.108 elapsed) :ghc>>
2016-05-24 04:16:21 +03:00
return $ BasicAlias ( T . pack old ) ( T . pack new )
2015-05-14 22:50:32 +03:00
2016-04-28 23:23:20 +03:00
regexaliasp :: Monad m => StringParser u m AccountAlias
2015-05-14 22:50:32 +03:00
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
2016-05-23 10:32:55 +03:00
endaliasesdirectivep :: ErroringJournalParser ()
2015-10-17 21:51:45 +03:00
endaliasesdirectivep = do
2011-08-04 12:45:18 +04:00
string " end aliases "
clearAccountAliases
2016-05-23 10:32:55 +03:00
tagdirectivep :: ErroringJournalParser ()
2015-10-17 21:51:45 +03:00
tagdirectivep = do
2011-08-04 11:49:10 +04:00
string " tag " <?> " tag directive "
many1 spacenonewline
_ <- many1 nonspace
restofline
2016-05-23 10:32:55 +03:00
return ()
2007-02-09 04:23:12 +03:00
2016-05-23 10:32:55 +03:00
endtagdirectivep :: ErroringJournalParser ()
2015-10-17 21:51:45 +03:00
endtagdirectivep = do
2011-08-04 11:49:10 +04:00
( string " end tag " <|> string " pop " ) <?> " end tag or pop directive "
restofline
2016-05-23 10:32:55 +03:00
return ()
2011-08-04 11:49:10 +04:00
2016-05-23 10:32:55 +03:00
defaultyeardirectivep :: ErroringJournalParser ()
2015-10-17 21:51:45 +03:00
defaultyeardirectivep = do
2011-08-04 11:49:10 +04:00
char 'Y' <?> " default year "
2007-02-09 04:23:12 +03:00
many spacenonewline
2011-08-04 11:49:10 +04:00
y <- many1 digit
let y' = read y
failIfInvalidYear y
setYear y'
2016-05-23 10:32:55 +03:00
defaultcommoditydirectivep :: ErroringJournalParser ()
2015-10-17 21:51:45 +03:00
defaultcommoditydirectivep = do
2011-08-04 11:49:10 +04:00
char 'D' <?> " default commodity "
many1 spacenonewline
2012-11-20 03:17:55 +04:00
Amount { .. } <- amountp
2011-08-04 11:49:10 +04:00
restofline
2016-05-23 10:32:55 +03:00
setDefaultCommodityAndStyle ( acommodity , astyle )
2007-02-09 04:23:12 +03:00
2016-04-28 23:23:20 +03:00
marketpricedirectivep :: ErroringJournalParser MarketPrice
2015-10-17 21:51:45 +03:00
marketpricedirectivep = do
2015-08-10 02:20:02 +03:00
char 'P' <?> " market price "
2008-12-16 13:54:20 +03:00
many spacenonewline
2014-08-08 18:27:32 +04:00
date <- try ( do { LocalTime d _ <- datetimep ; return d } ) <|> datep -- a time is ignored
2009-11-26 00:21:49 +03:00
many1 spacenonewline
2015-10-17 21:51:45 +03:00
symbol <- commoditysymbolp
2008-12-16 13:54:20 +03:00
many spacenonewline
2012-11-20 01:20:10 +04:00
price <- amountp
2008-12-16 13:54:20 +03:00
restofline
2015-08-10 02:20:02 +03:00
return $ MarketPrice date symbol price
2008-12-16 13:54:20 +03:00
2016-05-23 10:32:55 +03:00
ignoredpricecommoditydirectivep :: ErroringJournalParser ()
2015-10-17 21:51:45 +03:00
ignoredpricecommoditydirectivep = do
2010-03-13 01:52:57 +03:00
char 'N' <?> " ignored-price commodity "
many1 spacenonewline
2015-10-17 21:51:45 +03:00
commoditysymbolp
2010-03-13 01:52:57 +03:00
restofline
2016-05-23 10:32:55 +03:00
return ()
2010-03-13 01:52:57 +03:00
2016-05-23 10:32:55 +03:00
commodityconversiondirectivep :: ErroringJournalParser ()
2015-10-17 21:51:45 +03:00
commodityconversiondirectivep = do
2010-03-13 04:10:10 +03:00
char 'C' <?> " commodity conversion "
many1 spacenonewline
2012-11-20 01:20:10 +04:00
amountp
2010-03-13 04:10:10 +03:00
many spacenonewline
char '='
many spacenonewline
2012-11-20 01:20:10 +04:00
amountp
2010-03-13 04:10:10 +03:00
restofline
2016-05-23 10:32:55 +03:00
return ()
2010-03-13 04:10:10 +03:00
2016-04-23 21:27:39 +03:00
--- ** transactions
2016-04-23 03:43:16 +03:00
2016-04-28 23:23:20 +03:00
modifiertransactionp :: ErroringJournalParser ModifierTransaction
2015-10-17 21:51:45 +03:00
modifiertransactionp = do
2011-08-04 11:49:10 +04:00
char '=' <?> " modifier transaction "
2009-01-23 02:42:34 +03:00
many spacenonewline
2011-08-04 11:49:10 +04:00
valueexpr <- restofline
2016-04-28 23:23:20 +03:00
postings <- postingsp Nothing
2011-08-04 11:49:10 +04:00
return $ ModifierTransaction valueexpr postings
2009-01-23 02:42:34 +03:00
2016-04-28 23:23:20 +03:00
periodictransactionp :: ErroringJournalParser PeriodicTransaction
2015-10-17 21:51:45 +03:00
periodictransactionp = do
2011-08-04 11:49:10 +04:00
char '~' <?> " periodic transaction "
many spacenonewline
periodexpr <- restofline
2016-04-28 23:23:20 +03:00
postings <- postingsp Nothing
2011-08-04 11:49:10 +04:00
return $ PeriodicTransaction periodexpr postings
2010-11-13 02:54:21 +03:00
2012-05-15 05:49:05 +04:00
-- | Parse a (possibly unbalanced) transaction.
2016-04-28 23:23:20 +03:00
transactionp :: ErroringJournalParser Transaction
2015-10-17 21:51:45 +03:00
transactionp = do
-- ptrace "transactionp"
2015-06-29 02:20:28 +03:00
sourcepos <- genericSourcePos <$> getPosition
2014-08-08 18:27:32 +04:00
date <- datep <?> " transaction "
edate <- optionMaybe ( secondarydatep date ) <?> " secondary date "
2014-09-06 20:20:22 +04:00
lookAhead ( spacenonewline <|> newline ) <?> " whitespace or newline "
2015-05-16 21:51:35 +03:00
status <- statusp <?> " cleared status "
2014-02-06 06:55:38 +04:00
code <- codep <?> " transaction code "
2016-05-14 08:09:39 +03:00
description <- strip <$> descriptionp
2014-02-27 23:47:36 +04:00
comment <- try followingcommentp <|> ( newline >> return " " )
2016-04-28 23:23:20 +03:00
let tags = commentTags comment
postings <- postingsp ( Just date )
2016-05-23 10:32:55 +03:00
n <- incrementTransactionCount
return $ txnTieKnot $ Transaction n sourcepos date edate status code description comment tags postings " "
2007-02-09 04:23:12 +03:00
2012-12-06 04:28:23 +04:00
# ifdef TESTS
2015-10-17 21:51:45 +03:00
test_transactionp = do
2012-05-15 05:49:05 +04:00
let s ` gives ` t = do
2016-05-23 10:32:55 +03:00
let p = parseWithState mempty transactionp s
2012-12-06 04:28:23 +04:00
assertBool $ isRight p
2012-05-15 05:49:05 +04:00
let Right t2 = p
2012-12-06 04:28:23 +04:00
-- same f = assertEqual (f t) (f t2)
assertEqual ( tdate t ) ( tdate t2 )
2012-12-06 08:43:41 +04:00
assertEqual ( tdate2 t ) ( tdate2 t2 )
2012-12-06 04:28:23 +04:00
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 )
2014-09-11 00:07:53 +04:00
-- "0000/01/01\n\n" `gives` nulltransaction
2012-05-15 05:49:05 +04:00
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 " ,
2012-12-06 08:43:41 +04:00
tdate2 = Just $ parsedate " 2012/05/15 " ,
2015-05-16 21:51:35 +03:00
tstatus = Uncleared ,
2012-05-15 05:49:05 +04:00
tcode = " code " ,
tdescription = " desc " ,
2012-12-06 04:28:23 +04:00
tcomment = " tcomment1 \ n tcomment2 \ n ttag1: val1 \ n " ,
2012-05-28 02:59:06 +04:00
ttags = [ ( " ttag1 " , " val1 " ) ] ,
2012-05-15 05:49:05 +04:00
tpostings = [
nullposting {
2015-05-16 21:51:35 +03:00
pstatus = Cleared ,
2012-05-15 05:49:05 +04:00
paccount = " a " ,
2012-11-20 01:20:10 +04:00
pamount = Mixed [ usd 1 ] ,
2012-12-06 04:28:23 +04:00
pcomment = " pcomment1 \ n pcomment2 \ n ptag1: val1 \ n ptag2: val2 \ n " ,
2012-05-15 05:49:05 +04:00
ptype = RegularPosting ,
2012-05-28 02:59:06 +04:00
ptags = [ ( " ptag1 " , " val1 " ) , ( " ptag2 " , " val2 " ) ] ,
2012-05-15 05:49:05 +04:00
ptransaction = Nothing
}
] ,
tpreceding_comment_lines = " "
}
2015-06-11 20:13:27 +03:00
unlines [
" 2015/1/1 " ,
]
` gives `
nulltransaction {
tdate = parsedate " 2015/01/01 " ,
}
2012-05-15 05:49:05 +04:00
2016-05-23 10:32:55 +03:00
assertRight $ parseWithState mempty transactionp $ unlines
2012-12-06 04:28:23 +04:00
[ " 2007/01/28 coopportunity "
, " expenses:food:groceries $47.18 "
, " assets:checking $-47.18 "
, " "
]
2015-10-17 21:51:45 +03:00
-- transactionp should not parse just a date
2016-05-23 10:32:55 +03:00
assertLeft $ parseWithState mempty transactionp " 2009/1/1 \ n "
2012-12-06 04:28:23 +04:00
2015-10-17 21:51:45 +03:00
-- transactionp should not parse just a date and description
2016-05-23 10:32:55 +03:00
assertLeft $ parseWithState mempty transactionp " 2009/1/1 a \ n "
2012-12-06 04:28:23 +04:00
2015-10-17 21:51:45 +03:00
-- transactionp should not parse a following comment as part of the description
2016-05-23 10:32:55 +03:00
let p = parseWithState mempty transactionp " 2009/1/1 a ;comment \ n b 1 \ n "
2012-12-06 04:28:23 +04:00
assertRight p
assertEqual " a " ( let Right p' = p in tdescription p' )
-- parse transaction with following whitespace line
2016-05-23 10:32:55 +03:00
assertRight $ parseWithState mempty transactionp $ unlines
2012-12-06 04:28:23 +04:00
[ " 2012/1/1 "
2012-05-27 22:14:20 +04:00
, " a 1 "
, " b "
, " "
]
2014-09-11 00:07:53 +04:00
2016-05-23 10:32:55 +03:00
let p = parseWithState mempty transactionp $ unlines
2012-12-06 04:28:23 +04:00
[ " 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 )
2014-09-11 00:07:53 +04:00
# endif
2012-05-15 05:49:05 +04:00
2016-04-23 21:27:39 +03:00
--- ** postings
2007-02-09 04:23:12 +03:00
2016-04-28 23:23:20 +03:00
-- 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 "
2014-09-11 00:07:53 +04:00
2016-04-28 23:23:20 +03:00
-- linebeginningwithspaces :: Monad m => JournalParser m String
2012-05-14 22:52:22 +04:00
-- linebeginningwithspaces = do
-- sp <- many1 spacenonewline
-- c <- nonspace
-- cs <- restofline
-- return $ sp ++ (c:cs) ++ "\n"
2007-02-09 04:23:12 +03:00
2016-04-28 23:23:20 +03:00
postingp :: Maybe Day -> ErroringJournalParser Posting
postingp mtdate = do
-- pdbg 0 "postingp"
2009-05-25 21:28:41 +04:00
many1 spacenonewline
2015-05-16 21:51:35 +03:00
status <- statusp
2010-11-13 23:20:04 +03:00
many spacenonewline
2015-09-25 03:23:52 +03:00
account <- modifiedaccountnamep
lib: textification begins! account names
The first of several conversions from String to (strict) Text, hopefully
reducing space and time usage.
This one shows a small improvement, with GHC 7.10.3 and text-1.2.2.1:
hledger -f data/100x100x10.journal stats
string: <<ghc: 39471064 bytes, 77 GCs, 198421/275048 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.001 elapsed), 0.015 MUT (0.020 elapsed), 0.010 GC (0.014 elapsed) :ghc>>
text: <<ghc: 39268024 bytes, 77 GCs, 197018/270840 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.002 elapsed), 0.016 MUT (0.022 elapsed), 0.009 GC (0.011 elapsed) :ghc>>
hledger -f data/1000x100x10.journal stats
string: <<ghc: 318555920 bytes, 617 GCs, 2178997/7134472 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.001 elapsed), 0.129 MUT (0.136 elapsed), 0.067 GC (0.077 elapsed) :ghc>>
text: <<ghc: 314248496 bytes, 612 GCs, 2074045/6617960 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.003 elapsed), 0.137 MUT (0.145 elapsed), 0.067 GC (0.079 elapsed) :ghc>>
hledger -f data/10000x100x10.journal stats
string: <<ghc: 3114763608 bytes, 6026 GCs, 18858950/75552024 avg/max bytes residency (11 samples), 201M in use, 0.000 INIT (0.000 elapsed), 1.331 MUT (1.372 elapsed), 0.699 GC (0.812 elapsed) :ghc>>
text: <<ghc: 3071468920 bytes, 5968 GCs, 14120344/62951360 avg/max bytes residency (9 samples), 124M in use, 0.000 INIT (0.003 elapsed), 1.272 MUT (1.349 elapsed), 0.513 GC (0.578 elapsed) :ghc>>
hledger -f data/100000x100x10.journal stats
string: <<ghc: 31186579432 bytes, 60278 GCs, 135332581/740228992 avg/max bytes residency (13 samples), 1697M in use, 0.000 INIT (0.008 elapsed), 14.677 MUT (15.508 elapsed), 7.081 GC (8.074 elapsed) :ghc>>
text: <<ghc: 30753427672 bytes, 59763 GCs, 117595958/666457240 avg/max bytes residency (14 samples), 1588M in use, 0.000 INIT (0.008 elapsed), 13.713 MUT (13.966 elapsed), 6.220 GC (7.108 elapsed) :ghc>>
2016-05-24 04:16:21 +03:00
let ( ptype , account' ) = ( accountNamePostingType account , textUnbracket account )
2015-10-17 21:51:45 +03:00
amount <- spaceandamountormissingp
massertion <- partialbalanceassertionp
_ <- fixedlotpricep
2008-10-16 10:00:46 +04:00
many spacenonewline
2016-04-28 23:23:20 +03:00
( comment , tags , mdate , mdate2 ) <-
try ( followingcommentandtagsp mtdate ) <|> ( newline >> return ( " " , [] , Nothing , Nothing ) )
2014-11-03 08:52:12 +03:00
return posting
2016-04-28 23:23:20 +03:00
{ pdate = mdate
, pdate2 = mdate2
2014-11-03 08:52:12 +03:00
, pstatus = status
, paccount = account'
, pamount = amount
, pcomment = comment
, ptype = ptype
, ptags = tags
, pbalanceassertion = massertion
}
2012-12-06 04:28:23 +04:00
# ifdef TESTS
test_postingp = do
let s ` gives ` ep = do
2016-05-23 10:32:55 +03:00
let parse = parseWithState mempty ( postingp Nothing ) s
2014-09-11 00:07:53 +04:00
assertBool -- "postingp parser"
2012-12-06 04:28:23 +04:00
$ isRight parse
let Right ap = parse
same f = assertEqual ( f ep ) ( f ap )
same pdate
2012-05-15 05:49:05 +04:00
same pstatus
same paccount
same pamount
same pcomment
same ptype
2012-05-28 02:59:06 +04:00
same ptags
2012-05-15 05:49:05 +04:00
same ptransaction
2012-12-06 04:28:23 +04:00
" 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 " ) ] }
2014-09-11 00:07:53 +04:00
" a 1 ; [2012/11/28] \ n " ` gives `
2012-12-06 04:28:23 +04:00
( " a " ` post ` num 1 ) { pcomment = " [2012/11/28] \ n "
, ptags = [ ( " date " , " 2012/11/28 " ) ]
, pdate = parsedateM " 2012/11/28 " }
2014-09-11 00:07:53 +04:00
" a 1 ; a:a, [=2012/11/28] \ n " ` gives `
2012-12-06 04:28:23 +04:00
( " a " ` post ` num 1 ) { pcomment = " a:a, [=2012/11/28] \ n "
, ptags = [ ( " a " , " a " ) , ( " date2 " , " 2012/11/28 " ) ]
, pdate = Nothing }
2014-09-11 00:07:53 +04:00
" a 1 ; a:a \ n ; [2012/11/28=2012/11/29],b:b \ n " ` gives `
2012-12-06 04:28:23 +04:00
( " 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 " }
2014-09-11 00:07:53 +04:00
2012-12-06 04:28:23 +04:00
assertBool -- "postingp parses a quoted commodity with numbers"
2016-05-23 10:32:55 +03:00
( isRight $ parseWithState mempty ( postingp Nothing ) " a 1 \ " DE123 \ " \ n " )
2012-12-06 04:28:23 +04:00
-- ,"postingp parses balance assertions and fixed lot prices" ~: do
2016-05-23 10:32:55 +03:00
assertBool ( isRight $ parseWithState mempty ( postingp Nothing ) " a 1 \ " DE123 \ " =$1 { =2.2 EUR} \ n " )
2012-12-06 04:28:23 +04:00
2016-05-23 10:32:55 +03:00
-- let parse = parseWithState mempty postingp " a\n ;next-line comment\n"
2013-05-29 03:18:15 +04:00
-- assertRight parse
-- let Right p = parse
-- assertEqual "next-line comment\n" (pcomment p)
-- assertEqual (Just nullmixedamt) (pbalanceassertion p)
2014-09-11 00:07:53 +04:00
# endif
2012-05-15 05:49:05 +04:00
2016-04-28 23:23:20 +03:00
--- * more tests
2016-04-23 03:43:16 +03:00
2015-06-11 20:13:27 +03:00
tests_Hledger_Read_JournalReader = TestList $ concat [
-- test_numberp
]
2012-12-06 04:28:23 +04:00
{- old hunit tests
2015-06-11 20:13:27 +03:00
tests_Hledger_Read_JournalReader = TestList $ concat [
2014-02-06 06:55:38 +04:00
test_numberp ,
2012-12-06 04:28:23 +04:00
test_amountp ,
2015-10-17 21:51:45 +03:00
test_spaceandamountormissingp ,
2012-12-06 04:28:23 +04:00
test_tagcomment ,
test_inlinecomment ,
2014-02-27 23:47:36 +04:00
test_comments ,
2012-12-06 04:28:23 +04:00
test_ledgerDateSyntaxToTags ,
test_postingp ,
2015-10-17 21:51:45 +03:00
test_transactionp ,
2012-05-15 05:49:05 +04:00
[
2015-10-17 21:51:45 +03:00
" modifiertransactionp " ~: do
2016-05-23 10:32:55 +03:00
assertParse ( parseWithState mempty modifiertransactionp " = (some value expr) \ n some:postings 1 \ n " )
2010-03-13 04:10:10 +03:00
2015-10-17 21:51:45 +03:00
, " periodictransactionp " ~: do
2016-05-23 10:32:55 +03:00
assertParse ( parseWithState mempty periodictransactionp " ~ (some period expr) \ n some:postings 1 \ n " )
2010-03-13 04:10:10 +03:00
2015-10-17 21:51:45 +03:00
, " directivep " ~: do
2016-05-23 10:32:55 +03:00
assertParse ( parseWithState mempty directivep " !include /some/file.x \ n " )
assertParse ( parseWithState mempty directivep " account some:account \ n " )
assertParse ( parseWithState mempty ( directivep >> directivep ) " !account a \ n end \ n " )
2010-03-13 04:10:10 +03:00
2014-02-27 23:47:36 +04:00
, " comment " ~: do
2016-05-23 10:32:55 +03:00
assertParse ( parseWithState mempty comment " ; some comment \ n " )
assertParse ( parseWithState mempty comment " \ t ; x \ n " )
assertParse ( parseWithState mempty comment " #x " )
2010-03-13 04:10:10 +03:00
2014-08-08 18:27:32 +04:00
, " datep " ~: do
2016-05-23 10:32:55 +03:00
assertParse ( parseWithState mempty datep " 2011/1/1 " )
assertParseFailure ( parseWithState mempty datep " 1/1 " )
assertParse ( parseWithState mempty { jpsYear = Just 2011 } datep " 1/1 " )
2011-05-31 23:49:37 +04:00
2014-02-06 06:55:38 +04:00
, " datetimep " ~: do
let p = do { t <- datetimep ; eof ; return t }
2016-05-23 10:32:55 +03:00
bad = assertParseFailure . parseWithState mempty p
good = assertParse . parseWithState mempty p
2011-06-01 05:50:04 +04:00
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 ) )
2016-05-23 10:32:55 +03:00
assertParseEqual ( parseWithState mempty p " 2011/1/1 00:00-0800 " ) startofday
assertParseEqual ( parseWithState mempty p " 2011/1/1 00:00+1234 " ) startofday
2011-06-01 02:45:54 +04:00
2015-10-17 21:51:45 +03:00
, " defaultyeardirectivep " ~: do
2016-05-23 10:32:55 +03:00
assertParse ( parseWithState mempty defaultyeardirectivep " Y 2010 \ n " )
assertParse ( parseWithState mempty defaultyeardirectivep " Y 10001 \ n " )
2010-03-13 04:10:10 +03:00
2015-10-17 21:51:45 +03:00
, " marketpricedirectivep " ~:
2016-05-23 10:32:55 +03:00
assertParseEqual ( parseWithState mempty marketpricedirectivep " P 2004/05/01 XYZ $55.00 \ n " ) ( MarketPrice ( parsedate " 2004/05/01 " ) " XYZ " $ usd 55 )
2010-03-13 04:10:10 +03:00
2015-10-17 21:51:45 +03:00
, " ignoredpricecommoditydirectivep " ~: do
2016-05-23 10:32:55 +03:00
assertParse ( parseWithState mempty ignoredpricecommoditydirectivep " N $ \ n " )
2010-03-13 04:10:10 +03:00
2015-10-17 21:51:45 +03:00
, " defaultcommoditydirectivep " ~: do
2016-05-23 10:32:55 +03:00
assertParse ( parseWithState mempty defaultcommoditydirectivep " D $1,000.0 \ n " )
2010-03-13 04:10:10 +03:00
2015-10-17 21:51:45 +03:00
, " commodityconversiondirectivep " ~: do
2016-05-23 10:32:55 +03:00
assertParse ( parseWithState mempty commodityconversiondirectivep " C 1h = $50.00 \ n " )
2010-03-13 04:10:10 +03:00
2015-10-17 21:51:45 +03:00
, " tagdirectivep " ~: do
2016-05-23 10:32:55 +03:00
assertParse ( parseWithState mempty tagdirectivep " tag foo \ n " )
2010-03-13 04:10:10 +03:00
2015-10-17 21:51:45 +03:00
, " endtagdirectivep " ~: do
2016-05-23 10:32:55 +03:00
assertParse ( parseWithState mempty endtagdirectivep " end tag \ n " )
assertParse ( parseWithState mempty endtagdirectivep " pop \ n " )
2010-03-13 04:10:10 +03:00
2014-02-06 06:55:38 +04:00
, " 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: " )
2010-03-11 20:16:03 +03:00
2015-10-17 21:51:45 +03:00
, " leftsymbolamountp " ~: do
2016-05-23 10:32:55 +03:00
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 )
2010-05-27 03:44:08 +04:00
2012-05-27 22:14:20 +04:00
, " amount " ~: do
2012-11-20 03:17:55 +04:00
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 )
2016-05-23 10:32:55 +03:00
assertAmountParse ( parseWithState mempty amountp " 1 @ $2 " )
2012-11-20 06:22:20 +04:00
( num 1 ` withPrecision ` 0 ` at ` ( usd 2 ` withPrecision ` 0 ) )
2012-05-27 22:14:20 +04:00
2012-05-09 19:34:05 +04:00
] ]
2012-12-06 04:28:23 +04:00
- }