mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-20 02:37:12 +03:00
7ed2a0aa9b
In Amount, aismultiplier is a boolean flag that will always be False, except for in TMPostingRules, where it indicates whether the posting rule is a multiplier. It is therefore unnecessary in the vast majority of cases. This posting pulls this flag out of Amount and puts it into TMPostingRule, so it is only kept around when necessary. This changes the parsing of journals somewhat. Previously you could include an * before an amount anywhere in a Journal, and it would happily parse and set the aismultiplier flag true. This will now fail with a parse error: * is now only acceptable before an amount within an auto posting rule. Any usage of the library in which the aismultiplier field is read or set should be removed. If you truly need its functionality, you should switch to using TMPostingRule. This changes the JSON output of Amount, as it will no longer include aismultiplier.
1043 lines
38 KiB
Haskell
1043 lines
38 KiB
Haskell
--- * -*- outline-regexp:"--- *"; -*-
|
|
--- ** doc
|
|
-- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections.
|
|
{-|
|
|
|
|
A reader for hledger's journal file format
|
|
(<http://hledger.org/MANUAL.html#the-journal-file>). hledger's journal
|
|
format is a compatible subset of c++ ledger's
|
|
(<http://ledger-cli.org/3.0/doc/ledger3.html#Journal-Format>), so this
|
|
reader should handle many ledger files as well. Example:
|
|
|
|
@
|
|
2012\/3\/24 gift
|
|
expenses:gifts $10
|
|
assets:cash
|
|
@
|
|
|
|
Journal format supports the include directive which can read files in
|
|
other formats, so the other file format readers need to be importable
|
|
and invocable here.
|
|
|
|
Some important parts of journal parsing are therefore kept in
|
|
Hledger.Read.Common, to avoid import cycles.
|
|
|
|
-}
|
|
|
|
--- ** language
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE NoMonoLocalBinds #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
--- ** exports
|
|
module Hledger.Read.JournalReader (
|
|
|
|
-- * Reader-finding utils
|
|
findReader,
|
|
splitReaderPrefix,
|
|
|
|
-- * Reader
|
|
reader,
|
|
|
|
-- * Parsing utils
|
|
genericSourcePos,
|
|
parseAndFinaliseJournal,
|
|
runJournalParser,
|
|
rjp,
|
|
|
|
-- * Parsers used elsewhere
|
|
getParentAccount,
|
|
journalp,
|
|
directivep,
|
|
defaultyeardirectivep,
|
|
marketpricedirectivep,
|
|
datetimep,
|
|
datep,
|
|
modifiedaccountnamep,
|
|
tmpostingrulep,
|
|
statusp,
|
|
emptyorcommentlinep,
|
|
followingcommentp,
|
|
accountaliasp
|
|
|
|
-- * Tests
|
|
,tests_JournalReader
|
|
)
|
|
where
|
|
|
|
--- ** imports
|
|
-- import qualified Prelude (fail)
|
|
-- import "base-compat-batteries" Prelude.Compat hiding (fail, readFile)
|
|
import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (fail)
|
|
import qualified Control.Exception as C
|
|
import Control.Monad (forM_, when, void)
|
|
import Control.Monad.IO.Class (MonadIO, liftIO)
|
|
import Control.Monad.Except (ExceptT(..), runExceptT)
|
|
import Control.Monad.State.Strict (get,modify',put)
|
|
import Control.Monad.Trans.Class (lift)
|
|
import Data.Char (toLower)
|
|
import Data.Either (isRight)
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Text (Text)
|
|
import Data.String
|
|
import Data.List
|
|
import Data.Maybe
|
|
import qualified Data.Text as T
|
|
import Data.Time.Calendar
|
|
import Data.Time.LocalTime
|
|
import Safe
|
|
import Text.Megaparsec hiding (parse)
|
|
import Text.Megaparsec.Char
|
|
import Text.Megaparsec.Custom
|
|
import Text.Printf
|
|
import System.FilePath
|
|
import "Glob" System.FilePath.Glob hiding (match)
|
|
|
|
import Hledger.Data
|
|
import Hledger.Read.Common
|
|
import Hledger.Utils
|
|
|
|
import qualified Hledger.Read.TimedotReader as TimedotReader (reader)
|
|
import qualified Hledger.Read.TimeclockReader as TimeclockReader (reader)
|
|
import qualified Hledger.Read.CsvReader as CsvReader (reader)
|
|
|
|
--- ** doctest setup
|
|
-- $setup
|
|
-- >>> :set -XOverloadedStrings
|
|
|
|
--- ** reader finding utilities
|
|
-- Defined here rather than Hledger.Read so that we can use them in includedirectivep below.
|
|
|
|
-- The available journal readers, each one handling a particular data format.
|
|
readers' :: MonadIO m => [Reader m]
|
|
readers' = [
|
|
reader
|
|
,TimeclockReader.reader
|
|
,TimedotReader.reader
|
|
,CsvReader.reader
|
|
-- ,LedgerReader.reader
|
|
]
|
|
|
|
readerNames :: [String]
|
|
readerNames = map rFormat (readers'::[Reader IO])
|
|
|
|
-- | @findReader mformat mpath@
|
|
--
|
|
-- Find the reader named by @mformat@, if provided.
|
|
-- Or, if a file path is provided, find the first reader that handles
|
|
-- its file extension, if any.
|
|
findReader :: MonadIO m => Maybe StorageFormat -> Maybe FilePath -> Maybe (Reader m)
|
|
findReader Nothing Nothing = Nothing
|
|
findReader (Just fmt) _ = headMay [r | r <- readers', rFormat r == fmt]
|
|
findReader Nothing (Just path) =
|
|
case prefix of
|
|
Just fmt -> headMay [r | r <- readers', rFormat r == fmt]
|
|
Nothing -> headMay [r | r <- readers', ext `elem` rExtensions r]
|
|
where
|
|
(prefix,path') = splitReaderPrefix path
|
|
ext = map toLower $ drop 1 $ takeExtension path'
|
|
|
|
-- | A file path optionally prefixed by a reader name and colon
|
|
-- (journal:, csv:, timedot:, etc.).
|
|
type PrefixedFilePath = FilePath
|
|
|
|
-- | If a filepath is prefixed by one of the reader names and a colon,
|
|
-- split that off. Eg "csv:-" -> (Just "csv", "-").
|
|
splitReaderPrefix :: PrefixedFilePath -> (Maybe String, FilePath)
|
|
splitReaderPrefix f =
|
|
headDef (Nothing, f)
|
|
[(Just r, drop (length r + 1) f) | r <- readerNames, (r++":") `isPrefixOf` f]
|
|
|
|
--- ** reader
|
|
|
|
reader :: MonadIO m => Reader m
|
|
reader = Reader
|
|
{rFormat = "journal"
|
|
,rExtensions = ["journal", "j", "hledger", "ledger"]
|
|
,rReadFn = parse
|
|
,rParser = journalp -- no need to add command line aliases like journalp'
|
|
-- when called as a subparser I think
|
|
}
|
|
|
|
-- | Parse and post-process a "Journal" from hledger's journal file
|
|
-- format, or give an error.
|
|
parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
|
|
parse iopts = parseAndFinaliseJournal journalp' iopts
|
|
where
|
|
journalp' = do
|
|
-- reverse parsed aliases to ensure that they are applied in order given on commandline
|
|
mapM_ addAccountAlias (reverse $ aliasesFromOpts iopts)
|
|
journalp
|
|
|
|
--- ** parsers
|
|
--- *** journal
|
|
|
|
-- | A journal parser. Accumulates and returns a "ParsedJournal",
|
|
-- which should be finalised/validated before use.
|
|
--
|
|
-- >>> rejp (journalp <* eof) "2015/1/1\n a 0\n"
|
|
-- Right (Right Journal with 1 transactions, 1 accounts)
|
|
--
|
|
journalp :: MonadIO m => ErroringJournalParser m ParsedJournal
|
|
journalp = do
|
|
many addJournalItemP
|
|
eof
|
|
get
|
|
|
|
-- | A side-effecting parser; parses any kind of journal item
|
|
-- and updates the parse state accordingly.
|
|
addJournalItemP :: MonadIO m => ErroringJournalParser m ()
|
|
addJournalItemP =
|
|
-- all journal line types can be distinguished by the first
|
|
-- character, can use choice without backtracking
|
|
choice [
|
|
directivep
|
|
, transactionp >>= modify' . addTransaction
|
|
, transactionmodifierp >>= modify' . addTransactionModifier
|
|
, periodictransactionp >>= modify' . addPeriodicTransaction
|
|
, marketpricedirectivep >>= modify' . addPriceDirective
|
|
, void (lift emptyorcommentlinep)
|
|
, void (lift multilinecommentp)
|
|
] <?> "transaction or directive"
|
|
|
|
--- *** directives
|
|
|
|
-- | Parse any journal directive and update the parse state accordingly.
|
|
-- Cf http://hledger.org/manual.html#directives,
|
|
-- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives
|
|
directivep :: MonadIO m => ErroringJournalParser m ()
|
|
directivep = (do
|
|
optional $ char '!'
|
|
choice [
|
|
includedirectivep
|
|
,aliasdirectivep
|
|
,endaliasesdirectivep
|
|
,accountdirectivep
|
|
,applyaccountdirectivep
|
|
,commoditydirectivep
|
|
,endapplyaccountdirectivep
|
|
,payeedirectivep
|
|
,tagdirectivep
|
|
,endtagdirectivep
|
|
,defaultyeardirectivep
|
|
,defaultcommoditydirectivep
|
|
,commodityconversiondirectivep
|
|
,ignoredpricecommoditydirectivep
|
|
]
|
|
) <?> "directive"
|
|
|
|
-- | Parse an include directive. include's argument is an optionally
|
|
-- file-format-prefixed file path or glob pattern. In the latter case,
|
|
-- the prefix is applied to each matched path. Examples:
|
|
-- foo.j, foo/bar.j, timedot:foo/2020*.md
|
|
includedirectivep :: MonadIO m => ErroringJournalParser m ()
|
|
includedirectivep = do
|
|
string "include"
|
|
lift skipNonNewlineSpaces1
|
|
prefixedglob <- T.unpack <$> takeWhileP Nothing (/= '\n') -- don't consume newline yet
|
|
parentoff <- getOffset
|
|
parentpos <- getSourcePos
|
|
let (mprefix,glob) = splitReaderPrefix prefixedglob
|
|
paths <- getFilePaths parentoff parentpos glob
|
|
let prefixedpaths = case mprefix of
|
|
Nothing -> paths
|
|
Just fmt -> map ((fmt++":")++) paths
|
|
forM_ prefixedpaths $ parseChild parentpos
|
|
void newline
|
|
|
|
where
|
|
getFilePaths
|
|
:: MonadIO m => Int -> SourcePos -> FilePath -> JournalParser m [FilePath]
|
|
getFilePaths parseroff parserpos filename = do
|
|
let curdir = takeDirectory (sourceName parserpos)
|
|
filename' <- lift $ expandHomePath filename
|
|
`orRethrowIOError` (show parserpos ++ " locating " ++ filename)
|
|
-- Compiling filename as a glob pattern works even if it is a literal
|
|
fileglob <- case tryCompileWith compDefault{errorRecovery=False} filename' of
|
|
Right x -> pure x
|
|
Left e -> customFailure $
|
|
parseErrorAt parseroff $ "Invalid glob pattern: " ++ e
|
|
-- Get all matching files in the current working directory, sorting in
|
|
-- lexicographic order to simulate the output of 'ls'.
|
|
filepaths <- liftIO $ sort <$> globDir1 fileglob curdir
|
|
if (not . null) filepaths
|
|
then pure filepaths
|
|
else customFailure $ parseErrorAt parseroff $
|
|
"No existing files match pattern: " ++ filename
|
|
|
|
parseChild :: MonadIO m => SourcePos -> PrefixedFilePath -> ErroringJournalParser m ()
|
|
parseChild parentpos prefixedpath = do
|
|
let (_mprefix,filepath) = splitReaderPrefix prefixedpath
|
|
|
|
parentj <- get
|
|
let parentfilestack = jincludefilestack parentj
|
|
when (filepath `elem` parentfilestack) $
|
|
Fail.fail ("Cyclic include: " ++ filepath)
|
|
|
|
childInput <- lift $ readFilePortably filepath
|
|
`orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
|
|
let initChildj = newJournalWithParseStateFrom filepath parentj
|
|
|
|
-- Choose a reader/format based on the file path, or fall back
|
|
-- on journal. Duplicating readJournal a bit here.
|
|
let r = fromMaybe reader $ findReader Nothing (Just prefixedpath)
|
|
parser = rParser r
|
|
dbg6IO "trying reader" (rFormat r)
|
|
updatedChildj <- journalAddFile (filepath, childInput) <$>
|
|
parseIncludeFile parser initChildj filepath childInput
|
|
|
|
-- discard child's parse info, combine other fields
|
|
put $ updatedChildj <> parentj
|
|
|
|
newJournalWithParseStateFrom :: FilePath -> Journal -> Journal
|
|
newJournalWithParseStateFrom filepath j = nulljournal{
|
|
jparsedefaultyear = jparsedefaultyear j
|
|
,jparsedefaultcommodity = jparsedefaultcommodity j
|
|
,jparseparentaccounts = jparseparentaccounts j
|
|
,jparsealiases = jparsealiases j
|
|
,jcommodities = jcommodities j
|
|
-- ,jparsetransactioncount = jparsetransactioncount j
|
|
,jparsetimeclockentries = jparsetimeclockentries j
|
|
,jincludefilestack = filepath : jincludefilestack j
|
|
}
|
|
|
|
-- | Lift an IO action into the exception monad, rethrowing any IO
|
|
-- error with the given message prepended.
|
|
orRethrowIOError :: MonadIO m => IO a -> String -> TextParser m a
|
|
orRethrowIOError io msg = do
|
|
eResult <- liftIO $ (Right <$> io) `C.catch` \(e::C.IOException) -> pure $ Left $ printf "%s:\n%s" msg (show e)
|
|
case eResult of
|
|
Right res -> pure res
|
|
Left errMsg -> Fail.fail errMsg
|
|
|
|
-- Parse an account directive, adding its info to the journal's
|
|
-- list of account declarations.
|
|
accountdirectivep :: JournalParser m ()
|
|
accountdirectivep = do
|
|
off <- getOffset -- XXX figure out a more precise position later
|
|
|
|
string "account"
|
|
lift skipNonNewlineSpaces1
|
|
|
|
-- the account name, possibly modified by preceding alias or apply account directives
|
|
acct <- modifiedaccountnamep
|
|
|
|
-- maybe an account type code (ALERX) after two or more spaces
|
|
-- XXX added in 1.11, deprecated in 1.13, remove in 1.14
|
|
mtypecode :: Maybe Char <- lift $ optional $ try $ do
|
|
skipNonNewlineSpaces1 -- at least one more space in addition to the one consumed by modifiedaccountp
|
|
choice $ map char "ALERX"
|
|
|
|
-- maybe a comment, on this and/or following lines
|
|
(cmt, tags) <- lift transactioncommentp
|
|
|
|
-- maybe Ledger-style subdirectives (ignored)
|
|
skipMany indentedlinep
|
|
|
|
-- an account type may have been set by account type code or a tag;
|
|
-- the latter takes precedence
|
|
let
|
|
mtypecode' :: Maybe Text = maybe
|
|
(T.singleton <$> mtypecode)
|
|
Just
|
|
$ lookup accountTypeTagName tags
|
|
metype = parseAccountTypeCode <$> mtypecode'
|
|
|
|
-- update the journal
|
|
addAccountDeclaration (acct, cmt, tags)
|
|
case metype of
|
|
Nothing -> return ()
|
|
Just (Right t) -> addDeclaredAccountType acct t
|
|
Just (Left err) -> customFailure $ parseErrorAt off err
|
|
|
|
-- The special tag used for declaring account type. XXX change to "class" ?
|
|
accountTypeTagName = "type"
|
|
|
|
parseAccountTypeCode :: Text -> Either String AccountType
|
|
parseAccountTypeCode s =
|
|
case T.toLower s of
|
|
"asset" -> Right Asset
|
|
"a" -> Right Asset
|
|
"liability" -> Right Liability
|
|
"l" -> Right Liability
|
|
"equity" -> Right Equity
|
|
"e" -> Right Equity
|
|
"revenue" -> Right Revenue
|
|
"r" -> Right Revenue
|
|
"expense" -> Right Expense
|
|
"x" -> Right Expense
|
|
"cash" -> Right Cash
|
|
"c" -> Right Cash
|
|
_ -> Left err
|
|
where
|
|
err = T.unpack $ "invalid account type code "<>s<>", should be one of " <>
|
|
T.intercalate ", " ["A","L","E","R","X","C","Asset","Liability","Equity","Revenue","Expense","Cash"]
|
|
|
|
-- Add an account declaration to the journal, auto-numbering it.
|
|
addAccountDeclaration :: (AccountName,Text,[Tag]) -> JournalParser m ()
|
|
addAccountDeclaration (a,cmt,tags) =
|
|
modify' (\j ->
|
|
let
|
|
decls = jdeclaredaccounts j
|
|
d = (a, nullaccountdeclarationinfo{
|
|
adicomment = cmt
|
|
,aditags = tags
|
|
,adideclarationorder = length decls + 1
|
|
})
|
|
in
|
|
j{jdeclaredaccounts = d:decls})
|
|
|
|
-- Add a payee declaration to the journal.
|
|
addPayeeDeclaration :: (Payee,Text,[Tag]) -> JournalParser m ()
|
|
addPayeeDeclaration (p, cmt, tags) =
|
|
modify' (\j@Journal{jdeclaredpayees} -> j{jdeclaredpayees=d:jdeclaredpayees})
|
|
where
|
|
d = (p
|
|
,nullpayeedeclarationinfo{
|
|
pdicomment = cmt
|
|
,pditags = tags
|
|
})
|
|
|
|
indentedlinep :: JournalParser m String
|
|
indentedlinep = lift skipNonNewlineSpaces1 >> (rstrip <$> lift restofline)
|
|
|
|
-- | Parse a one-line or multi-line commodity directive.
|
|
--
|
|
-- >>> Right _ <- rjp commoditydirectivep "commodity $1.00"
|
|
-- >>> Right _ <- rjp commoditydirectivep "commodity $\n format $1.00"
|
|
-- >>> Right _ <- rjp commoditydirectivep "commodity $\n\n" -- a commodity with no format
|
|
-- >>> Right _ <- rjp commoditydirectivep "commodity $1.00\n format $1.00" -- both, what happens ?
|
|
commoditydirectivep :: JournalParser m ()
|
|
commoditydirectivep = commoditydirectiveonelinep <|> commoditydirectivemultilinep
|
|
|
|
-- | Parse a one-line commodity directive.
|
|
--
|
|
-- >>> Right _ <- rjp commoditydirectiveonelinep "commodity $1.00"
|
|
-- >>> Right _ <- rjp commoditydirectiveonelinep "commodity $1.00 ; blah\n"
|
|
commoditydirectiveonelinep :: JournalParser m ()
|
|
commoditydirectiveonelinep = do
|
|
(off, Amount{acommodity,astyle}) <- try $ do
|
|
string "commodity"
|
|
lift skipNonNewlineSpaces1
|
|
off <- getOffset
|
|
amount <- amountp
|
|
pure $ (off, amount)
|
|
lift skipNonNewlineSpaces
|
|
_ <- lift followingcommentp
|
|
let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg6 "style from commodity directive" astyle}
|
|
if asdecimalpoint astyle == Nothing
|
|
then customFailure $ parseErrorAt off pleaseincludedecimalpoint
|
|
else modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})
|
|
|
|
pleaseincludedecimalpoint :: String
|
|
pleaseincludedecimalpoint = chomp $ unlines [
|
|
"Please include a decimal point or decimal comma in commodity directives,"
|
|
,"to help us parse correctly. It may be followed by zero or more decimal digits."
|
|
,"Examples:"
|
|
,"commodity $1000. ; no thousands mark, decimal period, no decimals"
|
|
,"commodity 1.234,00 ARS ; period at thousands, decimal comma, 2 decimals"
|
|
,"commodity EUR 1 000,000 ; space at thousands, decimal comma, 3 decimals"
|
|
,"commodity INR1,23,45,678.0 ; comma at thousands/lakhs/crores, decimal period, 1 decimal"
|
|
]
|
|
|
|
-- | Parse a multi-line commodity directive, containing 0 or more format subdirectives.
|
|
--
|
|
-- >>> Right _ <- rjp commoditydirectivemultilinep "commodity $ ; blah \n format $1.00 ; blah"
|
|
commoditydirectivemultilinep :: JournalParser m ()
|
|
commoditydirectivemultilinep = do
|
|
string "commodity"
|
|
lift skipNonNewlineSpaces1
|
|
sym <- lift commoditysymbolp
|
|
_ <- lift followingcommentp
|
|
mformat <- lastMay <$> many (indented $ formatdirectivep sym)
|
|
let comm = Commodity{csymbol=sym, cformat=mformat}
|
|
modify' (\j -> j{jcommodities=M.insert sym comm $ jcommodities j})
|
|
where
|
|
indented = (lift skipNonNewlineSpaces1 >>)
|
|
|
|
-- | Parse a format (sub)directive, throwing a parse error if its
|
|
-- symbol does not match the one given.
|
|
formatdirectivep :: CommoditySymbol -> JournalParser m AmountStyle
|
|
formatdirectivep expectedsym = do
|
|
string "format"
|
|
lift skipNonNewlineSpaces1
|
|
off <- getOffset
|
|
Amount{acommodity,astyle} <- amountp
|
|
_ <- lift followingcommentp
|
|
if acommodity==expectedsym
|
|
then
|
|
if asdecimalpoint astyle == Nothing
|
|
then customFailure $ parseErrorAt off pleaseincludedecimalpoint
|
|
else return $ dbg6 "style from format subdirective" astyle
|
|
else customFailure $ parseErrorAt off $
|
|
printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity
|
|
|
|
keywordp :: String -> JournalParser m ()
|
|
keywordp = (() <$) . string . fromString
|
|
|
|
spacesp :: JournalParser m ()
|
|
spacesp = () <$ lift skipNonNewlineSpaces1
|
|
|
|
-- | Backtracking parser similar to string, but allows varying amount of space between words
|
|
keywordsp :: String -> JournalParser m ()
|
|
keywordsp = try . sequence_ . intersperse spacesp . map keywordp . words
|
|
|
|
applyaccountdirectivep :: JournalParser m ()
|
|
applyaccountdirectivep = do
|
|
keywordsp "apply account" <?> "apply account directive"
|
|
lift skipNonNewlineSpaces1
|
|
parent <- lift accountnamep
|
|
newline
|
|
pushParentAccount parent
|
|
|
|
endapplyaccountdirectivep :: JournalParser m ()
|
|
endapplyaccountdirectivep = do
|
|
keywordsp "end apply account" <?> "end apply account directive"
|
|
popParentAccount
|
|
|
|
aliasdirectivep :: JournalParser m ()
|
|
aliasdirectivep = do
|
|
string "alias"
|
|
lift skipNonNewlineSpaces1
|
|
alias <- lift accountaliasp
|
|
addAccountAlias alias
|
|
|
|
endaliasesdirectivep :: JournalParser m ()
|
|
endaliasesdirectivep = do
|
|
keywordsp "end aliases" <?> "end aliases directive"
|
|
clearAccountAliases
|
|
|
|
tagdirectivep :: JournalParser m ()
|
|
tagdirectivep = do
|
|
string "tag" <?> "tag directive"
|
|
lift skipNonNewlineSpaces1
|
|
_ <- lift $ some nonspace
|
|
lift restofline
|
|
return ()
|
|
|
|
endtagdirectivep :: JournalParser m ()
|
|
endtagdirectivep = do
|
|
(keywordsp "end tag" <|> keywordp "pop") <?> "end tag or pop directive"
|
|
lift restofline
|
|
return ()
|
|
|
|
payeedirectivep :: JournalParser m ()
|
|
payeedirectivep = do
|
|
string "payee" <?> "payee directive"
|
|
lift skipNonNewlineSpaces1
|
|
payee <- lift $ T.strip <$> noncommenttext1p
|
|
(comment, tags) <- lift transactioncommentp
|
|
addPayeeDeclaration (payee, comment, tags)
|
|
return ()
|
|
|
|
defaultyeardirectivep :: JournalParser m ()
|
|
defaultyeardirectivep = do
|
|
char 'Y' <?> "default year"
|
|
lift skipNonNewlineSpaces
|
|
setYear =<< lift yearp
|
|
|
|
defaultcommoditydirectivep :: JournalParser m ()
|
|
defaultcommoditydirectivep = do
|
|
char 'D' <?> "default commodity"
|
|
lift skipNonNewlineSpaces1
|
|
off <- getOffset
|
|
Amount{acommodity,astyle} <- amountp
|
|
lift restofline
|
|
if asdecimalpoint astyle == Nothing
|
|
then customFailure $ parseErrorAt off pleaseincludedecimalpoint
|
|
else setDefaultCommodityAndStyle (acommodity, astyle)
|
|
|
|
marketpricedirectivep :: JournalParser m PriceDirective
|
|
marketpricedirectivep = do
|
|
char 'P' <?> "market price"
|
|
lift skipNonNewlineSpaces
|
|
date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored
|
|
lift skipNonNewlineSpaces1
|
|
symbol <- lift commoditysymbolp
|
|
lift skipNonNewlineSpaces
|
|
price <- amountp
|
|
lift restofline
|
|
return $ PriceDirective date symbol price
|
|
|
|
ignoredpricecommoditydirectivep :: JournalParser m ()
|
|
ignoredpricecommoditydirectivep = do
|
|
char 'N' <?> "ignored-price commodity"
|
|
lift skipNonNewlineSpaces1
|
|
lift commoditysymbolp
|
|
lift restofline
|
|
return ()
|
|
|
|
commodityconversiondirectivep :: JournalParser m ()
|
|
commodityconversiondirectivep = do
|
|
char 'C' <?> "commodity conversion"
|
|
lift skipNonNewlineSpaces1
|
|
amountp
|
|
lift skipNonNewlineSpaces
|
|
char '='
|
|
lift skipNonNewlineSpaces
|
|
amountp
|
|
lift restofline
|
|
return ()
|
|
|
|
--- *** transactions
|
|
|
|
-- | Parse a transaction modifier (auto postings) rule.
|
|
transactionmodifierp :: JournalParser m TransactionModifier
|
|
transactionmodifierp = do
|
|
char '=' <?> "modifier transaction"
|
|
lift skipNonNewlineSpaces
|
|
querytxt <- lift $ T.strip <$> descriptionp
|
|
(_comment, _tags) <- lift transactioncommentp -- TODO apply these to modified txns ?
|
|
postingrules <- tmpostingrulesp Nothing
|
|
return $ TransactionModifier querytxt postingrules
|
|
|
|
-- | Parse a periodic transaction rule.
|
|
--
|
|
-- This reuses periodexprp which parses period expressions on the command line.
|
|
-- This is awkward because periodexprp supports relative and partial dates,
|
|
-- which we don't really need here, and it doesn't support the notion of a
|
|
-- default year set by a Y directive, which we do need to consider here.
|
|
-- We resolve it as follows: in periodic transactions' period expressions,
|
|
-- if there is a default year Y in effect, partial/relative dates are calculated
|
|
-- relative to Y/1/1. If not, they are calculated related to today as usual.
|
|
periodictransactionp :: MonadIO m => JournalParser m PeriodicTransaction
|
|
periodictransactionp = do
|
|
|
|
-- first line
|
|
char '~' <?> "periodic transaction"
|
|
lift $ skipNonNewlineSpaces
|
|
-- a period expression
|
|
off <- getOffset
|
|
|
|
-- if there's a default year in effect, use Y/1/1 as base for partial/relative dates
|
|
today <- liftIO getCurrentDay
|
|
mdefaultyear <- getYear
|
|
let refdate = case mdefaultyear of
|
|
Nothing -> today
|
|
Just y -> fromGregorian y 1 1
|
|
periodExcerpt <- lift $ excerpt_ $
|
|
singlespacedtextsatisfying1p (\c -> c /= ';' && c /= '\n')
|
|
let periodtxt = T.strip $ getExcerptText periodExcerpt
|
|
|
|
-- first parsing with 'singlespacedtextp', then "re-parsing" with
|
|
-- 'periodexprp' saves 'periodexprp' from having to respect the single-
|
|
-- and double-space parsing rules
|
|
(interval, span) <- lift $ reparseExcerpt periodExcerpt $ do
|
|
pexp <- periodexprp refdate
|
|
(<|>) eof $ do
|
|
offset1 <- getOffset
|
|
void takeRest
|
|
offset2 <- getOffset
|
|
customFailure $ parseErrorAtRegion offset1 offset2 $
|
|
"remainder of period expression cannot be parsed"
|
|
<> "\nperhaps you need to terminate the period expression with a double space?"
|
|
<> "\na double space is required between period expression and description/comment"
|
|
pure pexp
|
|
|
|
-- In periodic transactions, the period expression has an additional constraint:
|
|
case checkPeriodicTransactionStartDate interval span periodtxt of
|
|
Just e -> customFailure $ parseErrorAt off e
|
|
Nothing -> pure ()
|
|
|
|
status <- lift statusp <?> "cleared status"
|
|
code <- lift codep <?> "transaction code"
|
|
description <- lift $ T.strip <$> descriptionp
|
|
(comment, tags) <- lift transactioncommentp
|
|
-- next lines; use same year determined above
|
|
postings <- postingsp (Just $ first3 $ toGregorian refdate)
|
|
|
|
return $ nullperiodictransaction{
|
|
ptperiodexpr=periodtxt
|
|
,ptinterval=interval
|
|
,ptspan=span
|
|
,ptstatus=status
|
|
,ptcode=code
|
|
,ptdescription=description
|
|
,ptcomment=comment
|
|
,pttags=tags
|
|
,ptpostings=postings
|
|
}
|
|
|
|
-- | Parse a (possibly unbalanced) transaction.
|
|
transactionp :: JournalParser m Transaction
|
|
transactionp = do
|
|
-- dbgparse 0 "transactionp"
|
|
startpos <- getSourcePos
|
|
date <- datep <?> "transaction"
|
|
edate <- optional (lift $ secondarydatep date) <?> "secondary date"
|
|
lookAhead (lift spacenonewline <|> newline) <?> "whitespace or newline"
|
|
status <- lift statusp <?> "cleared status"
|
|
code <- lift codep <?> "transaction code"
|
|
description <- lift $ T.strip <$> descriptionp
|
|
(comment, tags) <- lift transactioncommentp
|
|
let year = first3 $ toGregorian date
|
|
postings <- postingsp (Just year)
|
|
endpos <- getSourcePos
|
|
let sourcepos = journalSourcePos startpos endpos
|
|
return $ txnTieKnot $ Transaction 0 "" sourcepos date edate status code description comment tags postings
|
|
|
|
--- *** postings
|
|
|
|
-- Parse the following whitespace-beginning lines as postings, posting
|
|
-- tags, and/or comments (inferring year, if needed, from the given date).
|
|
postingsp :: Maybe Year -> JournalParser m [Posting]
|
|
postingsp mTransactionYear = many (postingp mTransactionYear) <?> "postings"
|
|
|
|
-- linebeginningwithspaces :: JournalParser m String
|
|
-- linebeginningwithspaces = do
|
|
-- sp <- lift skipNonNewlineSpaces1
|
|
-- c <- nonspace
|
|
-- cs <- lift restofline
|
|
-- return $ sp ++ (c:cs) ++ "\n"
|
|
|
|
postingp :: Maybe Year -> JournalParser m Posting
|
|
postingp = fmap fst . postingphelper False
|
|
|
|
-- Parse the following whitespace-beginning lines as transaction posting rules, posting
|
|
-- tags, and/or comments (inferring year, if needed, from the given date).
|
|
tmpostingrulesp :: Maybe Year -> JournalParser m [TMPostingRule]
|
|
tmpostingrulesp mTransactionYear = many (tmpostingrulep mTransactionYear) <?> "posting rules"
|
|
|
|
tmpostingrulep :: Maybe Year -> JournalParser m TMPostingRule
|
|
tmpostingrulep = fmap (uncurry TMPostingRule) . postingphelper True
|
|
|
|
-- Parse a Posting, and return a flag with whether a multiplier has been detected.
|
|
-- The multiplier is used in TMPostingRules.
|
|
postingphelper :: Bool -> Maybe Year -> JournalParser m (Posting, Bool)
|
|
postingphelper isPostingRule mTransactionYear = do
|
|
-- lift $ dbgparse 0 "postingp"
|
|
(status, account) <- try $ do
|
|
lift skipNonNewlineSpaces1
|
|
status <- lift statusp
|
|
lift skipNonNewlineSpaces
|
|
account <- modifiedaccountnamep
|
|
return (status, account)
|
|
let (ptype, account') = (accountNamePostingType account, textUnbracket account)
|
|
lift skipNonNewlineSpaces
|
|
mult <- if isPostingRule then multiplierp else pure False
|
|
amount <- optional $ amountpwithmultiplier mult
|
|
lift skipNonNewlineSpaces
|
|
massertion <- optional balanceassertionp
|
|
lift skipNonNewlineSpaces
|
|
(comment,tags,mdate,mdate2) <- lift $ postingcommentp mTransactionYear
|
|
let p = posting
|
|
{ pdate=mdate
|
|
, pdate2=mdate2
|
|
, pstatus=status
|
|
, paccount=account'
|
|
, pamount=maybe missingmixedamt mixedAmount amount
|
|
, pcomment=comment
|
|
, ptype=ptype
|
|
, ptags=tags
|
|
, pbalanceassertion=massertion
|
|
}
|
|
return (p, mult)
|
|
where
|
|
multiplierp = option False $ True <$ char '*'
|
|
|
|
--- ** tests
|
|
|
|
tests_JournalReader = tests "JournalReader" [
|
|
|
|
let p = lift accountnamep :: JournalParser IO AccountName in
|
|
tests "accountnamep" [
|
|
test "basic" $ assertParse p "a:b:c"
|
|
-- ,test "empty inner component" $ assertParseError p "a::c" "" -- TODO
|
|
-- ,test "empty leading component" $ assertParseError p ":b:c" "x"
|
|
-- ,test "empty trailing component" $ assertParseError p "a:b:" "x"
|
|
]
|
|
|
|
-- "Parse a date in YYYY/MM/DD format.
|
|
-- Hyphen (-) and period (.) are also allowed as separators.
|
|
-- The year may be omitted if a default year has been set.
|
|
-- Leading zeroes may be omitted."
|
|
,tests "datep" [
|
|
test "YYYY/MM/DD" $ assertParseEq datep "2018/01/01" (fromGregorian 2018 1 1)
|
|
,test "YYYY-MM-DD" $ assertParse datep "2018-01-01"
|
|
,test "YYYY.MM.DD" $ assertParse datep "2018.01.01"
|
|
,test "yearless date with no default year" $ assertParseError datep "1/1" "current year is unknown"
|
|
,test "yearless date with default year" $ do
|
|
let s = "1/1"
|
|
ep <- parseWithState nulljournal{jparsedefaultyear=Just 2018} datep s
|
|
either (assertFailure . ("parse error at "++) . customErrorBundlePretty) (const $ return ()) ep
|
|
,test "no leading zero" $ assertParse datep "2018/1/1"
|
|
]
|
|
,test "datetimep" $ do
|
|
let
|
|
good = assertParse datetimep
|
|
bad = (\t -> assertParseError datetimep t "")
|
|
good "2011/1/1 00:00"
|
|
good "2011/1/1 23:59:59"
|
|
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"
|
|
bad "2011/1/1 3:5:7"
|
|
-- timezone is parsed but ignored
|
|
let t = LocalTime (fromGregorian 2018 1 1) (TimeOfDay 0 0 0)
|
|
assertParseEq datetimep "2018/1/1 00:00-0800" t
|
|
assertParseEq datetimep "2018/1/1 00:00+1234" t
|
|
|
|
,tests "periodictransactionp" [
|
|
|
|
test "more period text in comment after one space" $ assertParseEq periodictransactionp
|
|
"~ monthly from 2018/6 ;In 2019 we will change this\n"
|
|
nullperiodictransaction {
|
|
ptperiodexpr = "monthly from 2018/6"
|
|
,ptinterval = Months 1
|
|
,ptspan = DateSpan (Just $ fromGregorian 2018 6 1) Nothing
|
|
,ptdescription = ""
|
|
,ptcomment = "In 2019 we will change this\n"
|
|
}
|
|
|
|
,test "more period text in description after two spaces" $ assertParseEq periodictransactionp
|
|
"~ monthly from 2018/6 In 2019 we will change this\n"
|
|
nullperiodictransaction {
|
|
ptperiodexpr = "monthly from 2018/6"
|
|
,ptinterval = Months 1
|
|
,ptspan = DateSpan (Just $ fromGregorian 2018 6 1) Nothing
|
|
,ptdescription = "In 2019 we will change this"
|
|
,ptcomment = ""
|
|
}
|
|
|
|
,test "Next year in description" $ assertParseEq periodictransactionp
|
|
"~ monthly Next year blah blah\n"
|
|
nullperiodictransaction {
|
|
ptperiodexpr = "monthly"
|
|
,ptinterval = Months 1
|
|
,ptspan = DateSpan Nothing Nothing
|
|
,ptdescription = "Next year blah blah"
|
|
,ptcomment = ""
|
|
}
|
|
|
|
,test "Just date, no description" $ assertParseEq periodictransactionp
|
|
"~ 2019-01-04\n"
|
|
nullperiodictransaction {
|
|
ptperiodexpr = "2019-01-04"
|
|
,ptinterval = NoInterval
|
|
,ptspan = DateSpan (Just $ fromGregorian 2019 1 4) (Just $ fromGregorian 2019 1 5)
|
|
,ptdescription = ""
|
|
,ptcomment = ""
|
|
}
|
|
|
|
,test "Just date, no description + empty transaction comment" $ assertParse periodictransactionp
|
|
"~ 2019-01-04\n ;\n a 1\n b\n"
|
|
|
|
]
|
|
|
|
,tests "postingp" [
|
|
test "basic" $ assertParseEq (postingp Nothing)
|
|
" expenses:food:dining $10.00 ; a: a a \n ; b: b b \n"
|
|
posting{
|
|
paccount="expenses:food:dining",
|
|
pamount=mixedAmount (usd 10),
|
|
pcomment="a: a a\nb: b b\n",
|
|
ptags=[("a","a a"), ("b","b b")]
|
|
}
|
|
|
|
,test "posting dates" $ assertParseEq (postingp Nothing)
|
|
" a 1. ; date:2012/11/28, date2=2012/11/29,b:b\n"
|
|
nullposting{
|
|
paccount="a"
|
|
,pamount=mixedAmount (num 1)
|
|
,pcomment="date:2012/11/28, date2=2012/11/29,b:b\n"
|
|
,ptags=[("date", "2012/11/28"), ("date2=2012/11/29,b", "b")] -- TODO tag name parsed too greedily
|
|
,pdate=Just $ fromGregorian 2012 11 28
|
|
,pdate2=Nothing -- Just $ fromGregorian 2012 11 29
|
|
}
|
|
|
|
,test "posting dates bracket syntax" $ assertParseEq (postingp Nothing)
|
|
" a 1. ; [2012/11/28=2012/11/29]\n"
|
|
nullposting{
|
|
paccount="a"
|
|
,pamount=mixedAmount (num 1)
|
|
,pcomment="[2012/11/28=2012/11/29]\n"
|
|
,ptags=[]
|
|
,pdate= Just $ fromGregorian 2012 11 28
|
|
,pdate2=Just $ fromGregorian 2012 11 29
|
|
}
|
|
|
|
,test "quoted commodity symbol with digits" $ assertParse (postingp Nothing) " a 1 \"DE123\"\n"
|
|
|
|
,test "only lot price" $ assertParse (postingp Nothing) " a 1A {1B}\n"
|
|
,test "fixed lot price" $ assertParse (postingp Nothing) " a 1A {=1B}\n"
|
|
,test "total lot price" $ assertParse (postingp Nothing) " a 1A {{1B}}\n"
|
|
,test "fixed total lot price, and spaces" $ assertParse (postingp Nothing) " a 1A {{ = 1B }}\n"
|
|
,test "lot price before transaction price" $ assertParse (postingp Nothing) " a 1A {1B} @ 1B\n"
|
|
,test "lot price after transaction price" $ assertParse (postingp Nothing) " a 1A @ 1B {1B}\n"
|
|
,test "lot price after balance assertion not allowed" $ assertParseError (postingp Nothing) " a 1A @ 1B = 1A {1B}\n" "unexpected '{'"
|
|
,test "only lot date" $ assertParse (postingp Nothing) " a 1A [2000-01-01]\n"
|
|
,test "transaction price, lot price, lot date" $ assertParse (postingp Nothing) " a 1A @ 1B {1B} [2000-01-01]\n"
|
|
,test "lot date, lot price, transaction price" $ assertParse (postingp Nothing) " a 1A [2000-01-01] {1B} @ 1B\n"
|
|
|
|
,test "balance assertion over entire contents of account" $ assertParse (postingp Nothing) " a $1 == $1\n"
|
|
]
|
|
|
|
,tests "transactionmodifierp" [
|
|
|
|
test "basic" $ assertParseEq transactionmodifierp
|
|
"= (some value expr)\n some:postings 1.\n"
|
|
nulltransactionmodifier {
|
|
tmquerytxt = "(some value expr)"
|
|
,tmpostingrules = [TMPostingRule nullposting{paccount="some:postings", pamount=mixedAmount (num 1)} False]
|
|
}
|
|
]
|
|
|
|
,tests "transactionp" [
|
|
|
|
test "just a date" $ assertParseEq transactionp "2015/1/1\n" nulltransaction{tdate=fromGregorian 2015 1 1}
|
|
|
|
,test "more complex" $ assertParseEq transactionp
|
|
(T.unlines [
|
|
"2012/05/14=2012/05/15 (code) desc ; tcomment1",
|
|
" ; tcomment2",
|
|
" ; ttag1: val1",
|
|
" * a $1.00 ; pcomment1",
|
|
" ; pcomment2",
|
|
" ; ptag1: val1",
|
|
" ; ptag2: val2"
|
|
])
|
|
nulltransaction{
|
|
tsourcepos=JournalSourcePos "" (1,7), -- XXX why 7 here ?
|
|
tprecedingcomment="",
|
|
tdate=fromGregorian 2012 5 14,
|
|
tdate2=Just $ fromGregorian 2012 5 15,
|
|
tstatus=Unmarked,
|
|
tcode="code",
|
|
tdescription="desc",
|
|
tcomment="tcomment1\ntcomment2\nttag1: val1\n",
|
|
ttags=[("ttag1","val1")],
|
|
tpostings=[
|
|
nullposting{
|
|
pdate=Nothing,
|
|
pstatus=Cleared,
|
|
paccount="a",
|
|
pamount=mixedAmount (usd 1),
|
|
pcomment="pcomment1\npcomment2\nptag1: val1\nptag2: val2\n",
|
|
ptype=RegularPosting,
|
|
ptags=[("ptag1","val1"),("ptag2","val2")],
|
|
ptransaction=Nothing
|
|
}
|
|
]
|
|
}
|
|
|
|
,test "parses a well-formed transaction" $
|
|
assertBool "" $ isRight $ rjp transactionp $ T.unlines
|
|
["2007/01/28 coopportunity"
|
|
," expenses:food:groceries $47.18"
|
|
," assets:checking $-47.18"
|
|
,""
|
|
]
|
|
|
|
,test "does not parse a following comment as part of the description" $
|
|
assertParseEqOn transactionp "2009/1/1 a ;comment\n b 1\n" tdescription "a"
|
|
|
|
,test "parses a following whitespace line" $
|
|
assertBool "" $ isRight $ rjp transactionp $ T.unlines
|
|
["2012/1/1"
|
|
," a 1"
|
|
," b"
|
|
," "
|
|
]
|
|
|
|
,test "parses an empty transaction comment following whitespace line" $
|
|
assertBool "" $ isRight $ rjp transactionp $ T.unlines
|
|
["2012/1/1"
|
|
," ;"
|
|
," a 1"
|
|
," b"
|
|
," "
|
|
]
|
|
|
|
,test "comments everywhere, two postings parsed" $
|
|
assertParseEqOn transactionp
|
|
(T.unlines
|
|
["2009/1/1 x ; transaction comment"
|
|
," a 1 ; posting 1 comment"
|
|
," ; posting 1 comment 2"
|
|
," b"
|
|
," ; posting 2 comment"
|
|
])
|
|
(length . tpostings)
|
|
2
|
|
|
|
]
|
|
|
|
-- directives
|
|
|
|
,tests "directivep" [
|
|
test "supports !" $ do
|
|
assertParseE directivep "!account a\n"
|
|
assertParseE directivep "!D 1.0\n"
|
|
]
|
|
|
|
,tests "accountdirectivep" [
|
|
test "with-comment" $ assertParse accountdirectivep "account a:b ; a comment\n"
|
|
,test "does-not-support-!" $ assertParseError accountdirectivep "!account a:b\n" ""
|
|
,test "account-type-code" $ assertParse accountdirectivep "account a:b A\n"
|
|
,test "account-type-tag" $ assertParseStateOn accountdirectivep "account a:b ; type:asset\n"
|
|
jdeclaredaccounts
|
|
[("a:b", AccountDeclarationInfo{adicomment = "type:asset\n"
|
|
,aditags = [("type","asset")]
|
|
,adideclarationorder = 1
|
|
})
|
|
]
|
|
]
|
|
|
|
,test "commodityconversiondirectivep" $ do
|
|
assertParse commodityconversiondirectivep "C 1h = $50.00\n"
|
|
|
|
,test "defaultcommoditydirectivep" $ do
|
|
assertParse defaultcommoditydirectivep "D $1,000.0\n"
|
|
assertParseError defaultcommoditydirectivep "D $1000\n" "Please include a decimal point or decimal comma"
|
|
|
|
,tests "defaultyeardirectivep" [
|
|
test "1000" $ assertParse defaultyeardirectivep "Y 1000" -- XXX no \n like the others
|
|
-- ,test "999" $ assertParseError defaultyeardirectivep "Y 999" "bad year number"
|
|
,test "12345" $ assertParse defaultyeardirectivep "Y 12345"
|
|
]
|
|
|
|
,test "ignoredpricecommoditydirectivep" $ do
|
|
assertParse ignoredpricecommoditydirectivep "N $\n"
|
|
|
|
,tests "includedirectivep" [
|
|
test "include" $ assertParseErrorE includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile"
|
|
,test "glob" $ assertParseErrorE includedirectivep "include nosuchfile*\n" "No existing files match pattern: nosuchfile*"
|
|
]
|
|
|
|
,test "marketpricedirectivep" $ assertParseEq marketpricedirectivep
|
|
"P 2017/01/30 BTC $922.83\n"
|
|
PriceDirective{
|
|
pddate = fromGregorian 2017 1 30,
|
|
pdcommodity = "BTC",
|
|
pdamount = usd 922.83
|
|
}
|
|
|
|
,tests "payeedirectivep" [
|
|
test "simple" $ assertParse payeedirectivep "payee foo\n"
|
|
,test "with-comment" $ assertParse payeedirectivep "payee foo ; comment\n"
|
|
]
|
|
|
|
,test "tagdirectivep" $ do
|
|
assertParse tagdirectivep "tag foo \n"
|
|
|
|
,test "endtagdirectivep" $ do
|
|
assertParse endtagdirectivep "end tag \n"
|
|
assertParse endtagdirectivep "pop \n"
|
|
|
|
,tests "journalp" [
|
|
test "empty file" $ assertParseEqE journalp "" nulljournal
|
|
]
|
|
|
|
-- these are defined here rather than in Common so they can use journalp
|
|
,test "parseAndFinaliseJournal" $ do
|
|
ej <- runExceptT $ parseAndFinaliseJournal journalp definputopts "" "2019-1-1\n"
|
|
let Right j = ej
|
|
assertEqual "" [""] $ journalFilePaths j
|
|
|
|
]
|