811e71aba7
Like ledger, price amounts are now "unobserved", ie their precision does not affect the canonical display precisions used when displaying amounts, and transaction balancing is done based on display precision, ie amounts are considered to balance if their sum appears to be zero when using the canonical display precision.
680 lines
27 KiB
Haskell
680 lines
27 KiB
Haskell
{-# LANGUAGE CPP #-}
|
||
{-|
|
||
|
||
A reader for hledger's (and c++ ledger's) journal file format.
|
||
|
||
From the ledger 2.5 manual:
|
||
|
||
@
|
||
The ledger file format is quite simple, but also very flexible. It supports
|
||
many options, though typically the user can ignore most of them. They are
|
||
summarized below. The initial character of each line determines what the
|
||
line means, and how it should be interpreted. Allowable initial characters
|
||
are:
|
||
|
||
NUMBER A line beginning with a number denotes an entry. It may be followed by any
|
||
number of lines, each beginning with whitespace, to denote the entry’s account
|
||
transactions. The format of the first line is:
|
||
|
||
DATE[=EDATE] [*|!] [(CODE)] DESC
|
||
|
||
If ‘*’ appears after the date (with optional effective date), it indicates the entry
|
||
is “cleared”, which can mean whatever the user wants it t omean. If ‘!’ appears
|
||
after the date, it indicates d the entry is “pending”; i.e., tentatively cleared from
|
||
the user’s point of view, but not yet actually cleared. If a ‘CODE’ appears in
|
||
parentheses, it may be used to indicate a check number, or the type of the
|
||
transaction. Following these is the payee, or a description of the transaction.
|
||
The format of each following transaction is:
|
||
|
||
ACCOUNT AMOUNT [; NOTE]
|
||
|
||
The ‘ACCOUNT’ may be surrounded by parentheses if it is a virtual
|
||
transactions, or square brackets if it is a virtual transactions that must
|
||
balance. The ‘AMOUNT’ can be followed by a per-unit transaction cost,
|
||
by specifying ‘ AMOUNT’, or a complete transaction cost with ‘\@ AMOUNT’.
|
||
Lastly, the ‘NOTE’ may specify an actual and/or effective date for the
|
||
transaction by using the syntax ‘[ACTUAL_DATE]’ or ‘[=EFFECTIVE_DATE]’ or
|
||
‘[ACTUAL_DATE=EFFECtIVE_DATE]’.
|
||
|
||
= An automated entry. A value expression must appear after the equal sign.
|
||
After this initial line there should be a set of one or more transactions, just as
|
||
if it were normal entry. If the amounts of the transactions have no commodity,
|
||
they will be applied as modifiers to whichever real transaction is matched by
|
||
the value expression.
|
||
|
||
~ A period entry. A period expression must appear after the tilde.
|
||
After this initial line there should be a set of one or more transactions, just as
|
||
if it were normal entry.
|
||
|
||
! A line beginning with an exclamation mark denotes a command directive. It
|
||
must be immediately followed by the command word. The supported commands
|
||
are:
|
||
|
||
‘!include’
|
||
Include the stated ledger file.
|
||
‘!account’
|
||
The account name is given is taken to be the parent of all transac-
|
||
tions that follow, until ‘!end’ is seen.
|
||
‘!end’ Ends an account block.
|
||
|
||
; A line beginning with a colon indicates a comment, and is ignored.
|
||
|
||
Y If a line begins with a capital Y, it denotes the year used for all subsequent
|
||
entries that give a date without a year. The year should appear immediately
|
||
after the Y, for example: ‘Y2004’. This is useful at the beginning of a file, to
|
||
specify the year for that file. If all entries specify a year, however, this command
|
||
has no effect.
|
||
|
||
|
||
P Specifies a historical price for a commodity. These are usually found in a pricing
|
||
history file (see the ‘-Q’ option). The syntax is:
|
||
|
||
P DATE SYMBOL PRICE
|
||
|
||
N SYMBOL Indicates that pricing information is to be ignored for a given symbol, nor will
|
||
quotes ever be downloaded for that symbol. Useful with a home currency, such
|
||
as the dollar ($). It is recommended that these pricing options be set in the price
|
||
database file, which defaults to ‘~/.pricedb’. The syntax for this command is:
|
||
|
||
N SYMBOL
|
||
|
||
|
||
D AMOUNT Specifies the default commodity to use, by specifying an amount in the expected
|
||
format. The entry command will use this commodity as the default when none
|
||
other can be determined. This command may be used multiple times, to set
|
||
the default flags for different commodities; whichever is seen last is used as the
|
||
default commodity. For example, to set US dollars as the default commodity,
|
||
while also setting the thousands flag and decimal flag for that commodity, use:
|
||
|
||
D $1,000.00
|
||
|
||
C AMOUNT1 = AMOUNT2
|
||
Specifies a commodity conversion, where the first amount is given to be equiv-
|
||
alent to the second amount. The first amount should use the decimal precision
|
||
desired during reporting:
|
||
|
||
C 1.00 Kb = 1024 bytes
|
||
|
||
i, o, b, h
|
||
These four relate to timeclock support, which permits ledger to read timelog
|
||
files. See the timeclock’s documentation for more info on the syntax of its
|
||
timelog files.
|
||
@
|
||
|
||
-}
|
||
|
||
module Hledger.Read.JournalReader (
|
||
tests_JournalReader,
|
||
reader,
|
||
journalFile,
|
||
journalAddFile,
|
||
someamount,
|
||
ledgeraccountname,
|
||
ledgerExclamationDirective,
|
||
ledgerHistoricalPrice,
|
||
ledgerDefaultYear,
|
||
emptyLine,
|
||
ledgerdatetime,
|
||
)
|
||
where
|
||
import Control.Monad.Error (ErrorT(..), throwError, catchError)
|
||
import Data.List.Split (wordsBy)
|
||
import Text.ParserCombinators.Parsec hiding (parse)
|
||
#if __GLASGOW_HASKELL__ <= 610
|
||
import Prelude hiding (readFile, putStr, putStrLn, print, getContents)
|
||
import System.IO.UTF8
|
||
#endif
|
||
|
||
import Hledger.Data
|
||
import Hledger.Read.Utils
|
||
|
||
|
||
-- let's get to it
|
||
|
||
reader :: Reader
|
||
reader = Reader format detect parse
|
||
|
||
format :: String
|
||
format = "journal"
|
||
|
||
-- | Does the given file path and data provide hledger's journal file format ?
|
||
detect :: FilePath -> String -> Bool
|
||
detect f _ = fileSuffix f == format
|
||
|
||
-- | Parse and post-process a "Journal" from hledger's journal file
|
||
-- format, or give an error.
|
||
parse :: FilePath -> String -> ErrorT String IO Journal
|
||
parse = parseJournalWith journalFile
|
||
|
||
-- | Top-level journal parser. Returns a single composite, I/O performing,
|
||
-- error-raising "JournalUpdate" (and final "JournalContext") which can be
|
||
-- applied to an empty journal to get the final result.
|
||
journalFile :: GenParser Char JournalContext (JournalUpdate,JournalContext)
|
||
journalFile = do
|
||
journalupdates <- many journalItem
|
||
eof
|
||
finalctx <- getState
|
||
return $ (juSequence journalupdates, finalctx)
|
||
where
|
||
-- As all journal line types can be distinguished by the first
|
||
-- character, excepting transactions versus empty (blank or
|
||
-- comment-only) lines, can use choice w/o try
|
||
journalItem = choice [ ledgerExclamationDirective
|
||
, liftM (return . addTransaction) ledgerTransaction
|
||
, liftM (return . addModifierTransaction) ledgerModifierTransaction
|
||
, liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction
|
||
, liftM (return . addHistoricalPrice) ledgerHistoricalPrice
|
||
, ledgerDefaultYear
|
||
, ledgerDefaultCommodity
|
||
, ledgerIgnoredPriceCommodity
|
||
, ledgerTagDirective
|
||
, ledgerEndTagDirective
|
||
, emptyLine >> return (return id)
|
||
] <?> "journal transaction or directive"
|
||
|
||
journalAddFile :: (FilePath,String) -> Journal -> Journal
|
||
journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}
|
||
|
||
emptyLine :: GenParser Char JournalContext ()
|
||
emptyLine = do many spacenonewline
|
||
optional $ (char ';' <?> "comment") >> many (noneOf "\n")
|
||
newline
|
||
return ()
|
||
|
||
ledgercomment :: GenParser Char JournalContext String
|
||
ledgercomment = do
|
||
many1 $ char ';'
|
||
many spacenonewline
|
||
many (noneOf "\n")
|
||
<?> "comment"
|
||
|
||
ledgercommentline :: GenParser Char JournalContext String
|
||
ledgercommentline = do
|
||
many spacenonewline
|
||
s <- ledgercomment
|
||
optional newline
|
||
eof
|
||
return s
|
||
<?> "comment"
|
||
|
||
ledgerExclamationDirective :: GenParser Char JournalContext JournalUpdate
|
||
ledgerExclamationDirective = do
|
||
char '!' <?> "directive"
|
||
directive <- many nonspace
|
||
case directive of
|
||
"include" -> ledgerInclude
|
||
"account" -> ledgerAccountBegin
|
||
"end" -> ledgerAccountEnd
|
||
_ -> mzero
|
||
|
||
ledgerInclude :: GenParser Char JournalContext JournalUpdate
|
||
ledgerInclude = do
|
||
many1 spacenonewline
|
||
filename <- restofline
|
||
outerState <- getState
|
||
outerPos <- getPosition
|
||
return $ do filepath <- expandPath outerPos filename
|
||
txt <- readFileOrError outerPos filepath
|
||
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
|
||
case runParser journalFile outerState filepath txt of
|
||
Right (ju,_) -> juSequence [return $ journalAddFile (filepath,txt), ju] `catchError` (throwError . (inIncluded ++))
|
||
Left err -> throwError $ inIncluded ++ show err
|
||
where readFileOrError pos fp =
|
||
ErrorT $ liftM Right (readFile fp) `catch`
|
||
\err -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show err)
|
||
|
||
ledgerAccountBegin :: GenParser Char JournalContext JournalUpdate
|
||
ledgerAccountBegin = do many1 spacenonewline
|
||
parent <- ledgeraccountname
|
||
newline
|
||
pushParentAccount parent
|
||
return $ return id
|
||
|
||
ledgerAccountEnd :: GenParser Char JournalContext JournalUpdate
|
||
ledgerAccountEnd = popParentAccount >> return (return id)
|
||
|
||
ledgerModifierTransaction :: GenParser Char JournalContext ModifierTransaction
|
||
ledgerModifierTransaction = do
|
||
char '=' <?> "modifier transaction"
|
||
many spacenonewline
|
||
valueexpr <- restofline
|
||
postings <- ledgerpostings
|
||
return $ ModifierTransaction valueexpr postings
|
||
|
||
ledgerPeriodicTransaction :: GenParser Char JournalContext PeriodicTransaction
|
||
ledgerPeriodicTransaction = do
|
||
char '~' <?> "periodic transaction"
|
||
many spacenonewline
|
||
periodexpr <- restofline
|
||
postings <- ledgerpostings
|
||
return $ PeriodicTransaction periodexpr postings
|
||
|
||
ledgerHistoricalPrice :: GenParser Char JournalContext HistoricalPrice
|
||
ledgerHistoricalPrice = do
|
||
char 'P' <?> "historical price"
|
||
many spacenonewline
|
||
date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate -- a time is ignored
|
||
many1 spacenonewline
|
||
symbol <- commoditysymbol
|
||
many spacenonewline
|
||
price <- someamount
|
||
restofline
|
||
return $ HistoricalPrice date symbol price
|
||
|
||
ledgerIgnoredPriceCommodity :: GenParser Char JournalContext JournalUpdate
|
||
ledgerIgnoredPriceCommodity = do
|
||
char 'N' <?> "ignored-price commodity"
|
||
many1 spacenonewline
|
||
commoditysymbol
|
||
restofline
|
||
return $ return id
|
||
|
||
ledgerCommodityConversion :: GenParser Char JournalContext JournalUpdate
|
||
ledgerCommodityConversion = do
|
||
char 'C' <?> "commodity conversion"
|
||
many1 spacenonewline
|
||
someamount
|
||
many spacenonewline
|
||
char '='
|
||
many spacenonewline
|
||
someamount
|
||
restofline
|
||
return $ return id
|
||
|
||
ledgerTagDirective :: GenParser Char JournalContext JournalUpdate
|
||
ledgerTagDirective = do
|
||
string "tag" <?> "tag directive"
|
||
many1 spacenonewline
|
||
_ <- many1 nonspace
|
||
restofline
|
||
return $ return id
|
||
|
||
ledgerEndTagDirective :: GenParser Char JournalContext JournalUpdate
|
||
ledgerEndTagDirective = do
|
||
string "end tag" <?> "end tag directive"
|
||
restofline
|
||
return $ return id
|
||
|
||
-- like ledgerAccountBegin, updates the JournalContext
|
||
ledgerDefaultYear :: GenParser Char JournalContext JournalUpdate
|
||
ledgerDefaultYear = do
|
||
char 'Y' <?> "default year"
|
||
many spacenonewline
|
||
y <- many1 digit
|
||
let y' = read y
|
||
failIfInvalidYear y
|
||
setYear y'
|
||
return $ return id
|
||
|
||
ledgerDefaultCommodity :: GenParser Char JournalContext JournalUpdate
|
||
ledgerDefaultCommodity = do
|
||
char 'D' <?> "default commodity"
|
||
many1 spacenonewline
|
||
a <- someamount
|
||
-- someamount always returns a MixedAmount containing one Amount, but let's be safe
|
||
let as = amounts a
|
||
when (not $ null as) $ setCommodity $ commodity $ head as
|
||
restofline
|
||
return $ return id
|
||
|
||
-- | Try to parse a ledger entry. If we successfully parse an entry,
|
||
-- check it can be balanced, and fail if not.
|
||
ledgerTransaction :: GenParser Char JournalContext Transaction
|
||
ledgerTransaction = do
|
||
date <- ledgerdate <?> "transaction"
|
||
edate <- optionMaybe (ledgereffectivedate date) <?> "effective date"
|
||
status <- ledgerstatus <?> "cleared flag"
|
||
code <- ledgercode <?> "transaction code"
|
||
(description, comment) <-
|
||
(do {many1 spacenonewline; d <- liftM rstrip (many (noneOf ";\n")); c <- ledgercomment <|> return ""; newline; return (d, c)} <|>
|
||
do {many spacenonewline; c <- ledgercomment <|> return ""; newline; return ("", c)}
|
||
) <?> "description and/or comment"
|
||
md <- try ledgermetadata <|> return []
|
||
postings <- ledgerpostings
|
||
let t = txnTieKnot $ Transaction date edate status code description comment md postings ""
|
||
-- case balanceTransaction Nothing t of
|
||
-- Right t' -> return t'
|
||
-- Left err -> fail err
|
||
-- check it later, after we have worked out commodity display precisions
|
||
return t
|
||
|
||
ledgerdate :: GenParser Char JournalContext Day
|
||
ledgerdate = do
|
||
-- hacky: try to ensure precise errors for invalid dates
|
||
-- XXX reported error position is not too good
|
||
-- pos <- getPosition
|
||
datestr <- many1 $ choice' [digit, datesepchar]
|
||
let dateparts = wordsBy (`elem` datesepchars) datestr
|
||
case dateparts of
|
||
[y,m,d] -> do
|
||
failIfInvalidYear y
|
||
failIfInvalidMonth m
|
||
failIfInvalidDay d
|
||
return $ fromGregorian (read y) (read m) (read d)
|
||
[m,d] -> do
|
||
y <- getYear
|
||
case y of Nothing -> fail "partial date found, but no default year specified"
|
||
Just y' -> do failIfInvalidYear $ show y'
|
||
failIfInvalidMonth m
|
||
failIfInvalidDay d
|
||
return $ fromGregorian y' (read m) (read d)
|
||
_ -> fail $ "bad date: " ++ datestr
|
||
<?> "full or partial date"
|
||
|
||
ledgerdatetime :: GenParser Char JournalContext LocalTime
|
||
ledgerdatetime = do
|
||
day <- ledgerdate
|
||
many1 spacenonewline
|
||
h <- many1 digit
|
||
char ':'
|
||
m <- many1 digit
|
||
s <- optionMaybe $ do
|
||
char ':'
|
||
many1 digit
|
||
let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)
|
||
return $ LocalTime day tod
|
||
|
||
ledgereffectivedate :: Day -> GenParser Char JournalContext Day
|
||
ledgereffectivedate actualdate = do
|
||
char '='
|
||
-- kludgy way to use actual date for default year
|
||
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 ledgerdate
|
||
return edate
|
||
|
||
ledgerstatus :: GenParser Char JournalContext Bool
|
||
ledgerstatus = try (do { many1 spacenonewline; char '*' <?> "status"; return True } ) <|> return False
|
||
|
||
ledgercode :: GenParser Char JournalContext String
|
||
ledgercode = try (do { many1 spacenonewline; char '(' <?> "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
|
||
|
||
ledgermetadata :: GenParser Char JournalContext [(String,String)]
|
||
ledgermetadata = many ledgermetadataline
|
||
|
||
-- a comment line containing a metadata declaration, eg:
|
||
-- ; name: value
|
||
ledgermetadataline :: GenParser Char JournalContext (String,String)
|
||
ledgermetadataline = do
|
||
many1 spacenonewline
|
||
many1 $ char ';'
|
||
many spacenonewline
|
||
name <- many1 $ noneOf ": \t"
|
||
char ':'
|
||
many spacenonewline
|
||
value <- many (noneOf "\n")
|
||
optional newline
|
||
-- eof
|
||
return (name,value)
|
||
<?> "metadata line"
|
||
|
||
-- Parse the following whitespace-beginning lines as postings, posting metadata, and/or comments.
|
||
-- complicated to handle intermixed comment and metadata lines.. make me better ?
|
||
ledgerpostings :: GenParser Char JournalContext [Posting]
|
||
ledgerpostings = do
|
||
ctx <- getState
|
||
-- pass current position to the sub-parses for more useful errors
|
||
pos <- getPosition
|
||
ls <- many1 $ try linebeginningwithspaces
|
||
let parses p = isRight . parseWithCtx ctx p
|
||
postinglines = filter (not . (ledgercommentline `parses`)) ls
|
||
postinglinegroups :: [String] -> [String]
|
||
postinglinegroups [] = []
|
||
postinglinegroups (pline:ls) = (unlines $ pline:mdlines):postinglinegroups rest
|
||
where (mdlines,rest) = span (ledgermetadataline `parses`) ls
|
||
pstrs = postinglinegroups postinglines
|
||
when (null pstrs) $ fail "no postings"
|
||
return $ map (fromparse . parseWithCtx ctx (setPosition pos >> ledgerposting)) pstrs
|
||
<?> "postings"
|
||
|
||
linebeginningwithspaces :: GenParser Char JournalContext String
|
||
linebeginningwithspaces = do
|
||
sp <- many1 spacenonewline
|
||
c <- nonspace
|
||
cs <- restofline
|
||
return $ sp ++ (c:cs) ++ "\n"
|
||
|
||
ledgerposting :: GenParser Char JournalContext Posting
|
||
ledgerposting = do
|
||
many1 spacenonewline
|
||
status <- ledgerstatus
|
||
account <- transactionaccountname
|
||
let (ptype, account') = (postingTypeFromAccountName account, unbracket account)
|
||
amount <- postingamount
|
||
many spacenonewline
|
||
comment <- ledgercomment <|> return ""
|
||
newline
|
||
md <- ledgermetadata
|
||
return (Posting status account' amount comment ptype md Nothing)
|
||
|
||
-- qualify with the parent account from parsing context
|
||
transactionaccountname :: GenParser Char JournalContext AccountName
|
||
transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname
|
||
|
||
-- | Parse an account name. Account names may have single spaces inside
|
||
-- them, and are terminated by two or more spaces. They should have one or
|
||
-- more components of at least one character, separated by the account
|
||
-- separator char.
|
||
ledgeraccountname :: GenParser Char st AccountName
|
||
ledgeraccountname = 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 ' '}})
|
||
-- couldn't avoid consuming a final space sometimes, harmless
|
||
striptrailingspace s = if last s == ' ' then init s else s
|
||
|
||
-- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace
|
||
-- <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"
|
||
|
||
-- | Parse an amount, with an optional left or right currency symbol and
|
||
-- optional price.
|
||
postingamount :: GenParser Char JournalContext MixedAmount
|
||
postingamount =
|
||
try (do
|
||
many1 spacenonewline
|
||
someamount <|> return missingamt
|
||
) <|> return missingamt
|
||
|
||
someamount :: GenParser Char JournalContext MixedAmount
|
||
someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount
|
||
|
||
leftsymbolamount :: GenParser Char JournalContext MixedAmount
|
||
leftsymbolamount = do
|
||
sign <- optionMaybe $ string "-"
|
||
let applysign = if isJust sign then negate else id
|
||
sym <- commoditysymbol
|
||
sp <- many spacenonewline
|
||
(q,p,comma) <- amountquantity
|
||
pri <- priceamount
|
||
let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,comma=comma,precision=p}
|
||
return $ applysign $ Mixed [Amount c q pri]
|
||
<?> "left-symbol amount"
|
||
|
||
rightsymbolamount :: GenParser Char JournalContext MixedAmount
|
||
rightsymbolamount = do
|
||
(q,p,comma) <- amountquantity
|
||
sp <- many spacenonewline
|
||
sym <- commoditysymbol
|
||
pri <- priceamount
|
||
let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,comma=comma,precision=p}
|
||
return $ Mixed [Amount c q pri]
|
||
<?> "right-symbol amount"
|
||
|
||
nosymbolamount :: GenParser Char JournalContext MixedAmount
|
||
nosymbolamount = do
|
||
(q,p,comma) <- amountquantity
|
||
pri <- priceamount
|
||
defc <- getCommodity
|
||
let c = fromMaybe Commodity{symbol="",side=L,spaced=False,comma=comma,precision=p} defc
|
||
return $ Mixed [Amount c q pri]
|
||
<?> "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 (Maybe MixedAmount)
|
||
priceamount =
|
||
try (do
|
||
many spacenonewline
|
||
char '@'
|
||
many spacenonewline
|
||
a <- someamount -- XXX could parse more prices ad infinitum, shouldn't
|
||
return $ Just a
|
||
) <|> return Nothing
|
||
|
||
-- gawd.. trying to parse a ledger number without error:
|
||
|
||
-- | Parse a ledger-style numeric quantity and also return the number of
|
||
-- digits to the right of the decimal point and whether thousands are
|
||
-- separated by comma.
|
||
amountquantity :: GenParser Char JournalContext (Double, Int, Bool)
|
||
amountquantity = do
|
||
sign <- optionMaybe $ string "-"
|
||
(intwithcommas,frac) <- numberparts
|
||
let comma = ',' `elem` intwithcommas
|
||
let precision = length frac
|
||
-- read the actual value. We expect this read to never fail.
|
||
let int = filter (/= ',') intwithcommas
|
||
let int' = if null int then "0" else int
|
||
let frac' = if null frac then "0" else frac
|
||
let sign' = fromMaybe "" sign
|
||
let quantity = read $ sign'++int'++"."++frac'
|
||
return (quantity, precision, comma)
|
||
<?> "commodity quantity"
|
||
|
||
-- | parse the two strings of digits before and after a possible decimal
|
||
-- point. The integer part may contain commas, or either part may be
|
||
-- empty, or there may be no point.
|
||
numberparts :: GenParser Char JournalContext (String,String)
|
||
numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint
|
||
|
||
numberpartsstartingwithdigit :: GenParser Char JournalContext (String,String)
|
||
numberpartsstartingwithdigit = do
|
||
let digitorcomma = digit <|> char ','
|
||
first <- digit
|
||
rest <- many digitorcomma
|
||
frac <- try (do {char '.'; many digit}) <|> return ""
|
||
return (first:rest,frac)
|
||
|
||
numberpartsstartingwithpoint :: GenParser Char JournalContext (String,String)
|
||
numberpartsstartingwithpoint = do
|
||
char '.'
|
||
frac <- many1 digit
|
||
return ("",frac)
|
||
|
||
|
||
tests_JournalReader = TestList [
|
||
|
||
"ledgerTransaction" ~: do
|
||
assertParseEqual (parseWithCtx nullctx ledgerTransaction entry1_str) entry1
|
||
assertBool "ledgerTransaction should not parse just a date"
|
||
$ isLeft $ parseWithCtx nullctx ledgerTransaction "2009/1/1\n"
|
||
assertBool "ledgerTransaction should require some postings"
|
||
$ isLeft $ parseWithCtx nullctx ledgerTransaction "2009/1/1 a\n"
|
||
let t = parseWithCtx nullctx ledgerTransaction "2009/1/1 a ;comment\n b 1\n"
|
||
assertBool "ledgerTransaction should not include a comment in the description"
|
||
$ either (const False) ((== "a") . tdescription) t
|
||
|
||
,"ledgerModifierTransaction" ~: do
|
||
assertParse (parseWithCtx nullctx ledgerModifierTransaction "= (some value expr)\n some:postings 1\n")
|
||
|
||
,"ledgerPeriodicTransaction" ~: do
|
||
assertParse (parseWithCtx nullctx ledgerPeriodicTransaction "~ (some period expr)\n some:postings 1\n")
|
||
|
||
,"ledgerExclamationDirective" ~: do
|
||
assertParse (parseWithCtx nullctx ledgerExclamationDirective "!include /some/file.x\n")
|
||
assertParse (parseWithCtx nullctx ledgerExclamationDirective "!account some:account\n")
|
||
assertParse (parseWithCtx nullctx (ledgerExclamationDirective >> ledgerExclamationDirective) "!account a\n!end\n")
|
||
|
||
,"ledgercommentline" ~: do
|
||
assertParse (parseWithCtx nullctx ledgercommentline "; some comment \n")
|
||
assertParse (parseWithCtx nullctx ledgercommentline " \t; x\n")
|
||
assertParse (parseWithCtx nullctx ledgercommentline ";x")
|
||
|
||
,"ledgerDefaultYear" ~: do
|
||
assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 2010\n")
|
||
assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 10001\n")
|
||
|
||
,"ledgerHistoricalPrice" ~:
|
||
assertParseEqual (parseWithCtx nullctx ledgerHistoricalPrice "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55])
|
||
|
||
,"ledgerIgnoredPriceCommodity" ~: do
|
||
assertParse (parseWithCtx nullctx ledgerIgnoredPriceCommodity "N $\n")
|
||
|
||
,"ledgerDefaultCommodity" ~: do
|
||
assertParse (parseWithCtx nullctx ledgerDefaultCommodity "D $1,000.0\n")
|
||
|
||
,"ledgerCommodityConversion" ~: do
|
||
assertParse (parseWithCtx nullctx ledgerCommodityConversion "C 1h = $50.00\n")
|
||
|
||
,"ledgerTagDirective" ~: do
|
||
assertParse (parseWithCtx nullctx ledgerTagDirective "tag foo \n")
|
||
|
||
,"ledgerEndTagDirective" ~: do
|
||
assertParse (parseWithCtx nullctx ledgerEndTagDirective "end tag \n")
|
||
|
||
,"ledgeraccountname" ~: do
|
||
assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c")
|
||
assertBool "ledgeraccountname rejects an empty inner component" (isLeft $ parsewith ledgeraccountname "a::c")
|
||
assertBool "ledgeraccountname rejects an empty leading component" (isLeft $ parsewith ledgeraccountname ":b:c")
|
||
assertBool "ledgeraccountname rejects an empty trailing component" (isLeft $ parsewith ledgeraccountname "a:b:")
|
||
|
||
,"ledgerposting" ~: do
|
||
assertParseEqual (parseWithCtx nullctx ledgerposting " expenses:food:dining $10.00\n")
|
||
(Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting [] Nothing)
|
||
assertBool "ledgerposting parses a quoted commodity with numbers"
|
||
(isRight $ parseWithCtx nullctx ledgerposting " a 1 \"DE123\"\n")
|
||
|
||
,"someamount" ~: do
|
||
let -- | compare a parse result with a MixedAmount, showing the debug representation for clarity
|
||
assertMixedAmountParse parseresult mixedamount =
|
||
(either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount)
|
||
assertMixedAmountParse (parseWithCtx nullctx someamount "1 @ $2")
|
||
(Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])])
|
||
|
||
,"postingamount" ~: do
|
||
assertParseEqual (parseWithCtx nullctx postingamount " $47.18") (Mixed [dollars 47.18])
|
||
assertParseEqual (parseWithCtx nullctx postingamount " $1.")
|
||
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing])
|
||
|
||
,"leftsymbolamount" ~: do
|
||
assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1")
|
||
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing])
|
||
assertParseEqual (parseWithCtx nullctx leftsymbolamount "$-1")
|
||
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} (-1) Nothing])
|
||
assertParseEqual (parseWithCtx nullctx leftsymbolamount "-$1")
|
||
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} (-1) Nothing])
|
||
|
||
]
|
||
|
||
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 [dollars 47.18]) "" RegularPosting [] Nothing,
|
||
Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] Nothing] ""
|
||
|