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 --