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

lib: simplify parsers; cleanups (#275)

Browse Source 
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).
This commit is contained in:
Simon Michael 2016-05-23 00:32:55 -07:00
parent 4179a83c1d
commit 0f5ee154c4
18 changed files with 374 additions and 432 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hledger-api/hledger-api.hs
View File

@ -141,7 +141,7 @@ hledgerApiApp staticdir j = Servant.serve api server
accountnamesH = return $ journalAccountNames j accountnamesH = return $ journalAccountNames j
transactionsH = return $ jtxns j transactionsH = return $ jtxns j
pricesH = return $ jmarketprices 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 accountsH = return $ ledgerTopAccounts $ ledgerFromJournal Hledger.Query.Any j
accounttransactionsH (a::AccountName) = do accounttransactionsH (a::AccountName) = do
-- d <- liftIO getCurrentDay -- d <- liftIO getCurrentDay

160
hledger-lib/Hledger/Data/Journal.hs
View File

@ -1,4 +1,4 @@
-- {-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-}
{-| {-|
A 'Journal' is a set of transactions, plus optional related data. This is A 'Journal' is a set of transactions, plus optional related data. This is
@ -12,7 +12,6 @@ module Hledger.Data.Journal (
addMarketPrice, addMarketPrice,
addModifierTransaction, addModifierTransaction,
addPeriodicTransaction, addPeriodicTransaction,
addTimeclockEntry,
addTransaction, addTransaction,
journalApplyAliases, journalApplyAliases,
journalBalanceTransactions, journalBalanceTransactions,
@ -52,7 +51,6 @@ module Hledger.Data.Journal (
-- * Misc -- * Misc
canonicalStyleFrom, canonicalStyleFrom,
matchpats, matchpats,
nulljps,
nulljournal, nulljournal,
-- * Tests -- * Tests
samplejournal, samplejournal,
@ -67,7 +65,6 @@ import Data.Monoid
import Data.Ord import Data.Ord
import Safe (headMay, headDef) import Safe (headMay, headDef)
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.LocalTime
import Data.Tree import Data.Tree
import System.Time (ClockTime(TOD)) import System.Time (ClockTime(TOD))
import Test.HUnit import Test.HUnit
@ -82,10 +79,14 @@ import Hledger.Data.Amount
import Hledger.Data.Dates import Hledger.Data.Dates
import Hledger.Data.Transaction import Hledger.Data.Transaction
import Hledger.Data.Posting import Hledger.Data.Posting
import Hledger.Data.Timeclock
import Hledger.Query import Hledger.Query
-- try to make Journal ppShow-compatible
-- instance Show ClockTime where
-- show t = "<ClockTime>"
-- deriving instance Show Journal
instance Show Journal where instance Show Journal where
show j show j
| debugLevel < 3 = printf "Journal %s with %d transactions, %d accounts" | debugLevel < 3 = printf "Journal %s with %d transactions, %d accounts"
@ -108,7 +109,7 @@ instance Show Journal where
length (jperiodictxns j)) length (jperiodictxns j))
(length accounts) (length accounts)
(show accounts) (show accounts)
(show $ jcommoditystyles j) (show $ jinferredcommodities j)
-- ++ (show $ journalTransactions l) -- ++ (show $ journalTransactions l)
where accounts = filter (/= "root") $ flatten $ journalAccountNameTree j where accounts = filter (/= "root") $ flatten $ journalAccountNameTree j
@ -117,74 +118,73 @@ instance Show Journal where
-- ,show (jtxns j) -- ,show (jtxns j)
-- ,show (jmodifiertxns j) -- ,show (jmodifiertxns j)
-- ,show (jperiodictxns j) -- ,show (jperiodictxns j)
-- ,show $ open_timeclock_entries j -- ,show $ jparsetimeclockentries j
-- ,show $ jmarketprices j -- ,show $ jmarketprices j
-- ,show $ final_comment_lines j -- ,show $ jfinalcommentlines j
-- ,show $ jparsestate j -- ,show $ jparsestate j
-- ,show $ map fst $ files j -- ,show $ map fst $ jfiles j
-- ] -- ]
-- The monoid instance for Journal concatenates the list fields, -- The monoid instance for Journal is useful for two situations.
-- combines the map fields, keeps the final comment lines of the --
-- second journal, and keeps the latest of their last read times. -- 1. concatenating finalised journals, eg with multiple -f options:
-- See JournalParseState for how the final parse states are combined. -- 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 instance Monoid Journal where
mempty = nulljournal mempty = nulljournal
mappend j1 j2 = mappend j1 j2 = Journal {
Journal{jmodifiertxns = jmodifiertxns j1 <> jmodifiertxns j2 jparsedefaultyear = jparsedefaultyear j2
,jperiodictxns = jperiodictxns j1 <> jperiodictxns j2 ,jparsedefaultcommodity = jparsedefaultcommodity j2
,jtxns = jtxns j1 <> jtxns j2 ,jparseparentaccounts = jparseparentaccounts j2
,jcommoditystyles = jcommoditystyles j1 <> jcommoditystyles j2 ,jparsealiases = jparsealiases j2
,jcommodities = jcommodities j1 <> jcommodities j2 ,jparsetransactioncount = jparsetransactioncount j1 + jparsetransactioncount j2
,open_timeclock_entries = open_timeclock_entries j1 <> open_timeclock_entries j2 ,jparsetimeclockentries = jparsetimeclockentries j1 <> jparsetimeclockentries j2
,jmarketprices = jmarketprices j1 <> jmarketprices j2 ,jaccounts = jaccounts j1 <> jaccounts j2
,final_comment_lines = final_comment_lines j1 <> final_comment_lines j2 ,jcommodities = jcommodities j1 <> jcommodities j2
,jparsestate = jparsestate j1 <> jparsestate j2 ,jinferredcommodities = jinferredcommodities j1 <> jinferredcommodities j2
,files = files j1 <> files j2 ,jmarketprices = jmarketprices j1 <> jmarketprices j2
,filereadtime = max (filereadtime j1) (filereadtime 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
nulljournal = Journal { jmodifiertxns = [] nulljournal = Journal {
, jperiodictxns = [] jparsedefaultyear = Nothing
, jtxns = [] ,jparsedefaultcommodity = Nothing
, jcommodities = M.fromList [] ,jparseparentaccounts = []
, open_timeclock_entries = [] ,jparsealiases = []
, jmarketprices = [] ,jparsetransactioncount = 0
, final_comment_lines = [] ,jparsetimeclockentries = []
, jparsestate = nulljps ,jaccounts = []
, files = [] ,jcommodities = M.fromList []
, filereadtime = TOD 0 0 ,jinferredcommodities = M.fromList []
, jcommoditystyles = M.fromList [] ,jmarketprices = []
} ,jmodifiertxns = []
,jperiodictxns = []
-- The monoid instance for JournalParseState mostly discards the ,jtxns = []
-- second parse state, except the accounts defined by account ,jfinalcommentlines = []
-- directives are concatenated, and the transaction indices (counts of ,jfiles = []
-- transactions parsed, if any) are added. ,jlastreadtime = TOD 0 0
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}
journalFilePath :: Journal -> FilePath journalFilePath :: Journal -> FilePath
journalFilePath = fst . mainfile journalFilePath = fst . mainfile
journalFilePaths :: Journal -> [FilePath] journalFilePaths :: Journal -> [FilePath]
journalFilePaths = map fst . files journalFilePaths = map fst . jfiles
mainfile :: Journal -> (FilePath, String) mainfile :: Journal -> (FilePath, String)
mainfile = headDef ("", "") . files mainfile = headDef ("", "") . jfiles
addTransaction :: Transaction -> Journal -> Journal addTransaction :: Transaction -> Journal -> Journal
addTransaction t j = j { jtxns = t : jtxns j } 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 :: MarketPrice -> Journal -> Journal
addMarketPrice h j = j { jmarketprices = h : jmarketprices j } 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. -- | Get the transaction with this index (its 1-based position in the input stream), if any.
journalTransactionAt :: Journal -> Integer -> Maybe Transaction journalTransactionAt :: Journal -> Integer -> Maybe Transaction
journalTransactionAt Journal{jtxns=ts} i = 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} dotransaction t@Transaction{tpostings=ps} = t{tpostings=map doposting ps}
doposting p@Posting{paccount=a} = p{paccount= accountNameApplyAliases aliases a} doposting p@Posting{paccount=a} = p{paccount= accountNameApplyAliases aliases a}
-- | Do post-parse processing on a journal to make it ready for use: check -- | Do post-parse processing on a parsed journal to make it ready for
-- all transactions balance, canonicalise amount formats, close any open -- use. Reverse parsed data to normal order, canonicalise amount
-- timeclock entries, maybe check balance assertions and so on. -- formats, check/ensure that transactions are balanced, and maybe
journalFinalise :: ClockTime -> LocalTime -> FilePath -> String -> JournalParseState -> Bool -> Journal -> Either String Journal -- check balance assertions.
journalFinalise tclock tlocal path txt jps assrt j@Journal{files=fs} = do journalFinalise :: ClockTime -> FilePath -> String -> Bool -> ParsedJournal -> Either String Journal
journalFinalise t path txt assrt j@Journal{jfiles=fs} = do
(journalBalanceTransactions $ (journalBalanceTransactions $
journalApplyCommodityStyles $ journalApplyCommodityStyles $
journalCloseTimeclockEntries tlocal $ j{ jfiles = (path,txt) : reverse fs
j{ files=(path,txt):fs , jlastreadtime = t
, filereadtime=tclock , jtxns = reverse $ jtxns j -- NOTE: see addTransaction
, jparsestate=jps , jmodifiertxns = reverse $ jmodifiertxns j -- NOTE: see addModifierTransaction
, jtxns=reverse $ jtxns j -- NOTE: see addTransaction , jperiodictxns = reverse $ jperiodictxns j -- NOTE: see addPeriodicTransaction
, jmodifiertxns=reverse $ jmodifiertxns j -- NOTE: see addModifierTransaction , jmarketprices = reverse $ jmarketprices j -- NOTE: see addMarketPrice
, 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
}) })
>>= if assrt then journalCheckBalanceAssertions else return >>= if assrt then journalCheckBalanceAssertions else return
@ -553,7 +548,7 @@ splitAssertions ps
-- amounts and working out the canonical commodities, since balancing -- amounts and working out the canonical commodities, since balancing
-- depends on display precision. Reports only the first error encountered. -- depends on display precision. Reports only the first error encountered.
journalBalanceTransactions :: Journal -> Either String Journal 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'} case sequence $ map balance ts of Right ts' -> Right j{jtxns=map txnTieKnot ts'}
Left e -> Left e Left e -> Left e
where balance = balanceTransaction (Just ss) where balance = balanceTransaction (Just ss)
@ -583,7 +578,7 @@ journalCommodityStyle j c =
headDef amountstyle{asprecision=2} $ headDef amountstyle{asprecision=2} $
catMaybes [ catMaybes [
M.lookup c (jcommodities j) >>= cformat 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. -- | 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." -- commodity, and the highest precision of all posting amounts in the commodity."
journalInferCommodityStyles :: Journal -> Journal journalInferCommodityStyles :: Journal -> Journal
journalInferCommodityStyles j = journalInferCommodityStyles j =
j{jcommoditystyles = j{jinferredcommodities =
commodityStylesFromAmounts $ commodityStylesFromAmounts $
dbg8 "journalChooseCommmodityStyles using amounts" $ journalAmounts j} dbg8 "journalChooseCommmodityStyles using amounts" $ journalAmounts j}
@ -642,11 +637,6 @@ canonicalStyleFrom ss@(first:_) =
-- case ps of (MarketPrice{mpamount=a}:_) -> Just a -- case ps of (MarketPrice{mpamount=a}:_) -> Just a
-- _ -> Nothing -- _ -> 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. -- | Convert all this journal's amounts to cost by applying their prices, if any.
journalConvertAmountsToCost :: Journal -> Journal journalConvertAmountsToCost :: Journal -> Journal
journalConvertAmountsToCost j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} 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} fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}
fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a} fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}
fixmixedamount (Mixed as) = Mixed $ map fixamount as 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. -- -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol.
-- journalCanonicalCommodities :: Journal -> M.Map String CommoditySymbol -- journalCanonicalCommodities :: Journal -> M.Map String CommoditySymbol

2
hledger-lib/Hledger/Data/Ledger.hs
View File

@ -85,7 +85,7 @@ ledgerDateSpan = postingsDateSpan . ledgerPostings
-- | All commodities used in this ledger. -- | All commodities used in this ledger.
ledgerCommodities :: Ledger -> [CommoditySymbol] ledgerCommodities :: Ledger -> [CommoditySymbol]
ledgerCommodities = M.keys . jcommoditystyles . ljournal ledgerCommodities = M.keys . jinferredcommodities . ljournal
tests_ledgerFromJournal = [ tests_ledgerFromJournal = [

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

@ -222,52 +222,48 @@ instance NFData MarketPrice
type Year = Integer type Year = Integer
-- | Journal parse state is data we want to keep track of in the -- | A Journal, containing transactions and various other things.
-- course of parsing a journal. An example is the default year, which -- The basic data model for hledger.
-- 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. -- This is used during parsing (as the type alias ParsedJournal), and
data JournalParseState = JournalParseState { -- then finalised/validated for use as a Journal. Some extra
jpsYear :: !(Maybe Year) -- ^ the default year most recently specified with Y -- parsing-related fields are included for convenience, at least for
, jpsDefaultCommodityAndStyle :: !(Maybe (CommoditySymbol,AmountStyle)) -- ^ the default commodity and amount style most recently specified with D -- now. In a ParsedJournal these are updated as parsing proceeds, in a
, jpsAccounts :: ![AccountName] -- ^ the accounts that have been defined with account directives so far -- Journal they represent the final state at end of parsing (used eg
, jpsParentAccount :: ![AccountName] -- ^ the current stack of parent accounts/account name components -- by the add command).
-- specified with "apply account" directive(s). Concatenated, these --
-- are the account prefix prepended to parsed account names. data Journal = Journal {
, jpsAliases :: ![AccountAlias] -- ^ the current list of account name aliases in effect -- parsing-related data
, jpsTransactionIndex :: !Integer -- ^ the number of transactions read so far. (Does not count jparsedefaultyear :: (Maybe Year) -- ^ the current default year, specified by the most recent Y directive (or current date)
-- timeclock/timedot/CSV entries, currently). ,jparsedefaultcommodity :: (Maybe (CommoditySymbol,AmountStyle)) -- ^ the current default commodity and its format, specified by the most recent D directive
} deriving (Read, Show, Eq, Data, Typeable, Generic) ,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 ?)
instance NFData JournalParseState ,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 Data (ClockTime)
deriving instance Typeable (ClockTime) deriving instance Typeable (ClockTime)
deriving instance Generic (ClockTime) deriving instance Generic (ClockTime)
instance NFData 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 instance NFData Journal
-- | A JournalUpdate is some transformation of a Journal. It can do I/O or -- | A journal in the process of being parsed, not yet finalised.
-- raise an exception. -- The data is partial, and list fields are in reverse order.
type JournalUpdate = ExceptT String IO (Journal -> Journal) type ParsedJournal = Journal
-- | The id of a data format understood by hledger, eg @journal@ or @csv@. -- | The id of a data format understood by hledger, eg @journal@ or @csv@.
-- The --output-format option selects one of these for output. -- The --output-format option selects one of these for output.

17
hledger-lib/Hledger/Read.hs
View File

@ -10,6 +10,7 @@ to import modules below this one.
module Hledger.Read module Hledger.Read
( (
module Hledger.Read.Common,
readFormatNames, readFormatNames,
-- * Journal reading API -- * Journal reading API
defaultJournalPath, defaultJournalPath,
@ -22,12 +23,12 @@ module Hledger.Read
ensureJournalFileExists, ensureJournalFileExists,
-- * Parsers used elsewhere -- * Parsers used elsewhere
postingp, postingp,
accountnamep, -- accountnamep,
amountp, -- amountp,
amountp', -- amountp',
mamountp', -- mamountp',
numberp, -- numberp,
codep, -- codep,
accountaliasp, accountaliasp,
-- * Tests -- * Tests
samplejournal, samplejournal,
@ -47,8 +48,8 @@ import Test.HUnit
import Text.Printf import Text.Printf
import Hledger.Data.Dates (getCurrentDay) import Hledger.Data.Dates (getCurrentDay)
import Hledger.Data.Journal (nulljps)
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Read.Common
import Hledger.Read.JournalReader as JournalReader import Hledger.Read.JournalReader as JournalReader
import Hledger.Read.TimedotReader as TimedotReader import Hledger.Read.TimedotReader as TimedotReader
import Hledger.Read.TimeclockReader as TimeclockReader import Hledger.Read.TimeclockReader as TimeclockReader
@ -259,7 +260,7 @@ tests_Hledger_Read = TestList $
tests_Hledger_Read_CsvReader, tests_Hledger_Read_CsvReader,
"journal" ~: do "journal" ~: do
r <- runExceptT $ parseWithState nulljps JournalReader.journalp "" r <- runExceptT $ parseWithState mempty JournalReader.journalp ""
assertBool "journalp should parse an empty file" (isRight $ r) assertBool "journalp should parse an empty file" (isRight $ r)
jE <- readJournal Nothing Nothing True Nothing "" -- don't know how to get it from journal 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 either error' (assertBool "journalp parsing an empty file should give an empty journal" . null . jtxns) jE

172
hledger-lib/Hledger/Read/Common.hs
View File

@ -43,7 +43,7 @@ import Hledger.Utils
type StringParser u m a = ParsecT String u m a type StringParser u m a = ParsecT String u m a
-- | A string parser with journal-parsing state. -- | 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. -- | A journal parser that runs in IO and can throw an error mid-parse.
type ErroringJournalParser a = JournalParser (ExceptT String IO) a type ErroringJournalParser a = JournalParser (ExceptT String IO) a
@ -55,7 +55,7 @@ rsp = runStringParser
-- | Run a journal parser with a null journal-parsing state. -- | Run a journal parser with a null journal-parsing state.
runJournalParser, rjp :: Monad m => JournalParser m a -> String -> m (Either ParseError a) 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 rjp = runJournalParser
-- | Run an error-raising journal parser with a null journal-parsing state. -- | Run an error-raising journal parser with a null journal-parsing state.
@ -66,134 +66,72 @@ rejp = runErroringJournalParser
genericSourcePos :: SourcePos -> GenericSourcePos genericSourcePos :: SourcePos -> GenericSourcePos
genericSourcePos p = GenericSourcePos (sourceName p) (sourceLine p) (sourceColumn p) genericSourcePos p = GenericSourcePos (sourceName p) (sourceLine p) (sourceColumn p)
-- | Flatten a list of JournalUpdate's (journal-transforming -- | Given a parsec ParsedJournal parser, file path and data string,
-- monadic actions which can do IO or raise an exception) into a -- parse and post-process a ready-to-use Journal, or give an error.
-- single equivalent action. parseAndFinaliseJournal :: ErroringJournalParser ParsedJournal -> Bool -> FilePath -> String -> ExceptT String IO Journal
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
parseAndFinaliseJournal parser assrt f s = do parseAndFinaliseJournal parser assrt f s = do
tc <- liftIO getClockTime t <- liftIO getClockTime
tl <- liftIO getCurrentLocalTime
y <- liftIO getCurrentYear y <- liftIO getCurrentYear
r <- runParserT parser nulljps{jpsYear=Just y} f s ep <- runParserT parser nulljournal{jparsedefaultyear=Just y} f s
case r of case ep of
Right (updates,jps) -> do Right pj -> case journalFinalise t f s assrt pj of
j <- ap updates (return nulljournal) Right j -> return j
case journalFinalise tc tl f s jps assrt j of Left e -> throwError e
Right j' -> return j' Left e -> throwError $ show e
Left estr -> throwError estr
Left e -> throwError $ show e
setYear :: Monad m => Integer -> JournalParser m () 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 :: Monad m => JournalParser m (Maybe Integer)
getYear = fmap jpsYear getState getYear = fmap jparsedefaultyear getState
setDefaultCommodityAndStyle :: Monad m => (CommoditySymbol,AmountStyle) -> JournalParser m () 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 :: Monad m => JournalParser m (Maybe (CommoditySymbol,AmountStyle))
getDefaultCommodityAndStyle = jpsDefaultCommodityAndStyle `fmap` getState getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` getState
pushAccount :: Monad m => String -> JournalParser m () pushAccount :: Monad m => AccountName -> JournalParser m ()
pushAccount acct = modifyState addAccount pushAccount acct = modifyState (\j -> j{jaccounts = acct : jaccounts j})
where addAccount jps0 = jps0 { jpsAccounts = acct : jpsAccounts jps0 }
pushParentAccount :: Monad m => String -> JournalParser m () pushParentAccount :: Monad m => AccountName -> JournalParser m ()
pushParentAccount parent = modifyState addParentAccount pushParentAccount acct = modifyState (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j})
where addParentAccount jps0 = jps0 { jpsParentAccount = parent : jpsParentAccount jps0 }
popParentAccount :: Monad m => JournalParser m () popParentAccount :: Monad m => JournalParser m ()
popParentAccount = do jps0 <- getState popParentAccount = do
case jpsParentAccount jps0 of j <- getState
[] -> unexpected "End of apply account block with no beginning" case jparseparentaccounts j of
(_:rest) -> setState $ jps0 { jpsParentAccount = rest } [] -> unexpected "End of apply account block with no beginning"
(_:rest) -> setState j{jparseparentaccounts=rest}
getParentAccount :: Monad m => JournalParser m String 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 :: 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 :: Monad m => JournalParser m [AccountAlias]
getAccountAliases = fmap jpsAliases getState getAccountAliases = fmap jparsealiases getState
clearAccountAliases :: Monad m => JournalParser m () clearAccountAliases :: Monad m => JournalParser m ()
clearAccountAliases = modifyState (\(jps@JournalParseState{..}) -> jps{jpsAliases=[]}) clearAccountAliases = modifyState (\(j@Journal{..}) -> j{jparsealiases=[]})
getTransactionIndex :: Monad m => JournalParser m Integer getTransactionCount :: Monad m => JournalParser m Integer
getTransactionIndex = fmap jpsTransactionIndex getState getTransactionCount = fmap jparsetransactioncount getState
setTransactionIndex :: Monad m => Integer -> JournalParser m () setTransactionCount :: Monad m => Integer -> JournalParser m ()
setTransactionIndex i = modifyState (\jps -> jps{jpsTransactionIndex=i}) setTransactionCount i = modifyState (\j -> j{jparsetransactioncount=i})
-- | Increment the transaction index by one and return the new value. -- | Increment the transaction index by one and return the new value.
incrementTransactionIndex :: Monad m => JournalParser m Integer incrementTransactionCount :: Monad m => JournalParser m Integer
incrementTransactionIndex = do incrementTransactionCount = do
modifyState (\jps -> jps{jpsTransactionIndex=jpsTransactionIndex jps + 1}) modifyState (\j -> j{jparsetransactioncount=jparsetransactioncount j + 1})
getTransactionIndex getTransactionCount
journalAddFile :: (FilePath,String) -> Journal -> Journal journalAddFile :: (FilePath,String) -> Journal -> Journal
journalAddFile f j@Journal{files=fs} = j{files=fs++[f]} journalAddFile f j@Journal{jfiles=fs} = j{jfiles=fs++[f]}
-- NOTE: first encountered file to left, to avoid a reverse -- 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 -- -- | Terminate parsing entirely, returning the given error message
-- -- with the current parse position prepended. -- -- with the current parse position prepended.
@ -368,10 +306,10 @@ is' :: (Eq a, Show a) => a -> a -> Assertion
a `is'` e = assertEqual e a a `is'` e = assertEqual e a
test_spaceandamountormissingp = do test_spaceandamountormissingp = do
assertParseEqual' (parseWithState nulljps spaceandamountormissingp " $47.18") (Mixed [usd 47.18]) assertParseEqual' (parseWithState mempty spaceandamountormissingp " $47.18") (Mixed [usd 47.18])
assertParseEqual' (parseWithState nulljps spaceandamountormissingp "$47.18") missingmixedamt assertParseEqual' (parseWithState mempty spaceandamountormissingp "$47.18") missingmixedamt
assertParseEqual' (parseWithState nulljps spaceandamountormissingp " ") missingmixedamt assertParseEqual' (parseWithState mempty spaceandamountormissingp " ") missingmixedamt
assertParseEqual' (parseWithState nulljps spaceandamountormissingp "") missingmixedamt assertParseEqual' (parseWithState mempty spaceandamountormissingp "") missingmixedamt
#endif #endif
-- | Parse a single-commodity amount, with optional symbol on the left or -- | Parse a single-commodity amount, with optional symbol on the left or
@ -382,22 +320,22 @@ amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp
#ifdef TESTS #ifdef TESTS
test_amountp = do test_amountp = do
assertParseEqual' (parseWithState nulljps amountp "$47.18") (usd 47.18) assertParseEqual' (parseWithState mempty amountp "$47.18") (usd 47.18)
assertParseEqual' (parseWithState nulljps amountp "$1.") (usd 1 `withPrecision` 0) assertParseEqual' (parseWithState mempty amountp "$1.") (usd 1 `withPrecision` 0)
-- ,"amount with unit price" ~: do -- ,"amount with unit price" ~: do
assertParseEqual' assertParseEqual'
(parseWithState nulljps amountp "$10 @ €0.5") (parseWithState mempty amountp "$10 @ €0.5")
(usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1))
-- ,"amount with total price" ~: do -- ,"amount with total price" ~: do
assertParseEqual' assertParseEqual'
(parseWithState nulljps amountp "$10 @@ €5") (parseWithState mempty amountp "$10 @@ €5")
(usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0)) (usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0))
#endif #endif
-- | Parse an amount from a string, or get an error. -- | Parse an amount from a string, or get an error.
amountp' :: String -> Amount amountp' :: String -> Amount
amountp' s = amountp' s =
case runParser (amountp <* eof) nulljps "" s of case runParser (amountp <* eof) mempty "" s of
Right t -> t Right t -> t
Left err -> error' $ show err -- XXX should throwError Left err -> error' $ show err -- XXX should throwError
@ -572,8 +510,8 @@ numberp = do
numeric = isNumber . headDef '_' numeric = isNumber . headDef '_'
-- test_numberp = do -- test_numberp = do
-- let s `is` n = assertParseEqual (parseWithState nulljps numberp s) n -- let s `is` n = assertParseEqual (parseWithState mempty numberp s) n
-- assertFails = assertBool . isLeft . parseWithState nulljps numberp -- assertFails = assertBool . isLeft . parseWithState mempty numberp
-- assertFails "" -- assertFails ""
-- "0" `is` (0, 0, '.', ',', []) -- "0" `is` (0, 0, '.', ',', [])
-- "1" `is` (1, 0, '.', ',', []) -- "1" `is` (1, 0, '.', ',', [])
@ -796,9 +734,9 @@ datetagp mdefdate = do
startpos <- getPosition startpos <- getPosition
v <- tagvaluep v <- tagvaluep
-- re-parse value as a date. -- re-parse value as a date.
jps <- getState j <- getState
ep <- parseWithState ep <- parseWithState
jps{jpsYear=first3.toGregorian <$> mdefdate} j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
-- The value extends to a comma, newline, or end of file. -- The value extends to a comma, newline, or end of file.
-- It seems like ignoring any extra stuff following a date -- It seems like ignoring any extra stuff following a date
-- gives better errors here. -- gives better errors here.
@ -855,9 +793,9 @@ bracketeddatetagsp mdefdate = do
-- looks sufficiently like a bracketed date, now we -- looks sufficiently like a bracketed date, now we
-- re-parse as dates and throw any errors -- re-parse as dates and throw any errors
jps <- getState j <- getState
ep <- parseWithState ep <- parseWithState
jps{jpsYear=first3.toGregorian <$> mdefdate} j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
(do (do
setPosition startpos setPosition startpos
md1 <- optionMaybe datep md1 <- optionMaybe datep

4
hledger-lib/Hledger/Read/CsvReader.hs
View File

@ -605,7 +605,7 @@ transactionFromCsvRecord sourcepos rules record = t
status = status =
case mfieldtemplate "status" of case mfieldtemplate "status" of
Nothing -> Uncleared 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 where
statuserror err = error' $ unlines statuserror err = error' $ unlines
["error: could not parse \""++str++"\" as a cleared status (should be *, ! or empty)" ["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" precomment = maybe "" render $ mfieldtemplate "precomment"
currency = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency" currency = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency"
amountstr = (currency++) $ negateIfParenthesised $ getAmountStr rules record 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 amounterror err = error' $ unlines
["error: could not parse \""++amountstr++"\" as an amount" ["error: could not parse \""++amountstr++"\" as an amount"
,showRecord record ,showRecord record

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

@ -56,14 +56,14 @@ module Hledger.Read.JournalReader (
marketpricedirectivep, marketpricedirectivep,
datetimep, datetimep,
datep, datep,
codep, -- codep,
accountnamep, -- accountnamep,
modifiedaccountnamep, modifiedaccountnamep,
postingp, postingp,
amountp, -- amountp,
amountp', -- amountp',
mamountp', -- mamountp',
numberp, -- numberp,
statusp, statusp,
emptyorcommentlinep, emptyorcommentlinep,
followingcommentp, followingcommentp,
@ -78,8 +78,10 @@ where
import Prelude () import Prelude ()
import Prelude.Compat hiding (readFile) import Prelude.Compat hiding (readFile)
import qualified Control.Exception as C 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 qualified Data.Map.Strict as M
import Data.Monoid
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.LocalTime import Data.Time.LocalTime
import Safe import Safe
@ -121,32 +123,40 @@ parse _ = parseAndFinaliseJournal journalp
--- * parsers --- * parsers
--- ** journal --- ** journal
-- | Top-level journal parser. Returns a single composite, I/O performing, -- | A journal parser. Accumulates and returns a "ParsedJournal",
-- error-raising "JournalUpdate" (and final "JournalParseState") which can be -- which should be finalised/validated before use.
-- applied to an empty journal to get the final result. --
journalp :: ErroringJournalParser (JournalUpdate,JournalParseState) -- >>> rejp (journalp <* eof) "2015/1/1\n a 0\n"
-- Right Journal with 1 transactions, 1 accounts
--
journalp :: ErroringJournalParser ParsedJournal
journalp = do journalp = do
journalupdates <- many journalItem many addJournalItemP
eof eof
finaljps <- getState getState
return (combineJournalUpdates journalupdates, finaljps)
where -- | A side-effecting parser; parses any kind of journal item
-- As all journal line types can be distinguished by the first -- and updates the parse state accordingly.
-- character, excepting transactions versus empty (blank or addJournalItemP :: ErroringJournalParser ()
-- comment-only) lines, can use choice w/o try addJournalItemP = do
journalItem = choice [ directivep -- all journal line types can be distinguished by the first
, fmap (return . addTransaction) transactionp -- character, can use choice without backtracking
, fmap (return . addModifierTransaction) modifiertransactionp choice [
, fmap (return . addPeriodicTransaction) periodictransactionp directivep
, fmap (return . addMarketPrice) marketpricedirectivep , transactionp >>= modifyState . addTransaction
, emptyorcommentlinep >> return (return id) , modifiertransactionp >>= modifyState . addModifierTransaction
, multilinecommentp >> return (return id) , periodictransactionp >>= modifyState . addPeriodicTransaction
] <?> "transaction or directive" , marketpricedirectivep >>= modifyState . addMarketPrice
, void emptyorcommentlinep
, void multilinecommentp
] <?> "transaction or directive"
--- ** directives --- ** directives
-- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives -- | Parse any journal directive and update the parse state accordingly.
directivep :: ErroringJournalParser JournalUpdate -- Cf http://hledger.org/manual.html#directives,
-- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives
directivep :: ErroringJournalParser ()
directivep = do directivep = do
optional $ char '!' optional $ char '!'
choice' [ choice' [
@ -166,51 +176,65 @@ directivep = do
] ]
<?> "directive" <?> "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 includedirectivep = do
string "include" string "include"
many1 spacenonewline many1 spacenonewline
filename <- restofline filename <- restofline
outerState <- getState parentpos <- getPosition
outerPos <- getPosition parentj <- getState
let curdir = takeDirectory (sourceName outerPos) let childj = newJournalWithParseStateFrom parentj
-- XXX clean this up, probably after getting rid of JournalUpdate (ep :: Either String ParsedJournal) <-
let (u::ExceptT String IO (Journal -> Journal, JournalParseState)) = do liftIO $ runExceptT $ do
filepath <- expandPath curdir filename let curdir = takeDirectory (sourceName parentpos)
txt <- readFileOrError outerPos filepath filepath <- expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename)
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n" txt <- readFile' filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
r <- runParserT (ep1::Either ParseError ParsedJournal) <-
(choice' [journalp runParserT
,timeclockfilep (choice' [journalp
,timedotfilep ,timeclockfilep
-- can't include a csv file yet, that reader is special ,timedotfilep
]) -- can't include a csv file yet, that reader is special
outerState filepath txt ])
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 -- | Lift an IO action into the exception monad, rethrowing any IO
Right (ju, jps) -> do -- error with the given message prepended.
u <- combineJournalUpdates [ return $ journalAddFile (filepath,txt) orRethrowIOError :: IO a -> String -> ExceptT String IO a
, ju orRethrowIOError io msg =
] `catchError` (throwError . (inIncluded ++)) ExceptT $
return (u, jps) (Right <$> io)
Left err -> throwError $ inIncluded ++ show err `C.catch` \(e::C.IOException) -> return $ Left $ printf "%s:\n%s" msg (show e)
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
accountdirectivep :: ErroringJournalParser JournalUpdate accountdirectivep :: ErroringJournalParser ()
accountdirectivep = do accountdirectivep = do
string "account" string "account"
many1 spacenonewline many1 spacenonewline
acct <- accountnamep acct <- accountnamep
newline newline
_ <- many indentedlinep _ <- many indentedlinep
pushAccount acct modifyState (\j -> j{jaccounts = acct : jaccounts j})
return $ ExceptT $ return $ Right id
indentedlinep = many1 spacenonewline >> (rstrip <$> restofline) 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 format $1.00"
-- >>> Right _ <- rejp commoditydirectivep "commodity $\n\n" -- a commodity with no format -- >>> Right _ <- rejp commoditydirectivep "commodity $\n\n" -- a commodity with no format
-- >>> Right _ <- rejp commoditydirectivep "commodity $1.00\n format $1.00" -- both, what happens ? -- >>> Right _ <- rejp commoditydirectivep "commodity $1.00\n format $1.00" -- both, what happens ?
commoditydirectivep :: ErroringJournalParser JournalUpdate commoditydirectivep :: ErroringJournalParser ()
commoditydirectivep = try commoditydirectiveonelinep <|> commoditydirectivemultilinep commoditydirectivep = try commoditydirectiveonelinep <|> commoditydirectivemultilinep
-- | Parse a one-line commodity directive. -- | Parse a one-line commodity directive.
-- --
-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00" -- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00"
-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00 ; blah\n" -- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00 ; blah\n"
commoditydirectiveonelinep :: ErroringJournalParser JournalUpdate commoditydirectiveonelinep :: ErroringJournalParser ()
commoditydirectiveonelinep = do commoditydirectiveonelinep = do
string "commodity" string "commodity"
many1 spacenonewline many1 spacenonewline
@ -235,12 +259,12 @@ commoditydirectiveonelinep = do
many spacenonewline many spacenonewline
_ <- followingcommentp <|> (eolof >> return "") _ <- followingcommentp <|> (eolof >> return "")
let comm = Commodity{csymbol=acommodity, cformat=Just astyle} 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. -- | Parse a multi-line commodity directive, containing 0 or more format subdirectives.
-- --
-- >>> Right _ <- rejp commoditydirectivemultilinep "commodity $ ; blah \n format $1.00 ; blah" -- >>> Right _ <- rejp commoditydirectivemultilinep "commodity $ ; blah \n format $1.00 ; blah"
commoditydirectivemultilinep :: ErroringJournalParser JournalUpdate commoditydirectivemultilinep :: ErroringJournalParser ()
commoditydirectivemultilinep = do commoditydirectivemultilinep = do
string "commodity" string "commodity"
many1 spacenonewline many1 spacenonewline
@ -248,9 +272,9 @@ commoditydirectivemultilinep = do
_ <- followingcommentp <|> (eolof >> return "") _ <- followingcommentp <|> (eolof >> return "")
mformat <- lastMay <$> many (indented $ formatdirectivep sym) mformat <- lastMay <$> many (indented $ formatdirectivep sym)
let comm = Commodity{csymbol=sym, cformat=mformat} let comm = Commodity{csymbol=sym, cformat=mformat}
return $ ExceptT $ return $ Right $ \j -> j{jcommodities=M.insert sym comm $ jcommodities j} modifyState (\j -> j{jcommodities=M.insert sym comm $ jcommodities j})
where
indented = (many1 spacenonewline >>) indented = (many1 spacenonewline >>)
-- | Parse a format (sub)directive, throwing a parse error if its -- | Parse a format (sub)directive, throwing a parse error if its
-- symbol does not match the one given. -- symbol does not match the one given.
@ -266,28 +290,25 @@ formatdirectivep expectedsym = do
else parserErrorAt pos $ else parserErrorAt pos $
printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity
applyaccountdirectivep :: ErroringJournalParser JournalUpdate applyaccountdirectivep :: ErroringJournalParser ()
applyaccountdirectivep = do applyaccountdirectivep = do
string "apply" >> many1 spacenonewline >> string "account" string "apply" >> many1 spacenonewline >> string "account"
many1 spacenonewline many1 spacenonewline
parent <- accountnamep parent <- accountnamep
newline newline
pushParentAccount parent pushParentAccount parent
return $ ExceptT $ return $ Right id
endapplyaccountdirectivep :: ErroringJournalParser JournalUpdate endapplyaccountdirectivep :: ErroringJournalParser ()
endapplyaccountdirectivep = do endapplyaccountdirectivep = do
string "end" >> many1 spacenonewline >> string "apply" >> many1 spacenonewline >> string "account" string "end" >> many1 spacenonewline >> string "apply" >> many1 spacenonewline >> string "account"
popParentAccount popParentAccount
return $ ExceptT $ return $ Right id
aliasdirectivep :: ErroringJournalParser JournalUpdate aliasdirectivep :: ErroringJournalParser ()
aliasdirectivep = do aliasdirectivep = do
string "alias" string "alias"
many1 spacenonewline many1 spacenonewline
alias <- accountaliasp alias <- accountaliasp
addAccountAlias alias addAccountAlias alias
return $ return id
accountaliasp :: Monad m => StringParser u m AccountAlias accountaliasp :: Monad m => StringParser u m AccountAlias
accountaliasp = regexaliasp <|> basicaliasp accountaliasp = regexaliasp <|> basicaliasp
@ -313,27 +334,26 @@ regexaliasp = do
repl <- rstrip <$> anyChar `manyTill` eolof repl <- rstrip <$> anyChar `manyTill` eolof
return $ RegexAlias re repl return $ RegexAlias re repl
endaliasesdirectivep :: ErroringJournalParser JournalUpdate endaliasesdirectivep :: ErroringJournalParser ()
endaliasesdirectivep = do endaliasesdirectivep = do
string "end aliases" string "end aliases"
clearAccountAliases clearAccountAliases
return (return id)
tagdirectivep :: ErroringJournalParser JournalUpdate tagdirectivep :: ErroringJournalParser ()
tagdirectivep = do tagdirectivep = do
string "tag" <?> "tag directive" string "tag" <?> "tag directive"
many1 spacenonewline many1 spacenonewline
_ <- many1 nonspace _ <- many1 nonspace
restofline restofline
return $ return id return ()
endtagdirectivep :: ErroringJournalParser JournalUpdate endtagdirectivep :: ErroringJournalParser ()
endtagdirectivep = do endtagdirectivep = do
(string "end tag" <|> string "pop") <?> "end tag or pop directive" (string "end tag" <|> string "pop") <?> "end tag or pop directive"
restofline restofline
return $ return id return ()
defaultyeardirectivep :: ErroringJournalParser JournalUpdate defaultyeardirectivep :: ErroringJournalParser ()
defaultyeardirectivep = do defaultyeardirectivep = do
char 'Y' <?> "default year" char 'Y' <?> "default year"
many spacenonewline many spacenonewline
@ -341,16 +361,14 @@ defaultyeardirectivep = do
let y' = read y let y' = read y
failIfInvalidYear y failIfInvalidYear y
setYear y' setYear y'
return $ return id
defaultcommoditydirectivep :: ErroringJournalParser JournalUpdate defaultcommoditydirectivep :: ErroringJournalParser ()
defaultcommoditydirectivep = do defaultcommoditydirectivep = do
char 'D' <?> "default commodity" char 'D' <?> "default commodity"
many1 spacenonewline many1 spacenonewline
Amount{..} <- amountp Amount{..} <- amountp
setDefaultCommodityAndStyle (acommodity, astyle)
restofline restofline
return $ return id setDefaultCommodityAndStyle (acommodity, astyle)
marketpricedirectivep :: ErroringJournalParser MarketPrice marketpricedirectivep :: ErroringJournalParser MarketPrice
marketpricedirectivep = do marketpricedirectivep = do
@ -364,15 +382,15 @@ marketpricedirectivep = do
restofline restofline
return $ MarketPrice date symbol price return $ MarketPrice date symbol price
ignoredpricecommoditydirectivep :: ErroringJournalParser JournalUpdate ignoredpricecommoditydirectivep :: ErroringJournalParser ()
ignoredpricecommoditydirectivep = do ignoredpricecommoditydirectivep = do
char 'N' <?> "ignored-price commodity" char 'N' <?> "ignored-price commodity"
many1 spacenonewline many1 spacenonewline
commoditysymbolp commoditysymbolp
restofline restofline
return $ return id return ()
commodityconversiondirectivep :: ErroringJournalParser JournalUpdate commodityconversiondirectivep :: ErroringJournalParser ()
commodityconversiondirectivep = do commodityconversiondirectivep = do
char 'C' <?> "commodity conversion" char 'C' <?> "commodity conversion"
many1 spacenonewline many1 spacenonewline
@ -382,7 +400,7 @@ commodityconversiondirectivep = do
many spacenonewline many spacenonewline
amountp amountp
restofline restofline
return $ return id return ()
--- ** transactions --- ** transactions
@ -416,13 +434,13 @@ transactionp = do
comment <- try followingcommentp <|> (newline >> return "") comment <- try followingcommentp <|> (newline >> return "")
let tags = commentTags comment let tags = commentTags comment
postings <- postingsp (Just date) postings <- postingsp (Just date)
idx <- incrementTransactionIndex n <- incrementTransactionCount
return $ txnTieKnot $ Transaction idx sourcepos date edate status code description comment tags postings "" return $ txnTieKnot $ Transaction n sourcepos date edate status code description comment tags postings ""
#ifdef TESTS #ifdef TESTS
test_transactionp = do test_transactionp = do
let s `gives` t = do let s `gives` t = do
let p = parseWithState nulljps transactionp s let p = parseWithState mempty transactionp s
assertBool $ isRight p assertBool $ isRight p
let Right t2 = p let Right t2 = p
-- same f = assertEqual (f t) (f t2) -- same f = assertEqual (f t) (f t2)
@ -475,7 +493,7 @@ test_transactionp = do
tdate=parsedate "2015/01/01", tdate=parsedate "2015/01/01",
} }
assertRight $ parseWithState nulljps transactionp $ unlines assertRight $ parseWithState mempty transactionp $ unlines
["2007/01/28 coopportunity" ["2007/01/28 coopportunity"
," expenses:food:groceries $47.18" ," expenses:food:groceries $47.18"
," assets:checking $-47.18" ," assets:checking $-47.18"
@ -483,25 +501,25 @@ test_transactionp = do
] ]
-- transactionp should not parse just a date -- 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 -- 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 -- 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 assertRight p
assertEqual "a" (let Right p' = p in tdescription p') assertEqual "a" (let Right p' = p in tdescription p')
-- parse transaction with following whitespace line -- parse transaction with following whitespace line
assertRight $ parseWithState nulljps transactionp $ unlines assertRight $ parseWithState mempty transactionp $ unlines
["2012/1/1" ["2012/1/1"
," a 1" ," a 1"
," b" ," b"
," " ," "
] ]
let p = parseWithState nulljps transactionp $ unlines let p = parseWithState mempty transactionp $ unlines
["2009/1/1 x ; transaction comment" ["2009/1/1 x ; transaction comment"
," a 1 ; posting 1 comment" ," a 1 ; posting 1 comment"
," ; posting 1 comment 2" ," ; posting 1 comment 2"
@ -555,7 +573,7 @@ postingp mtdate = do
#ifdef TESTS #ifdef TESTS
test_postingp = do test_postingp = do
let s `gives` ep = do let s `gives` ep = do
let parse = parseWithState nulljps (postingp Nothing) s let parse = parseWithState mempty (postingp Nothing) s
assertBool -- "postingp parser" assertBool -- "postingp parser"
$ isRight parse $ isRight parse
let Right ap = parse let Right ap = parse
@ -587,12 +605,12 @@ test_postingp = do
,pdate=parsedateM "2012/11/28"} ,pdate=parsedateM "2012/11/28"}
assertBool -- "postingp parses a quoted commodity with numbers" assertBool -- "postingp parses a quoted commodity with numbers"
(isRight $ 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 -- ,"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 -- assertRight parse
-- let Right p = parse -- let Right p = parse
-- assertEqual "next-line comment\n" (pcomment p) -- assertEqual "next-line comment\n" (pcomment p)
@ -619,30 +637,30 @@ tests_Hledger_Read_JournalReader = TestList $ concat [
test_transactionp, test_transactionp,
[ [
"modifiertransactionp" ~: do "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 ,"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 ,"directivep" ~: do
assertParse (parseWithState nulljps directivep "!include /some/file.x\n") assertParse (parseWithState mempty directivep "!include /some/file.x\n")
assertParse (parseWithState nulljps directivep "account some:account\n") assertParse (parseWithState mempty directivep "account some:account\n")
assertParse (parseWithState nulljps (directivep >> directivep) "!account a\nend\n") assertParse (parseWithState mempty (directivep >> directivep) "!account a\nend\n")
,"comment" ~: do ,"comment" ~: do
assertParse (parseWithState nulljps comment "; some comment \n") assertParse (parseWithState mempty comment "; some comment \n")
assertParse (parseWithState nulljps comment " \t; x\n") assertParse (parseWithState mempty comment " \t; x\n")
assertParse (parseWithState nulljps comment "#x") assertParse (parseWithState mempty comment "#x")
,"datep" ~: do ,"datep" ~: do
assertParse (parseWithState nulljps datep "2011/1/1") assertParse (parseWithState mempty datep "2011/1/1")
assertParseFailure (parseWithState nulljps datep "1/1") assertParseFailure (parseWithState mempty datep "1/1")
assertParse (parseWithState nulljps{jpsYear=Just 2011} datep "1/1") assertParse (parseWithState mempty{jpsYear=Just 2011} datep "1/1")
,"datetimep" ~: do ,"datetimep" ~: do
let p = do {t <- datetimep; eof; return t} let p = do {t <- datetimep; eof; return t}
bad = assertParseFailure . parseWithState nulljps p bad = assertParseFailure . parseWithState mempty p
good = assertParse . parseWithState nulljps p good = assertParse . parseWithState mempty p
bad "2011/1/1" bad "2011/1/1"
bad "2011/1/1 24:00:00" bad "2011/1/1 24:00:00"
bad "2011/1/1 00:60: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" good "2011/1/1 3:5:7"
-- timezone is parsed but ignored -- timezone is parsed but ignored
let startofday = LocalTime (fromGregorian 2011 1 1) (TimeOfDay 0 0 (fromIntegral 0)) 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 mempty 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+1234") startofday
,"defaultyeardirectivep" ~: do ,"defaultyeardirectivep" ~: do
assertParse (parseWithState nulljps defaultyeardirectivep "Y 2010\n") assertParse (parseWithState mempty defaultyeardirectivep "Y 2010\n")
assertParse (parseWithState nulljps defaultyeardirectivep "Y 10001\n") assertParse (parseWithState mempty defaultyeardirectivep "Y 10001\n")
,"marketpricedirectivep" ~: ,"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 ,"ignoredpricecommoditydirectivep" ~: do
assertParse (parseWithState nulljps ignoredpricecommoditydirectivep "N $\n") assertParse (parseWithState mempty ignoredpricecommoditydirectivep "N $\n")
,"defaultcommoditydirectivep" ~: do ,"defaultcommoditydirectivep" ~: do
assertParse (parseWithState nulljps defaultcommoditydirectivep "D $1,000.0\n") assertParse (parseWithState mempty defaultcommoditydirectivep "D $1,000.0\n")
,"commodityconversiondirectivep" ~: do ,"commodityconversiondirectivep" ~: do
assertParse (parseWithState nulljps commodityconversiondirectivep "C 1h = $50.00\n") assertParse (parseWithState mempty commodityconversiondirectivep "C 1h = $50.00\n")
,"tagdirectivep" ~: do ,"tagdirectivep" ~: do
assertParse (parseWithState nulljps tagdirectivep "tag foo \n") assertParse (parseWithState mempty tagdirectivep "tag foo \n")
,"endtagdirectivep" ~: do ,"endtagdirectivep" ~: do
assertParse (parseWithState nulljps endtagdirectivep "end tag \n") assertParse (parseWithState mempty endtagdirectivep "end tag \n")
assertParse (parseWithState nulljps endtagdirectivep "pop \n") assertParse (parseWithState mempty endtagdirectivep "pop \n")
,"accountnamep" ~: do ,"accountnamep" ~: do
assertBool "accountnamep parses a normal account name" (isRight $ parsewith accountnamep "a:b:c") 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:") assertBool "accountnamep rejects an empty trailing component" (isLeft $ parsewith accountnamep "a:b:")
,"leftsymbolamountp" ~: do ,"leftsymbolamountp" ~: do
assertParseEqual (parseWithState nulljps leftsymbolamountp "$1") (usd 1 `withPrecision` 0) assertParseEqual (parseWithState mempty 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 nulljps leftsymbolamountp "-$1") (usd (-1) `withPrecision` 0) assertParseEqual (parseWithState mempty leftsymbolamountp "-$1") (usd (-1) `withPrecision` 0)
,"amount" ~: do ,"amount" ~: do
let -- | compare a parse result with an expected amount, showing the debug representation for clarity let -- | compare a parse result with an expected amount, showing the debug representation for clarity
assertAmountParse parseresult amount = assertAmountParse parseresult amount =
(either (const "parse error") showAmountDebug parseresult) ~?= (showAmountDebug 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)) (num 1 `withPrecision` 0 `at` (usd 2 `withPrecision` 0))
]] ]]

27
hledger-lib/Hledger/Read/TimeclockReader.hs
View File

@ -51,9 +51,9 @@ module Hledger.Read.TimeclockReader (
where where
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
import Control.Monad (liftM) import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except (ExceptT) import Control.Monad.Except (ExceptT)
import Data.List (foldl')
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Test.HUnit import Test.HUnit
import Text.Parsec hiding (parse) import Text.Parsec hiding (parse)
@ -61,9 +61,7 @@ import System.FilePath
import Hledger.Data import Hledger.Data
-- XXX too much reuse ? -- XXX too much reuse ?
import Hledger.Read.Common ( import Hledger.Read.Common
emptyorcommentlinep, datetimep, parseAndFinaliseJournal, modifiedaccountnamep, genericSourcePos
)
import Hledger.Utils import Hledger.Utils
@ -85,22 +83,27 @@ detect f s
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal
parse _ = parseAndFinaliseJournal timeclockfilep parse _ = parseAndFinaliseJournal timeclockfilep
timeclockfilep :: ParsecT [Char] JournalParseState (ExceptT String IO) (JournalUpdate, JournalParseState) timeclockfilep :: ErroringJournalParser ParsedJournal
timeclockfilep = do items <- many timeclockitemp timeclockfilep = do many timeclockitemp
eof eof
jps <- getState j@Journal{jtxns=ts, jparsetimeclockentries=es} <- getState
return (liftM (foldl' (\acc new x -> new (acc x)) id) $ sequence items, jps) -- 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 where
-- As all ledger line types can be distinguished by the first -- As all ledger line types can be distinguished by the first
-- character, excepting transactions versus empty (blank or -- character, excepting transactions versus empty (blank or
-- comment-only) lines, can use choice w/o try -- comment-only) lines, can use choice w/o try
timeclockitemp = choice [ timeclockitemp = choice [
emptyorcommentlinep >> return (return id) void emptyorcommentlinep
, liftM (return . addTimeclockEntry) timeclockentryp , timeclockentryp >>= \e -> modifyState (\j -> j{jparsetimeclockentries = e : jparsetimeclockentries j})
] <?> "timeclock entry, or default year or historical price directive" ] <?> "timeclock entry, or default year or historical price directive"
-- | Parse a timeclock entry. -- | Parse a timeclock entry.
timeclockentryp :: ParsecT [Char] JournalParseState (ExceptT String IO) TimeclockEntry timeclockentryp :: ErroringJournalParser TimeclockEntry
timeclockentryp = do timeclockentryp = do
sourcepos <- genericSourcePos <$> getPosition sourcepos <- genericSourcePos <$> getPosition
code <- oneOf "bhioO" code <- oneOf "bhioO"

28
hledger-lib/Hledger/Read/TimedotReader.hs
View File

@ -32,7 +32,7 @@ module Hledger.Read.TimedotReader (
where where
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
import Control.Monad (liftM) import Control.Monad
import Control.Monad.Except (ExceptT) import Control.Monad.Except (ExceptT)
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.List (foldl') import Data.List (foldl')
@ -42,10 +42,7 @@ import Text.Parsec hiding (parse)
import System.FilePath import System.FilePath
import Hledger.Data import Hledger.Data
import Hledger.Read.Common ( import Hledger.Read.Common
datep, numberp, emptyorcommentlinep, followingcommentp,
parseAndFinaliseJournal, modifiedaccountnamep, genericSourcePos
)
import Hledger.Utils hiding (ptrace) import Hledger.Utils hiding (ptrace)
-- easier to toggle this here sometimes -- easier to toggle this here sometimes
@ -69,17 +66,16 @@ detect f s
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal
parse _ = parseAndFinaliseJournal timedotfilep parse _ = parseAndFinaliseJournal timedotfilep
timedotfilep :: ParsecT [Char] JournalParseState (ExceptT String IO) (JournalUpdate, JournalParseState) timedotfilep :: ErroringJournalParser ParsedJournal
timedotfilep = do items <- many timedotfileitemp timedotfilep = do many timedotfileitemp
eof eof
jps <- getState getState
return (liftM (foldl' (\acc new x -> new (acc x)) id) $ sequence items, jps)
where where
timedotfileitemp = do timedotfileitemp = do
ptrace "timedotfileitemp" ptrace "timedotfileitemp"
choice [ choice [
emptyorcommentlinep >> return (return id), void emptyorcommentlinep
liftM (return . addTransactions) timedotdayp ,timedotdayp >>= \ts -> modifyState (addTransactions ts)
] <?> "timedot day entry, or default year or comment line or blank line" ] <?> "timedot day entry, or default year or comment line or blank line"
addTransactions :: [Transaction] -> Journal -> Journal addTransactions :: [Transaction] -> Journal -> Journal
@ -92,7 +88,7 @@ addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts)
-- biz.research . -- biz.research .
-- inc.client1 .... .... .... .... .... .... -- inc.client1 .... .... .... .... .... ....
-- @ -- @
timedotdayp :: ParsecT [Char] JournalParseState (ExceptT String IO) [Transaction] timedotdayp :: ErroringJournalParser [Transaction]
timedotdayp = do timedotdayp = do
ptrace " timedotdayp" ptrace " timedotdayp"
d <- datep <* eolof d <- datep <* eolof
@ -104,7 +100,7 @@ timedotdayp = do
-- @ -- @
-- fos.haskell .... .. -- fos.haskell .... ..
-- @ -- @
timedotentryp :: ParsecT [Char] JournalParseState (ExceptT String IO) Transaction timedotentryp :: ErroringJournalParser Transaction
timedotentryp = do timedotentryp = do
ptrace " timedotentryp" ptrace " timedotentryp"
pos <- genericSourcePos <$> getPosition pos <- genericSourcePos <$> getPosition
@ -128,14 +124,14 @@ timedotentryp = do
} }
return t return t
timedotdurationp :: ParsecT [Char] JournalParseState (ExceptT String IO) Quantity timedotdurationp :: ErroringJournalParser Quantity
timedotdurationp = try timedotnumberp <|> timedotdotsp timedotdurationp = try timedotnumberp <|> timedotdotsp
-- | Parse a duration written as a decimal number of hours (optionally followed by the letter h). -- | Parse a duration written as a decimal number of hours (optionally followed by the letter h).
-- @ -- @
-- 1.5h -- 1.5h
-- @ -- @
timedotnumberp :: ParsecT [Char] JournalParseState (ExceptT String IO) Quantity timedotnumberp :: ErroringJournalParser Quantity
timedotnumberp = do timedotnumberp = do
(q, _, _, _) <- numberp (q, _, _, _) <- numberp
many spacenonewline many spacenonewline
@ -147,7 +143,7 @@ timedotnumberp = do
-- @ -- @
-- .... .. -- .... ..
-- @ -- @
timedotdotsp :: ParsecT [Char] JournalParseState (ExceptT String IO) Quantity timedotdotsp :: ErroringJournalParser Quantity
timedotdotsp = do timedotdotsp = do
dots <- filter (not.isSpace) <$> many (oneOf ". ") dots <- filter (not.isSpace) <$> many (oneOf ". ")
return $ (/4) $ fromIntegral $ length dots return $ (/4) $ fromIntegral $ length dots

10
hledger-lib/Hledger/Utils.hs
View File

@ -32,7 +32,6 @@ module Hledger.Utils (---- provide these frequently used modules - or not, for c
) )
where where
import Control.Monad (liftM) import Control.Monad (liftM)
import Control.Monad.IO.Class (MonadIO, liftIO)
-- import Data.Char -- import Data.Char
-- import Data.List -- import Data.List
-- import Data.Maybe -- 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, -- | Convert a possibly relative, possibly tilde-containing file path to an absolute one,
-- given the current directory. ~username is not supported. Leave "-" unchanged. -- 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 _ "-" = return "-"
expandPath curdir p = (if isRelative p then (curdir </>) else id) `liftM` expandPath' p expandPath curdir p = (if isRelative p then (curdir </>) else id) `liftM` expandPath' p
where where
expandPath' ('~':'/':p) = liftIO $ (</> p) `fmap` getHomeDirectory expandPath' ('~':'/':p) = (</> p) <$> getHomeDirectory
expandPath' ('~':'\\':p) = liftIO $ (</> p) `fmap` getHomeDirectory expandPath' ('~':'\\':p) = (</> p) <$> getHomeDirectory
expandPath' ('~':_) = error' "~USERNAME in paths is not supported" expandPath' ('~':_) = ioError $ userError "~USERNAME in paths is not supported"
expandPath' p = return p expandPath' p = return p
firstJust ms = case dropWhile (==Nothing) ms of firstJust ms = case dropWhile (==Nothing) ms of

2
hledger-web/Foundation.hs
View File

@ -391,7 +391,7 @@ addform _ vd@VD{..} = [hamlet|
where where
amtvar = "amount" ++ show n amtvar = "amount" ++ show n
amtph = "Amount " ++ show n amtph = "Amount " ++ show n
filepaths = map fst $ files j filepaths = map fst $ jfiles j
-- <button .btn style="font-size:18px;" type=submit title="Add this transaction">Add -- <button .btn style="font-size:18px;" type=submit title="Add this transaction">Add

2
hledger-web/Handler/AddForm.hs
View File

@ -96,7 +96,7 @@ postAddForm = do
map fst amtparams `elem` [[1..num], [1..num-1]] = [] map fst amtparams `elem` [[1..num], [1..num-1]] = []
| otherwise = ["the posting parameters are malformed"] | otherwise = ["the posting parameters are malformed"]
eaccts = map (parsewith (accountnamep <* eof) . strip . T.unpack . snd) acctparams eaccts = map (parsewith (accountnamep <* eof) . strip . T.unpack . snd) acctparams
eamts = map (runParser (amountp <* eof) nulljps "" . strip . T.unpack . snd) amtparams eamts = map (runParser (amountp <* eof) mempty "" . strip . T.unpack . snd) amtparams
(accts, acctErrs) = (rights eaccts, map show $ lefts eaccts) (accts, acctErrs) = (rights eaccts, map show $ lefts eaccts)
(amts', amtErrs) = (rights eamts, map show $ lefts eamts) (amts', amtErrs) = (rights eamts, map show $ lefts eamts)
amts | length amts' == num = amts' amts | length amts' == num = amts'

2
hledger/Hledger/Cli.hs
View File

@ -74,7 +74,7 @@ tests_Hledger_Cli = TestList
let ignoresourcepos j = j{jtxns=map (\t -> t{tsourcepos=nullsourcepos}) (jtxns j)} in let ignoresourcepos j = j{jtxns=map (\t -> t{tsourcepos=nullsourcepos}) (jtxns j)} in
let sameParse str1 str2 = do j1 <- readJournal Nothing Nothing True Nothing str1 >>= either error' (return . ignoresourcepos) let sameParse str1 str2 = do j1 <- readJournal Nothing Nothing True Nothing str1 >>= either error' (return . ignoresourcepos)
j2 <- readJournal Nothing Nothing True Nothing str2 >>= either error' (return . ignoresourcepos) j2 <- readJournal Nothing Nothing True Nothing str2 >>= either error' (return . ignoresourcepos)
j1 `is` j2{filereadtime=filereadtime j1, files=files j1, jparsestate=jparsestate j1} j1 `is` j2{jlastreadtime=jlastreadtime j1, jfiles=jfiles j1} --, jparsestate=jparsestate j1}
in TestList in TestList
[ [
"apply account directive 1" ~: sameParse "apply account directive 1" ~: sameParse

12
hledger/Hledger/Cli/Add.hs
View File

@ -181,8 +181,8 @@ dateAndCodeWizard EntryState{..} = do
where where
parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc
where where
edc = runParser (dateandcodep <* eof) nulljps "" $ lowercase s edc = runParser (dateandcodep <* eof) mempty "" $ lowercase s
dateandcodep :: Stream [Char] m t => ParsecT [Char] JournalParseState m (SmartDate, String) dateandcodep :: Monad m => JournalParser m (SmartDate, String)
dateandcodep = do dateandcodep = do
d <- smartdate d <- smartdate
c <- optionMaybe codep c <- optionMaybe codep
@ -245,7 +245,7 @@ accountWizard EntryState{..} = do
parseAccountOrDotOrNull _ _ "." = dbg1 $ Just "." -- . always signals end of txn parseAccountOrDotOrNull _ _ "." = dbg1 $ Just "." -- . always signals end of txn
parseAccountOrDotOrNull "" True "" = dbg1 $ Just "" -- when there's no default and txn is balanced, "" also signals end of txn parseAccountOrDotOrNull "" True "" = dbg1 $ Just "" -- when there's no default and txn is balanced, "" also signals end of txn
parseAccountOrDotOrNull def@(_:_) _ "" = dbg1 $ Just def -- when there's a default, "" means use that parseAccountOrDotOrNull def@(_:_) _ "" = dbg1 $ Just def -- when there's a default, "" means use that
parseAccountOrDotOrNull _ _ s = dbg1 $ either (const Nothing) validateAccount $ runParser (accountnamep <* eof) (jparsestate esJournal) "" s -- otherwise, try to parse the input as an accountname parseAccountOrDotOrNull _ _ s = dbg1 $ either (const Nothing) validateAccount $ runParser (accountnamep <* eof) esJournal "" s -- otherwise, try to parse the input as an accountname
dbg1 = id -- strace dbg1 = id -- strace
validateAccount s | no_new_accounts_ esOpts && not (s `elem` journalAccountNames esJournal) = Nothing validateAccount s | no_new_accounts_ esOpts && not (s `elem` journalAccountNames esJournal) = Nothing
| otherwise = Just s | otherwise = Just s
@ -270,8 +270,8 @@ amountAndCommentWizard EntryState{..} = do
line $ green $ printf "Amount %d%s: " pnum (showDefault def) line $ green $ printf "Amount %d%s: " pnum (showDefault def)
where where
parseAmountAndComment = either (const Nothing) Just . runParser (amountandcommentp <* eof) noDefCommodityJPS "" parseAmountAndComment = either (const Nothing) Just . runParser (amountandcommentp <* eof) noDefCommodityJPS ""
noDefCommodityJPS = (jparsestate esJournal){jpsDefaultCommodityAndStyle=Nothing} noDefCommodityJPS = esJournal{jparsedefaultcommodity=Nothing}
amountandcommentp :: Stream [Char] m t => ParsecT [Char] JournalParseState m (Amount, String) amountandcommentp :: Monad m => JournalParser m (Amount, String)
amountandcommentp = do amountandcommentp = do
a <- amountp a <- amountp
many spacenonewline many spacenonewline
@ -291,7 +291,7 @@ amountAndCommentWizard EntryState{..} = do
-- --
-- let -- (amt,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') amtcmt -- let -- (amt,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') amtcmt
-- a = fromparse $ runParser (amountp <|> return missingamt) (jparsestate esJournal) "" amt -- a = fromparse $ runParser (amountp <|> return missingamt) (jparsestate esJournal) "" amt
-- awithoutjps = fromparse $ runParser (amountp <|> return missingamt) nulljps "" amt -- awithoutjps = fromparse $ runParser (amountp <|> return missingamt) mempty "" amt
-- defamtaccepted = Just (showAmount a) == mdefamt -- defamtaccepted = Just (showAmount a) == mdefamt
-- es2 = if defamtaccepted then es1 else es1{esHistoricalPostings=Nothing} -- es2 = if defamtaccepted then es1 else es1{esHistoricalPostings=Nothing}
-- mdefaultcommodityapplied = if acommodity a == acommodity awithoutjps then Nothing else Just $ acommodity a -- mdefaultcommodityapplied = if acommodity a == acommodity awithoutjps then Nothing else Just $ acommodity a

4
hledger/Hledger/Cli/Utils.hs
View File

@ -129,14 +129,14 @@ journalReloadIfChanged opts _d j = do
-- | Has the journal's main data file changed since the journal was last -- | Has the journal's main data file changed since the journal was last
-- read ? -- read ?
journalFileIsNewer :: Journal -> IO Bool journalFileIsNewer :: Journal -> IO Bool
journalFileIsNewer j@Journal{filereadtime=tread} = do journalFileIsNewer j@Journal{jlastreadtime=tread} = do
tmod <- fileModificationTime $ journalFilePath j tmod <- fileModificationTime $ journalFilePath j
return $ diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0) return $ diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0)
-- | Has the specified file (presumably one of journal's data files) -- | Has the specified file (presumably one of journal's data files)
-- changed since journal was last read ? -- changed since journal was last read ?
journalSpecifiedFileIsNewer :: Journal -> FilePath -> IO Bool journalSpecifiedFileIsNewer :: Journal -> FilePath -> IO Bool
journalSpecifiedFileIsNewer Journal{filereadtime=tread} f = do journalSpecifiedFileIsNewer Journal{jlastreadtime=tread} f = do
tmod <- fileModificationTime f tmod <- fileModificationTime f
return $ diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0) return $ diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0)

6
tests/journal/include.test
View File

@ -28,10 +28,10 @@ include b.timedot
2016/01/01 2016/01/01
(x) 1.00 (x) 1.00
2016/01/01 *
(b.bb) 1.00
2016/01/01 * 12:00-16:00 2016/01/01 * 12:00-16:00
(a:aa) 4.00h (a:aa) 4.00h
2016/01/01 *
(b.bb) 1.00
>>>=0 >>>=0

2
tests/stats/stats.test
View File

@ -9,6 +9,6 @@ hledger -f- stats
<<< <<<
include a.j include a.j
include b.j include b.j
>>> /Included files *: *\.\/a/ >>> /Included files *: *\.\/a\.j/
>>>2 >>>2
>>>=0 >>>=0