From 0f5ee154c496e4e650c5f14bc7a6737e0f7d8eb6 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Mon, 23 May 2016 00:32:55 -0700 Subject: [PATCH] lib: simplify parsers; cleanups (#275) The journal/timeclock/timedot parsers, instead of constructing (opaque) journal update functions which are later applied to build the journal, now construct the journal directly (by modifying the parser state). This is easier to understand and debug. It also removes any possibility of the journal updates being a space leak. (They weren't, in fact memory usage is now slightly higher, but that will be addressed in other ways.) Also: Journal data and journal parse info have been merged into one type (for now), and field names are more consistent. The ParsedJournal type alias has been added to distinguish being-parsed and finalised journals. Journal is now a monoid. stats: fixed an issue with ordering of include files journal: fixed an issue with ordering of included same-date transactions timeclock: sessions can no longer span file boundaries (unclocked-out sessions will be auto-closed at the end of the file). expandPath now throws a proper IO error (and requires the IO monad). --- hledger-api/hledger-api.hs | 2 +- hledger-lib/Hledger/Data/Journal.hs | 160 ++++++----- hledger-lib/Hledger/Data/Ledger.hs | 2 +- hledger-lib/Hledger/Data/Types.hs | 74 +++--- hledger-lib/Hledger/Read.hs | 17 +- hledger-lib/Hledger/Read/Common.hs | 172 ++++-------- hledger-lib/Hledger/Read/CsvReader.hs | 4 +- hledger-lib/Hledger/Read/JournalReader.hs | 280 +++++++++++--------- hledger-lib/Hledger/Read/TimeclockReader.hs | 27 +- hledger-lib/Hledger/Read/TimedotReader.hs | 28 +- hledger-lib/Hledger/Utils.hs | 10 +- hledger-web/Foundation.hs | 2 +- hledger-web/Handler/AddForm.hs | 2 +- hledger/Hledger/Cli.hs | 2 +- hledger/Hledger/Cli/Add.hs | 12 +- hledger/Hledger/Cli/Utils.hs | 4 +- tests/journal/include.test | 6 +- tests/stats/stats.test | 2 +- 18 files changed, 374 insertions(+), 432 deletions(-) diff --git a/hledger-api/hledger-api.hs b/hledger-api/hledger-api.hs index 32bfb08c0..28e6c1b3c 100644 --- a/hledger-api/hledger-api.hs +++ b/hledger-api/hledger-api.hs @@ -141,7 +141,7 @@ hledgerApiApp staticdir j = Servant.serve api server accountnamesH = return $ journalAccountNames j transactionsH = return $ jtxns j pricesH = return $ jmarketprices j - commoditiesH = return $ (M.keys . jcommoditystyles) j + commoditiesH = return $ (M.keys . jinferredcommodities) j accountsH = return $ ledgerTopAccounts $ ledgerFromJournal Hledger.Query.Any j accounttransactionsH (a::AccountName) = do -- d <- liftIO getCurrentDay diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index 7720bcaa1..f6234d2d7 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/hledger-lib/Hledger/Data/Journal.hs @@ -1,4 +1,4 @@ --- {-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} {-| A 'Journal' is a set of transactions, plus optional related data. This is @@ -12,7 +12,6 @@ module Hledger.Data.Journal ( addMarketPrice, addModifierTransaction, addPeriodicTransaction, - addTimeclockEntry, addTransaction, journalApplyAliases, journalBalanceTransactions, @@ -52,7 +51,6 @@ module Hledger.Data.Journal ( -- * Misc canonicalStyleFrom, matchpats, - nulljps, nulljournal, -- * Tests samplejournal, @@ -67,7 +65,6 @@ import Data.Monoid import Data.Ord import Safe (headMay, headDef) import Data.Time.Calendar -import Data.Time.LocalTime import Data.Tree import System.Time (ClockTime(TOD)) import Test.HUnit @@ -82,10 +79,14 @@ import Hledger.Data.Amount import Hledger.Data.Dates import Hledger.Data.Transaction import Hledger.Data.Posting -import Hledger.Data.Timeclock import Hledger.Query +-- try to make Journal ppShow-compatible +-- instance Show ClockTime where +-- show t = "" +-- deriving instance Show Journal + instance Show Journal where show j | debugLevel < 3 = printf "Journal %s with %d transactions, %d accounts" @@ -108,7 +109,7 @@ instance Show Journal where length (jperiodictxns j)) (length accounts) (show accounts) - (show $ jcommoditystyles j) + (show $ jinferredcommodities j) -- ++ (show $ journalTransactions l) where accounts = filter (/= "root") $ flatten $ journalAccountNameTree j @@ -117,74 +118,73 @@ instance Show Journal where -- ,show (jtxns j) -- ,show (jmodifiertxns j) -- ,show (jperiodictxns j) --- ,show $ open_timeclock_entries j +-- ,show $ jparsetimeclockentries j -- ,show $ jmarketprices j --- ,show $ final_comment_lines j +-- ,show $ jfinalcommentlines j -- ,show $ jparsestate j --- ,show $ map fst $ files j +-- ,show $ map fst $ jfiles j -- ] --- The monoid instance for Journal concatenates the list fields, --- combines the map fields, keeps the final comment lines of the --- second journal, and keeps the latest of their last read times. --- See JournalParseState for how the final parse states are combined. +-- The monoid instance for Journal is useful for two situations. +-- +-- 1. concatenating finalised journals, eg with multiple -f options: +-- FIRST <> SECOND. The second's list fields are appended to the +-- first's, map fields are combined, transaction counts are summed, +-- the parse state of the second is kept. +-- +-- 2. merging a child parsed journal, eg with the include directive: +-- CHILD <> PARENT. A parsed journal's data is in reverse order, so +-- this gives what we want. +-- instance Monoid Journal where mempty = nulljournal - mappend j1 j2 = - Journal{jmodifiertxns = jmodifiertxns j1 <> jmodifiertxns j2 - ,jperiodictxns = jperiodictxns j1 <> jperiodictxns j2 - ,jtxns = jtxns j1 <> jtxns j2 - ,jcommoditystyles = jcommoditystyles j1 <> jcommoditystyles j2 - ,jcommodities = jcommodities j1 <> jcommodities j2 - ,open_timeclock_entries = open_timeclock_entries j1 <> open_timeclock_entries j2 - ,jmarketprices = jmarketprices j1 <> jmarketprices j2 - ,final_comment_lines = final_comment_lines j1 <> final_comment_lines j2 - ,jparsestate = jparsestate j1 <> jparsestate j2 - ,files = files j1 <> files j2 - ,filereadtime = max (filereadtime j1) (filereadtime j2) - } + mappend j1 j2 = Journal { + jparsedefaultyear = jparsedefaultyear j2 + ,jparsedefaultcommodity = jparsedefaultcommodity j2 + ,jparseparentaccounts = jparseparentaccounts j2 + ,jparsealiases = jparsealiases j2 + ,jparsetransactioncount = jparsetransactioncount j1 + jparsetransactioncount j2 + ,jparsetimeclockentries = jparsetimeclockentries j1 <> jparsetimeclockentries j2 + ,jaccounts = jaccounts j1 <> jaccounts j2 + ,jcommodities = jcommodities j1 <> jcommodities j2 + ,jinferredcommodities = jinferredcommodities j1 <> jinferredcommodities j2 + ,jmarketprices = jmarketprices j1 <> jmarketprices j2 + ,jmodifiertxns = jmodifiertxns j1 <> jmodifiertxns j2 + ,jperiodictxns = jperiodictxns j1 <> jperiodictxns j2 + ,jtxns = jtxns j1 <> jtxns j2 + ,jfinalcommentlines = jfinalcommentlines j2 + ,jfiles = jfiles j1 <> jfiles j2 + ,jlastreadtime = max (jlastreadtime j1) (jlastreadtime j2) + } nulljournal :: Journal -nulljournal = Journal { jmodifiertxns = [] - , jperiodictxns = [] - , jtxns = [] - , jcommodities = M.fromList [] - , open_timeclock_entries = [] - , jmarketprices = [] - , final_comment_lines = [] - , jparsestate = nulljps - , files = [] - , filereadtime = TOD 0 0 - , jcommoditystyles = M.fromList [] - } - --- The monoid instance for JournalParseState mostly discards the --- second parse state, except the accounts defined by account --- directives are concatenated, and the transaction indices (counts of --- transactions parsed, if any) are added. -instance Monoid JournalParseState where - mempty = nulljps - mappend c1 c2 = - JournalParseState { - jpsYear = jpsYear c1 - , jpsDefaultCommodityAndStyle = jpsDefaultCommodityAndStyle c1 - , jpsAccounts = jpsAccounts c1 ++ jpsAccounts c2 - , jpsParentAccount = jpsParentAccount c1 - , jpsAliases = jpsAliases c1 - , jpsTransactionIndex = jpsTransactionIndex c1 + jpsTransactionIndex c2 - } - -nulljps :: JournalParseState -nulljps = JournalParseState{jpsYear=Nothing, jpsDefaultCommodityAndStyle=Nothing, jpsAccounts=[], jpsParentAccount=[], jpsAliases=[], jpsTransactionIndex=0} +nulljournal = Journal { + jparsedefaultyear = Nothing + ,jparsedefaultcommodity = Nothing + ,jparseparentaccounts = [] + ,jparsealiases = [] + ,jparsetransactioncount = 0 + ,jparsetimeclockentries = [] + ,jaccounts = [] + ,jcommodities = M.fromList [] + ,jinferredcommodities = M.fromList [] + ,jmarketprices = [] + ,jmodifiertxns = [] + ,jperiodictxns = [] + ,jtxns = [] + ,jfinalcommentlines = [] + ,jfiles = [] + ,jlastreadtime = TOD 0 0 + } journalFilePath :: Journal -> FilePath journalFilePath = fst . mainfile journalFilePaths :: Journal -> [FilePath] -journalFilePaths = map fst . files +journalFilePaths = map fst . jfiles mainfile :: Journal -> (FilePath, String) -mainfile = headDef ("", "") . files +mainfile = headDef ("", "") . jfiles addTransaction :: Transaction -> Journal -> Journal addTransaction t j = j { jtxns = t : jtxns j } @@ -198,9 +198,6 @@ addPeriodicTransaction pt j = j { jperiodictxns = pt : jperiodictxns j } addMarketPrice :: MarketPrice -> Journal -> Journal addMarketPrice h j = j { jmarketprices = h : jmarketprices j } -addTimeclockEntry :: TimeclockEntry -> Journal -> Journal -addTimeclockEntry tle j = j { open_timeclock_entries = tle : open_timeclock_entries j } - -- | Get the transaction with this index (its 1-based position in the input stream), if any. journalTransactionAt :: Journal -> Integer -> Maybe Transaction journalTransactionAt Journal{jtxns=ts} i = @@ -452,22 +449,20 @@ journalApplyAliases aliases j@Journal{jtxns=ts} = dotransaction t@Transaction{tpostings=ps} = t{tpostings=map doposting ps} doposting p@Posting{paccount=a} = p{paccount= accountNameApplyAliases aliases a} --- | Do post-parse processing on a journal to make it ready for use: check --- all transactions balance, canonicalise amount formats, close any open --- timeclock entries, maybe check balance assertions and so on. -journalFinalise :: ClockTime -> LocalTime -> FilePath -> String -> JournalParseState -> Bool -> Journal -> Either String Journal -journalFinalise tclock tlocal path txt jps assrt j@Journal{files=fs} = do +-- | Do post-parse processing on a parsed journal to make it ready for +-- use. Reverse parsed data to normal order, canonicalise amount +-- formats, check/ensure that transactions are balanced, and maybe +-- check balance assertions. +journalFinalise :: ClockTime -> FilePath -> String -> Bool -> ParsedJournal -> Either String Journal +journalFinalise t path txt assrt j@Journal{jfiles=fs} = do (journalBalanceTransactions $ journalApplyCommodityStyles $ - journalCloseTimeclockEntries tlocal $ - j{ files=(path,txt):fs - , filereadtime=tclock - , jparsestate=jps - , jtxns=reverse $ jtxns j -- NOTE: see addTransaction - , jmodifiertxns=reverse $ jmodifiertxns j -- NOTE: see addModifierTransaction - , jperiodictxns=reverse $ jperiodictxns j -- NOTE: see addPeriodicTransaction - , jmarketprices=reverse $ jmarketprices j -- NOTE: see addMarketPrice - , open_timeclock_entries=reverse $ open_timeclock_entries j -- NOTE: see addTimeclockEntry + j{ jfiles = (path,txt) : reverse fs + , jlastreadtime = t + , jtxns = reverse $ jtxns j -- NOTE: see addTransaction + , jmodifiertxns = reverse $ jmodifiertxns j -- NOTE: see addModifierTransaction + , jperiodictxns = reverse $ jperiodictxns j -- NOTE: see addPeriodicTransaction + , jmarketprices = reverse $ jmarketprices j -- NOTE: see addMarketPrice }) >>= if assrt then journalCheckBalanceAssertions else return @@ -553,7 +548,7 @@ splitAssertions ps -- amounts and working out the canonical commodities, since balancing -- depends on display precision. Reports only the first error encountered. journalBalanceTransactions :: Journal -> Either String Journal -journalBalanceTransactions j@Journal{jtxns=ts, jcommoditystyles=ss} = +journalBalanceTransactions j@Journal{jtxns=ts, jinferredcommodities=ss} = case sequence $ map balance ts of Right ts' -> Right j{jtxns=map txnTieKnot ts'} Left e -> Left e where balance = balanceTransaction (Just ss) @@ -583,7 +578,7 @@ journalCommodityStyle j c = headDef amountstyle{asprecision=2} $ catMaybes [ M.lookup c (jcommodities j) >>= cformat - ,M.lookup c $ jcommoditystyles j + ,M.lookup c $ jinferredcommodities j ] -- | Infer a display format for each commodity based on the amounts parsed. @@ -591,7 +586,7 @@ journalCommodityStyle j c = -- commodity, and the highest precision of all posting amounts in the commodity." journalInferCommodityStyles :: Journal -> Journal journalInferCommodityStyles j = - j{jcommoditystyles = + j{jinferredcommodities = commodityStylesFromAmounts $ dbg8 "journalChooseCommmodityStyles using amounts" $ journalAmounts j} @@ -642,11 +637,6 @@ canonicalStyleFrom ss@(first:_) = -- case ps of (MarketPrice{mpamount=a}:_) -> Just a -- _ -> Nothing --- | Close any open timeclock sessions in this journal using the provided current time. -journalCloseTimeclockEntries :: LocalTime -> Journal -> Journal -journalCloseTimeclockEntries now j@Journal{jtxns=ts, open_timeclock_entries=es} = - j{jtxns = ts ++ (timeclockEntriesToTransactions now es), open_timeclock_entries = []} - -- | Convert all this journal's amounts to cost by applying their prices, if any. journalConvertAmountsToCost :: Journal -> Journal journalConvertAmountsToCost j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} @@ -655,7 +645,7 @@ journalConvertAmountsToCost j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps} fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a} fixmixedamount (Mixed as) = Mixed $ map fixamount as - fixamount = canonicaliseAmount (jcommoditystyles j) . costOfAmount + fixamount = canonicaliseAmount (jinferredcommodities j) . costOfAmount -- -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol. -- journalCanonicalCommodities :: Journal -> M.Map String CommoditySymbol diff --git a/hledger-lib/Hledger/Data/Ledger.hs b/hledger-lib/Hledger/Data/Ledger.hs index 124f3b334..6eb106b3e 100644 --- a/hledger-lib/Hledger/Data/Ledger.hs +++ b/hledger-lib/Hledger/Data/Ledger.hs @@ -85,7 +85,7 @@ ledgerDateSpan = postingsDateSpan . ledgerPostings -- | All commodities used in this ledger. ledgerCommodities :: Ledger -> [CommoditySymbol] -ledgerCommodities = M.keys . jcommoditystyles . ljournal +ledgerCommodities = M.keys . jinferredcommodities . ljournal tests_ledgerFromJournal = [ diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index 4e7a95aeb..e3f329f29 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -222,52 +222,48 @@ instance NFData MarketPrice type Year = Integer --- | Journal parse state is data we want to keep track of in the --- course of parsing a journal. An example is the default year, which --- changes when a Y directive is encountered. At the end of parsing, --- the final state is saved for later use by eg the add command. -data JournalParseState = JournalParseState { - jpsYear :: !(Maybe Year) -- ^ the default year most recently specified with Y - , jpsDefaultCommodityAndStyle :: !(Maybe (CommoditySymbol,AmountStyle)) -- ^ the default commodity and amount style most recently specified with D - , jpsAccounts :: ![AccountName] -- ^ the accounts that have been defined with account directives so far - , jpsParentAccount :: ![AccountName] -- ^ the current stack of parent accounts/account name components - -- specified with "apply account" directive(s). Concatenated, these - -- are the account prefix prepended to parsed account names. - , jpsAliases :: ![AccountAlias] -- ^ the current list of account name aliases in effect - , jpsTransactionIndex :: !Integer -- ^ the number of transactions read so far. (Does not count - -- timeclock/timedot/CSV entries, currently). - } deriving (Read, Show, Eq, Data, Typeable, Generic) - -instance NFData JournalParseState +-- | A Journal, containing transactions and various other things. +-- The basic data model for hledger. +-- +-- This is used during parsing (as the type alias ParsedJournal), and +-- then finalised/validated for use as a Journal. Some extra +-- parsing-related fields are included for convenience, at least for +-- now. In a ParsedJournal these are updated as parsing proceeds, in a +-- Journal they represent the final state at end of parsing (used eg +-- by the add command). +-- +data Journal = Journal { + -- parsing-related data + jparsedefaultyear :: (Maybe Year) -- ^ the current default year, specified by the most recent Y directive (or current date) + ,jparsedefaultcommodity :: (Maybe (CommoditySymbol,AmountStyle)) -- ^ the current default commodity and its format, specified by the most recent D directive + ,jparseparentaccounts :: [AccountName] -- ^ the current stack of parent account names, specified by apply account directives + ,jparsealiases :: [AccountAlias] -- ^ the current account name aliases in effect, specified by alias directives (& options ?) + ,jparsetransactioncount :: Integer -- ^ the current count of transactions parsed so far (only journal format txns, currently) + ,jparsetimeclockentries :: [TimeclockEntry] -- ^ timeclock sessions which have not been clocked out + -- principal data + ,jaccounts :: [AccountName] -- ^ accounts that have been declared by account directives + ,jcommodities :: M.Map CommoditySymbol Commodity -- ^ commodities and formats declared by commodity directives + ,jinferredcommodities :: M.Map CommoditySymbol AmountStyle -- ^ commodities and formats inferred from journal amounts + ,jmarketprices :: [MarketPrice] + ,jmodifiertxns :: [ModifierTransaction] + ,jperiodictxns :: [PeriodicTransaction] + ,jtxns :: [Transaction] + ,jfinalcommentlines :: String -- ^ any final trailing comments in the (main) journal file + ,jfiles :: [(FilePath, String)] -- ^ the file path and raw text of the main and + -- any included journal files. The main file is first, + -- followed by any included files in the order encountered. + ,jlastreadtime :: ClockTime -- ^ when this journal was last read from its file(s) + } deriving (Eq, Typeable, Data, Generic) deriving instance Data (ClockTime) deriving instance Typeable (ClockTime) deriving instance Generic (ClockTime) - instance NFData ClockTime - -data Journal = Journal { - jmodifiertxns :: [ModifierTransaction], - jperiodictxns :: [PeriodicTransaction], - jtxns :: [Transaction], - jcommoditystyles :: M.Map CommoditySymbol AmountStyle, -- ^ commodities and formats inferred from journal amounts - jcommodities :: M.Map CommoditySymbol Commodity, -- ^ commodities and formats defined by commodity directives - open_timeclock_entries :: [TimeclockEntry], - jmarketprices :: [MarketPrice], - final_comment_lines :: String, -- ^ any trailing comments from the journal file - jparsestate :: JournalParseState, -- ^ the final parse state - files :: [(FilePath, String)], -- ^ the file path and raw text of the main and - -- any included journal files. The main file is - -- first followed by any included files in the - -- order encountered. - filereadtime :: ClockTime -- ^ when this journal was last read from its file(s) - } deriving (Eq, Typeable, Data, Generic) - instance NFData Journal --- | A JournalUpdate is some transformation of a Journal. It can do I/O or --- raise an exception. -type JournalUpdate = ExceptT String IO (Journal -> Journal) +-- | A journal in the process of being parsed, not yet finalised. +-- The data is partial, and list fields are in reverse order. +type ParsedJournal = Journal -- | The id of a data format understood by hledger, eg @journal@ or @csv@. -- The --output-format option selects one of these for output. diff --git a/hledger-lib/Hledger/Read.hs b/hledger-lib/Hledger/Read.hs index 409c3f0d3..e2d4e7031 100644 --- a/hledger-lib/Hledger/Read.hs +++ b/hledger-lib/Hledger/Read.hs @@ -10,6 +10,7 @@ to import modules below this one. module Hledger.Read ( + module Hledger.Read.Common, readFormatNames, -- * Journal reading API defaultJournalPath, @@ -22,12 +23,12 @@ module Hledger.Read ensureJournalFileExists, -- * Parsers used elsewhere postingp, - accountnamep, - amountp, - amountp', - mamountp', - numberp, - codep, + -- accountnamep, + -- amountp, + -- amountp', + -- mamountp', + -- numberp, + -- codep, accountaliasp, -- * Tests samplejournal, @@ -47,8 +48,8 @@ import Test.HUnit import Text.Printf import Hledger.Data.Dates (getCurrentDay) -import Hledger.Data.Journal (nulljps) import Hledger.Data.Types +import Hledger.Read.Common import Hledger.Read.JournalReader as JournalReader import Hledger.Read.TimedotReader as TimedotReader import Hledger.Read.TimeclockReader as TimeclockReader @@ -259,7 +260,7 @@ tests_Hledger_Read = TestList $ tests_Hledger_Read_CsvReader, "journal" ~: do - r <- runExceptT $ parseWithState nulljps JournalReader.journalp "" + r <- runExceptT $ parseWithState mempty JournalReader.journalp "" assertBool "journalp should parse an empty file" (isRight $ r) jE <- readJournal Nothing Nothing True Nothing "" -- don't know how to get it from journal either error' (assertBool "journalp parsing an empty file should give an empty journal" . null . jtxns) jE diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 4622b2d22..b584ca7be 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -43,7 +43,7 @@ import Hledger.Utils type StringParser u m a = ParsecT String u m a -- | A string parser with journal-parsing state. -type JournalParser m a = StringParser JournalParseState m a +type JournalParser m a = StringParser Journal m a -- | A journal parser that runs in IO and can throw an error mid-parse. type ErroringJournalParser a = JournalParser (ExceptT String IO) a @@ -55,7 +55,7 @@ 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 nulljps "" s +runJournalParser p s = runParserT p mempty "" s rjp = runJournalParser -- | Run an error-raising journal parser with a null journal-parsing state. @@ -66,134 +66,72 @@ rejp = runErroringJournalParser genericSourcePos :: SourcePos -> GenericSourcePos genericSourcePos p = GenericSourcePos (sourceName p) (sourceLine p) (sourceColumn p) --- | Flatten a list of JournalUpdate's (journal-transforming --- monadic actions which can do IO or raise an exception) into a --- single equivalent action. -combineJournalUpdates :: [JournalUpdate] -> JournalUpdate -combineJournalUpdates us = foldl' (flip (.)) id <$> sequence us --- XXX may be contributing to excessive stack use - --- cf http://neilmitchell.blogspot.co.uk/2015/09/detecting-space-leaks.html --- $ ./devprof +RTS -K576K -xc --- Exception (reporting due to +RTS -xc): (THUNK_STATIC), stack trace: --- Hledger.Read.JournalReader.combineJournalUpdates.\, --- called from Hledger.Read.JournalReader.combineJournalUpdates, --- called from Hledger.Read.JournalReader.fixedlotprice, --- called from Hledger.Read.JournalReader.partialbalanceassertion, --- called from Hledger.Read.JournalReader.getDefaultCommodityAndStyle, --- called from Hledger.Read.JournalReader.priceamount, --- called from Hledger.Read.JournalReader.nosymbolamount, --- called from Hledger.Read.JournalReader.numberp, --- called from Hledger.Read.JournalReader.rightsymbolamount, --- called from Hledger.Read.JournalReader.simplecommoditysymbol, --- called from Hledger.Read.JournalReader.quotedcommoditysymbol, --- called from Hledger.Read.JournalReader.commoditysymbol, --- called from Hledger.Read.JournalReader.signp, --- called from Hledger.Read.JournalReader.leftsymbolamount, --- called from Hledger.Read.JournalReader.amountp, --- called from Hledger.Read.JournalReader.spaceandamountormissing, --- called from Hledger.Read.JournalReader.accountnamep.singlespace, --- called from Hledger.Utils.Parse.nonspace, --- called from Hledger.Read.JournalReader.accountnamep, --- called from Hledger.Read.JournalReader.getAccountAliases, --- called from Hledger.Read.JournalReader.getParentAccount, --- called from Hledger.Read.JournalReader.modifiedaccountnamep, --- called from Hledger.Read.JournalReader.postingp, --- called from Hledger.Read.JournalReader.postings, --- called from Hledger.Read.JournalReader.commentStartingWith, --- called from Hledger.Read.JournalReader.semicoloncomment, --- called from Hledger.Read.JournalReader.followingcommentp, --- called from Hledger.Read.JournalReader.descriptionp, --- called from Hledger.Read.JournalReader.codep, --- called from Hledger.Read.JournalReader.statusp, --- called from Hledger.Utils.Parse.spacenonewline, --- called from Hledger.Read.JournalReader.secondarydatep, --- called from Hledger.Data.Dates.datesepchar, --- called from Hledger.Read.JournalReader.datep, --- called from Hledger.Read.JournalReader.transaction, --- called from Hledger.Utils.Parse.choice', --- called from Hledger.Read.JournalReader.directive, --- called from Hledger.Read.JournalReader.emptyorcommentlinep, --- called from Hledger.Read.JournalReader.multilinecommentp, --- called from Hledger.Read.JournalReader.journal.journalItem, --- called from Hledger.Read.JournalReader.journal, --- called from Hledger.Read.JournalReader.parseJournalWith, --- called from Hledger.Read.readJournal.tryReaders.firstSuccessOrBestError, --- called from Hledger.Read.readJournal.tryReaders, --- called from Hledger.Read.readJournal, --- called from Main.main, --- called from Main.CAF --- Stack space overflow: current size 33568 bytes. - --- | 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. -parseAndFinaliseJournal :: ErroringJournalParser (JournalUpdate,JournalParseState) -> Bool -> FilePath -> String -> ExceptT String IO Journal +-- | Given a parsec ParsedJournal parser, file path and data string, +-- parse and post-process a ready-to-use Journal, or give an error. +parseAndFinaliseJournal :: ErroringJournalParser ParsedJournal -> Bool -> FilePath -> String -> ExceptT String IO Journal parseAndFinaliseJournal parser assrt f s = do - tc <- liftIO getClockTime - tl <- liftIO getCurrentLocalTime + t <- liftIO getClockTime y <- liftIO getCurrentYear - r <- runParserT parser nulljps{jpsYear=Just y} f s - case r of - Right (updates,jps) -> do - j <- ap updates (return nulljournal) - case journalFinalise tc tl f s jps assrt j of - Right j' -> return j' - Left estr -> throwError estr - Left e -> throwError $ show e + ep <- runParserT parser nulljournal{jparsedefaultyear=Just y} f s + case ep of + Right pj -> case journalFinalise t f s assrt pj of + Right j -> return j + Left e -> throwError e + Left e -> throwError $ show e setYear :: Monad m => Integer -> JournalParser m () -setYear y = modifyState (\jps -> jps{jpsYear=Just y}) +setYear y = modifyState (\j -> j{jparsedefaultyear=Just y}) getYear :: Monad m => JournalParser m (Maybe Integer) -getYear = fmap jpsYear getState +getYear = fmap jparsedefaultyear getState setDefaultCommodityAndStyle :: Monad m => (CommoditySymbol,AmountStyle) -> JournalParser m () -setDefaultCommodityAndStyle cs = modifyState (\jps -> jps{jpsDefaultCommodityAndStyle=Just cs}) +setDefaultCommodityAndStyle cs = modifyState (\j -> j{jparsedefaultcommodity=Just cs}) getDefaultCommodityAndStyle :: Monad m => JournalParser m (Maybe (CommoditySymbol,AmountStyle)) -getDefaultCommodityAndStyle = jpsDefaultCommodityAndStyle `fmap` getState +getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` getState -pushAccount :: Monad m => String -> JournalParser m () -pushAccount acct = modifyState addAccount - where addAccount jps0 = jps0 { jpsAccounts = acct : jpsAccounts jps0 } +pushAccount :: Monad m => AccountName -> JournalParser m () +pushAccount acct = modifyState (\j -> j{jaccounts = acct : jaccounts j}) -pushParentAccount :: Monad m => String -> JournalParser m () -pushParentAccount parent = modifyState addParentAccount - where addParentAccount jps0 = jps0 { jpsParentAccount = parent : jpsParentAccount jps0 } +pushParentAccount :: Monad m => AccountName -> JournalParser m () +pushParentAccount acct = modifyState (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j}) popParentAccount :: Monad m => JournalParser m () -popParentAccount = do jps0 <- getState - case jpsParentAccount jps0 of - [] -> unexpected "End of apply account block with no beginning" - (_:rest) -> setState $ jps0 { jpsParentAccount = rest } +popParentAccount = do + j <- getState + case jparseparentaccounts j of + [] -> unexpected "End of apply account block with no beginning" + (_:rest) -> setState j{jparseparentaccounts=rest} getParentAccount :: Monad m => JournalParser m String -getParentAccount = fmap (concatAccountNames . reverse . jpsParentAccount) getState +getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) getState addAccountAlias :: Monad m => AccountAlias -> JournalParser m () -addAccountAlias a = modifyState (\(jps@JournalParseState{..}) -> jps{jpsAliases=a:jpsAliases}) +addAccountAlias a = modifyState (\(j@Journal{..}) -> j{jparsealiases=a:jparsealiases}) getAccountAliases :: Monad m => JournalParser m [AccountAlias] -getAccountAliases = fmap jpsAliases getState +getAccountAliases = fmap jparsealiases getState clearAccountAliases :: Monad m => JournalParser m () -clearAccountAliases = modifyState (\(jps@JournalParseState{..}) -> jps{jpsAliases=[]}) +clearAccountAliases = modifyState (\(j@Journal{..}) -> j{jparsealiases=[]}) -getTransactionIndex :: Monad m => JournalParser m Integer -getTransactionIndex = fmap jpsTransactionIndex getState +getTransactionCount :: Monad m => JournalParser m Integer +getTransactionCount = fmap jparsetransactioncount getState -setTransactionIndex :: Monad m => Integer -> JournalParser m () -setTransactionIndex i = modifyState (\jps -> jps{jpsTransactionIndex=i}) +setTransactionCount :: Monad m => Integer -> JournalParser m () +setTransactionCount i = modifyState (\j -> j{jparsetransactioncount=i}) -- | Increment the transaction index by one and return the new value. -incrementTransactionIndex :: Monad m => JournalParser m Integer -incrementTransactionIndex = do - modifyState (\jps -> jps{jpsTransactionIndex=jpsTransactionIndex jps + 1}) - getTransactionIndex +incrementTransactionCount :: Monad m => JournalParser m Integer +incrementTransactionCount = do + modifyState (\j -> j{jparsetransactioncount=jparsetransactioncount j + 1}) + getTransactionCount journalAddFile :: (FilePath,String) -> Journal -> Journal -journalAddFile f j@Journal{files=fs} = j{files=fs++[f]} - -- NOTE: first encountered file to left, to avoid a reverse +journalAddFile f j@Journal{jfiles=fs} = j{jfiles=fs++[f]} + -- append, unlike the other fields, even though we do a final reverse, + -- to compensate for additional reversal due to including/monoid-concatting -- -- | Terminate parsing entirely, returning the given error message -- -- with the current parse position prepended. @@ -368,10 +306,10 @@ is' :: (Eq a, Show a) => a -> a -> Assertion a `is'` e = assertEqual e a test_spaceandamountormissingp = do - assertParseEqual' (parseWithState nulljps spaceandamountormissingp " $47.18") (Mixed [usd 47.18]) - assertParseEqual' (parseWithState nulljps spaceandamountormissingp "$47.18") missingmixedamt - assertParseEqual' (parseWithState nulljps spaceandamountormissingp " ") missingmixedamt - assertParseEqual' (parseWithState nulljps spaceandamountormissingp "") missingmixedamt + assertParseEqual' (parseWithState mempty spaceandamountormissingp " $47.18") (Mixed [usd 47.18]) + assertParseEqual' (parseWithState mempty spaceandamountormissingp "$47.18") missingmixedamt + assertParseEqual' (parseWithState mempty spaceandamountormissingp " ") missingmixedamt + assertParseEqual' (parseWithState mempty spaceandamountormissingp "") missingmixedamt #endif -- | Parse a single-commodity amount, with optional symbol on the left or @@ -382,22 +320,22 @@ amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp #ifdef TESTS test_amountp = do - assertParseEqual' (parseWithState nulljps amountp "$47.18") (usd 47.18) - assertParseEqual' (parseWithState nulljps amountp "$1.") (usd 1 `withPrecision` 0) + assertParseEqual' (parseWithState mempty amountp "$47.18") (usd 47.18) + assertParseEqual' (parseWithState mempty amountp "$1.") (usd 1 `withPrecision` 0) -- ,"amount with unit price" ~: do assertParseEqual' - (parseWithState nulljps amountp "$10 @ €0.5") + (parseWithState mempty amountp "$10 @ €0.5") (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- ,"amount with total price" ~: do assertParseEqual' - (parseWithState nulljps amountp "$10 @@ €5") + (parseWithState mempty amountp "$10 @@ €5") (usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0)) #endif -- | Parse an amount from a string, or get an error. amountp' :: String -> Amount amountp' s = - case runParser (amountp <* eof) nulljps "" s of + case runParser (amountp <* eof) mempty "" s of Right t -> t Left err -> error' $ show err -- XXX should throwError @@ -572,8 +510,8 @@ numberp = do numeric = isNumber . headDef '_' -- test_numberp = do --- let s `is` n = assertParseEqual (parseWithState nulljps numberp s) n --- assertFails = assertBool . isLeft . parseWithState nulljps numberp +-- let s `is` n = assertParseEqual (parseWithState mempty numberp s) n +-- assertFails = assertBool . isLeft . parseWithState mempty numberp -- assertFails "" -- "0" `is` (0, 0, '.', ',', []) -- "1" `is` (1, 0, '.', ',', []) @@ -796,9 +734,9 @@ datetagp mdefdate = do startpos <- getPosition v <- tagvaluep -- re-parse value as a date. - jps <- getState + j <- getState ep <- parseWithState - jps{jpsYear=first3.toGregorian <$> mdefdate} + j{jparsedefaultyear=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. @@ -855,9 +793,9 @@ bracketeddatetagsp mdefdate = do -- looks sufficiently like a bracketed date, now we -- re-parse as dates and throw any errors - jps <- getState + j <- getState ep <- parseWithState - jps{jpsYear=first3.toGregorian <$> mdefdate} + j{jparsedefaultyear=first3.toGregorian <$> mdefdate} (do setPosition startpos md1 <- optionMaybe datep diff --git a/hledger-lib/Hledger/Read/CsvReader.hs b/hledger-lib/Hledger/Read/CsvReader.hs index 27317f7c8..b0c4b631e 100644 --- a/hledger-lib/Hledger/Read/CsvReader.hs +++ b/hledger-lib/Hledger/Read/CsvReader.hs @@ -605,7 +605,7 @@ transactionFromCsvRecord sourcepos rules record = t status = case mfieldtemplate "status" of Nothing -> Uncleared - Just str -> either statuserror id $ runParser (statusp <* eof) nulljps "" $ render str + Just str -> either statuserror id $ runParser (statusp <* eof) mempty "" $ render str where statuserror err = error' $ unlines ["error: could not parse \""++str++"\" as a cleared status (should be *, ! or empty)" @@ -617,7 +617,7 @@ transactionFromCsvRecord sourcepos rules record = t precomment = maybe "" render $ mfieldtemplate "precomment" currency = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency" amountstr = (currency++) $ negateIfParenthesised $ getAmountStr rules record - amount = either amounterror (Mixed . (:[])) $ runParser (amountp <* eof) nulljps "" amountstr + amount = either amounterror (Mixed . (:[])) $ runParser (amountp <* eof) mempty "" amountstr amounterror err = error' $ unlines ["error: could not parse \""++amountstr++"\" as an amount" ,showRecord record diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index 78c1d0f46..31f214d7d 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -56,14 +56,14 @@ module Hledger.Read.JournalReader ( marketpricedirectivep, datetimep, datep, - codep, - accountnamep, + -- codep, + -- accountnamep, modifiedaccountnamep, postingp, - amountp, - amountp', - mamountp', - numberp, + -- amountp, + -- amountp', + -- mamountp', + -- numberp, statusp, emptyorcommentlinep, followingcommentp, @@ -78,8 +78,10 @@ where import Prelude () import Prelude.Compat hiding (readFile) import qualified Control.Exception as C -import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError, catchError) +import Control.Monad +import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError) import qualified Data.Map.Strict as M +import Data.Monoid import Data.Time.Calendar import Data.Time.LocalTime import Safe @@ -121,32 +123,40 @@ parse _ = parseAndFinaliseJournal journalp --- * parsers --- ** journal --- | Top-level journal parser. Returns a single composite, I/O performing, --- error-raising "JournalUpdate" (and final "JournalParseState") which can be --- applied to an empty journal to get the final result. -journalp :: ErroringJournalParser (JournalUpdate,JournalParseState) +-- | A journal parser. Accumulates and returns a "ParsedJournal", +-- which should be finalised/validated before use. +-- +-- >>> rejp (journalp <* eof) "2015/1/1\n a 0\n" +-- Right Journal with 1 transactions, 1 accounts +-- +journalp :: ErroringJournalParser ParsedJournal journalp = do - journalupdates <- many journalItem + many addJournalItemP eof - finaljps <- getState - return (combineJournalUpdates journalupdates, finaljps) - where - -- As all journal line types can be distinguished by the first - -- character, excepting transactions versus empty (blank or - -- comment-only) lines, can use choice w/o try - journalItem = choice [ directivep - , fmap (return . addTransaction) transactionp - , fmap (return . addModifierTransaction) modifiertransactionp - , fmap (return . addPeriodicTransaction) periodictransactionp - , fmap (return . addMarketPrice) marketpricedirectivep - , emptyorcommentlinep >> return (return id) - , multilinecommentp >> return (return id) - ] "transaction or directive" + getState + +-- | A side-effecting parser; parses any kind of journal item +-- and updates the parse state accordingly. +addJournalItemP :: ErroringJournalParser () +addJournalItemP = do + -- all journal line types can be distinguished by the first + -- character, can use choice without backtracking + choice [ + directivep + , transactionp >>= modifyState . addTransaction + , modifiertransactionp >>= modifyState . addModifierTransaction + , periodictransactionp >>= modifyState . addPeriodicTransaction + , marketpricedirectivep >>= modifyState . addMarketPrice + , void emptyorcommentlinep + , void multilinecommentp + ] "transaction or directive" --- ** directives --- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives -directivep :: ErroringJournalParser JournalUpdate +-- | Parse any journal directive and update the parse state accordingly. +-- Cf http://hledger.org/manual.html#directives, +-- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives +directivep :: ErroringJournalParser () directivep = do optional $ char '!' choice' [ @@ -166,51 +176,65 @@ directivep = do ] "directive" -includedirectivep :: ErroringJournalParser JournalUpdate +newJournalWithParseStateFrom :: Journal -> Journal +newJournalWithParseStateFrom j = mempty{ + jparsedefaultyear = jparsedefaultyear j + ,jparsedefaultcommodity = jparsedefaultcommodity j + ,jparseparentaccounts = jparseparentaccounts j + ,jparsealiases = jparsealiases j + ,jparsetransactioncount = jparsetransactioncount j + ,jparsetimeclockentries = jparsetimeclockentries j + } + +includedirectivep :: ErroringJournalParser () includedirectivep = do string "include" many1 spacenonewline - filename <- restofline - outerState <- getState - outerPos <- getPosition - let curdir = takeDirectory (sourceName outerPos) - -- XXX clean this up, probably after getting rid of JournalUpdate - let (u::ExceptT String IO (Journal -> Journal, JournalParseState)) = do - filepath <- expandPath curdir filename - txt <- readFileOrError outerPos filepath - let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n" - r <- runParserT - (choice' [journalp - ,timeclockfilep - ,timedotfilep - -- can't include a csv file yet, that reader is special - ]) - outerState filepath txt + filename <- restofline + parentpos <- getPosition + parentj <- getState + let childj = newJournalWithParseStateFrom parentj + (ep :: Either String ParsedJournal) <- + liftIO $ runExceptT $ do + let curdir = takeDirectory (sourceName parentpos) + filepath <- expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename) + txt <- readFile' filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath) + (ep1::Either ParseError ParsedJournal) <- + runParserT + (choice' [journalp + ,timeclockfilep + ,timedotfilep + -- can't include a csv file yet, that reader is special + ]) + childj filepath txt + either + (throwError + . ((show parentpos ++ " in included file " ++ show filename ++ ":\n") ++) + . show) + (return . journalAddFile (filepath,txt)) + ep1 + case ep of + Left e -> throwError e + Right jchild -> modifyState (\jparent -> + -- trace ("jparent txns: " ++ show (jtxns jparent)) $ trace ("jchild txns: "++ show (jtxns jchild)) $ + jchild <> jparent) - case r of - Right (ju, jps) -> do - u <- combineJournalUpdates [ return $ journalAddFile (filepath,txt) - , ju - ] `catchError` (throwError . (inIncluded ++)) - return (u, jps) - Left err -> throwError $ inIncluded ++ show err - where readFileOrError pos fp = - ExceptT $ fmap Right (readFile' fp) `C.catch` - \e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException)) - r <- liftIO $ runExceptT u - case r of - Left err -> return $ throwError err - Right (ju, _finalparsejps) -> return $ ExceptT $ return $ Right ju +-- | Lift an IO action into the exception monad, rethrowing any IO +-- error with the given message prepended. +orRethrowIOError :: IO a -> String -> ExceptT String IO a +orRethrowIOError io msg = + ExceptT $ + (Right <$> io) + `C.catch` \(e::C.IOException) -> return $ Left $ printf "%s:\n%s" msg (show e) -accountdirectivep :: ErroringJournalParser JournalUpdate +accountdirectivep :: ErroringJournalParser () accountdirectivep = do string "account" many1 spacenonewline acct <- accountnamep newline _ <- many indentedlinep - pushAccount acct - return $ ExceptT $ return $ Right id + modifyState (\j -> j{jaccounts = acct : jaccounts j}) indentedlinep = many1 spacenonewline >> (rstrip <$> restofline) @@ -220,14 +244,14 @@ indentedlinep = many1 spacenonewline >> (rstrip <$> restofline) -- >>> Right _ <- rejp commoditydirectivep "commodity $\n format $1.00" -- >>> Right _ <- rejp commoditydirectivep "commodity $\n\n" -- a commodity with no format -- >>> Right _ <- rejp commoditydirectivep "commodity $1.00\n format $1.00" -- both, what happens ? -commoditydirectivep :: ErroringJournalParser JournalUpdate +commoditydirectivep :: ErroringJournalParser () commoditydirectivep = try commoditydirectiveonelinep <|> commoditydirectivemultilinep -- | Parse a one-line commodity directive. -- -- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00" -- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00 ; blah\n" -commoditydirectiveonelinep :: ErroringJournalParser JournalUpdate +commoditydirectiveonelinep :: ErroringJournalParser () commoditydirectiveonelinep = do string "commodity" many1 spacenonewline @@ -235,12 +259,12 @@ commoditydirectiveonelinep = do many spacenonewline _ <- followingcommentp <|> (eolof >> return "") let comm = Commodity{csymbol=acommodity, cformat=Just astyle} - return $ ExceptT $ return $ Right $ \j -> j{jcommodities=M.insert acommodity comm $ jcommodities j} + modifyState (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j}) -- | Parse a multi-line commodity directive, containing 0 or more format subdirectives. -- -- >>> Right _ <- rejp commoditydirectivemultilinep "commodity $ ; blah \n format $1.00 ; blah" -commoditydirectivemultilinep :: ErroringJournalParser JournalUpdate +commoditydirectivemultilinep :: ErroringJournalParser () commoditydirectivemultilinep = do string "commodity" many1 spacenonewline @@ -248,9 +272,9 @@ commoditydirectivemultilinep = do _ <- followingcommentp <|> (eolof >> return "") mformat <- lastMay <$> many (indented $ formatdirectivep sym) let comm = Commodity{csymbol=sym, cformat=mformat} - return $ ExceptT $ return $ Right $ \j -> j{jcommodities=M.insert sym comm $ jcommodities j} - -indented = (many1 spacenonewline >>) + modifyState (\j -> j{jcommodities=M.insert sym comm $ jcommodities j}) + where + indented = (many1 spacenonewline >>) -- | Parse a format (sub)directive, throwing a parse error if its -- symbol does not match the one given. @@ -266,28 +290,25 @@ formatdirectivep expectedsym = do else parserErrorAt pos $ printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity -applyaccountdirectivep :: ErroringJournalParser JournalUpdate +applyaccountdirectivep :: ErroringJournalParser () applyaccountdirectivep = do string "apply" >> many1 spacenonewline >> string "account" many1 spacenonewline parent <- accountnamep newline pushParentAccount parent - return $ ExceptT $ return $ Right id -endapplyaccountdirectivep :: ErroringJournalParser JournalUpdate +endapplyaccountdirectivep :: ErroringJournalParser () endapplyaccountdirectivep = do string "end" >> many1 spacenonewline >> string "apply" >> many1 spacenonewline >> string "account" popParentAccount - return $ ExceptT $ return $ Right id -aliasdirectivep :: ErroringJournalParser JournalUpdate +aliasdirectivep :: ErroringJournalParser () aliasdirectivep = do string "alias" many1 spacenonewline alias <- accountaliasp addAccountAlias alias - return $ return id accountaliasp :: Monad m => StringParser u m AccountAlias accountaliasp = regexaliasp <|> basicaliasp @@ -313,27 +334,26 @@ regexaliasp = do repl <- rstrip <$> anyChar `manyTill` eolof return $ RegexAlias re repl -endaliasesdirectivep :: ErroringJournalParser JournalUpdate +endaliasesdirectivep :: ErroringJournalParser () endaliasesdirectivep = do string "end aliases" clearAccountAliases - return (return id) -tagdirectivep :: ErroringJournalParser JournalUpdate +tagdirectivep :: ErroringJournalParser () tagdirectivep = do string "tag" "tag directive" many1 spacenonewline _ <- many1 nonspace restofline - return $ return id + return () -endtagdirectivep :: ErroringJournalParser JournalUpdate +endtagdirectivep :: ErroringJournalParser () endtagdirectivep = do (string "end tag" <|> string "pop") "end tag or pop directive" restofline - return $ return id + return () -defaultyeardirectivep :: ErroringJournalParser JournalUpdate +defaultyeardirectivep :: ErroringJournalParser () defaultyeardirectivep = do char 'Y' "default year" many spacenonewline @@ -341,16 +361,14 @@ defaultyeardirectivep = do let y' = read y failIfInvalidYear y setYear y' - return $ return id -defaultcommoditydirectivep :: ErroringJournalParser JournalUpdate +defaultcommoditydirectivep :: ErroringJournalParser () defaultcommoditydirectivep = do char 'D' "default commodity" many1 spacenonewline Amount{..} <- amountp - setDefaultCommodityAndStyle (acommodity, astyle) restofline - return $ return id + setDefaultCommodityAndStyle (acommodity, astyle) marketpricedirectivep :: ErroringJournalParser MarketPrice marketpricedirectivep = do @@ -364,15 +382,15 @@ marketpricedirectivep = do restofline return $ MarketPrice date symbol price -ignoredpricecommoditydirectivep :: ErroringJournalParser JournalUpdate +ignoredpricecommoditydirectivep :: ErroringJournalParser () ignoredpricecommoditydirectivep = do char 'N' "ignored-price commodity" many1 spacenonewline commoditysymbolp restofline - return $ return id + return () -commodityconversiondirectivep :: ErroringJournalParser JournalUpdate +commodityconversiondirectivep :: ErroringJournalParser () commodityconversiondirectivep = do char 'C' "commodity conversion" many1 spacenonewline @@ -382,7 +400,7 @@ commodityconversiondirectivep = do many spacenonewline amountp restofline - return $ return id + return () --- ** transactions @@ -416,13 +434,13 @@ transactionp = do comment <- try followingcommentp <|> (newline >> return "") let tags = commentTags comment postings <- postingsp (Just date) - idx <- incrementTransactionIndex - return $ txnTieKnot $ Transaction idx sourcepos date edate status code description comment tags postings "" + n <- incrementTransactionCount + return $ txnTieKnot $ Transaction n sourcepos date edate status code description comment tags postings "" #ifdef TESTS test_transactionp = do let s `gives` t = do - let p = parseWithState nulljps transactionp s + let p = parseWithState mempty transactionp s assertBool $ isRight p let Right t2 = p -- same f = assertEqual (f t) (f t2) @@ -475,7 +493,7 @@ test_transactionp = do tdate=parsedate "2015/01/01", } - assertRight $ parseWithState nulljps transactionp $ unlines + assertRight $ parseWithState mempty transactionp $ unlines ["2007/01/28 coopportunity" ," expenses:food:groceries $47.18" ," assets:checking $-47.18" @@ -483,25 +501,25 @@ test_transactionp = do ] -- transactionp should not parse just a date - assertLeft $ parseWithState nulljps transactionp "2009/1/1\n" + assertLeft $ parseWithState mempty transactionp "2009/1/1\n" -- transactionp should not parse just a date and description - assertLeft $ parseWithState nulljps transactionp "2009/1/1 a\n" + assertLeft $ parseWithState mempty transactionp "2009/1/1 a\n" -- transactionp should not parse a following comment as part of the description - let p = parseWithState nulljps transactionp "2009/1/1 a ;comment\n b 1\n" + let p = parseWithState mempty transactionp "2009/1/1 a ;comment\n b 1\n" assertRight p assertEqual "a" (let Right p' = p in tdescription p') -- parse transaction with following whitespace line - assertRight $ parseWithState nulljps transactionp $ unlines + assertRight $ parseWithState mempty transactionp $ unlines ["2012/1/1" ," a 1" ," b" ," " ] - let p = parseWithState nulljps transactionp $ unlines + let p = parseWithState mempty transactionp $ unlines ["2009/1/1 x ; transaction comment" ," a 1 ; posting 1 comment" ," ; posting 1 comment 2" @@ -555,7 +573,7 @@ postingp mtdate = do #ifdef TESTS test_postingp = do let s `gives` ep = do - let parse = parseWithState nulljps (postingp Nothing) s + let parse = parseWithState mempty (postingp Nothing) s assertBool -- "postingp parser" $ isRight parse let Right ap = parse @@ -587,12 +605,12 @@ test_postingp = do ,pdate=parsedateM "2012/11/28"} assertBool -- "postingp parses a quoted commodity with numbers" - (isRight $ parseWithState nulljps (postingp Nothing) " a 1 \"DE123\"\n") + (isRight $ parseWithState mempty (postingp Nothing) " a 1 \"DE123\"\n") -- ,"postingp parses balance assertions and fixed lot prices" ~: do - assertBool (isRight $ parseWithState nulljps (postingp Nothing) " a 1 \"DE123\" =$1 { =2.2 EUR} \n") + assertBool (isRight $ parseWithState mempty (postingp Nothing) " a 1 \"DE123\" =$1 { =2.2 EUR} \n") - -- let parse = parseWithState nulljps postingp " a\n ;next-line comment\n" + -- let parse = parseWithState mempty postingp " a\n ;next-line comment\n" -- assertRight parse -- let Right p = parse -- assertEqual "next-line comment\n" (pcomment p) @@ -619,30 +637,30 @@ tests_Hledger_Read_JournalReader = TestList $ concat [ test_transactionp, [ "modifiertransactionp" ~: do - assertParse (parseWithState nulljps modifiertransactionp "= (some value expr)\n some:postings 1\n") + assertParse (parseWithState mempty modifiertransactionp "= (some value expr)\n some:postings 1\n") ,"periodictransactionp" ~: do - assertParse (parseWithState nulljps periodictransactionp "~ (some period expr)\n some:postings 1\n") + assertParse (parseWithState mempty periodictransactionp "~ (some period expr)\n some:postings 1\n") ,"directivep" ~: do - assertParse (parseWithState nulljps directivep "!include /some/file.x\n") - assertParse (parseWithState nulljps directivep "account some:account\n") - assertParse (parseWithState nulljps (directivep >> directivep) "!account a\nend\n") + assertParse (parseWithState mempty directivep "!include /some/file.x\n") + assertParse (parseWithState mempty directivep "account some:account\n") + assertParse (parseWithState mempty (directivep >> directivep) "!account a\nend\n") ,"comment" ~: do - assertParse (parseWithState nulljps comment "; some comment \n") - assertParse (parseWithState nulljps comment " \t; x\n") - assertParse (parseWithState nulljps comment "#x") + assertParse (parseWithState mempty comment "; some comment \n") + assertParse (parseWithState mempty comment " \t; x\n") + assertParse (parseWithState mempty comment "#x") ,"datep" ~: do - assertParse (parseWithState nulljps datep "2011/1/1") - assertParseFailure (parseWithState nulljps datep "1/1") - assertParse (parseWithState nulljps{jpsYear=Just 2011} datep "1/1") + assertParse (parseWithState mempty datep "2011/1/1") + assertParseFailure (parseWithState mempty datep "1/1") + assertParse (parseWithState mempty{jpsYear=Just 2011} datep "1/1") ,"datetimep" ~: do let p = do {t <- datetimep; eof; return t} - bad = assertParseFailure . parseWithState nulljps p - good = assertParse . parseWithState nulljps p + bad = assertParseFailure . parseWithState mempty p + good = assertParse . parseWithState mempty p bad "2011/1/1" bad "2011/1/1 24:00:00" bad "2011/1/1 00:60:00" @@ -652,31 +670,31 @@ tests_Hledger_Read_JournalReader = TestList $ concat [ good "2011/1/1 3:5:7" -- timezone is parsed but ignored let startofday = LocalTime (fromGregorian 2011 1 1) (TimeOfDay 0 0 (fromIntegral 0)) - assertParseEqual (parseWithState nulljps p "2011/1/1 00:00-0800") startofday - assertParseEqual (parseWithState nulljps p "2011/1/1 00:00+1234") startofday + assertParseEqual (parseWithState mempty p "2011/1/1 00:00-0800") startofday + assertParseEqual (parseWithState mempty p "2011/1/1 00:00+1234") startofday ,"defaultyeardirectivep" ~: do - assertParse (parseWithState nulljps defaultyeardirectivep "Y 2010\n") - assertParse (parseWithState nulljps defaultyeardirectivep "Y 10001\n") + assertParse (parseWithState mempty defaultyeardirectivep "Y 2010\n") + assertParse (parseWithState mempty defaultyeardirectivep "Y 10001\n") ,"marketpricedirectivep" ~: - assertParseEqual (parseWithState nulljps marketpricedirectivep "P 2004/05/01 XYZ $55.00\n") (MarketPrice (parsedate "2004/05/01") "XYZ" $ usd 55) + assertParseEqual (parseWithState mempty marketpricedirectivep "P 2004/05/01 XYZ $55.00\n") (MarketPrice (parsedate "2004/05/01") "XYZ" $ usd 55) ,"ignoredpricecommoditydirectivep" ~: do - assertParse (parseWithState nulljps ignoredpricecommoditydirectivep "N $\n") + assertParse (parseWithState mempty ignoredpricecommoditydirectivep "N $\n") ,"defaultcommoditydirectivep" ~: do - assertParse (parseWithState nulljps defaultcommoditydirectivep "D $1,000.0\n") + assertParse (parseWithState mempty defaultcommoditydirectivep "D $1,000.0\n") ,"commodityconversiondirectivep" ~: do - assertParse (parseWithState nulljps commodityconversiondirectivep "C 1h = $50.00\n") + assertParse (parseWithState mempty commodityconversiondirectivep "C 1h = $50.00\n") ,"tagdirectivep" ~: do - assertParse (parseWithState nulljps tagdirectivep "tag foo \n") + assertParse (parseWithState mempty tagdirectivep "tag foo \n") ,"endtagdirectivep" ~: do - assertParse (parseWithState nulljps endtagdirectivep "end tag \n") - assertParse (parseWithState nulljps endtagdirectivep "pop \n") + assertParse (parseWithState mempty endtagdirectivep "end tag \n") + assertParse (parseWithState mempty endtagdirectivep "pop \n") ,"accountnamep" ~: do assertBool "accountnamep parses a normal account name" (isRight $ parsewith accountnamep "a:b:c") @@ -685,15 +703,15 @@ tests_Hledger_Read_JournalReader = TestList $ concat [ assertBool "accountnamep rejects an empty trailing component" (isLeft $ parsewith accountnamep "a:b:") ,"leftsymbolamountp" ~: do - assertParseEqual (parseWithState nulljps leftsymbolamountp "$1") (usd 1 `withPrecision` 0) - assertParseEqual (parseWithState nulljps leftsymbolamountp "$-1") (usd (-1) `withPrecision` 0) - assertParseEqual (parseWithState nulljps leftsymbolamountp "-$1") (usd (-1) `withPrecision` 0) + assertParseEqual (parseWithState mempty leftsymbolamountp "$1") (usd 1 `withPrecision` 0) + assertParseEqual (parseWithState mempty leftsymbolamountp "$-1") (usd (-1) `withPrecision` 0) + assertParseEqual (parseWithState mempty leftsymbolamountp "-$1") (usd (-1) `withPrecision` 0) ,"amount" ~: do let -- | compare a parse result with an expected amount, showing the debug representation for clarity assertAmountParse parseresult amount = (either (const "parse error") showAmountDebug parseresult) ~?= (showAmountDebug amount) - assertAmountParse (parseWithState nulljps amountp "1 @ $2") + assertAmountParse (parseWithState mempty amountp "1 @ $2") (num 1 `withPrecision` 0 `at` (usd 2 `withPrecision` 0)) ]] diff --git a/hledger-lib/Hledger/Read/TimeclockReader.hs b/hledger-lib/Hledger/Read/TimeclockReader.hs index c121a1fff..2fc9e80a3 100644 --- a/hledger-lib/Hledger/Read/TimeclockReader.hs +++ b/hledger-lib/Hledger/Read/TimeclockReader.hs @@ -51,9 +51,9 @@ module Hledger.Read.TimeclockReader ( where import Prelude () import Prelude.Compat -import Control.Monad (liftM) +import Control.Monad +import Control.Monad.IO.Class (liftIO) import Control.Monad.Except (ExceptT) -import Data.List (foldl') import Data.Maybe (fromMaybe) import Test.HUnit import Text.Parsec hiding (parse) @@ -61,9 +61,7 @@ import System.FilePath import Hledger.Data -- XXX too much reuse ? -import Hledger.Read.Common ( - emptyorcommentlinep, datetimep, parseAndFinaliseJournal, modifiedaccountnamep, genericSourcePos - ) +import Hledger.Read.Common import Hledger.Utils @@ -85,22 +83,27 @@ detect f s parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal parse _ = parseAndFinaliseJournal timeclockfilep -timeclockfilep :: ParsecT [Char] JournalParseState (ExceptT String IO) (JournalUpdate, JournalParseState) -timeclockfilep = do items <- many timeclockitemp +timeclockfilep :: ErroringJournalParser ParsedJournal +timeclockfilep = do many timeclockitemp eof - jps <- getState - return (liftM (foldl' (\acc new x -> new (acc x)) id) $ sequence items, jps) + j@Journal{jtxns=ts, jparsetimeclockentries=es} <- getState + -- Convert timeclock entries in this journal to transactions, closing any unfinished sessions. + -- Doing this here rather than in journalFinalise means timeclock sessions can't span file boundaries, + -- but it simplifies code above. + now <- liftIO getCurrentLocalTime + let j' = j{jtxns = ts ++ timeclockEntriesToTransactions now (reverse es), jparsetimeclockentries = []} + return j' 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 timeclockitemp = choice [ - emptyorcommentlinep >> return (return id) - , liftM (return . addTimeclockEntry) timeclockentryp + void emptyorcommentlinep + , timeclockentryp >>= \e -> modifyState (\j -> j{jparsetimeclockentries = e : jparsetimeclockentries j}) ] "timeclock entry, or default year or historical price directive" -- | Parse a timeclock entry. -timeclockentryp :: ParsecT [Char] JournalParseState (ExceptT String IO) TimeclockEntry +timeclockentryp :: ErroringJournalParser TimeclockEntry timeclockentryp = do sourcepos <- genericSourcePos <$> getPosition code <- oneOf "bhioO" diff --git a/hledger-lib/Hledger/Read/TimedotReader.hs b/hledger-lib/Hledger/Read/TimedotReader.hs index d254c9d1e..29e9975a8 100644 --- a/hledger-lib/Hledger/Read/TimedotReader.hs +++ b/hledger-lib/Hledger/Read/TimedotReader.hs @@ -32,7 +32,7 @@ module Hledger.Read.TimedotReader ( where import Prelude () import Prelude.Compat -import Control.Monad (liftM) +import Control.Monad import Control.Monad.Except (ExceptT) import Data.Char (isSpace) import Data.List (foldl') @@ -42,10 +42,7 @@ import Text.Parsec hiding (parse) import System.FilePath import Hledger.Data -import Hledger.Read.Common ( - datep, numberp, emptyorcommentlinep, followingcommentp, - parseAndFinaliseJournal, modifiedaccountnamep, genericSourcePos - ) +import Hledger.Read.Common import Hledger.Utils hiding (ptrace) -- easier to toggle this here sometimes @@ -69,17 +66,16 @@ detect f s parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal parse _ = parseAndFinaliseJournal timedotfilep -timedotfilep :: ParsecT [Char] JournalParseState (ExceptT String IO) (JournalUpdate, JournalParseState) -timedotfilep = do items <- many timedotfileitemp +timedotfilep :: ErroringJournalParser ParsedJournal +timedotfilep = do many timedotfileitemp eof - jps <- getState - return (liftM (foldl' (\acc new x -> new (acc x)) id) $ sequence items, jps) + getState where timedotfileitemp = do ptrace "timedotfileitemp" choice [ - emptyorcommentlinep >> return (return id), - liftM (return . addTransactions) timedotdayp + void emptyorcommentlinep + ,timedotdayp >>= \ts -> modifyState (addTransactions ts) ] "timedot day entry, or default year or comment line or blank line" addTransactions :: [Transaction] -> Journal -> Journal @@ -92,7 +88,7 @@ addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts) -- biz.research . -- inc.client1 .... .... .... .... .... .... -- @ -timedotdayp :: ParsecT [Char] JournalParseState (ExceptT String IO) [Transaction] +timedotdayp :: ErroringJournalParser [Transaction] timedotdayp = do ptrace " timedotdayp" d <- datep <* eolof @@ -104,7 +100,7 @@ timedotdayp = do -- @ -- fos.haskell .... .. -- @ -timedotentryp :: ParsecT [Char] JournalParseState (ExceptT String IO) Transaction +timedotentryp :: ErroringJournalParser Transaction timedotentryp = do ptrace " timedotentryp" pos <- genericSourcePos <$> getPosition @@ -128,14 +124,14 @@ timedotentryp = do } return t -timedotdurationp :: ParsecT [Char] JournalParseState (ExceptT String IO) Quantity +timedotdurationp :: ErroringJournalParser Quantity timedotdurationp = try timedotnumberp <|> timedotdotsp -- | Parse a duration written as a decimal number of hours (optionally followed by the letter h). -- @ -- 1.5h -- @ -timedotnumberp :: ParsecT [Char] JournalParseState (ExceptT String IO) Quantity +timedotnumberp :: ErroringJournalParser Quantity timedotnumberp = do (q, _, _, _) <- numberp many spacenonewline @@ -147,7 +143,7 @@ timedotnumberp = do -- @ -- .... .. -- @ -timedotdotsp :: ParsecT [Char] JournalParseState (ExceptT String IO) Quantity +timedotdotsp :: ErroringJournalParser Quantity timedotdotsp = do dots <- filter (not.isSpace) <$> many (oneOf ". ") return $ (/4) $ fromIntegral $ length dots diff --git a/hledger-lib/Hledger/Utils.hs b/hledger-lib/Hledger/Utils.hs index 22925f95f..2f7ca29fd 100644 --- a/hledger-lib/Hledger/Utils.hs +++ b/hledger-lib/Hledger/Utils.hs @@ -32,7 +32,6 @@ module Hledger.Utils (---- provide these frequently used modules - or not, for c ) where import Control.Monad (liftM) -import Control.Monad.IO.Class (MonadIO, liftIO) -- import Data.Char -- import Data.List -- import Data.Maybe @@ -115,13 +114,14 @@ applyN n f = (!! n) . iterate f -- | Convert a possibly relative, possibly tilde-containing file path to an absolute one, -- given the current directory. ~username is not supported. Leave "-" unchanged. -expandPath :: MonadIO m => FilePath -> FilePath -> m FilePath -- general type sig for use in reader parsers +-- Can raise an error. +expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers expandPath _ "-" = return "-" expandPath curdir p = (if isRelative p then (curdir ) else id) `liftM` expandPath' p where - expandPath' ('~':'/':p) = liftIO $ ( p) `fmap` getHomeDirectory - expandPath' ('~':'\\':p) = liftIO $ ( p) `fmap` getHomeDirectory - expandPath' ('~':_) = error' "~USERNAME in paths is not supported" + expandPath' ('~':'/':p) = ( p) <$> getHomeDirectory + expandPath' ('~':'\\':p) = ( p) <$> getHomeDirectory + expandPath' ('~':_) = ioError $ userError "~USERNAME in paths is not supported" expandPath' p = return p firstJust ms = case dropWhile (==Nothing) ms of diff --git a/hledger-web/Foundation.hs b/hledger-web/Foundation.hs index ba569f836..a82af68c5 100644 --- a/hledger-web/Foundation.hs +++ b/hledger-web/Foundation.hs @@ -391,7 +391,7 @@ addform _ vd@VD{..} = [hamlet| where amtvar = "amount" ++ show n amtph = "Amount " ++ show n - filepaths = map fst $ files j + filepaths = map fst $ jfiles j --