827 lines
33 KiB
Haskell
827 lines
33 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
{-|
|
|
|
|
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
|
|
@
|
|
|
|
-}
|
|
|
|
module Hledger.Read.JournalReader (
|
|
-- * Reader
|
|
reader,
|
|
-- * Parsers used elsewhere
|
|
emptyLine,
|
|
journalFile,
|
|
ledgeraccountname,
|
|
ledgerdatetime,
|
|
ledgerDefaultYear,
|
|
ledgerDirective,
|
|
ledgerHistoricalPrice,
|
|
someamount,
|
|
parseJournalWith,
|
|
getParentAccount,
|
|
-- * Tests
|
|
tests_Hledger_Read_JournalReader
|
|
)
|
|
where
|
|
import Control.Monad
|
|
import Control.Monad.Error
|
|
import Data.Char (isNumber)
|
|
import Data.List
|
|
import Data.List.Split (wordsBy)
|
|
import Data.Maybe
|
|
import Data.Time.Calendar
|
|
-- import Data.Time.Clock
|
|
-- import Data.Time.Format
|
|
import Data.Time.LocalTime
|
|
import Safe (headDef)
|
|
-- import System.Locale (defaultTimeLocale)
|
|
import Test.HUnit
|
|
import Text.ParserCombinators.Parsec hiding (parse)
|
|
import Text.Printf
|
|
import System.FilePath
|
|
import System.Time (getClockTime)
|
|
|
|
import Hledger.Data
|
|
import Hledger.Utils
|
|
import Prelude hiding (readFile)
|
|
import Hledger.Utils.UTF8IOCompat (readFile)
|
|
|
|
|
|
-- 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 _ = takeExtension f == format
|
|
|
|
-- | Parse and post-process a "Journal" from hledger's journal file
|
|
-- format, or give an error.
|
|
parse :: Maybe FilePath -> FilePath -> String -> ErrorT String IO Journal
|
|
parse _ = parseJournalWith journalFile
|
|
|
|
-- parsing utils
|
|
|
|
-- | Flatten a list of JournalUpdate's into a single equivalent one.
|
|
combineJournalUpdates :: [JournalUpdate] -> JournalUpdate
|
|
combineJournalUpdates us = liftM (foldr (.) id) $ sequence us
|
|
|
|
-- | Given a JournalUpdate-generating parsec parser, file path and data string,
|
|
-- parse and post-process a Journal so that it's ready to use, or give an error.
|
|
parseJournalWith :: (GenParser Char JournalContext (JournalUpdate,JournalContext)) -> FilePath -> String -> ErrorT String IO Journal
|
|
parseJournalWith p f s = do
|
|
tc <- liftIO getClockTime
|
|
tl <- liftIO getCurrentLocalTime
|
|
y <- liftIO getCurrentYear
|
|
case runParser p nullctx{ctxYear=Just y} f s of
|
|
Right (updates,ctx) -> do
|
|
j <- updates `ap` return nulljournal
|
|
case journalFinalise tc tl f s ctx j of
|
|
Right j' -> return j'
|
|
Left estr -> throwError estr
|
|
Left e -> throwError $ show e
|
|
|
|
setYear :: Integer -> GenParser tok JournalContext ()
|
|
setYear y = updateState (\ctx -> ctx{ctxYear=Just y})
|
|
|
|
getYear :: GenParser tok JournalContext (Maybe Integer)
|
|
getYear = liftM ctxYear getState
|
|
|
|
setCommodity :: Commodity -> GenParser tok JournalContext ()
|
|
setCommodity c = updateState (\ctx -> ctx{ctxCommodity=Just c})
|
|
|
|
getCommodity :: GenParser tok JournalContext (Maybe Commodity)
|
|
getCommodity = liftM ctxCommodity getState
|
|
|
|
pushParentAccount :: String -> GenParser tok JournalContext ()
|
|
pushParentAccount parent = updateState addParentAccount
|
|
where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 }
|
|
|
|
popParentAccount :: GenParser tok JournalContext ()
|
|
popParentAccount = do ctx0 <- getState
|
|
case ctxAccount ctx0 of
|
|
[] -> unexpected "End of account block with no beginning"
|
|
(_:rest) -> setState $ ctx0 { ctxAccount = rest }
|
|
|
|
getParentAccount :: GenParser tok JournalContext String
|
|
getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState
|
|
|
|
addAccountAlias :: (AccountName,AccountName) -> GenParser tok JournalContext ()
|
|
addAccountAlias a = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})
|
|
|
|
getAccountAliases :: GenParser tok JournalContext [(AccountName,AccountName)]
|
|
getAccountAliases = liftM ctxAliases getState
|
|
|
|
clearAccountAliases :: GenParser tok JournalContext ()
|
|
clearAccountAliases = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})
|
|
|
|
--
|
|
|
|
-- | 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 $ (combineJournalUpdates 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 [ ledgerDirective
|
|
, liftM (return . addTransaction) ledgerTransaction
|
|
, liftM (return . addModifierTransaction) ledgerModifierTransaction
|
|
, liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction
|
|
, liftM (return . addHistoricalPrice) ledgerHistoricalPrice
|
|
, emptyLine >> return (return id)
|
|
] <?> "journal transaction or directive"
|
|
|
|
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"
|
|
|
|
ledgerDirective :: GenParser Char JournalContext JournalUpdate
|
|
ledgerDirective = do
|
|
optional $ char '!'
|
|
choice' [
|
|
ledgerInclude
|
|
,ledgerAlias
|
|
,ledgerEndAliases
|
|
,ledgerAccountBegin
|
|
,ledgerAccountEnd
|
|
,ledgerTagDirective
|
|
,ledgerEndTagDirective
|
|
,ledgerDefaultYear
|
|
,ledgerDefaultCommodity
|
|
,ledgerCommodityConversion
|
|
,ledgerIgnoredPriceCommodity
|
|
]
|
|
<?> "directive"
|
|
|
|
ledgerInclude :: GenParser Char JournalContext JournalUpdate
|
|
ledgerInclude = do
|
|
string "include"
|
|
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,_) -> combineJournalUpdates [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)
|
|
|
|
journalAddFile :: (FilePath,String) -> Journal -> Journal
|
|
journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}
|
|
|
|
ledgerAccountBegin :: GenParser Char JournalContext JournalUpdate
|
|
ledgerAccountBegin = do
|
|
string "account"
|
|
many1 spacenonewline
|
|
parent <- ledgeraccountname
|
|
newline
|
|
pushParentAccount parent
|
|
return $ return id
|
|
|
|
ledgerAccountEnd :: GenParser Char JournalContext JournalUpdate
|
|
ledgerAccountEnd = do
|
|
string "end"
|
|
popParentAccount
|
|
return (return id)
|
|
|
|
ledgerAlias :: GenParser Char JournalContext JournalUpdate
|
|
ledgerAlias = do
|
|
string "alias"
|
|
many1 spacenonewline
|
|
orig <- many1 $ noneOf "="
|
|
char '='
|
|
alias <- restofline
|
|
addAccountAlias (accountNameWithoutPostingType $ strip orig
|
|
,accountNameWithoutPostingType $ strip alias)
|
|
return $ return id
|
|
|
|
ledgerEndAliases :: GenParser Char JournalContext JournalUpdate
|
|
ledgerEndAliases = do
|
|
string "end aliases"
|
|
clearAccountAliases
|
|
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" <|> string "pop") <?> "end tag or pop directive"
|
|
restofline
|
|
return $ return id
|
|
|
|
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
|
|
|
|
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
|
|
|
|
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
|
|
|
|
-- | Parse a (possibly unbalanced) ledger transaction.
|
|
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
|
|
return $ txnTieKnot $ Transaction date edate status code description comment md postings ""
|
|
|
|
-- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed. The year
|
|
-- may be omitted if a default year has already been set.
|
|
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
|
|
currentyear <- getYear
|
|
[y,m,d] <- case (dateparts,currentyear) of
|
|
([m,d],Just y) -> return [show y,m,d]
|
|
([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"
|
|
([y,m,d],_) -> return [y,m,d]
|
|
_ -> fail $ "bad date: " ++ datestr
|
|
let maybedate = fromGregorianValid (read y) (read m) (read d)
|
|
case maybedate of
|
|
Nothing -> fail $ "bad date: " ++ datestr
|
|
Just date -> return date
|
|
<?> "full or partial date"
|
|
|
|
-- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format. Any
|
|
-- timezone will be ignored; the time is treated as local time. Fewer
|
|
-- digits are allowed, except in the timezone. The year may be omitted if
|
|
-- a default year has already been set.
|
|
ledgerdatetime :: GenParser Char JournalContext LocalTime
|
|
ledgerdatetime = do
|
|
day <- ledgerdate
|
|
many1 spacenonewline
|
|
h <- many1 digit
|
|
let h' = read h
|
|
guard $ h' >= 0 && h' <= 23
|
|
char ':'
|
|
m <- many1 digit
|
|
let m' = read m
|
|
guard $ m' >= 0 && m' <= 59
|
|
s <- optionMaybe $ char ':' >> many1 digit
|
|
let s' = case s of Just sstr -> read sstr
|
|
Nothing -> 0
|
|
guard $ s' >= 0 && s' <= 59
|
|
{- tz <- -}
|
|
optionMaybe $ do
|
|
plusminus <- oneOf "-+"
|
|
d1 <- digit
|
|
d2 <- digit
|
|
d3 <- digit
|
|
d4 <- digit
|
|
return $ plusminus:d1:d2:d3:d4:""
|
|
-- ltz <- liftIO $ getCurrentTimeZone
|
|
-- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz
|
|
-- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
|
|
return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
|
|
|
|
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 { many 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
|
|
-- we'll set the correct position for sub-parses for more useful errors
|
|
pos <- getPosition
|
|
ls <- many1 $ try linebeginningwithspaces
|
|
let lsnumbered = zip ls [0..]
|
|
parses p = isRight . parseWithCtx ctx p
|
|
postinglines = filter (not . (ledgercommentline `parses`) . fst) lsnumbered
|
|
-- group any metadata lines with the posting line above
|
|
postinglinegroups :: [(String,Line)] -> [(String,Line)]
|
|
postinglinegroups [] = []
|
|
postinglinegroups ((pline,num):ls) = (unlines (pline:(map fst mdlines)), num):postinglinegroups rest
|
|
where (mdlines,rest) = span ((ledgermetadataline `parses`) . fst) ls
|
|
pstrs = postinglinegroups postinglines
|
|
parseNumberedPostingLine (str,num) = fromparse $ parseWithCtx ctx (setPosition (incSourceLine pos num) >> ledgerposting) str
|
|
when (null pstrs) $ fail "no postings"
|
|
return $ map parseNumberedPostingLine 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
|
|
many spacenonewline
|
|
account <- modifiedaccountname
|
|
let (ptype, account') = (accountNamePostingType account, unbracket account)
|
|
amount <- postingamount
|
|
many spacenonewline
|
|
comment <- ledgercomment <|> return ""
|
|
newline
|
|
md <- ledgermetadata
|
|
return (Posting status account' amount comment ptype md Nothing)
|
|
|
|
-- Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
|
|
modifiedaccountname :: GenParser Char JournalContext AccountName
|
|
modifiedaccountname = do
|
|
a <- ledgeraccountname
|
|
prefix <- getParentAccount
|
|
let prefixed = prefix `joinAccountNames` a
|
|
aliases <- getAccountAliases
|
|
return $ accountNameApplyAliases aliases prefixed
|
|
|
|
-- | 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,d,s,spos) <- number
|
|
pri <- priceamount
|
|
let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,decimalpoint=d,precision=p,separator=s,separatorpositions=spos}
|
|
return $ applysign $ Mixed [Amount c q pri]
|
|
<?> "left-symbol amount"
|
|
|
|
rightsymbolamount :: GenParser Char JournalContext MixedAmount
|
|
rightsymbolamount = do
|
|
(q,p,d,s,spos) <- number
|
|
sp <- many spacenonewline
|
|
sym <- commoditysymbol
|
|
pri <- priceamount
|
|
let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,decimalpoint=d,precision=p,separator=s,separatorpositions=spos}
|
|
return $ Mixed [Amount c q pri]
|
|
<?> "right-symbol amount"
|
|
|
|
nosymbolamount :: GenParser Char JournalContext MixedAmount
|
|
nosymbolamount = do
|
|
(q,p,d,s,spos) <- number
|
|
pri <- priceamount
|
|
defc <- getCommodity
|
|
let c = fromMaybe Commodity{symbol="",side=L,spaced=False,decimalpoint=d,precision=p,separator=s,separatorpositions=spos} 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 Price)
|
|
priceamount =
|
|
try (do
|
|
many spacenonewline
|
|
char '@'
|
|
try (do
|
|
char '@'
|
|
many spacenonewline
|
|
a <- someamount -- XXX can parse more prices ad infinitum, shouldn't
|
|
return $ Just $ TotalPrice a)
|
|
<|> (do
|
|
many spacenonewline
|
|
a <- someamount -- XXX can parse more prices ad infinitum, shouldn't
|
|
return $ Just $ UnitPrice a))
|
|
<|> return Nothing
|
|
|
|
-- gawd.. trying to parse a ledger number without error:
|
|
|
|
type Quantity = Double
|
|
|
|
-- -- | 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 (Quantity, 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)
|
|
|
|
-- | Parse a numeric quantity for its value and display attributes. Some
|
|
-- international number formats (cf
|
|
-- http://en.wikipedia.org/wiki/Decimal_separator) are accepted: either
|
|
-- period or comma may be used for the decimal point, and the other of
|
|
-- these may be used for separating digit groups in the integer part (eg a
|
|
-- thousands separator). This returns the numeric value, the precision
|
|
-- (number of digits to the right of the decimal point), the decimal point
|
|
-- and separator characters (defaulting to . and ,), and the positions of
|
|
-- separators (counting leftward from the decimal point, the last is
|
|
-- assumed to repeat).
|
|
number :: GenParser Char JournalContext (Quantity, Int, Char, Char, [Int])
|
|
number = do
|
|
sign <- optionMaybe $ string "-"
|
|
parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.']
|
|
let numeric = isNumber . headDef '_'
|
|
(_, puncparts) = partition numeric parts
|
|
(ok,decimalpoint',separator') =
|
|
case puncparts of
|
|
[] -> (True, Nothing, Nothing) -- no punctuation chars
|
|
[d:""] -> (True, Just d, Nothing) -- just one punctuation char, assume it's a decimal point
|
|
[_] -> (False, Nothing, Nothing) -- adjacent punctuation chars, not ok
|
|
_:_:_ -> let (s:ss, d) = (init puncparts, last puncparts) -- two or more punctuation chars
|
|
in if (any ((/=1).length) puncparts -- adjacent punctuation chars, not ok
|
|
|| any (s/=) ss -- separator chars differ, not ok
|
|
|| head parts == s) -- number begins with a separator char, not ok
|
|
then (False, Nothing, Nothing)
|
|
else if s == d
|
|
then (True, Nothing, Just $ head s) -- just one kind of punctuation, assume separator chars
|
|
else (True, Just $ head d, Just $ head s) -- separators and a decimal point
|
|
when (not ok) (fail $ "number seems ill-formed: "++concat parts)
|
|
let (intparts',fracparts') = span ((/= decimalpoint') . Just . head) parts
|
|
(intparts, fracpart) = (filter numeric intparts', filter numeric fracparts')
|
|
separatorpositions = reverse $ map length $ drop 1 intparts
|
|
int = concat $ "":intparts
|
|
frac = concat $ "":fracpart
|
|
precision = length frac
|
|
int' = if null int then "0" else int
|
|
frac' = if null frac then "0" else frac
|
|
sign' = fromMaybe "" sign
|
|
quantity = read $ sign'++int'++"."++frac' -- this read should never fail
|
|
(decimalpoint, separator) = case (decimalpoint', separator') of (Just d, Just s) -> (d,s)
|
|
(Just '.',Nothing) -> ('.',',')
|
|
(Just ',',Nothing) -> (',','.')
|
|
(Nothing, Just '.') -> (',','.')
|
|
(Nothing, Just ',') -> ('.',',')
|
|
_ -> ('.',',')
|
|
return (quantity,precision,decimalpoint,separator,separatorpositions)
|
|
<?> "number"
|
|
|
|
tests_Hledger_Read_JournalReader = TestList [
|
|
|
|
"number" ~: do
|
|
let s `is` n = assertParseEqual (parseWithCtx nullctx number s) n
|
|
assertFails = assertBool "" . isLeft . parseWithCtx nullctx number
|
|
assertFails ""
|
|
"0" `is` (0, 0, '.', ',', [])
|
|
"1" `is` (1, 0, '.', ',', [])
|
|
"1.1" `is` (1.1, 1, '.', ',', [])
|
|
"1,000.1" `is` (1000.1, 1, '.', ',', [3])
|
|
"1.00.000,1" `is` (100000.1, 1, ',', '.', [3,2])
|
|
"1,000,000" `is` (1000000, 0, '.', ',', [3,3])
|
|
"1." `is` (1, 0, '.', ',', [])
|
|
"1," `is` (1, 0, ',', '.', [])
|
|
".1" `is` (0.1, 1, '.', ',', [])
|
|
",1" `is` (0.1, 1, ',', '.', [])
|
|
assertFails "1,000.000,1"
|
|
assertFails "1.000,000.1"
|
|
assertFails "1,000.000.1"
|
|
assertFails "1,,1"
|
|
assertFails "1..1"
|
|
assertFails ".1,"
|
|
assertFails ",1."
|
|
|
|
,"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")
|
|
|
|
,"ledgerDirective" ~: do
|
|
assertParse (parseWithCtx nullctx ledgerDirective "!include /some/file.x\n")
|
|
assertParse (parseWithCtx nullctx ledgerDirective "account some:account\n")
|
|
assertParse (parseWithCtx nullctx (ledgerDirective >> ledgerDirective) "!account a\nend\n")
|
|
|
|
,"ledgercommentline" ~: do
|
|
assertParse (parseWithCtx nullctx ledgercommentline "; some comment \n")
|
|
assertParse (parseWithCtx nullctx ledgercommentline " \t; x\n")
|
|
assertParse (parseWithCtx nullctx ledgercommentline ";x")
|
|
|
|
,"ledgerdate" ~: do
|
|
assertParse (parseWithCtx nullctx ledgerdate "2011/1/1")
|
|
assertParseFailure (parseWithCtx nullctx ledgerdate "1/1")
|
|
assertParse (parseWithCtx nullctx{ctxYear=Just 2011} ledgerdate "1/1")
|
|
|
|
,"ledgerdatetime" ~: do
|
|
let p = do {t <- ledgerdatetime; eof; return t}
|
|
bad = assertParseFailure . parseWithCtx nullctx p
|
|
good = assertParse . parseWithCtx nullctx p
|
|
bad "2011/1/1"
|
|
bad "2011/1/1 24:00:00"
|
|
bad "2011/1/1 00:60:00"
|
|
bad "2011/1/1 00:00:60"
|
|
good "2011/1/1 00:00"
|
|
good "2011/1/1 23:59:59"
|
|
good "2011/1/1 3:5:7"
|
|
-- timezone is parsed but ignored
|
|
let startofday = LocalTime (fromGregorian 2011 1 1) (TimeOfDay 0 0 (fromIntegral 0))
|
|
assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00-0800") startofday
|
|
assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00+1234") startofday
|
|
|
|
,"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")
|
|
,"ledgerEndTagDirective" ~: do
|
|
assertParse (parseWithCtx nullctx ledgerEndTagDirective "pop \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 $ UnitPrice $ 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,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} 1 Nothing])
|
|
,"postingamount with unit price" ~: do
|
|
assertParseEqual
|
|
(parseWithCtx nullctx postingamount " $10 @ €0.5")
|
|
(Mixed [Amount{commodity=dollar{precision=0},
|
|
quantity=10,
|
|
price=(Just $ UnitPrice $ Mixed [Amount{commodity=euro{precision=1},
|
|
quantity=0.5,
|
|
price=Nothing}])}])
|
|
,"postingamount with total price" ~: do
|
|
assertParseEqual
|
|
(parseWithCtx nullctx postingamount " $10 @@ €5")
|
|
(Mixed [Amount{commodity=dollar{precision=0},
|
|
quantity=10,
|
|
price=(Just $ TotalPrice $ Mixed [Amount{commodity=euro{precision=0},
|
|
quantity=5,
|
|
price=Nothing}])}])
|
|
|
|
,"leftsymbolamount" ~: do
|
|
assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1")
|
|
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} 1 Nothing])
|
|
assertParseEqual (parseWithCtx nullctx leftsymbolamount "$-1")
|
|
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} (-1) Nothing])
|
|
assertParseEqual (parseWithCtx nullctx leftsymbolamount "-$1")
|
|
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} (-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] ""
|
|
|