This commit is contained in:
Simon Michael 2010-03-13 01:16:59 +00:00
parent fd8ebd7c3d
commit d028e9eb17

View File

@ -161,6 +161,10 @@ import Ledger.Commodity (dollars,dollar,unknown)
import System.FilePath(takeDirectory,combine) import System.FilePath(takeDirectory,combine)
-- | A JournalUpdate is some transformation of a "Journal". It can do I/O
-- or raise an error.
type JournalUpdate = ErrorT String IO (Journal -> Journal)
-- | Some context kept during parsing. -- | Some context kept during parsing.
data LedgerFileCtx = Ctx { data LedgerFileCtx = Ctx {
ctxYear :: !(Maybe Integer) -- ^ the default year most recently specified with Y ctxYear :: !(Maybe Integer) -- ^ the default year most recently specified with Y
@ -218,10 +222,10 @@ parseLedger reftime inname intxt =
-- parsers -- parsers
-- | Top-level journal parser. Returns a mighty composite, I/O performing, -- | Top-level journal parser. Returns a single composite, I/O performing,
-- error-raising journal transformation, which should be applied to a -- error-raising "JournalUpdate" which can be applied to an empty journal
-- journal to get the final result. -- to get the final result.
ledgerFile :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerFile :: GenParser Char LedgerFileCtx JournalUpdate
ledgerFile = do items <- many ledgerItem ledgerFile = do items <- many ledgerItem
eof eof
return $ liftM (foldr (.) id) $ sequence items return $ liftM (foldr (.) id) $ sequence items
@ -264,7 +268,7 @@ ledgercommentline = do
return s return s
<?> "comment" <?> "comment"
ledgerExclamationDirective :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerExclamationDirective :: GenParser Char LedgerFileCtx JournalUpdate
ledgerExclamationDirective = do ledgerExclamationDirective = do
char '!' <?> "directive" char '!' <?> "directive"
directive <- many nonspace directive <- many nonspace
@ -274,7 +278,7 @@ ledgerExclamationDirective = do
"end" -> ledgerAccountEnd "end" -> ledgerAccountEnd
_ -> mzero _ -> mzero
ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerInclude :: GenParser Char LedgerFileCtx JournalUpdate
ledgerInclude = do many1 spacenonewline ledgerInclude = do many1 spacenonewline
filename <- restofline filename <- restofline
outerState <- getState outerState <- getState
@ -289,14 +293,14 @@ ledgerInclude = do many1 spacenonewline
currentPos = show outerPos currentPos = show outerPos
whileReading = " reading " ++ show filename ++ ":\n" whileReading = " reading " ++ show filename ++ ":\n"
ledgerAccountBegin :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerAccountBegin :: GenParser Char LedgerFileCtx JournalUpdate
ledgerAccountBegin = do many1 spacenonewline ledgerAccountBegin = do many1 spacenonewline
parent <- ledgeraccountname parent <- ledgeraccountname
newline newline
pushParentAccount parent pushParentAccount parent
return $ return id return $ return id
ledgerAccountEnd :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerAccountEnd :: GenParser Char LedgerFileCtx JournalUpdate
ledgerAccountEnd = popParentAccount >> return (return id) ledgerAccountEnd = popParentAccount >> return (return id)
ledgerModifierTransaction :: GenParser Char LedgerFileCtx ModifierTransaction ledgerModifierTransaction :: GenParser Char LedgerFileCtx ModifierTransaction
@ -327,7 +331,7 @@ ledgerHistoricalPrice = do
restofline restofline
return $ HistoricalPrice date symbol price return $ HistoricalPrice date symbol price
ledgerIgnoredPriceCommodity :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerIgnoredPriceCommodity :: GenParser Char LedgerFileCtx JournalUpdate
ledgerIgnoredPriceCommodity = do ledgerIgnoredPriceCommodity = do
char 'N' <?> "ignored-price commodity" char 'N' <?> "ignored-price commodity"
many1 spacenonewline many1 spacenonewline
@ -335,7 +339,7 @@ ledgerIgnoredPriceCommodity = do
restofline restofline
return $ return id return $ return id
ledgerDefaultCommodity :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerDefaultCommodity :: GenParser Char LedgerFileCtx JournalUpdate
ledgerDefaultCommodity = do ledgerDefaultCommodity = do
char 'D' <?> "default commodity" char 'D' <?> "default commodity"
many1 spacenonewline many1 spacenonewline
@ -343,7 +347,7 @@ ledgerDefaultCommodity = do
restofline restofline
return $ return id return $ return id
ledgerCommodityConversion :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerCommodityConversion :: GenParser Char LedgerFileCtx JournalUpdate
ledgerCommodityConversion = do ledgerCommodityConversion = do
char 'C' <?> "commodity conversion" char 'C' <?> "commodity conversion"
many1 spacenonewline many1 spacenonewline
@ -355,7 +359,7 @@ ledgerCommodityConversion = do
restofline restofline
return $ return id return $ return id
ledgerTagDirective :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerTagDirective :: GenParser Char LedgerFileCtx JournalUpdate
ledgerTagDirective = do ledgerTagDirective = do
string "tag" <?> "tag directive" string "tag" <?> "tag directive"
many1 spacenonewline many1 spacenonewline
@ -363,14 +367,14 @@ ledgerTagDirective = do
restofline restofline
return $ return id return $ return id
ledgerEndTagDirective :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerEndTagDirective :: GenParser Char LedgerFileCtx JournalUpdate
ledgerEndTagDirective = do ledgerEndTagDirective = do
string "end tag" <?> "end tag directive" string "end tag" <?> "end tag directive"
restofline restofline
return $ return id return $ return id
-- like ledgerAccountBegin, updates the LedgerFileCtx -- like ledgerAccountBegin, updates the LedgerFileCtx
ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerDefaultYear :: GenParser Char LedgerFileCtx JournalUpdate
ledgerDefaultYear = do ledgerDefaultYear = do
char 'Y' <?> "default year" char 'Y' <?> "default year"
many spacenonewline many spacenonewline