2010-02-13 23:00:34 +03:00
|
|
|
|
{-# LANGUAGE CPP #-}
|
2008-10-01 04:29:58 +04:00
|
|
|
|
{-|
|
2008-10-03 06:28:58 +04:00
|
|
|
|
|
2010-05-27 07:58:47 +04:00
|
|
|
|
Parsers for hledger's journal file format and the timelog file format.
|
2008-10-08 22:25:51 +04:00
|
|
|
|
|
2010-03-13 02:46:20 +03:00
|
|
|
|
Here is the ledger grammar from the ledger 2.5 manual:
|
2007-03-12 10:40:33 +03:00
|
|
|
|
|
2008-10-01 05:40:32 +04:00
|
|
|
|
@
|
2008-10-01 04:40:51 +04:00
|
|
|
|
The ledger file format is quite simple, but also very flexible. It supports
|
2007-02-09 04:23:12 +03:00
|
|
|
|
many options, though typically the user can ignore most of them. They are
|
|
|
|
|
summarized below. The initial character of each line determines what the
|
|
|
|
|
line means, and how it should be interpreted. Allowable initial characters
|
|
|
|
|
are:
|
|
|
|
|
|
|
|
|
|
NUMBER A line beginning with a number denotes an entry. It may be followed by any
|
|
|
|
|
number of lines, each beginning with whitespace, to denote the entry’s account
|
2008-10-01 04:40:51 +04:00
|
|
|
|
transactions. The format of the first line is:
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
|
|
|
|
DATE[=EDATE] [*|!] [(CODE)] DESC
|
|
|
|
|
|
|
|
|
|
If ‘*’ appears after the date (with optional effective date), it indicates the entry
|
|
|
|
|
is “cleared”, which can mean whatever the user wants it t omean. If ‘!’ appears
|
|
|
|
|
after the date, it indicates d the entry is “pending”; i.e., tentatively cleared from
|
|
|
|
|
the user’s point of view, but not yet actually cleared. If a ‘CODE’ appears in
|
|
|
|
|
parentheses, it may be used to indicate a check number, or the type of the
|
|
|
|
|
transaction. Following these is the payee, or a description of the transaction.
|
|
|
|
|
The format of each following transaction is:
|
|
|
|
|
|
|
|
|
|
ACCOUNT AMOUNT [; NOTE]
|
|
|
|
|
|
|
|
|
|
The ‘ACCOUNT’ may be surrounded by parentheses if it is a virtual
|
|
|
|
|
transactions, or square brackets if it is a virtual transactions that must
|
|
|
|
|
balance. The ‘AMOUNT’ can be followed by a per-unit transaction cost,
|
2008-10-01 04:29:58 +04:00
|
|
|
|
by specifying ‘ AMOUNT’, or a complete transaction cost with ‘\@ AMOUNT’.
|
2007-02-09 04:23:12 +03:00
|
|
|
|
Lastly, the ‘NOTE’ may specify an actual and/or effective date for the
|
|
|
|
|
transaction by using the syntax ‘[ACTUAL_DATE]’ or ‘[=EFFECTIVE_DATE]’ or
|
|
|
|
|
‘[ACTUAL_DATE=EFFECtIVE_DATE]’.
|
|
|
|
|
|
|
|
|
|
= An automated entry. A value expression must appear after the equal sign.
|
|
|
|
|
After this initial line there should be a set of one or more transactions, just as
|
|
|
|
|
if it were normal entry. If the amounts of the transactions have no commodity,
|
2008-10-01 04:40:51 +04:00
|
|
|
|
they will be applied as modifiers to whichever real transaction is matched by
|
2007-02-09 04:23:12 +03:00
|
|
|
|
the value expression.
|
|
|
|
|
|
|
|
|
|
~ A period entry. A period expression must appear after the tilde.
|
|
|
|
|
After this initial line there should be a set of one or more transactions, just as
|
|
|
|
|
if it were normal entry.
|
|
|
|
|
|
|
|
|
|
! A line beginning with an exclamation mark denotes a command directive. It
|
|
|
|
|
must be immediately followed by the command word. The supported commands
|
|
|
|
|
are:
|
|
|
|
|
|
|
|
|
|
‘!include’
|
2008-10-01 04:40:51 +04:00
|
|
|
|
Include the stated ledger file.
|
2007-02-09 04:23:12 +03:00
|
|
|
|
‘!account’
|
|
|
|
|
The account name is given is taken to be the parent of all transac-
|
|
|
|
|
tions that follow, until ‘!end’ is seen.
|
|
|
|
|
‘!end’ Ends an account block.
|
|
|
|
|
|
|
|
|
|
; A line beginning with a colon indicates a comment, and is ignored.
|
|
|
|
|
|
|
|
|
|
Y If a line begins with a capital Y, it denotes the year used for all subsequent
|
|
|
|
|
entries that give a date without a year. The year should appear immediately
|
2008-10-01 04:40:51 +04:00
|
|
|
|
after the Y, for example: ‘Y2004’. This is useful at the beginning of a file, to
|
|
|
|
|
specify the year for that file. If all entries specify a year, however, this command
|
2007-02-09 04:23:12 +03:00
|
|
|
|
has no effect.
|
|
|
|
|
|
|
|
|
|
|
2008-10-01 04:40:51 +04:00
|
|
|
|
P Specifies a historical price for a commodity. These are usually found in a pricing
|
|
|
|
|
history file (see the ‘-Q’ option). The syntax is:
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
|
|
|
|
P DATE SYMBOL PRICE
|
|
|
|
|
|
|
|
|
|
N SYMBOL Indicates that pricing information is to be ignored for a given symbol, nor will
|
|
|
|
|
quotes ever be downloaded for that symbol. Useful with a home currency, such
|
|
|
|
|
as the dollar ($). It is recommended that these pricing options be set in the price
|
2008-10-01 04:40:51 +04:00
|
|
|
|
database file, which defaults to ‘~/.pricedb’. The syntax for this command is:
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
|
|
|
|
N SYMBOL
|
|
|
|
|
|
|
|
|
|
|
2008-10-01 04:40:51 +04:00
|
|
|
|
D AMOUNT Specifies the default commodity to use, by specifying an amount in the expected
|
2007-02-09 04:23:12 +03:00
|
|
|
|
format. The entry command will use this commodity as the default when none
|
|
|
|
|
other can be determined. This command may be used multiple times, to set
|
2008-10-01 04:40:51 +04:00
|
|
|
|
the default flags for different commodities; whichever is seen last is used as the
|
2007-02-09 04:23:12 +03:00
|
|
|
|
default commodity. For example, to set US dollars as the default commodity,
|
2008-10-01 04:40:51 +04:00
|
|
|
|
while also setting the thousands flag and decimal flag for that commodity, use:
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
|
|
|
|
D $1,000.00
|
|
|
|
|
|
|
|
|
|
C AMOUNT1 = AMOUNT2
|
2008-10-01 04:40:51 +04:00
|
|
|
|
Specifies a commodity conversion, where the first amount is given to be equiv-
|
|
|
|
|
alent to the second amount. The first amount should use the decimal precision
|
2007-02-09 04:23:12 +03:00
|
|
|
|
desired during reporting:
|
|
|
|
|
|
|
|
|
|
C 1.00 Kb = 1024 bytes
|
|
|
|
|
|
|
|
|
|
i, o, b, h
|
|
|
|
|
These four relate to timeclock support, which permits ledger to read timelog
|
2008-10-01 04:40:51 +04:00
|
|
|
|
files. See the timeclock’s documentation for more info on the syntax of its
|
|
|
|
|
timelog files.
|
2008-10-01 05:40:32 +04:00
|
|
|
|
@
|
2008-10-01 04:29:58 +04:00
|
|
|
|
|
2010-03-13 02:46:20 +03:00
|
|
|
|
Here is the timelog grammar from timeclock.el 2.6:
|
|
|
|
|
|
|
|
|
|
@
|
|
|
|
|
A timelog contains data in the form of a single entry per line.
|
|
|
|
|
Each entry has the form:
|
|
|
|
|
|
|
|
|
|
CODE YYYY/MM/DD HH:MM:SS [COMMENT]
|
|
|
|
|
|
|
|
|
|
CODE is one of: b, h, i, o or O. COMMENT is optional when the code is
|
|
|
|
|
i, o or O. The meanings of the codes are:
|
|
|
|
|
|
|
|
|
|
b Set the current time balance, or \"time debt\". Useful when
|
|
|
|
|
archiving old log data, when a debt must be carried forward.
|
|
|
|
|
The COMMENT here is the number of seconds of debt.
|
|
|
|
|
|
|
|
|
|
h Set the required working time for the given day. This must
|
|
|
|
|
be the first entry for that day. The COMMENT in this case is
|
|
|
|
|
the number of hours in this workday. Floating point amounts
|
|
|
|
|
are allowed.
|
|
|
|
|
|
|
|
|
|
i Clock in. The COMMENT in this case should be the name of the
|
|
|
|
|
project worked on.
|
|
|
|
|
|
|
|
|
|
o Clock out. COMMENT is unnecessary, but can be used to provide
|
|
|
|
|
a description of how the period went, for example.
|
|
|
|
|
|
|
|
|
|
O Final clock out. Whatever project was being worked on, it is
|
|
|
|
|
now finished. Useful for creating summary reports.
|
|
|
|
|
@
|
|
|
|
|
|
|
|
|
|
Example:
|
|
|
|
|
|
2010-03-13 03:17:47 +03:00
|
|
|
|
@
|
2010-03-13 02:46:20 +03:00
|
|
|
|
i 2007/03/10 12:26:00 hledger
|
|
|
|
|
o 2007/03/10 17:26:02
|
2010-03-13 03:17:47 +03:00
|
|
|
|
@
|
2010-03-13 02:46:20 +03:00
|
|
|
|
|
2007-02-09 04:23:12 +03:00
|
|
|
|
-}
|
2007-07-04 16:05:54 +04:00
|
|
|
|
|
2010-05-20 03:08:53 +04:00
|
|
|
|
module Hledger.Data.Parse
|
2010-03-13 02:46:20 +03:00
|
|
|
|
where
|
|
|
|
|
import Control.Monad.Error (ErrorT(..), MonadIO, liftIO, throwError, catchError)
|
|
|
|
|
import Text.ParserCombinators.Parsec
|
|
|
|
|
import System.Directory
|
|
|
|
|
#if __GLASGOW_HASKELL__ <= 610
|
|
|
|
|
import Prelude hiding (readFile, putStr, putStrLn, print, getContents)
|
|
|
|
|
import System.IO.UTF8
|
|
|
|
|
#endif
|
2010-05-20 03:08:53 +04:00
|
|
|
|
import Hledger.Data.Utils
|
|
|
|
|
import Hledger.Data.Types
|
|
|
|
|
import Hledger.Data.Dates
|
|
|
|
|
import Hledger.Data.AccountName (accountNameFromComponents,accountNameComponents)
|
|
|
|
|
import Hledger.Data.Amount
|
|
|
|
|
import Hledger.Data.Transaction
|
|
|
|
|
import Hledger.Data.Posting
|
|
|
|
|
import Hledger.Data.Journal
|
2010-05-27 05:31:50 +04:00
|
|
|
|
import Hledger.Data.Commodity (dollars,dollar,unknown,nonsimplecommoditychars)
|
2010-03-13 02:46:20 +03:00
|
|
|
|
import System.FilePath(takeDirectory,combine)
|
2010-05-23 03:35:34 +04:00
|
|
|
|
import System.Time (getClockTime)
|
2010-03-13 02:46:20 +03:00
|
|
|
|
|
|
|
|
|
|
2010-03-13 04:16:59 +03:00
|
|
|
|
-- | A JournalUpdate is some transformation of a "Journal". It can do I/O
|
|
|
|
|
-- or raise an error.
|
|
|
|
|
type JournalUpdate = ErrorT String IO (Journal -> Journal)
|
|
|
|
|
|
2010-03-13 02:46:20 +03:00
|
|
|
|
-- | Some context kept during parsing.
|
|
|
|
|
data LedgerFileCtx = Ctx {
|
|
|
|
|
ctxYear :: !(Maybe Integer) -- ^ the default year most recently specified with Y
|
|
|
|
|
, ctxCommod :: !(Maybe String) -- ^ I don't know
|
|
|
|
|
, ctxAccount :: ![String] -- ^ the current stack of parent accounts specified by !account
|
|
|
|
|
} deriving (Read, Show)
|
|
|
|
|
|
|
|
|
|
emptyCtx :: LedgerFileCtx
|
|
|
|
|
emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] }
|
|
|
|
|
|
|
|
|
|
setYear :: Integer -> GenParser tok LedgerFileCtx ()
|
|
|
|
|
setYear y = updateState (\ctx -> ctx{ctxYear=Just y})
|
|
|
|
|
|
|
|
|
|
getYear :: GenParser tok LedgerFileCtx (Maybe Integer)
|
|
|
|
|
getYear = liftM ctxYear getState
|
|
|
|
|
|
|
|
|
|
pushParentAccount :: String -> GenParser tok LedgerFileCtx ()
|
|
|
|
|
pushParentAccount parent = updateState addParentAccount
|
|
|
|
|
where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 }
|
|
|
|
|
normalize = (++ ":")
|
|
|
|
|
|
|
|
|
|
popParentAccount :: GenParser tok LedgerFileCtx ()
|
|
|
|
|
popParentAccount = do ctx0 <- getState
|
|
|
|
|
case ctxAccount ctx0 of
|
|
|
|
|
[] -> unexpected "End of account block with no beginning"
|
|
|
|
|
(_:rest) -> setState $ ctx0 { ctxAccount = rest }
|
|
|
|
|
|
|
|
|
|
getParentAccount :: GenParser tok LedgerFileCtx String
|
|
|
|
|
getParentAccount = liftM (concat . reverse . ctxAccount) getState
|
|
|
|
|
|
|
|
|
|
expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath
|
|
|
|
|
expandPath pos fp = liftM mkRelative (expandHome fp)
|
|
|
|
|
where
|
|
|
|
|
mkRelative = combine (takeDirectory (sourceName pos))
|
|
|
|
|
expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory
|
|
|
|
|
return $ homedir ++ drop 1 inname
|
|
|
|
|
| otherwise = return inname
|
|
|
|
|
|
|
|
|
|
-- let's get to it
|
|
|
|
|
|
2010-05-23 03:35:34 +04:00
|
|
|
|
-- | Parse and post-process a journal file or timelog file to a "Journal",
|
|
|
|
|
-- or give an error.
|
|
|
|
|
parseJournalFile :: FilePath -> ErrorT String IO Journal
|
|
|
|
|
parseJournalFile "-" = liftIO getContents >>= parseJournal "-"
|
|
|
|
|
parseJournalFile f = liftIO (readFile f) >>= parseJournal f
|
|
|
|
|
|
|
|
|
|
-- | Parse and post-process a "Journal" from a string, saving the provided
|
|
|
|
|
-- file path and the current time, or give an error.
|
|
|
|
|
parseJournal :: FilePath -> String -> ErrorT String IO Journal
|
|
|
|
|
parseJournal f s = do
|
|
|
|
|
tc <- liftIO getClockTime
|
|
|
|
|
tl <- liftIO getCurrentLocalTime
|
|
|
|
|
case runParser ledgerFile emptyCtx f s of
|
|
|
|
|
Right m -> liftM (journalFinalise tc tl f s) $ m `ap` return nulljournal
|
2010-03-13 02:46:20 +03:00
|
|
|
|
Left err -> throwError $ show err -- XXX raises an uncaught exception if we have a parsec user error, eg from many ?
|
|
|
|
|
|
2010-03-13 04:16:59 +03:00
|
|
|
|
-- | Top-level journal parser. Returns a single composite, I/O performing,
|
|
|
|
|
-- error-raising "JournalUpdate" which can be applied to an empty journal
|
|
|
|
|
-- to get the final result.
|
|
|
|
|
ledgerFile :: GenParser Char LedgerFileCtx JournalUpdate
|
2010-03-13 02:46:20 +03:00
|
|
|
|
ledgerFile = do items <- many ledgerItem
|
|
|
|
|
eof
|
|
|
|
|
return $ liftM (foldr (.) id) $ sequence items
|
|
|
|
|
where
|
|
|
|
|
-- As all ledger line types can be distinguished by the first
|
|
|
|
|
-- character, excepting transactions versus empty (blank or
|
|
|
|
|
-- comment-only) lines, can use choice w/o try
|
|
|
|
|
ledgerItem = choice [ ledgerExclamationDirective
|
|
|
|
|
, liftM (return . addTransaction) ledgerTransaction
|
|
|
|
|
, liftM (return . addModifierTransaction) ledgerModifierTransaction
|
|
|
|
|
, liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction
|
|
|
|
|
, liftM (return . addHistoricalPrice) ledgerHistoricalPrice
|
|
|
|
|
, ledgerDefaultYear
|
|
|
|
|
, ledgerIgnoredPriceCommodity
|
|
|
|
|
, ledgerTagDirective
|
|
|
|
|
, ledgerEndTagDirective
|
|
|
|
|
, emptyLine >> return (return id)
|
|
|
|
|
, liftM (return . addTimeLogEntry) timelogentry
|
2010-04-15 20:14:50 +04:00
|
|
|
|
] <?> "ledger transaction, timelog entry, or directive"
|
2010-03-13 02:46:20 +03:00
|
|
|
|
|
2008-12-08 06:45:35 +03:00
|
|
|
|
emptyLine :: GenParser Char st ()
|
|
|
|
|
emptyLine = do many spacenonewline
|
2009-04-10 08:38:46 +04:00
|
|
|
|
optional $ (char ';' <?> "comment") >> many (noneOf "\n")
|
2008-12-08 06:45:35 +03:00
|
|
|
|
newline
|
|
|
|
|
return ()
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
2008-12-08 04:49:31 +03:00
|
|
|
|
ledgercomment :: GenParser Char st String
|
2009-06-20 08:01:25 +04:00
|
|
|
|
ledgercomment = do
|
|
|
|
|
many1 $ char ';'
|
|
|
|
|
many spacenonewline
|
|
|
|
|
many (noneOf "\n")
|
|
|
|
|
<?> "comment"
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
2009-06-20 08:02:10 +04:00
|
|
|
|
ledgercommentline :: GenParser Char st String
|
|
|
|
|
ledgercommentline = do
|
|
|
|
|
many spacenonewline
|
|
|
|
|
s <- ledgercomment
|
|
|
|
|
optional newline
|
|
|
|
|
eof
|
|
|
|
|
return s
|
|
|
|
|
<?> "comment"
|
|
|
|
|
|
2010-03-13 04:16:59 +03:00
|
|
|
|
ledgerExclamationDirective :: GenParser Char LedgerFileCtx JournalUpdate
|
2010-03-13 02:46:20 +03:00
|
|
|
|
ledgerExclamationDirective = do
|
|
|
|
|
char '!' <?> "directive"
|
|
|
|
|
directive <- many nonspace
|
|
|
|
|
case directive of
|
|
|
|
|
"include" -> ledgerInclude
|
|
|
|
|
"account" -> ledgerAccountBegin
|
|
|
|
|
"end" -> ledgerAccountEnd
|
|
|
|
|
_ -> mzero
|
|
|
|
|
|
2010-03-13 04:16:59 +03:00
|
|
|
|
ledgerInclude :: GenParser Char LedgerFileCtx JournalUpdate
|
2010-03-13 02:46:20 +03:00
|
|
|
|
ledgerInclude = do many1 spacenonewline
|
|
|
|
|
filename <- restofline
|
|
|
|
|
outerState <- getState
|
|
|
|
|
outerPos <- getPosition
|
|
|
|
|
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
|
|
|
|
|
return $ do contents <- expandPath outerPos filename >>= readFileE outerPos
|
|
|
|
|
case runParser ledgerFile outerState filename contents of
|
|
|
|
|
Right l -> l `catchError` (throwError . (inIncluded ++))
|
|
|
|
|
Left perr -> throwError $ inIncluded ++ show perr
|
|
|
|
|
where readFileE outerPos filename = ErrorT $ liftM Right (readFile filename) `catch` leftError
|
|
|
|
|
where leftError err = return $ Left $ currentPos ++ whileReading ++ show err
|
|
|
|
|
currentPos = show outerPos
|
|
|
|
|
whileReading = " reading " ++ show filename ++ ":\n"
|
|
|
|
|
|
2010-03-13 04:16:59 +03:00
|
|
|
|
ledgerAccountBegin :: GenParser Char LedgerFileCtx JournalUpdate
|
2010-03-13 02:46:20 +03:00
|
|
|
|
ledgerAccountBegin = do many1 spacenonewline
|
|
|
|
|
parent <- ledgeraccountname
|
|
|
|
|
newline
|
|
|
|
|
pushParentAccount parent
|
|
|
|
|
return $ return id
|
|
|
|
|
|
2010-03-13 04:16:59 +03:00
|
|
|
|
ledgerAccountEnd :: GenParser Char LedgerFileCtx JournalUpdate
|
2010-03-13 02:46:20 +03:00
|
|
|
|
ledgerAccountEnd = popParentAccount >> return (return id)
|
|
|
|
|
|
2009-04-03 14:58:05 +04:00
|
|
|
|
ledgerModifierTransaction :: GenParser Char LedgerFileCtx ModifierTransaction
|
|
|
|
|
ledgerModifierTransaction = do
|
|
|
|
|
char '=' <?> "modifier transaction"
|
2007-02-09 04:23:12 +03:00
|
|
|
|
many spacenonewline
|
|
|
|
|
valueexpr <- restofline
|
2009-04-03 14:58:05 +04:00
|
|
|
|
postings <- ledgerpostings
|
|
|
|
|
return $ ModifierTransaction valueexpr postings
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
2009-04-03 14:58:05 +04:00
|
|
|
|
ledgerPeriodicTransaction :: GenParser Char LedgerFileCtx PeriodicTransaction
|
|
|
|
|
ledgerPeriodicTransaction = do
|
2009-04-10 08:38:46 +04:00
|
|
|
|
char '~' <?> "periodic transaction"
|
2007-02-09 04:23:12 +03:00
|
|
|
|
many spacenonewline
|
|
|
|
|
periodexpr <- restofline
|
2009-04-03 14:58:05 +04:00
|
|
|
|
postings <- ledgerpostings
|
|
|
|
|
return $ PeriodicTransaction periodexpr postings
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
2008-12-16 13:54:20 +03:00
|
|
|
|
ledgerHistoricalPrice :: GenParser Char LedgerFileCtx HistoricalPrice
|
|
|
|
|
ledgerHistoricalPrice = do
|
2009-04-10 08:38:46 +04:00
|
|
|
|
char 'P' <?> "historical price"
|
2008-12-16 13:54:20 +03:00
|
|
|
|
many spacenonewline
|
2009-11-19 05:02:12 +03:00
|
|
|
|
date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate -- a time is ignored
|
2009-11-26 00:21:49 +03:00
|
|
|
|
many1 spacenonewline
|
2009-12-09 23:51:00 +03:00
|
|
|
|
symbol <- commoditysymbol
|
2008-12-16 13:54:20 +03:00
|
|
|
|
many spacenonewline
|
2009-12-09 23:51:00 +03:00
|
|
|
|
price <- someamount
|
2008-12-16 13:54:20 +03:00
|
|
|
|
restofline
|
2009-12-09 23:51:00 +03:00
|
|
|
|
return $ HistoricalPrice date symbol price
|
2008-12-16 13:54:20 +03:00
|
|
|
|
|
2010-03-13 04:16:59 +03:00
|
|
|
|
ledgerIgnoredPriceCommodity :: GenParser Char LedgerFileCtx JournalUpdate
|
2010-03-13 02:46:20 +03:00
|
|
|
|
ledgerIgnoredPriceCommodity = do
|
2010-03-13 01:52:57 +03:00
|
|
|
|
char 'N' <?> "ignored-price commodity"
|
|
|
|
|
many1 spacenonewline
|
|
|
|
|
commoditysymbol
|
|
|
|
|
restofline
|
|
|
|
|
return $ return id
|
|
|
|
|
|
2010-03-13 04:16:59 +03:00
|
|
|
|
ledgerDefaultCommodity :: GenParser Char LedgerFileCtx JournalUpdate
|
2010-03-13 04:10:10 +03:00
|
|
|
|
ledgerDefaultCommodity = do
|
|
|
|
|
char 'D' <?> "default commodity"
|
|
|
|
|
many1 spacenonewline
|
|
|
|
|
someamount
|
|
|
|
|
restofline
|
|
|
|
|
return $ return id
|
|
|
|
|
|
2010-03-13 04:16:59 +03:00
|
|
|
|
ledgerCommodityConversion :: GenParser Char LedgerFileCtx JournalUpdate
|
2010-03-13 04:10:10 +03:00
|
|
|
|
ledgerCommodityConversion = do
|
|
|
|
|
char 'C' <?> "commodity conversion"
|
|
|
|
|
many1 spacenonewline
|
|
|
|
|
someamount
|
|
|
|
|
many spacenonewline
|
|
|
|
|
char '='
|
|
|
|
|
many spacenonewline
|
|
|
|
|
someamount
|
|
|
|
|
restofline
|
|
|
|
|
return $ return id
|
|
|
|
|
|
2010-03-13 04:16:59 +03:00
|
|
|
|
ledgerTagDirective :: GenParser Char LedgerFileCtx JournalUpdate
|
2010-03-13 01:52:57 +03:00
|
|
|
|
ledgerTagDirective = do
|
|
|
|
|
string "tag" <?> "tag directive"
|
|
|
|
|
many1 spacenonewline
|
|
|
|
|
_ <- many1 nonspace
|
|
|
|
|
restofline
|
|
|
|
|
return $ return id
|
|
|
|
|
|
2010-03-13 04:16:59 +03:00
|
|
|
|
ledgerEndTagDirective :: GenParser Char LedgerFileCtx JournalUpdate
|
2010-03-13 01:52:57 +03:00
|
|
|
|
ledgerEndTagDirective = do
|
|
|
|
|
string "end tag" <?> "end tag directive"
|
|
|
|
|
restofline
|
|
|
|
|
return $ return id
|
|
|
|
|
|
2009-01-23 02:42:34 +03:00
|
|
|
|
-- like ledgerAccountBegin, updates the LedgerFileCtx
|
2010-03-13 04:16:59 +03:00
|
|
|
|
ledgerDefaultYear :: GenParser Char LedgerFileCtx JournalUpdate
|
2009-01-23 02:42:34 +03:00
|
|
|
|
ledgerDefaultYear = do
|
|
|
|
|
char 'Y' <?> "default year"
|
|
|
|
|
many spacenonewline
|
|
|
|
|
y <- many1 digit
|
|
|
|
|
let y' = read y
|
2010-04-15 01:49:34 +04:00
|
|
|
|
failIfInvalidYear y
|
2009-01-23 02:42:34 +03:00
|
|
|
|
setYear y'
|
|
|
|
|
return $ return id
|
|
|
|
|
|
2010-03-13 02:46:20 +03:00
|
|
|
|
-- | Try to parse a ledger entry. If we successfully parse an entry,
|
|
|
|
|
-- check it can be balanced, and fail if not.
|
2009-12-16 11:07:26 +03:00
|
|
|
|
ledgerTransaction :: GenParser Char LedgerFileCtx Transaction
|
2009-04-03 14:58:05 +04:00
|
|
|
|
ledgerTransaction = do
|
2009-04-10 08:38:46 +04:00
|
|
|
|
date <- ledgerdate <?> "transaction"
|
2010-04-16 00:44:04 +04:00
|
|
|
|
edate <- optionMaybe (ledgereffectivedate date) <?> "effective date"
|
|
|
|
|
status <- ledgerstatus <?> "cleared flag"
|
|
|
|
|
code <- ledgercode <?> "transaction code"
|
|
|
|
|
(description, comment) <-
|
|
|
|
|
(do {many1 spacenonewline; d <- liftM rstrip (many (noneOf ";\n")); c <- ledgercomment <|> return ""; newline; return (d, c)} <|>
|
|
|
|
|
do {many spacenonewline; c <- ledgercomment <|> return ""; newline; return ("", c)}
|
|
|
|
|
) <?> "description and/or comment"
|
2009-04-03 14:58:05 +04:00
|
|
|
|
postings <- ledgerpostings
|
2009-12-19 06:44:52 +03:00
|
|
|
|
let t = txnTieKnot $ Transaction date edate status code description comment postings ""
|
2009-12-16 11:07:26 +03:00
|
|
|
|
case balanceTransaction t of
|
2009-04-03 14:58:05 +04:00
|
|
|
|
Right t' -> return t'
|
2009-06-05 23:35:12 +04:00
|
|
|
|
Left err -> fail err
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
2009-01-28 00:55:26 +03:00
|
|
|
|
ledgerdate :: GenParser Char LedgerFileCtx Day
|
2010-04-15 01:49:34 +04:00
|
|
|
|
ledgerdate = choice' [ledgerfulldate, ledgerpartialdate] <?> "full or partial date"
|
2009-01-28 00:55:26 +03:00
|
|
|
|
|
|
|
|
|
ledgerfulldate :: GenParser Char LedgerFileCtx Day
|
|
|
|
|
ledgerfulldate = do
|
|
|
|
|
(y,m,d) <- ymd
|
|
|
|
|
return $ fromGregorian (read y) (read m) (read d)
|
|
|
|
|
|
2010-03-13 02:46:20 +03:00
|
|
|
|
-- | Match a partial M/D date in a ledger, and also require that a default
|
|
|
|
|
-- year directive was previously encountered.
|
2009-01-28 00:55:26 +03:00
|
|
|
|
ledgerpartialdate :: GenParser Char LedgerFileCtx Day
|
|
|
|
|
ledgerpartialdate = do
|
|
|
|
|
(_,m,d) <- md
|
|
|
|
|
y <- getYear
|
2010-04-15 01:49:34 +04:00
|
|
|
|
when (isNothing y) $ fail "partial date found, but no default year specified"
|
2009-01-28 00:55:26 +03:00
|
|
|
|
return $ fromGregorian (fromJust y) (read m) (read d)
|
2008-11-11 15:34:05 +03:00
|
|
|
|
|
2009-01-25 10:06:59 +03:00
|
|
|
|
ledgerdatetime :: GenParser Char LedgerFileCtx LocalTime
|
2008-11-11 15:34:05 +03:00
|
|
|
|
ledgerdatetime = do
|
2008-11-27 07:01:07 +03:00
|
|
|
|
day <- ledgerdate
|
2009-12-08 02:29:19 +03:00
|
|
|
|
many1 spacenonewline
|
2008-11-11 15:34:05 +03:00
|
|
|
|
h <- many1 digit
|
|
|
|
|
char ':'
|
|
|
|
|
m <- many1 digit
|
2008-11-12 10:17:31 +03:00
|
|
|
|
s <- optionMaybe $ do
|
|
|
|
|
char ':'
|
|
|
|
|
many1 digit
|
2009-01-25 00:46:09 +03:00
|
|
|
|
let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)
|
2009-01-25 10:06:59 +03:00
|
|
|
|
return $ LocalTime day tod
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
2010-04-16 00:44:04 +04:00
|
|
|
|
ledgereffectivedate :: Day -> GenParser Char LedgerFileCtx Day
|
2010-02-04 00:19:01 +03:00
|
|
|
|
ledgereffectivedate actualdate = do
|
2009-12-12 06:03:41 +03:00
|
|
|
|
char '='
|
2010-03-13 02:46:20 +03:00
|
|
|
|
-- kludgy way to use actual date for default year
|
2010-02-04 00:19:01 +03:00
|
|
|
|
let withDefaultYear d p = do
|
|
|
|
|
y <- getYear
|
|
|
|
|
let (y',_,_) = toGregorian d in setYear y'
|
|
|
|
|
r <- p
|
|
|
|
|
when (isJust y) $ setYear $ fromJust y
|
|
|
|
|
return r
|
|
|
|
|
edate <- withDefaultYear actualdate ledgerdate
|
2010-04-16 00:44:04 +04:00
|
|
|
|
return edate
|
2009-11-26 00:21:49 +03:00
|
|
|
|
|
2008-12-08 04:49:31 +03:00
|
|
|
|
ledgerstatus :: GenParser Char st Bool
|
2009-11-26 00:21:49 +03:00
|
|
|
|
ledgerstatus = try (do { many1 spacenonewline; char '*' <?> "status"; return True } ) <|> return False
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
2008-12-08 04:49:31 +03:00
|
|
|
|
ledgercode :: GenParser Char st String
|
2009-11-26 00:21:49 +03:00
|
|
|
|
ledgercode = try (do { many1 spacenonewline; char '(' <?> "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
2009-04-03 14:58:05 +04:00
|
|
|
|
ledgerpostings :: GenParser Char LedgerFileCtx [Posting]
|
2009-06-20 08:02:10 +04:00
|
|
|
|
ledgerpostings = do
|
2010-03-13 02:46:20 +03:00
|
|
|
|
-- complicated to handle intermixed comment lines.. please make me better.
|
2009-06-20 08:02:10 +04:00
|
|
|
|
ctx <- getState
|
2009-09-22 19:56:59 +04:00
|
|
|
|
let parses p = isRight . parseWithCtx ctx p
|
2009-06-21 18:42:59 +04:00
|
|
|
|
ls <- many1 $ try linebeginningwithspaces
|
2009-06-20 08:02:10 +04:00
|
|
|
|
let ls' = filter (not . (ledgercommentline `parses`)) ls
|
2010-04-15 01:49:34 +04:00
|
|
|
|
when (null ls') $ fail "no postings"
|
2009-06-20 08:02:10 +04:00
|
|
|
|
return $ map (fromparse . parseWithCtx ctx ledgerposting) ls'
|
2009-06-20 08:09:59 +04:00
|
|
|
|
<?> "postings"
|
2009-06-20 08:02:10 +04:00
|
|
|
|
|
|
|
|
|
linebeginningwithspaces :: GenParser Char st String
|
|
|
|
|
linebeginningwithspaces = do
|
|
|
|
|
sp <- many1 spacenonewline
|
|
|
|
|
c <- nonspace
|
|
|
|
|
cs <- restofline
|
|
|
|
|
return $ sp ++ (c:cs) ++ "\n"
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
2009-04-03 14:58:05 +04:00
|
|
|
|
ledgerposting :: GenParser Char LedgerFileCtx Posting
|
2009-05-25 21:28:41 +04:00
|
|
|
|
ledgerposting = do
|
|
|
|
|
many1 spacenonewline
|
2009-01-23 03:14:12 +03:00
|
|
|
|
status <- ledgerstatus
|
2008-12-08 10:21:33 +03:00
|
|
|
|
account <- transactionaccountname
|
2009-05-25 21:28:41 +04:00
|
|
|
|
let (ptype, account') = (postingTypeFromAccountName account, unbracket account)
|
2009-04-08 01:18:51 +04:00
|
|
|
|
amount <- postingamount
|
2008-10-16 10:00:46 +04:00
|
|
|
|
many spacenonewline
|
2009-06-20 08:01:25 +04:00
|
|
|
|
comment <- ledgercomment <|> return ""
|
2010-04-06 00:37:19 +04:00
|
|
|
|
newline
|
2009-12-19 06:44:52 +03:00
|
|
|
|
return (Posting status account' amount comment ptype Nothing)
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
2010-03-13 02:46:20 +03:00
|
|
|
|
-- qualify with the parent account from parsing context
|
2008-12-08 10:21:33 +03:00
|
|
|
|
transactionaccountname :: GenParser Char LedgerFileCtx AccountName
|
|
|
|
|
transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname
|
|
|
|
|
|
2010-03-13 02:46:20 +03:00
|
|
|
|
-- | Parse an account name. Account names may have single spaces inside
|
|
|
|
|
-- them, and are terminated by two or more spaces. They should have one or
|
|
|
|
|
-- more components of at least one character, separated by the account
|
|
|
|
|
-- separator char.
|
|
|
|
|
ledgeraccountname :: GenParser Char st AccountName
|
2008-10-08 22:25:51 +04:00
|
|
|
|
ledgeraccountname = do
|
2009-06-05 22:02:22 +04:00
|
|
|
|
a <- many1 (nonspace <|> singlespace)
|
|
|
|
|
let a' = striptrailingspace a
|
|
|
|
|
when (accountNameFromComponents (accountNameComponents a') /= a')
|
|
|
|
|
(fail $ "accountname seems ill-formed: "++a')
|
|
|
|
|
return a'
|
2008-10-03 13:47:50 +04:00
|
|
|
|
where
|
|
|
|
|
singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})
|
|
|
|
|
-- couldn't avoid consuming a final space sometimes, harmless
|
2008-10-08 23:36:22 +04:00
|
|
|
|
striptrailingspace s = if last s == ' ' then init s else s
|
2007-02-09 04:23:12 +03:00
|
|
|
|
|
2009-05-25 21:28:41 +04:00
|
|
|
|
-- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace
|
|
|
|
|
-- <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"
|
2008-10-16 10:00:46 +04:00
|
|
|
|
|
2010-03-13 02:46:20 +03:00
|
|
|
|
-- | Parse an amount, with an optional left or right currency symbol and
|
|
|
|
|
-- optional price.
|
2009-04-08 01:18:51 +04:00
|
|
|
|
postingamount :: GenParser Char st MixedAmount
|
|
|
|
|
postingamount =
|
2008-10-13 01:52:48 +04:00
|
|
|
|
try (do
|
|
|
|
|
many1 spacenonewline
|
2009-09-22 16:17:25 +04:00
|
|
|
|
someamount <|> return missingamt
|
2008-10-19 00:29:42 +04:00
|
|
|
|
) <|> return missingamt
|
2008-10-13 01:52:48 +04:00
|
|
|
|
|
2009-04-08 01:38:38 +04:00
|
|
|
|
someamount :: GenParser Char st MixedAmount
|
2008-11-22 19:26:01 +03:00
|
|
|
|
someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount
|
|
|
|
|
|
2008-12-08 04:49:31 +03:00
|
|
|
|
leftsymbolamount :: GenParser Char st MixedAmount
|
2008-10-13 01:52:48 +04:00
|
|
|
|
leftsymbolamount = do
|
2010-05-27 03:44:08 +04:00
|
|
|
|
sign <- optionMaybe $ string "-"
|
|
|
|
|
let applysign = if isJust sign then negate else id
|
2008-10-13 01:52:48 +04:00
|
|
|
|
sym <- commoditysymbol
|
|
|
|
|
sp <- many spacenonewline
|
2008-10-15 03:14:31 +04:00
|
|
|
|
(q,p,comma) <- amountquantity
|
2008-11-22 19:26:01 +03:00
|
|
|
|
pri <- priceamount
|
2008-10-18 14:46:49 +04:00
|
|
|
|
let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,comma=comma,precision=p}
|
2010-05-27 03:44:08 +04:00
|
|
|
|
return $ applysign $ Mixed [Amount c q pri]
|
2008-10-13 01:52:48 +04:00
|
|
|
|
<?> "left-symbol amount"
|
|
|
|
|
|
2008-12-08 04:49:31 +03:00
|
|
|
|
rightsymbolamount :: GenParser Char st MixedAmount
|
2008-10-13 01:52:48 +04:00
|
|
|
|
rightsymbolamount = do
|
2008-10-15 03:14:31 +04:00
|
|
|
|
(q,p,comma) <- amountquantity
|
2008-10-13 01:52:48 +04:00
|
|
|
|
sp <- many spacenonewline
|
|
|
|
|
sym <- commoditysymbol
|
2008-11-22 19:26:01 +03:00
|
|
|
|
pri <- priceamount
|
2008-10-18 14:46:49 +04:00
|
|
|
|
let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,comma=comma,precision=p}
|
2008-11-22 19:26:01 +03:00
|
|
|
|
return $ Mixed [Amount c q pri]
|
2008-10-13 01:52:48 +04:00
|
|
|
|
<?> "right-symbol amount"
|
|
|
|
|
|
2008-12-08 04:49:31 +03:00
|
|
|
|
nosymbolamount :: GenParser Char st MixedAmount
|
2008-10-13 01:52:48 +04:00
|
|
|
|
nosymbolamount = do
|
2008-10-15 03:14:31 +04:00
|
|
|
|
(q,p,comma) <- amountquantity
|
2008-11-22 19:26:01 +03:00
|
|
|
|
pri <- priceamount
|
2008-10-18 14:46:49 +04:00
|
|
|
|
let c = Commodity {symbol="",side=L,spaced=False,comma=comma,precision=p}
|
2008-11-22 19:26:01 +03:00
|
|
|
|
return $ Mixed [Amount c q pri]
|
2008-10-13 01:52:48 +04:00
|
|
|
|
<?> "no-symbol amount"
|
|
|
|
|
|
2008-12-08 04:49:31 +03:00
|
|
|
|
commoditysymbol :: GenParser Char st String
|
2010-05-27 05:31:50 +04:00
|
|
|
|
commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) <?> "commodity symbol"
|
2010-04-06 00:55:57 +04:00
|
|
|
|
|
|
|
|
|
quotedcommoditysymbol :: GenParser Char st String
|
|
|
|
|
quotedcommoditysymbol = do
|
|
|
|
|
char '"'
|
2010-05-27 05:31:50 +04:00
|
|
|
|
s <- many1 $ noneOf ";\n\""
|
2010-04-06 00:55:57 +04:00
|
|
|
|
char '"'
|
|
|
|
|
return s
|
2008-10-15 03:14:31 +04:00
|
|
|
|
|
2010-05-27 05:31:50 +04:00
|
|
|
|
simplecommoditysymbol :: GenParser Char st String
|
|
|
|
|
simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars)
|
|
|
|
|
|
2008-12-08 04:49:31 +03:00
|
|
|
|
priceamount :: GenParser Char st (Maybe MixedAmount)
|
2008-11-22 19:26:01 +03:00
|
|
|
|
priceamount =
|
|
|
|
|
try (do
|
|
|
|
|
many spacenonewline
|
|
|
|
|
char '@'
|
|
|
|
|
many spacenonewline
|
2010-05-23 02:05:12 +04:00
|
|
|
|
a <- someamount -- XXX could parse more prices ad infinitum, shouldn't
|
2008-11-22 19:26:01 +03:00
|
|
|
|
return $ Just a
|
|
|
|
|
) <|> return Nothing
|
|
|
|
|
|
2008-10-15 03:14:31 +04:00
|
|
|
|
-- gawd.. trying to parse a ledger number without error:
|
|
|
|
|
|
2010-03-13 02:46:20 +03:00
|
|
|
|
-- | Parse a ledger-style numeric quantity and also return the number of
|
2008-10-15 04:33:15 +04:00
|
|
|
|
-- digits to the right of the decimal point and whether thousands are
|
|
|
|
|
-- separated by comma.
|
2008-12-08 04:49:31 +03:00
|
|
|
|
amountquantity :: GenParser Char st (Double, Int, Bool)
|
2008-10-15 03:14:31 +04:00
|
|
|
|
amountquantity = do
|
|
|
|
|
sign <- optionMaybe $ string "-"
|
|
|
|
|
(intwithcommas,frac) <- numberparts
|
|
|
|
|
let comma = ',' `elem` intwithcommas
|
|
|
|
|
let precision = length frac
|
|
|
|
|
-- read the actual value. We expect this read to never fail.
|
|
|
|
|
let int = filter (/= ',') intwithcommas
|
|
|
|
|
let int' = if null int then "0" else int
|
|
|
|
|
let frac' = if null frac then "0" else frac
|
|
|
|
|
let sign' = fromMaybe "" sign
|
|
|
|
|
let quantity = read $ sign'++int'++"."++frac'
|
|
|
|
|
return (quantity, precision, comma)
|
2008-10-13 01:52:48 +04:00
|
|
|
|
<?> "commodity quantity"
|
2008-10-15 03:14:31 +04:00
|
|
|
|
|
2008-10-15 10:00:10 +04:00
|
|
|
|
-- | parse the two strings of digits before and after a possible decimal
|
|
|
|
|
-- point. The integer part may contain commas, or either part may be
|
|
|
|
|
-- empty, or there may be no point.
|
2008-12-08 04:49:31 +03:00
|
|
|
|
numberparts :: GenParser Char st (String,String)
|
2008-10-15 03:14:31 +04:00
|
|
|
|
numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint
|
|
|
|
|
|
2008-12-08 04:49:31 +03:00
|
|
|
|
numberpartsstartingwithdigit :: GenParser Char st (String,String)
|
2008-10-15 03:14:31 +04:00
|
|
|
|
numberpartsstartingwithdigit = do
|
|
|
|
|
let digitorcomma = digit <|> char ','
|
|
|
|
|
first <- digit
|
|
|
|
|
rest <- many digitorcomma
|
2009-09-22 14:50:02 +04:00
|
|
|
|
frac <- try (do {char '.'; many digit}) <|> return ""
|
2008-10-15 03:14:31 +04:00
|
|
|
|
return (first:rest,frac)
|
|
|
|
|
|
2008-12-08 04:49:31 +03:00
|
|
|
|
numberpartsstartingwithpoint :: GenParser Char st (String,String)
|
2008-10-15 03:14:31 +04:00
|
|
|
|
numberpartsstartingwithpoint = do
|
|
|
|
|
char '.'
|
|
|
|
|
frac <- many1 digit
|
|
|
|
|
return ("",frac)
|
|
|
|
|
|
|
|
|
|
|
2010-03-13 02:46:20 +03:00
|
|
|
|
-- | Parse a timelog entry.
|
2008-12-10 20:40:36 +03:00
|
|
|
|
timelogentry :: GenParser Char LedgerFileCtx TimeLogEntry
|
2007-03-12 03:13:53 +03:00
|
|
|
|
timelogentry = do
|
|
|
|
|
code <- oneOf "bhioO"
|
|
|
|
|
many1 spacenonewline
|
2008-11-11 15:34:05 +03:00
|
|
|
|
datetime <- ledgerdatetime
|
2009-12-08 02:29:19 +03:00
|
|
|
|
comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline)
|
|
|
|
|
return $ TimeLogEntry (read [code]) datetime (fromMaybe "" comment)
|
2007-03-12 03:13:53 +03:00
|
|
|
|
|
2008-11-22 15:18:19 +03:00
|
|
|
|
|
2010-03-13 02:46:20 +03:00
|
|
|
|
-- | Parse a hledger display expression, which is a simple date test like
|
|
|
|
|
-- "d>[DATE]" or "d<=[DATE]", and return a "Posting"-matching predicate.
|
2009-12-19 08:57:54 +03:00
|
|
|
|
datedisplayexpr :: GenParser Char st (Posting -> Bool)
|
2008-11-25 00:51:31 +03:00
|
|
|
|
datedisplayexpr = do
|
|
|
|
|
char 'd'
|
2008-11-27 00:18:24 +03:00
|
|
|
|
op <- compareop
|
2008-11-25 21:47:26 +03:00
|
|
|
|
char '['
|
2008-11-25 00:51:31 +03:00
|
|
|
|
(y,m,d) <- smartdate
|
2008-11-25 21:47:26 +03:00
|
|
|
|
char ']'
|
2009-06-05 13:44:20 +04:00
|
|
|
|
let date = parsedate $ printf "%04s/%02s/%02s" y m d
|
2009-12-19 08:57:54 +03:00
|
|
|
|
test op = return $ (`op` date) . postingDate
|
2009-06-05 13:44:20 +04:00
|
|
|
|
case op of
|
|
|
|
|
"<" -> test (<)
|
|
|
|
|
"<=" -> test (<=)
|
|
|
|
|
"=" -> test (==)
|
|
|
|
|
"==" -> test (==)
|
|
|
|
|
">=" -> test (>=)
|
|
|
|
|
">" -> test (>)
|
|
|
|
|
_ -> mzero
|
2008-11-27 00:18:24 +03:00
|
|
|
|
|
|
|
|
|
compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"]
|
2008-11-27 03:35:00 +03:00
|
|
|
|
|
2010-03-11 20:16:03 +03:00
|
|
|
|
|
|
|
|
|
tests_Parse = TestList [
|
|
|
|
|
|
2010-03-13 04:10:10 +03:00
|
|
|
|
"ledgerTransaction" ~: do
|
2010-03-11 20:16:03 +03:00
|
|
|
|
assertParseEqual (parseWithCtx emptyCtx ledgerTransaction entry1_str) entry1
|
|
|
|
|
assertBool "ledgerTransaction should not parse just a date"
|
|
|
|
|
$ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1\n"
|
|
|
|
|
assertBool "ledgerTransaction should require some postings"
|
|
|
|
|
$ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a\n"
|
|
|
|
|
let t = parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a ;comment\n b 1\n"
|
|
|
|
|
assertBool "ledgerTransaction should not include a comment in the description"
|
|
|
|
|
$ either (const False) ((== "a") . tdescription) t
|
|
|
|
|
|
2010-03-13 04:10:10 +03:00
|
|
|
|
,"ledgerModifierTransaction" ~: do
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgerModifierTransaction "= (some value expr)\n some:postings 1\n")
|
|
|
|
|
|
|
|
|
|
,"ledgerPeriodicTransaction" ~: do
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgerPeriodicTransaction "~ (some period expr)\n some:postings 1\n")
|
|
|
|
|
|
|
|
|
|
,"ledgerExclamationDirective" ~: do
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgerExclamationDirective "!include /some/file.x\n")
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgerExclamationDirective "!account some:account\n")
|
|
|
|
|
assertParse (parseWithCtx emptyCtx (ledgerExclamationDirective >> ledgerExclamationDirective) "!account a\n!end\n")
|
|
|
|
|
|
|
|
|
|
,"ledgercommentline" ~: do
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgercommentline "; some comment \n")
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgercommentline " \t; x\n")
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgercommentline ";x")
|
|
|
|
|
|
|
|
|
|
,"ledgerDefaultYear" ~: do
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgerDefaultYear "Y 2010\n")
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgerDefaultYear "Y 10001\n")
|
|
|
|
|
|
|
|
|
|
,"ledgerHistoricalPrice" ~:
|
|
|
|
|
assertParseEqual (parseWithCtx emptyCtx ledgerHistoricalPrice "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55])
|
|
|
|
|
|
|
|
|
|
,"ledgerIgnoredPriceCommodity" ~: do
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgerIgnoredPriceCommodity "N $\n")
|
|
|
|
|
|
|
|
|
|
,"ledgerDefaultCommodity" ~: do
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgerDefaultCommodity "D $1,000.0\n")
|
|
|
|
|
|
|
|
|
|
,"ledgerCommodityConversion" ~: do
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgerCommodityConversion "C 1h = $50.00\n")
|
|
|
|
|
|
|
|
|
|
,"ledgerTagDirective" ~: do
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgerTagDirective "tag foo \n")
|
|
|
|
|
|
|
|
|
|
,"ledgerEndTagDirective" ~: do
|
|
|
|
|
assertParse (parseWithCtx emptyCtx ledgerEndTagDirective "end tag \n")
|
|
|
|
|
|
2010-03-11 20:16:03 +03:00
|
|
|
|
,"ledgeraccountname" ~: do
|
|
|
|
|
assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c")
|
|
|
|
|
assertBool "ledgeraccountname rejects an empty inner component" (isLeft $ parsewith ledgeraccountname "a::c")
|
|
|
|
|
assertBool "ledgeraccountname rejects an empty leading component" (isLeft $ parsewith ledgeraccountname ":b:c")
|
|
|
|
|
assertBool "ledgeraccountname rejects an empty trailing component" (isLeft $ parsewith ledgeraccountname "a:b:")
|
|
|
|
|
|
2010-04-06 00:55:57 +04:00
|
|
|
|
,"ledgerposting" ~: do
|
2010-03-11 20:16:03 +03:00
|
|
|
|
assertParseEqual (parseWithCtx emptyCtx ledgerposting " expenses:food:dining $10.00\n")
|
|
|
|
|
(Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting Nothing)
|
2010-04-06 00:55:57 +04:00
|
|
|
|
assertBool "ledgerposting parses a quoted commodity with numbers"
|
|
|
|
|
(isRight $ parseWithCtx emptyCtx ledgerposting " a 1 \"DE123\"\n")
|
2010-03-11 20:16:03 +03:00
|
|
|
|
|
|
|
|
|
,"someamount" ~: do
|
|
|
|
|
let -- | compare a parse result with a MixedAmount, showing the debug representation for clarity
|
|
|
|
|
assertMixedAmountParse parseresult mixedamount =
|
|
|
|
|
(either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount)
|
|
|
|
|
assertMixedAmountParse (parsewith someamount "1 @ $2")
|
|
|
|
|
(Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])])
|
|
|
|
|
|
|
|
|
|
,"postingamount" ~: do
|
|
|
|
|
assertParseEqual (parseWithCtx emptyCtx postingamount " $47.18") (Mixed [dollars 47.18])
|
|
|
|
|
assertParseEqual (parseWithCtx emptyCtx postingamount " $1.")
|
|
|
|
|
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing])
|
|
|
|
|
|
2010-05-27 03:44:08 +04:00
|
|
|
|
,"leftsymbolamount" ~: do
|
|
|
|
|
assertParseEqual (parseWithCtx emptyCtx leftsymbolamount "$1")
|
|
|
|
|
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing])
|
|
|
|
|
assertParseEqual (parseWithCtx emptyCtx leftsymbolamount "$-1")
|
|
|
|
|
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} (-1) Nothing])
|
|
|
|
|
assertParseEqual (parseWithCtx emptyCtx leftsymbolamount "-$1")
|
|
|
|
|
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} (-1) Nothing])
|
|
|
|
|
|
2010-03-11 20:16:03 +03:00
|
|
|
|
]
|
|
|
|
|
|
|
|
|
|
entry1_str = unlines
|
|
|
|
|
["2007/01/28 coopportunity"
|
|
|
|
|
," expenses:food:groceries $47.18"
|
|
|
|
|
," assets:checking $-47.18"
|
|
|
|
|
,""
|
|
|
|
|
]
|
|
|
|
|
|
|
|
|
|
entry1 =
|
|
|
|
|
txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""
|
|
|
|
|
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing,
|
|
|
|
|
Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting Nothing] ""
|
|
|
|
|
|
|
|
|
|
|