slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lib: fix bracketed posting dates, parser cleanup (#304)

Browse Source 
Bracketed posting dates were fragile; they worked only if you wrote full
10-character dates. Also some semantics were a bit unclear. Now they
should be robust, and have been documented more clearly. This is a
legacy undocumented Ledger syntax, but it improves compatibility and
might be preferable to the more verbose "date:" tags if you write
posting dates often (as I do).

Internally, bracketed posting dates are no longer considered to be tags.
Journal comment, tag, and posting date parsers have been reworked, all
with doctests. Also the journal parser types generally have been
tightened up and clarified, making it much easier to know how to combine
and run them. There's now

-- | A parser of strings with generic user state, monad and return type.
type StringParser u m a = ParsecT String u m a

-- | A string parser with journal-parsing state.
type JournalParser m a = StringParser JournalContext m a

-- | A journal parser that runs in IO and can throw an error mid-parse.
type ErroringJournalParser a = JournalParser (ExceptT String IO) a

and corresponding convenience functions (and short aliases) for running them.
This commit is contained in:
Simon Michael 2016-04-28 13:23:20 -07:00
parent 259e7bfbe3
commit 856c0b3042
6 changed files with 442 additions and 201 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
hledger-lib/Hledger/Data/Types.hs
View File

@ -129,7 +129,9 @@ data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting
instance NFData PostingType instance NFData PostingType
type Tag = (String, String) -- ^ A tag name and (possibly empty) value. type TagName = String
type TagValue = String
type Tag = (TagName, TagValue) -- ^ A tag name and (possibly empty) value.
data ClearedStatus = Uncleared | Pending | Cleared data ClearedStatus = Uncleared | Pending | Cleared
deriving (Eq,Ord,Typeable,Data,Generic) deriving (Eq,Ord,Typeable,Data,Generic)

485
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -1,8 +1,9 @@
--- * doc --- * doc
-- lines beginning "--- *" are collapsible orgstruct nodes. Emacs users: -- Lines beginning "--- *" are collapsible orgstruct nodes. Emacs users,
-- (add-hook 'haskell-mode-hook -- (add-hook 'haskell-mode-hook
-- (lambda () (set-variable 'orgstruct-heading-prefix-regexp "--- " t)) -- (lambda () (set-variable 'orgstruct-heading-prefix-regexp "--- " t))
-- 'orgstruct-mode) -- 'orgstruct-mode)
-- and press TAB on nodes to expand/collapse.
{-| {-|
@ -24,10 +25,12 @@ reader should handle many ledger files as well. Example:
-- {-# OPTIONS_GHC -F -pgmF htfpp #-} -- {-# OPTIONS_GHC -F -pgmF htfpp #-}
{-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds, ScopedTypeVariables, FlexibleContexts #-} {-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds, ScopedTypeVariables, FlexibleContexts, TupleSections #-}
module Hledger.Read.JournalReader ( module Hledger.Read.JournalReader (
--- * exports
-- * Reader -- * Reader
reader, reader,
@ -71,12 +74,13 @@ import qualified Control.Exception as C
import Control.Monad.Compat import Control.Monad.Compat
import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError, catchError) import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError, catchError)
import Data.Char (isNumber) import Data.Char (isNumber)
import Data.Functor.Identity
import Data.List.Compat import Data.List.Compat
import Data.List.Split (wordsBy) import Data.List.Split (wordsBy)
import Data.Maybe import Data.Maybe
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.LocalTime import Data.Time.LocalTime
import Safe (headDef, lastDef) import Safe
import Test.HUnit import Test.HUnit
#ifdef TESTS #ifdef TESTS
import Test.Framework import Test.Framework
@ -112,6 +116,30 @@ parse _ = parseAndFinaliseJournal journalp
--- * parsing utils --- * parsing utils
-- | A parser of strings with generic user state, monad and return type.
type StringParser u m a = ParsecT String u m a
-- | A string parser with journal-parsing state.
type JournalParser m a = StringParser JournalContext m a
-- | A journal parser that runs in IO and can throw an error mid-parse.
type ErroringJournalParser a = JournalParser (ExceptT String IO) a
-- | Run a string parser with no state in the identity monad.
runStringParser, rsp :: StringParser () Identity a -> String -> Either ParseError a
runStringParser p s = runIdentity $ runParserT p () "" s
rsp = runStringParser
-- | Run a journal parser with a null journal-parsing state.
runJournalParser, rjp :: Monad m => JournalParser m a -> String -> m (Either ParseError a)
runJournalParser p s = runParserT p nullctx "" s
rjp = runJournalParser
-- | Run an error-raising journal parser with a null journal-parsing state.
runErroringJournalParser, rejp :: ErroringJournalParser a -> String -> IO (Either String a)
runErroringJournalParser p s = runExceptT $ runJournalParser p s >>= either (throwError.show) return
rejp = runErroringJournalParser
genericSourcePos :: SourcePos -> GenericSourcePos genericSourcePos :: SourcePos -> GenericSourcePos
genericSourcePos p = GenericSourcePos (sourceName p) (sourceLine p) (sourceColumn p) genericSourcePos p = GenericSourcePos (sourceName p) (sourceLine p) (sourceColumn p)
@ -177,7 +205,7 @@ combineJournalUpdates us = foldl' (flip (.)) id <$> sequence us
-- | Given a JournalUpdate-generating parsec parser, file path and data string, -- | 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. -- parse and post-process a Journal so that it's ready to use, or give an error.
parseAndFinaliseJournal :: parseAndFinaliseJournal ::
(ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext)) (ErroringJournalParser (JournalUpdate,JournalContext))
-> Bool -> FilePath -> String -> ExceptT String IO Journal -> Bool -> FilePath -> String -> ExceptT String IO Journal
parseAndFinaliseJournal parser assrt f s = do parseAndFinaliseJournal parser assrt f s = do
tc <- liftIO getClockTime tc <- liftIO getClockTime
@ -192,48 +220,48 @@ parseAndFinaliseJournal parser assrt f s = do
Left estr -> throwError estr Left estr -> throwError estr
Left e -> throwError $ show e Left e -> throwError $ show e
setYear :: Stream [Char] m Char => Integer -> ParsecT [Char] JournalContext m () setYear :: Monad m => Integer -> JournalParser m ()
setYear y = modifyState (\ctx -> ctx{ctxYear=Just y}) setYear y = modifyState (\ctx -> ctx{ctxYear=Just y})
getYear :: Stream [Char] m Char => ParsecT s JournalContext m (Maybe Integer) getYear :: Monad m => JournalParser m (Maybe Integer)
getYear = liftM ctxYear getState getYear = liftM ctxYear getState
setDefaultCommodityAndStyle :: Stream [Char] m Char => (Commodity,AmountStyle) -> ParsecT [Char] JournalContext m () setDefaultCommodityAndStyle :: Monad m => (Commodity,AmountStyle) -> JournalParser m ()
setDefaultCommodityAndStyle cs = modifyState (\ctx -> ctx{ctxDefaultCommodityAndStyle=Just cs}) setDefaultCommodityAndStyle cs = modifyState (\ctx -> ctx{ctxDefaultCommodityAndStyle=Just cs})
getDefaultCommodityAndStyle :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe (Commodity,AmountStyle)) getDefaultCommodityAndStyle :: Monad m => JournalParser m (Maybe (Commodity,AmountStyle))
getDefaultCommodityAndStyle = ctxDefaultCommodityAndStyle `fmap` getState getDefaultCommodityAndStyle = ctxDefaultCommodityAndStyle `fmap` getState
pushAccount :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m () pushAccount :: Monad m => String -> JournalParser m ()
pushAccount acct = modifyState addAccount pushAccount acct = modifyState addAccount
where addAccount ctx0 = ctx0 { ctxAccounts = acct : ctxAccounts ctx0 } where addAccount ctx0 = ctx0 { ctxAccounts = acct : ctxAccounts ctx0 }
pushParentAccount :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m () pushParentAccount :: Monad m => String -> JournalParser m ()
pushParentAccount parent = modifyState addParentAccount pushParentAccount parent = modifyState addParentAccount
where addParentAccount ctx0 = ctx0 { ctxParentAccount = parent : ctxParentAccount ctx0 } where addParentAccount ctx0 = ctx0 { ctxParentAccount = parent : ctxParentAccount ctx0 }
popParentAccount :: Stream [Char] m Char => ParsecT [Char] JournalContext m () popParentAccount :: Monad m => JournalParser m ()
popParentAccount = do ctx0 <- getState popParentAccount = do ctx0 <- getState
case ctxParentAccount ctx0 of case ctxParentAccount ctx0 of
[] -> unexpected "End of apply account block with no beginning" [] -> unexpected "End of apply account block with no beginning"
(_:rest) -> setState $ ctx0 { ctxParentAccount = rest } (_:rest) -> setState $ ctx0 { ctxParentAccount = rest }
getParentAccount :: Stream [Char] m Char => ParsecT [Char] JournalContext m String getParentAccount :: Monad m => JournalParser m String
getParentAccount = liftM (concatAccountNames . reverse . ctxParentAccount) getState getParentAccount = liftM (concatAccountNames . reverse . ctxParentAccount) getState
addAccountAlias :: Stream [Char] m Char => AccountAlias -> ParsecT [Char] JournalContext m () addAccountAlias :: Monad m => AccountAlias -> JournalParser m ()
addAccountAlias a = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases}) addAccountAlias a = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})
getAccountAliases :: Stream [Char] m Char => ParsecT [Char] JournalContext m [AccountAlias] getAccountAliases :: Monad m => JournalParser m [AccountAlias]
getAccountAliases = liftM ctxAliases getState getAccountAliases = liftM ctxAliases getState
clearAccountAliases :: Stream [Char] m Char => ParsecT [Char] JournalContext m () clearAccountAliases :: Monad m => JournalParser m ()
clearAccountAliases = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]}) clearAccountAliases = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})
getIndex :: Stream [Char] m Char => ParsecT s JournalContext m Integer getIndex :: Monad m => JournalParser m Integer
getIndex = liftM ctxTransactionIndex getState getIndex = liftM ctxTransactionIndex getState
setIndex :: Stream [Char] m Char => Integer -> ParsecT [Char] JournalContext m () setIndex :: Monad m => Integer -> JournalParser m ()
setIndex i = modifyState (\ctx -> ctx{ctxTransactionIndex=i}) setIndex i = modifyState (\ctx -> ctx{ctxTransactionIndex=i})
--- * parsers --- * parsers
@ -242,7 +270,7 @@ setIndex i = modifyState (\ctx -> ctx{ctxTransactionIndex=i})
-- | Top-level journal parser. Returns a single composite, I/O performing, -- | Top-level journal parser. Returns a single composite, I/O performing,
-- error-raising "JournalUpdate" (and final "JournalContext") which can be -- error-raising "JournalUpdate" (and final "JournalContext") which can be
-- applied to an empty journal to get the final result. -- applied to an empty journal to get the final result.
journalp :: ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext) journalp :: ErroringJournalParser (JournalUpdate,JournalContext)
journalp = do journalp = do
journalupdates <- many journalItem journalupdates <- many journalItem
eof eof
@ -264,7 +292,7 @@ journalp = do
--- ** directives --- ** directives
-- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives -- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives
directivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate directivep :: ErroringJournalParser JournalUpdate
directivep = do directivep = do
optional $ char '!' optional $ char '!'
choice' [ choice' [
@ -283,7 +311,7 @@ directivep = do
] ]
<?> "directive" <?> "directive"
includedirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate includedirectivep :: ErroringJournalParser JournalUpdate
includedirectivep = do includedirectivep = do
string "include" string "include"
many1 spacenonewline many1 spacenonewline
@ -316,7 +344,7 @@ journalAddFile :: (FilePath,String) -> Journal -> Journal
journalAddFile f j@Journal{files=fs} = j{files=fs++[f]} journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}
-- NOTE: first encountered file to left, to avoid a reverse -- NOTE: first encountered file to left, to avoid a reverse
accountdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate accountdirectivep :: ErroringJournalParser JournalUpdate
accountdirectivep = do accountdirectivep = do
string "account" string "account"
many1 spacenonewline many1 spacenonewline
@ -327,7 +355,7 @@ accountdirectivep = do
pushAccount acct pushAccount acct
return $ ExceptT $ return $ Right id return $ ExceptT $ return $ Right id
applyaccountdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate applyaccountdirectivep :: ErroringJournalParser JournalUpdate
applyaccountdirectivep = do applyaccountdirectivep = do
string "apply" >> many1 spacenonewline >> string "account" string "apply" >> many1 spacenonewline >> string "account"
many1 spacenonewline many1 spacenonewline
@ -336,13 +364,13 @@ applyaccountdirectivep = do
pushParentAccount parent pushParentAccount parent
return $ ExceptT $ return $ Right id return $ ExceptT $ return $ Right id
endapplyaccountdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate endapplyaccountdirectivep :: ErroringJournalParser JournalUpdate
endapplyaccountdirectivep = do endapplyaccountdirectivep = do
string "end" >> many1 spacenonewline >> string "apply" >> many1 spacenonewline >> string "account" string "end" >> many1 spacenonewline >> string "apply" >> many1 spacenonewline >> string "account"
popParentAccount popParentAccount
return $ ExceptT $ return $ Right id return $ ExceptT $ return $ Right id
aliasdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate aliasdirectivep :: ErroringJournalParser JournalUpdate
aliasdirectivep = do aliasdirectivep = do
string "alias" string "alias"
many1 spacenonewline many1 spacenonewline
@ -350,10 +378,10 @@ aliasdirectivep = do
addAccountAlias alias addAccountAlias alias
return $ return id return $ return id
accountaliasp :: Stream [Char] m Char => ParsecT [Char] st m AccountAlias accountaliasp :: Monad m => StringParser u m AccountAlias
accountaliasp = regexaliasp <|> basicaliasp accountaliasp = regexaliasp <|> basicaliasp
basicaliasp :: Stream [Char] m Char => ParsecT [Char] st m AccountAlias basicaliasp :: Monad m => StringParser u m AccountAlias
basicaliasp = do basicaliasp = do
-- pdbg 0 "basicaliasp" -- pdbg 0 "basicaliasp"
old <- rstrip <$> (many1 $ noneOf "=") old <- rstrip <$> (many1 $ noneOf "=")
@ -362,7 +390,7 @@ basicaliasp = do
new <- rstrip <$> anyChar `manyTill` eolof -- don't require a final newline, good for cli options new <- rstrip <$> anyChar `manyTill` eolof -- don't require a final newline, good for cli options
return $ BasicAlias old new return $ BasicAlias old new
regexaliasp :: Stream [Char] m Char => ParsecT [Char] st m AccountAlias regexaliasp :: Monad m => StringParser u m AccountAlias
regexaliasp = do regexaliasp = do
-- pdbg 0 "regexaliasp" -- pdbg 0 "regexaliasp"
char '/' char '/'
@ -374,13 +402,13 @@ regexaliasp = do
repl <- rstrip <$> anyChar `manyTill` eolof repl <- rstrip <$> anyChar `manyTill` eolof
return $ RegexAlias re repl return $ RegexAlias re repl
endaliasesdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate endaliasesdirectivep :: ErroringJournalParser JournalUpdate
endaliasesdirectivep = do endaliasesdirectivep = do
string "end aliases" string "end aliases"
clearAccountAliases clearAccountAliases
return (return id) return (return id)
tagdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate tagdirectivep :: ErroringJournalParser JournalUpdate
tagdirectivep = do tagdirectivep = do
string "tag" <?> "tag directive" string "tag" <?> "tag directive"
many1 spacenonewline many1 spacenonewline
@ -388,13 +416,13 @@ tagdirectivep = do
restofline restofline
return $ return id return $ return id
endtagdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate endtagdirectivep :: ErroringJournalParser JournalUpdate
endtagdirectivep = do endtagdirectivep = do
(string "end tag" <|> string "pop") <?> "end tag or pop directive" (string "end tag" <|> string "pop") <?> "end tag or pop directive"
restofline restofline
return $ return id return $ return id
defaultyeardirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate defaultyeardirectivep :: ErroringJournalParser JournalUpdate
defaultyeardirectivep = do defaultyeardirectivep = do
char 'Y' <?> "default year" char 'Y' <?> "default year"
many spacenonewline many spacenonewline
@ -404,7 +432,7 @@ defaultyeardirectivep = do
setYear y' setYear y'
return $ return id return $ return id
defaultcommoditydirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate defaultcommoditydirectivep :: ErroringJournalParser JournalUpdate
defaultcommoditydirectivep = do defaultcommoditydirectivep = do
char 'D' <?> "default commodity" char 'D' <?> "default commodity"
many1 spacenonewline many1 spacenonewline
@ -413,7 +441,7 @@ defaultcommoditydirectivep = do
restofline restofline
return $ return id return $ return id
marketpricedirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) MarketPrice marketpricedirectivep :: ErroringJournalParser MarketPrice
marketpricedirectivep = do marketpricedirectivep = do
char 'P' <?> "market price" char 'P' <?> "market price"
many spacenonewline many spacenonewline
@ -425,7 +453,7 @@ marketpricedirectivep = do
restofline restofline
return $ MarketPrice date symbol price return $ MarketPrice date symbol price
ignoredpricecommoditydirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate ignoredpricecommoditydirectivep :: ErroringJournalParser JournalUpdate
ignoredpricecommoditydirectivep = do ignoredpricecommoditydirectivep = do
char 'N' <?> "ignored-price commodity" char 'N' <?> "ignored-price commodity"
many1 spacenonewline many1 spacenonewline
@ -433,7 +461,7 @@ ignoredpricecommoditydirectivep = do
restofline restofline
return $ return id return $ return id
commodityconversiondirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate commodityconversiondirectivep :: ErroringJournalParser JournalUpdate
commodityconversiondirectivep = do commodityconversiondirectivep = do
char 'C' <?> "commodity conversion" char 'C' <?> "commodity conversion"
many1 spacenonewline many1 spacenonewline
@ -447,24 +475,24 @@ commodityconversiondirectivep = do
--- ** transactions --- ** transactions
modifiertransactionp :: ParsecT [Char] JournalContext (ExceptT String IO) ModifierTransaction modifiertransactionp :: ErroringJournalParser ModifierTransaction
modifiertransactionp = do modifiertransactionp = do
char '=' <?> "modifier transaction" char '=' <?> "modifier transaction"
many spacenonewline many spacenonewline
valueexpr <- restofline valueexpr <- restofline
postings <- postingsp postings <- postingsp Nothing
return $ ModifierTransaction valueexpr postings return $ ModifierTransaction valueexpr postings
periodictransactionp :: ParsecT [Char] JournalContext (ExceptT String IO) PeriodicTransaction periodictransactionp :: ErroringJournalParser PeriodicTransaction
periodictransactionp = do periodictransactionp = do
char '~' <?> "periodic transaction" char '~' <?> "periodic transaction"
many spacenonewline many spacenonewline
periodexpr <- restofline periodexpr <- restofline
postings <- postingsp postings <- postingsp Nothing
return $ PeriodicTransaction periodexpr postings return $ PeriodicTransaction periodexpr postings
-- | Parse a (possibly unbalanced) transaction. -- | Parse a (possibly unbalanced) transaction.
transactionp :: ParsecT [Char] JournalContext (ExceptT String IO) Transaction transactionp :: ErroringJournalParser Transaction
transactionp = do transactionp = do
-- ptrace "transactionp" -- ptrace "transactionp"
sourcepos <- genericSourcePos <$> getPosition sourcepos <- genericSourcePos <$> getPosition
@ -475,8 +503,8 @@ transactionp = do
code <- codep <?> "transaction code" code <- codep <?> "transaction code"
description <- descriptionp >>= return . strip description <- descriptionp >>= return . strip
comment <- try followingcommentp <|> (newline >> return "") comment <- try followingcommentp <|> (newline >> return "")
let tags = tagsInComment comment let tags = commentTags comment
postings <- postingsp postings <- postingsp (Just date)
i' <- (+1) <$> getIndex i' <- (+1) <$> getIndex
setIndex i' setIndex i'
return $ txnTieKnot $ Transaction i' sourcepos date edate status code description comment tags postings "" return $ txnTieKnot $ Transaction i' sourcepos date edate status code description comment tags postings ""
@ -574,7 +602,7 @@ test_transactionp = do
assertEqual 2 (let Right t = p in length $ tpostings t) assertEqual 2 (let Right t = p in length $ tpostings t)
#endif #endif
statusp :: Stream [Char] m Char => ParsecT [Char] JournalContext m ClearedStatus statusp :: Monad m => JournalParser m ClearedStatus
statusp = statusp =
choice' choice'
[ many spacenonewline >> char '*' >> return Cleared [ many spacenonewline >> char '*' >> return Cleared
@ -583,7 +611,7 @@ statusp =
] ]
<?> "cleared status" <?> "cleared status"
codep :: Stream [Char] m Char => ParsecT [Char] JournalContext m String codep :: Monad m => JournalParser m String
codep = try (do { many1 spacenonewline; char '(' <?> "codep"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" codep = try (do { many1 spacenonewline; char '(' <?> "codep"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
descriptionp = many (noneOf ";\n") descriptionp = many (noneOf ";\n")
@ -594,7 +622,7 @@ descriptionp = many (noneOf ";\n")
-- Hyphen (-) and period (.) are also allowed as separators. -- Hyphen (-) and period (.) are also allowed as separators.
-- The year may be omitted if a default year has been set. -- The year may be omitted if a default year has been set.
-- Leading zeroes may be omitted. -- Leading zeroes may be omitted.
datep :: Stream [Char] m t => ParsecT [Char] JournalContext m Day datep :: Monad m => JournalParser m Day
datep = do datep = do
-- hacky: try to ensure precise errors for invalid dates -- hacky: try to ensure precise errors for invalid dates
-- XXX reported error position is not too good -- XXX reported error position is not too good
@ -624,7 +652,7 @@ datep = do
-- Seconds are optional. -- Seconds are optional.
-- The timezone is optional and ignored (the time is always interpreted as a local time). -- The timezone is optional and ignored (the time is always interpreted as a local time).
-- Leading zeroes may be omitted (except in a timezone). -- Leading zeroes may be omitted (except in a timezone).
datetimep :: Stream [Char] m Char => ParsecT [Char] JournalContext m LocalTime datetimep :: Monad m => JournalParser m LocalTime
datetimep = do datetimep = do
day <- datep day <- datep
many1 spacenonewline many1 spacenonewline
@ -652,7 +680,7 @@ datetimep = do
-- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
secondarydatep :: Stream [Char] m Char => Day -> ParsecT [Char] JournalContext m Day secondarydatep :: Monad m => Day -> JournalParser m Day
secondarydatep primarydate = do secondarydatep primarydate = do
char '=' char '='
-- kludgy way to use primary date for default year -- kludgy way to use primary date for default year
@ -665,21 +693,33 @@ secondarydatep primarydate = do
edate <- withDefaultYear primarydate datep edate <- withDefaultYear primarydate datep
return edate return edate
-- |
-- >> parsewith twoorthreepartdatestringp "2016/01/2"
-- Right "2016/01/2"
-- twoorthreepartdatestringp = do
-- n1 <- many1 digit
-- c <- datesepchar
-- n2 <- many1 digit
-- mn3 <- optionMaybe $ char c >> many1 digit
-- return $ n1 ++ c:n2 ++ maybe "" (c:) mn3
--- ** postings --- ** postings
-- Parse the following whitespace-beginning lines as postings, posting tags, and/or comments. -- Parse the following whitespace-beginning lines as postings, posting
postingsp :: Stream [Char] m Char => ParsecT [Char] JournalContext m [Posting] -- tags, and/or comments (inferring year, if needed, from the given date).
postingsp = many (try postingp) <?> "postings" postingsp :: Maybe Day -> ErroringJournalParser [Posting]
postingsp mdate = many (try $ postingp mdate) <?> "postings"
-- linebeginningwithspaces :: Stream [Char] m Char => ParsecT [Char] JournalContext m String -- linebeginningwithspaces :: Monad m => JournalParser m String
-- linebeginningwithspaces = do -- linebeginningwithspaces = do
-- sp <- many1 spacenonewline -- sp <- many1 spacenonewline
-- c <- nonspace -- c <- nonspace
-- cs <- restofline -- cs <- restofline
-- return $ sp ++ (c:cs) ++ "\n" -- return $ sp ++ (c:cs) ++ "\n"
postingp :: Stream [Char] m Char => ParsecT [Char] JournalContext m Posting postingp :: Maybe Day -> ErroringJournalParser Posting
postingp = do postingp mtdate = do
-- pdbg 0 "postingp"
many1 spacenonewline many1 spacenonewline
status <- statusp status <- statusp
many spacenonewline many spacenonewline
@ -689,23 +729,11 @@ postingp = do
massertion <- partialbalanceassertionp massertion <- partialbalanceassertionp
_ <- fixedlotpricep _ <- fixedlotpricep
many spacenonewline many spacenonewline
ctx <- getState (comment,tags,mdate,mdate2) <-
comment <- try followingcommentp <|> (newline >> return "") try (followingcommentandtagsp mtdate) <|> (newline >> return ("",[],Nothing,Nothing))
let tags = tagsInComment comment
-- parse any dates specified with tags here for good parse errors
date <- case dateValueFromTags tags of
Nothing -> return Nothing
Just v -> case runParser (datep <* eof) ctx "" v of
Right d -> return $ Just d
Left err -> parserFail $ show err
date2 <- case date2ValueFromTags tags of
Nothing -> return Nothing
Just v -> case runParser (datep <* eof) ctx "" v of
Right d -> return $ Just d
Left err -> parserFail $ show err
return posting return posting
{ pdate=date { pdate=mdate
, pdate2=date2 , pdate2=mdate2
, pstatus=status , pstatus=status
, paccount=account' , paccount=account'
, pamount=amount , pamount=amount
@ -718,7 +746,7 @@ postingp = do
#ifdef TESTS #ifdef TESTS
test_postingp = do test_postingp = do
let s `gives` ep = do let s `gives` ep = do
let parse = parseWithCtx nullctx postingp s let parse = parseWithCtx nullctx (postingp Nothing) s
assertBool -- "postingp parser" assertBool -- "postingp parser"
$ isRight parse $ isRight parse
let Right ap = parse let Right ap = parse
@ -750,10 +778,10 @@ test_postingp = do
,pdate=parsedateM "2012/11/28"} ,pdate=parsedateM "2012/11/28"}
assertBool -- "postingp parses a quoted commodity with numbers" assertBool -- "postingp parses a quoted commodity with numbers"
(isRight $ parseWithCtx nullctx postingp " a 1 \"DE123\"\n") (isRight $ parseWithCtx nullctx (postingp Nothing) " a 1 \"DE123\"\n")
-- ,"postingp parses balance assertions and fixed lot prices" ~: do -- ,"postingp parses balance assertions and fixed lot prices" ~: do
assertBool (isRight $ parseWithCtx nullctx postingp " a 1 \"DE123\" =$1 { =2.2 EUR} \n") assertBool (isRight $ parseWithCtx nullctx (postingp Nothing) " a 1 \"DE123\" =$1 { =2.2 EUR} \n")
-- let parse = parseWithCtx nullctx postingp " a\n ;next-line comment\n" -- let parse = parseWithCtx nullctx postingp " a\n ;next-line comment\n"
-- assertRight parse -- assertRight parse
@ -765,7 +793,7 @@ test_postingp = do
--- ** account names --- ** account names
-- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect. -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
modifiedaccountnamep :: Stream [Char] m Char => ParsecT [Char] JournalContext m AccountName modifiedaccountnamep :: Monad m => JournalParser m AccountName
modifiedaccountnamep = do modifiedaccountnamep = do
parent <- getParentAccount parent <- getParentAccount
aliases <- getAccountAliases aliases <- getAccountAliases
@ -781,7 +809,7 @@ modifiedaccountnamep = do
-- spaces (or end of input). Also they have one or more components of -- spaces (or end of input). Also they have one or more components of
-- at least one character, separated by the account separator char. -- at least one character, separated by the account separator char.
-- (This parser will also consume one following space, if present.) -- (This parser will also consume one following space, if present.)
accountnamep :: Stream [Char] m Char => ParsecT [Char] st m AccountName accountnamep :: Monad m => StringParser u m AccountName
accountnamep = do accountnamep = do
a <- do a <- do
c <- nonspace c <- nonspace
@ -803,7 +831,7 @@ accountnamep = do
-- | Parse whitespace then an amount, with an optional left or right -- | Parse whitespace then an amount, with an optional left or right
-- currency symbol and optional price, or return the special -- currency symbol and optional price, or return the special
-- "missing" marker amount. -- "missing" marker amount.
spaceandamountormissingp :: Stream [Char] m Char => ParsecT [Char] JournalContext m MixedAmount spaceandamountormissingp :: Monad m => JournalParser m MixedAmount
spaceandamountormissingp = spaceandamountormissingp =
try (do try (do
many1 spacenonewline many1 spacenonewline
@ -827,7 +855,7 @@ test_spaceandamountormissingp = do
-- | Parse a single-commodity amount, with optional symbol on the left or -- | Parse a single-commodity amount, with optional symbol on the left or
-- right, optional unit or total price, and optional (ignored) -- right, optional unit or total price, and optional (ignored)
-- ledger-style balance assertion or fixed lot price declaration. -- ledger-style balance assertion or fixed lot price declaration.
amountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount amountp :: Monad m => JournalParser m Amount
amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp
#ifdef TESTS #ifdef TESTS
@ -849,19 +877,19 @@ amountp' :: String -> Amount
amountp' s = amountp' s =
case runParser (amountp <* eof) nullctx "" s of case runParser (amountp <* eof) nullctx "" s of
Right t -> t Right t -> t
Left err -> error' $ show err Left err -> error' $ show err -- XXX should throwError
-- | Parse a mixed amount from a string, or get an error. -- | Parse a mixed amount from a string, or get an error.
mamountp' :: String -> MixedAmount mamountp' :: String -> MixedAmount
mamountp' = Mixed . (:[]) . amountp' mamountp' = Mixed . (:[]) . amountp'
signp :: Stream [Char] m t => ParsecT [Char] JournalContext m String signp :: Monad m => JournalParser m String
signp = do signp = do
sign <- optionMaybe $ oneOf "+-" sign <- optionMaybe $ oneOf "+-"
return $ case sign of Just '-' -> "-" return $ case sign of Just '-' -> "-"
_ -> "" _ -> ""
leftsymbolamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount leftsymbolamountp :: Monad m => JournalParser m Amount
leftsymbolamountp = do leftsymbolamountp = do
sign <- signp sign <- signp
c <- commoditysymbolp c <- commoditysymbolp
@ -873,7 +901,7 @@ leftsymbolamountp = do
return $ applysign $ Amount c q p s return $ applysign $ Amount c q p s
<?> "left-symbol amount" <?> "left-symbol amount"
rightsymbolamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount rightsymbolamountp :: Monad m => JournalParser m Amount
rightsymbolamountp = do rightsymbolamountp = do
(q,prec,mdec,mgrps) <- numberp (q,prec,mdec,mgrps) <- numberp
sp <- many spacenonewline sp <- many spacenonewline
@ -883,7 +911,7 @@ rightsymbolamountp = do
return $ Amount c q p s return $ Amount c q p s
<?> "right-symbol amount" <?> "right-symbol amount"
nosymbolamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount nosymbolamountp :: Monad m => JournalParser m Amount
nosymbolamountp = do nosymbolamountp = do
(q,prec,mdec,mgrps) <- numberp (q,prec,mdec,mgrps) <- numberp
p <- priceamountp p <- priceamountp
@ -895,20 +923,20 @@ nosymbolamountp = do
return $ Amount c q p s return $ Amount c q p s
<?> "no-symbol amount" <?> "no-symbol amount"
commoditysymbolp :: Stream [Char] m t => ParsecT [Char] JournalContext m String commoditysymbolp :: Monad m => JournalParser m String
commoditysymbolp = (quotedcommoditysymbolp <|> simplecommoditysymbolp) <?> "commodity symbol" commoditysymbolp = (quotedcommoditysymbolp <|> simplecommoditysymbolp) <?> "commodity symbol"
quotedcommoditysymbolp :: Stream [Char] m t => ParsecT [Char] JournalContext m String quotedcommoditysymbolp :: Monad m => JournalParser m String
quotedcommoditysymbolp = do quotedcommoditysymbolp = do
char '"' char '"'
s <- many1 $ noneOf ";\n\"" s <- many1 $ noneOf ";\n\""
char '"' char '"'
return s return s
simplecommoditysymbolp :: Stream [Char] m t => ParsecT [Char] JournalContext m String simplecommoditysymbolp :: Monad m => JournalParser m String
simplecommoditysymbolp = many1 (noneOf nonsimplecommoditychars) simplecommoditysymbolp = many1 (noneOf nonsimplecommoditychars)
priceamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Price priceamountp :: Monad m => JournalParser m Price
priceamountp = priceamountp =
try (do try (do
many spacenonewline many spacenonewline
@ -924,7 +952,7 @@ priceamountp =
return $ UnitPrice a)) return $ UnitPrice a))
<|> return NoPrice <|> return NoPrice
partialbalanceassertionp :: Stream [Char] m t => ParsecT [Char] JournalContext m (Maybe MixedAmount) partialbalanceassertionp :: Monad m => JournalParser m (Maybe MixedAmount)
partialbalanceassertionp = partialbalanceassertionp =
try (do try (do
many spacenonewline many spacenonewline
@ -934,7 +962,7 @@ partialbalanceassertionp =
return $ Just $ Mixed [a]) return $ Just $ Mixed [a])
<|> return Nothing <|> return Nothing
-- balanceassertion :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe MixedAmount) -- balanceassertion :: Monad m => JournalParser m (Maybe MixedAmount)
-- balanceassertion = -- balanceassertion =
-- try (do -- try (do
-- many spacenonewline -- many spacenonewline
@ -945,7 +973,7 @@ partialbalanceassertionp =
-- <|> return Nothing -- <|> return Nothing
-- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices -- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices
fixedlotpricep :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe Amount) fixedlotpricep :: Monad m => JournalParser m (Maybe Amount)
fixedlotpricep = fixedlotpricep =
try (do try (do
many spacenonewline many spacenonewline
@ -971,7 +999,7 @@ fixedlotpricep =
-- seen following the decimal point), the decimal point character used if any, -- seen following the decimal point), the decimal point character used if any,
-- and the digit group style if any. -- and the digit group style if any.
-- --
numberp :: Stream [Char] m t => ParsecT [Char] JournalContext m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle) numberp :: Monad m => JournalParser m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
numberp = do numberp = do
-- a number is an optional sign followed by a sequence of digits possibly -- a number is an optional sign followed by a sequence of digits possibly
-- interspersed with periods, commas, or both -- interspersed with periods, commas, or both
@ -1045,7 +1073,7 @@ numberp = do
--- ** comments --- ** comments
multilinecommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m () multilinecommentp :: Monad m => JournalParser m ()
multilinecommentp = do multilinecommentp = do
string "comment" >> many spacenonewline >> newline string "comment" >> many spacenonewline >> newline
go go
@ -1054,28 +1082,83 @@ multilinecommentp = do
<|> (anyLine >> go) <|> (anyLine >> go)
anyLine = anyChar `manyTill` newline anyLine = anyChar `manyTill` newline
emptyorcommentlinep :: Stream [Char] m Char => ParsecT [Char] JournalContext m () emptyorcommentlinep :: Monad m => JournalParser m ()
emptyorcommentlinep = do emptyorcommentlinep = do
many spacenonewline >> (commentp <|> (many spacenonewline >> newline >> return "")) many spacenonewline >> (commentp <|> (many spacenonewline >> newline >> return ""))
return () return ()
followingcommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String -- | Parse a possibly multi-line comment following a semicolon.
followingcommentp :: Monad m => JournalParser m String
followingcommentp = followingcommentp =
-- ptrace "followingcommentp" -- ptrace "followingcommentp"
do samelinecomment <- many spacenonewline >> (try semicoloncommentp <|> (newline >> return "")) do samelinecomment <- many spacenonewline >> (try semicoloncommentp <|> (newline >> return ""))
newlinecomments <- many (try (many1 spacenonewline >> semicoloncommentp)) newlinecomments <- many (try (many1 spacenonewline >> semicoloncommentp))
return $ unlines $ samelinecomment:newlinecomments return $ unlines $ samelinecomment:newlinecomments
commentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String -- | Parse a possibly multi-line comment following a semicolon, and
-- any tags and/or posting dates within it. Posting dates can be
-- expressed with "date"/"date2" tags and/or bracketed dates. The
-- dates are parsed in full here so that errors are reported in the
-- right position. Missing years can be inferred if a default date is
-- provided.
--
-- >>> rejp (followingcommentandtagsp (Just $ fromGregorian 2000 1 2)) "; a:b, date:3/4, [=5/6]"
-- Right ("a:b, date:3/4, [=5/6]\n",[("a","b"),("date","3/4")],Just 2000-03-04,Just 2000-05-06)
--
-- Year unspecified and no default provided -> unknown year error, at correct position:
-- >>> rejp (followingcommentandtagsp Nothing) " ; xxx date:3/4\n ; second line"
-- Left ...line 1, column 22...year is unknown...
--
-- Date tag value contains trailing text - forgot the comma, confused:
-- the syntaxes ? We'll accept the leading date anyway
-- >>> rejp (followingcommentandtagsp (Just $ fromGregorian 2000 1 2)) "; date:3/4=5/6"
-- Right ("date:3/4=5/6\n",[("date","3/4=5/6")],Just 2000-03-04,Nothing)
--
followingcommentandtagsp :: Maybe Day -> ErroringJournalParser (String, [Tag], Maybe Day, Maybe Day)
followingcommentandtagsp mdefdate = do
-- pdbg 0 "followingcommentandtagsp"
-- Parse a single or multi-line comment, starting on this line or the next one.
-- Save the starting position and preserve all whitespace for the subsequent re-parsing,
-- to get good error positions.
startpos <- getPosition
commentandwhitespace <- do
let semicoloncommentp' = (:) <$> char ';' <*> anyChar `manyTill` eolof
sp1 <- many spacenonewline
l1 <- try semicoloncommentp' <|> (newline >> return "")
ls <- many $ try ((++) <$> many1 spacenonewline <*> semicoloncommentp')
return $ unlines $ (sp1 ++ l1) : ls
let comment = unlines $ map (lstrip . dropWhile (==';') . strip) $ lines commentandwhitespace
-- pdbg 0 $ "commentws:"++show commentandwhitespace
-- pdbg 0 $ "comment:"++show comment
-- Reparse the comment for any tags.
tags <- case runStringParser (setPosition startpos >> tagsp) commentandwhitespace of
Right ts -> return ts
Left e -> throwError $ show e
-- pdbg 0 $ "tags: "++show tags
-- Reparse the comment for any posting dates. Use the transaction date for defaults, if provided.
epdates <- liftIO $ rejp (setPosition startpos >> postingdatesp mdefdate) commentandwhitespace
pdates <- case epdates of
Right ds -> return ds
Left e -> throwError e
-- pdbg 0 $ "pdates: "++show pdates
let mdate = headMay $ map snd $ filter ((=="date").fst) pdates
mdate2 = headMay $ map snd $ filter ((=="date2").fst) pdates
return (comment, tags, mdate, mdate2)
commentp :: Monad m => JournalParser m String
commentp = commentStartingWithp commentchars commentp = commentStartingWithp commentchars
commentchars :: [Char] commentchars :: [Char]
commentchars = "#;*" commentchars = "#;*"
semicoloncommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String semicoloncommentp :: Monad m => JournalParser m String
semicoloncommentp = commentStartingWithp ";" semicoloncommentp = commentStartingWithp ";"
commentStartingWithp :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m String commentStartingWithp :: Monad m => String -> JournalParser m String
commentStartingWithp cs = do commentStartingWithp cs = do
-- ptrace "commentStartingWith" -- ptrace "commentStartingWith"
oneOf cs oneOf cs
@ -1086,74 +1169,188 @@ commentStartingWithp cs = do
--- ** tags --- ** tags
tagsInComment :: String -> [Tag] -- | Extract any tags (name:value ended by comma or newline) embedded in a string.
tagsInComment c = concatMap tagsInCommentLine $ lines c' --
where -- >>> commentTags "a b:, c:c d:d, e"
c' = ledgerDateSyntaxToTags c -- [("b",""),("c","c d:d")]
--
-- >>> commentTags "a [1/1/1] [1/1] [1], [=1/1/1] [=1/1] [=1] [1/1=1/1/1] [1=1/1/1] b:c"
-- [("b","c")]
--
-- --[("date","1/1/1"),("date","1/1"),("date2","1/1/1"),("date2","1/1"),("date","1/1"),("date2","1/1/1"),("date","1"),("date2","1/1/1")]
--
-- >>> commentTags "\na b:, \nd:e, f"
-- [("b",""),("d","e")]
--
commentTags :: String -> [Tag]
commentTags s =
case runStringParser tagsp s of
Right r -> r
Left _ -> [] -- shouldn't happen
-- | -- | Parse all tags found in a string.
-- ==== __Examples__ tagsp :: StringParser u Identity [Tag]
-- >>> tagsInCommentLine "" tagsp = do
-- [] -- pdbg 0 $ "tagsp"
-- >>> tagsInCommentLine "a b" many (try (nontagp >> tagp))
-- []
-- >>> tagsInCommentLine "a b:, c:c d:d, e"
-- [("c","c d:d")]
tagsInCommentLine :: String -> [Tag]
tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ','
where
maybetag s = case runParser (tagp <* eof) nullctx "" s of
Right t -> Just t
Left _ -> Nothing
-- | Parse everything up till the first tag.
--
-- >>> rsp nontagp "\na b:, \nd:e, f"
-- Right "\na "
nontagp :: StringParser u Identity String
nontagp = do
-- pdbg 0 "nontagp"
-- anyChar `manyTill` (lookAhead (try (tagorbracketeddatetagsp Nothing >> return ()) <|> eof))
anyChar `manyTill` (lookAhead (try (tagp >> return ()) <|> eof))
-- XXX costly ?
-- | Tags begin with a colon-suffixed tag name (a word beginning with
-- a letter) and are followed by a tag value (any text up to a comma
-- or newline, whitespace-stripped).
--
-- >>> rsp tagp "a:b b , c AuxDate: 4/2"
-- Right ("a","b b")
--
tagp :: Monad m => StringParser u m Tag
tagp = do tagp = do
-- ptrace "tag" -- pdbg 0 "tagp"
n <- tagnamep n <- tagnamep
v <- tagvaluep v <- tagvaluep
return (n,v) return (n,v)
-- |
-- >>> rsp tagnamep "a:"
-- Right "a"
tagnamep :: Monad m => StringParser u m String
tagnamep = do tagnamep = do
-- ptrace "tagname" -- pdbg 0 "tagnamep"
n <- many1 $ noneOf ": \t" many1 (noneOf ": \t\n") <* char ':'
char ':'
return n
tagvaluep :: Monad m => StringParser u m String
tagvaluep = do tagvaluep = do
-- ptrace "tagvalue" -- ptrace "tagvalue"
v <- anyChar `manyTill` ((char ',' >> return ()) <|> eolof) v <- anyChar `manyTill` ((try (char ',') >> return ()) <|> eolof)
return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
ledgerDateSyntaxToTags :: String -> String --- ** posting dates
ledgerDateSyntaxToTags = regexReplaceBy "\\[[-.\\/0-9=]+\\]" replace
where
replace ('[':s) | lastDef ' ' s == ']' = replace' $ init s
replace s = s
replace' s | isdate s = datetag s -- | Parse all posting dates found in a string. Posting dates can be
replace' ('=':s) | isdate s = date2tag s -- expressed with date/date2 tags and/or bracketed dates. The dates
replace' s | last s =='=' && isdate (init s) = datetag (init s) -- are parsed fully to give useful errors. Missing years can be
replace' s | length ds == 2 && isdate d1 && isdate d1 = datetag d1 ++ date2tag d2 -- inferred only if a default date is provided.
where --
ds = splitAtElement '=' s postingdatesp :: Maybe Day -> ErroringJournalParser [(TagName,Day)]
d1 = headDef "" ds postingdatesp mdefdate = do
d2 = lastDef "" ds -- pdbg 0 $ "postingdatesp"
replace' s = s let p = (datetagp mdefdate >>= return.(:[])) <|> bracketeddatetagsp mdefdate
nonp =
many (notFollowedBy p >> anyChar)
-- anyChar `manyTill` (lookAhead (try (p >> return ()) <|> eof))
concat <$> (many $ try (nonp >> p))
isdate = isJust . parsedateM --- ** date tags
datetag s = "date:"++s++", "
date2tag s = "date2:"++s++", "
#ifdef TESTS -- | Date tags are tags with name "date" or "date2". Their value is
test_ledgerDateSyntaxToTags = do -- parsed as a date, using the provided default date if any for
assertEqual "date2:2012/11/28, " $ ledgerDateSyntaxToTags "[=2012/11/28]" -- inferring a missing year if needed. Any error in date parsing is
#endif -- reported and terminates parsing.
--
-- >>> rejp (datetagp Nothing) "date: 2000/1/2 "
-- Right ("date",2000-01-02)
--
-- >>> rejp (datetagp (Just $ fromGregorian 2001 2 3)) "date2:3/4"
-- Right ("date2",2001-03-04)
--
-- >>> rejp (datetagp Nothing) "date: 3/4"
-- Left ...line 1, column 9...year is unknown...
--
datetagp :: Maybe Day -> ErroringJournalParser (TagName,Day)
datetagp mdefdate = do
-- pdbg 0 "datetagp"
string "date"
n <- maybe "" id <$> optionMaybe (string "2")
char ':'
startpos <- getPosition
v <- tagvaluep
-- re-parse value as a date.
ctx <- getState
ep <- parseWithCtx
ctx{ctxYear=first3.toGregorian <$> mdefdate}
-- The value extends to a comma, newline, or end of file.
-- It seems like ignoring any extra stuff following a date
-- gives better errors here.
(do
setPosition startpos
datep) -- <* eof)
v
case ep
of Left e -> throwError $ show e
Right d -> return ("date"++n, d)
dateValueFromTags, date2ValueFromTags :: [Tag] -> Maybe String --- ** bracketed dates
dateValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date") . fst) ts
date2ValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date2") . fst) ts
-- tagorbracketeddatetagsp :: Monad m => Maybe Day -> StringParser u m [Tag]
-- tagorbracketeddatetagsp mdefdate =
-- bracketeddatetagsp mdefdate <|> ((:[]) <$> tagp)
--- * tests -- | Parse Ledger-style bracketed posting dates ([DATE=DATE2]), as
-- "date" and/or "date2" tags. Anything that looks like an attempt at
-- this (a square-bracketed sequence of 0123456789/-.= containing at
-- least one digit and one date separator) is also parsed, and will
-- throw an appropriate error.
--
-- The dates are parsed in full here so that errors are reported in
-- the right position. A missing year in DATE can be inferred if a
-- default date is provided. A missing year in DATE2 will be inferred
-- from DATE.
--
-- >>> rejp (bracketeddatetagsp Nothing) "[2016/1/2=3/4]"
-- Right [("date",2016-01-02),("date2",2016-03-04)]
--
-- >>> rejp (bracketeddatetagsp Nothing) "[1]"
-- Left ...not a bracketed date...
--
-- >>> rejp (bracketeddatetagsp Nothing) "[2016/1/32]"
-- Left ...line 1, column 11...bad date...
--
-- >>> rejp (bracketeddatetagsp Nothing) "[1/31]"
-- Left ...line 1, column 6...year is unknown...
--
-- >>> rejp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"
-- Left ...line 1, column 15...bad date, different separators...
--
bracketeddatetagsp :: Maybe Day -> ErroringJournalParser [(TagName, Day)]
bracketeddatetagsp mdefdate = do
-- pdbg 0 "bracketeddatetagsp"
char '['
startpos <- getPosition
let digits = "0123456789"
s <- many1 (oneOf $ '=':digits++datesepchars)
char ']'
unless (any (`elem` s) digits && any (`elem` datesepchars) s) $
parserFail "not a bracketed date"
-- looks sufficiently like a bracketed date, now we
-- re-parse as dates and throw any errors
ctx <- getState
ep <- parseWithCtx
ctx{ctxYear=first3.toGregorian <$> mdefdate}
(do
setPosition startpos
md1 <- optionMaybe datep
maybe (return ()) (setYear.first3.toGregorian) md1
md2 <- optionMaybe $ char '=' >> datep
eof
return (md1,md2)
)
s
case ep
of Left e -> throwError $ show e
Right (md1,md2) -> return $ catMaybes $
[maybe Nothing (Just.("date",)) md1, maybe Nothing (Just.("date2",)) md2]
--- * more tests
tests_Hledger_Read_JournalReader = TestList $ concat [ tests_Hledger_Read_JournalReader = TestList $ concat [
-- test_numberp -- test_numberp

87
hledger-lib/doc/hledger_journal.5.m4.md
View File

@ -86,11 +86,9 @@ left blank, in which case it will be inferred.
### Simple dates ### Simple dates
Within a journal file, transaction dates use Y/M/D (or Y-M-D or Y.M.D) Within a journal file, transaction dates use Y/M/D (or Y-M-D or Y.M.D)
Leading zeroes are optional. Leading zeros are optional.
The year may be omitted, in which case it defaults to the current The year may be omitted, in which case it will be inferred from the context - the current transaction, the default year set with a
year, or you can set the default year with a [default year directive](#default-year), or the current date when the command is run.
[default year directive](#default-year).
Some examples: `2010/01/31`, `1/31`, `2010-01-31`, `2010.1.31`. Some examples: `2010/01/31`, `1/31`, `2010-01-31`, `2010.1.31`.
### Secondary dates ### Secondary dates
@ -115,14 +113,12 @@ primary date if unspecified.
assets:checking assets:checking
``` ```
<div style="clear:both;"></div> ```shell
```{.shell}
$ hledger register checking $ hledger register checking
2010/02/23 movie ticket assets:checking $-10 $-10 2010/02/23 movie ticket assets:checking $-10 $-10
``` ```
<div style="clear:both;"></div> ```shell
```{.shell}
$ hledger register checking --date2 $ hledger register checking --date2
2010/02/19 movie ticket assets:checking $-10 $-10 2010/02/19 movie ticket assets:checking $-10 $-10
``` ```
@ -135,40 +131,39 @@ superseded by...
### Posting dates ### Posting dates
You can give individual postings a different date from their parent You can give individual postings a different date from their parent
transaction, by adding a [posting tag](#tags) (see below) like transaction, by adding a [posting comment](#comments) containing a
`date:DATE`, where DATE is a [simple date](#simple-dates). This is [tag](#tags) (see below) like `date:DATE`. This is probably the best
probably the best way to control posting dates precisely. Eg in this way to control posting dates precisely. Eg in this example the expense
example the expense should appear in May reports, and the deduction should appear in May reports, and the deduction from checking should
from checking should be reported on 6/1 for easy bank reconciliation: be reported on 6/1 for easy bank reconciliation:
``` {.journal} ```journal
2015/5/30 2015/5/30
expenses:food $10 ; food purchased on saturday 5/30 expenses:food $10 ; food purchased on saturday 5/30
assets:checking ; bank cleared it on monday, date:6/1 assets:checking ; bank cleared it on monday, date:6/1
``` ```
<div style="clear:both;"></div> ```shell
```{.shell} $ hledger -f t.j register food
$ hledger -f tt.j register food
2015/05/30 expenses:food $10 $10 2015/05/30 expenses:food $10 $10
``` ```
<div style="clear:both;"></div> ```shell
```{.shell} $ hledger -f t.j register checking
$ hledger -f tt.j register checking
2015/06/01 assets:checking $-10 $-10 2015/06/01 assets:checking $-10 $-10
``` ```
A posting date will use the year of the transaction date if unspecified. DATE should be a [simple date](#simple-dates); if the year is not
specified it will use the year of the transaction's date. You can set
the secondary date similarly, with `date2:DATE2`. The `date:` or
`date2:` tags must have a valid simple date value if they are present,
eg a `date:` tag with no value is not allowed.
You can also set the secondary date, with `date2:DATE2`. Ledger's earlier, more compact bracketed date syntax is also
For compatibility, Ledger's older posting date syntax is also supported: `[DATE]`, `[DATE=DATE2]` or `[=DATE2]`. hledger will
supported: `[DATE]`, `[DATE=DATE2]` or `[=DATE2]` in a posting attempt to parse any square-bracketed sequence of the `0123456789/-.=`
comment. characters in this way. With this syntax, DATE infers its year from
the transaction and DATE2 infers its year from DATE.
When using any of these forms, be sure to provide a valid simple date
or you'll get a parse error. Eg a `date:` tag with no value is not
allowed.
## Account names ## Account names
@ -249,7 +244,7 @@ These look like `=EXPECTEDBALANCE` following a posting's amount. Eg in
this example we assert the expected dollar balance in accounts a and b after this example we assert the expected dollar balance in accounts a and b after
each posting: each posting:
``` {.journal} ```journal
2013/1/1 2013/1/1
a $1 =$1 a $1 =$1
b =$-1 b =$-1
@ -308,7 +303,7 @@ for this kind of total balance assertion if there's demand.)
Balance assertions do not count the balance from subaccounts; they check Balance assertions do not count the balance from subaccounts; they check
the posted account's exclusive balance. For example: the posted account's exclusive balance. For example:
``` {.journal} ```journal
1/1 1/1
checking:fund 1 = 1 ; post to this subaccount, its balance is now 1 checking:fund 1 = 1 ; post to this subaccount, its balance is now 1
checking 1 = 1 ; post to the parent account, its exclusive balance is now 1 checking 1 = 1 ; post to the parent account, its exclusive balance is now 1
@ -472,7 +467,7 @@ while tags in a posting comment affect only that posting.
For example, the following transaction has three tags (A, TAG2, third-tag) For example, the following transaction has three tags (A, TAG2, third-tag)
and the posting has four (A, TAG2, third-tag, posting-tag): and the posting has four (A, TAG2, third-tag, posting-tag):
``` {.journal} ```journal
1/1 a transaction ; A:, TAG2: 1/1 a transaction ; A:, TAG2:
; third-tag: a third transaction tag, this time with a value ; third-tag: a third transaction tag, this time with a value
(a) $1 ; posting-tag: (a) $1 ; posting-tag:
@ -480,7 +475,7 @@ and the posting has four (A, TAG2, third-tag, posting-tag):
Tags are like Ledger's Tags are like Ledger's
[metadata](http://ledger-cli.org/3.0/doc/ledger3.html#Metadata) [metadata](http://ledger-cli.org/3.0/doc/ledger3.html#Metadata)
feature, except hledger's tag values are always simple strings. feature, except hledger's tag values are simple strings.
## Directives ## Directives
@ -503,7 +498,7 @@ This affects all subsequent journal entries in the current file or its
[included files](#including-other-files). [included files](#including-other-files).
The spaces around the = are optional: The spaces around the = are optional:
``` {.journal} ```journal
alias OLD = NEW alias OLD = NEW
``` ```
@ -514,7 +509,7 @@ OLD and NEW are full account names.
hledger will replace any occurrence of the old account name with the hledger will replace any occurrence of the old account name with the
new one. Subaccounts are also affected. Eg: new one. Subaccounts are also affected. Eg:
``` {.journal} ```journal
alias checking = assets:bank:wells fargo:checking alias checking = assets:bank:wells fargo:checking
# rewrites "checking" to "assets:bank:wells fargo:checking", or "checking:a" to "assets:bank:wells fargo:checking:a" # rewrites "checking" to "assets:bank:wells fargo:checking", or "checking:a" to "assets:bank:wells fargo:checking:a"
``` ```
@ -524,7 +519,7 @@ alias checking = assets:bank:wells fargo:checking
There is also a more powerful variant that uses a regular expression, There is also a more powerful variant that uses a regular expression,
indicated by the forward slashes. (This was the default behaviour in hledger 0.24-0.25): indicated by the forward slashes. (This was the default behaviour in hledger 0.24-0.25):
``` {.journal} ```journal
alias /REGEX/ = REPLACEMENT alias /REGEX/ = REPLACEMENT
``` ```
@ -540,7 +535,7 @@ Note, currently regular expression aliases may cause noticeable slow-downs.
(And if you use Ledger on your hledger file, they will be ignored.) (And if you use Ledger on your hledger file, they will be ignored.)
Eg: Eg:
``` {.journal} ```journal
alias /^(.+):bank:([^:]+)(.*)/ = \1:\2 \3 alias /^(.+):bank:([^:]+)(.*)/ = \1:\2 \3
# rewrites "assets:bank:wells fargo:checking" to "assets:wells fargo checking" # rewrites "assets:bank:wells fargo:checking" to "assets:wells fargo checking"
``` ```
@ -559,7 +554,7 @@ Aliases are applied in the following order:
You can clear (forget) all currently defined aliases with the `end aliases` directive: You can clear (forget) all currently defined aliases with the `end aliases` directive:
``` {.journal} ```journal
end aliases end aliases
``` ```
@ -568,7 +563,7 @@ end aliases
The `account` directive predefines account names, as in Ledger and Beancount. The `account` directive predefines account names, as in Ledger and Beancount.
This may be useful for your own documentation; hledger doesn't make use of it yet. This may be useful for your own documentation; hledger doesn't make use of it yet.
``` {.journal} ```journal
; account ACCT ; account ACCT
; OPTIONAL COMMENTS/TAGS... ; OPTIONAL COMMENTS/TAGS...
@ -587,7 +582,7 @@ You can specify a parent account which will be prepended to all accounts
within a section of the journal. Use the `apply account` and `end apply account` within a section of the journal. Use the `apply account` and `end apply account`
directives like so: directives like so:
``` {.journal} ```journal
apply account home apply account home
2010/1/1 2010/1/1
@ -597,7 +592,7 @@ apply account home
end apply account end apply account
``` ```
which is equivalent to: which is equivalent to:
``` {.journal} ```journal
2010/01/01 2010/01/01
home:food $10 home:food $10
home:cash $-10 home:cash $-10
@ -606,7 +601,7 @@ which is equivalent to:
If `end apply account` is omitted, the effect lasts to the end of the file. If `end apply account` is omitted, the effect lasts to the end of the file.
Included files are also affected, eg: Included files are also affected, eg:
``` {.journal} ```journal
apply account business apply account business
include biz.journal include biz.journal
end apply account end apply account
@ -644,7 +639,7 @@ D £1,000.00
c £1000 c £1000
d d
``` ```
```{.shell} ```shell
$ hledger print $ hledger print
2010/01/01 2010/01/01
a £2,340.00 a £2,340.00
@ -660,7 +655,7 @@ $ hledger print
You can set a default year to be used for subsequent dates which don't You can set a default year to be used for subsequent dates which don't
specify a year. This is a line beginning with `Y` followed by the year. Eg: specify a year. This is a line beginning with `Y` followed by the year. Eg:
``` {.journal} ```journal
Y2009 ; set default year to 2009 Y2009 ; set default year to 2009
12/15 ; equivalent to 2009/12/15 12/15 ; equivalent to 2009/12/15
@ -683,7 +678,7 @@ Y2010 ; change default year to 2010
You can pull in the content of additional journal files by writing an You can pull in the content of additional journal files by writing an
include directive, like this: include directive, like this:
``` {.journal} ```journal
include path/to/file.journal include path/to/file.journal
``` ```

11
tests/journal/dates.test
View File

@ -35,17 +35,10 @@ hledger -f- print
b b
>>>2 /bad date/ >>>2 /bad date/
>>>= 1 >>>= 1
# 5. dates should be followed by whitespace or newline # 5. dates must be followed by whitespace or newline
hledger -f- print hledger -f- print
<<< <<<
2015/9/6: 2015/9/6*
a 0
>>>2 /unexpected ":"/
>>>= 1
# 6.
hledger -f- print
<<<
2015/9/6=9/6* x
a 0 a 0
>>>2 /unexpected "*"/ >>>2 /unexpected "*"/
>>>= 1 >>>= 1

54
tests/journal/posting-dates.test Normal file
View File

@ -0,0 +1,54 @@
# 1. posting dates can be set with a tag. Also the year can be
# inferred from the transaction. If there are multiple tags, the first
# is used. Date separators /-. are allowed.
hledger -f- register
<<<
2000/1/2
a 0 ; date: 3/4, date: 4-5, date:6.7
>>> /^2000\/03\/04/
>>>=0
# 2. If the date: or date2: tags do not have a valid simple date
# value, there should be a corresponding error at the right position
hledger -f- register
<<<
comment
Journal comment to prevent this being parsed as a timedot file
end comment
2000/1/1
a 0 ; date: 3.31
2000/1/2
b 0
; date: 3.32
>>>2 /line 10, column 19/
>>>=1
# 3. Ledger's bracketed date syntax is also supported: `[DATE]`,
# `[DATE=DATE2]` or `[=DATE2]`. This is equivalent to using `date:` or
# `date2:` tags.
hledger -f- register --date2
<<<
2000/1/2
a 0 ; [=3-4]
>>> /^2000\/03\/04/
>>>=0
# 4. Date parsing and error reporting activates for square brackets
# containing only `0123456789/-.=` characters.
hledger -f- register
<<<
comment
Journal comment to prevent this being parsed as a timedot file
end comment
2000/1/2
a 0 ; [3/4 ] space, causes this to be ignored
2000/1/2
b 0 ; [1/1=1/2/3/4] bad second date, should error
>>>2 /line 9, column 25/
>>>=1

2
tests/journal/tags.test
View File

@ -16,7 +16,7 @@ hledger -f - print
; txntag2: txn val 2 ; txntag2: txn val 2
a 1 a 1
; posting1tag1: posting 1 val 1 ; posting1tag1: posting 1 val 1
; posting1tag2: ; posting1tag2:
b -1 ; posting-2-tag-1: posting 2 val 1 b -1 ; posting-2-tag-1: posting 2 val 1
; posting-2-tag-2: ; posting-2-tag-2: