mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-19 10:17:35 +03:00
lib: simplify parsers; cleanups (#275)
The journal/timeclock/timedot parsers, instead of constructing (opaque) journal update functions which are later applied to build the journal, now construct the journal directly (by modifying the parser state). This is easier to understand and debug. It also removes any possibility of the journal updates being a space leak. (They weren't, in fact memory usage is now slightly higher, but that will be addressed in other ways.) Also: Journal data and journal parse info have been merged into one type (for now), and field names are more consistent. The ParsedJournal type alias has been added to distinguish being-parsed and finalised journals. Journal is now a monoid. stats: fixed an issue with ordering of include files journal: fixed an issue with ordering of included same-date transactions timeclock: sessions can no longer span file boundaries (unclocked-out sessions will be auto-closed at the end of the file). expandPath now throws a proper IO error (and requires the IO monad).
This commit is contained in:
Simon Michael
parent
4179a83c1d
commit
0f5ee154c4
@ -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
|
||||
|
||||
@ -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 = "<ClockTime>"
|
||||
-- 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
|
||||
|
||||
@ -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 = [
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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))
|
||||
|
||||
]]
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
-- <button .btn style="font-size:18px;" type=submit title="Add this transaction">Add
|
||||
|
||||
|
||||
@ -96,7 +96,7 @@ postAddForm = do
|
||||
map fst amtparams `elem` [[1..num], [1..num-1]] = []
|
||||
| otherwise = ["the posting parameters are malformed"]
|
||||
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)
|
||||
(amts', amtErrs) = (rights eamts, map show $ lefts eamts)
|
||||
amts | length amts' == num = amts'
|
||||
|
||||
@ -74,7 +74,7 @@ tests_Hledger_Cli = TestList
|
||||
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)
|
||||
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
|
||||
[
|
||||
"apply account directive 1" ~: sameParse
|
||||
|
||||
@ -181,8 +181,8 @@ dateAndCodeWizard EntryState{..} = do
|
||||
where
|
||||
parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc
|
||||
where
|
||||
edc = runParser (dateandcodep <* eof) nulljps "" $ lowercase s
|
||||
dateandcodep :: Stream [Char] m t => ParsecT [Char] JournalParseState m (SmartDate, String)
|
||||
edc = runParser (dateandcodep <* eof) mempty "" $ lowercase s
|
||||
dateandcodep :: Monad m => JournalParser m (SmartDate, String)
|
||||
dateandcodep = do
|
||||
d <- smartdate
|
||||
c <- optionMaybe codep
|
||||
@ -245,7 +245,7 @@ accountWizard EntryState{..} = do
|
||||
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 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
|
||||
validateAccount s | no_new_accounts_ esOpts && not (s `elem` journalAccountNames esJournal) = Nothing
|
||||
| otherwise = Just s
|
||||
@ -270,8 +270,8 @@ amountAndCommentWizard EntryState{..} = do
|
||||
line $ green $ printf "Amount %d%s: " pnum (showDefault def)
|
||||
where
|
||||
parseAmountAndComment = either (const Nothing) Just . runParser (amountandcommentp <* eof) noDefCommodityJPS ""
|
||||
noDefCommodityJPS = (jparsestate esJournal){jpsDefaultCommodityAndStyle=Nothing}
|
||||
amountandcommentp :: Stream [Char] m t => ParsecT [Char] JournalParseState m (Amount, String)
|
||||
noDefCommodityJPS = esJournal{jparsedefaultcommodity=Nothing}
|
||||
amountandcommentp :: Monad m => JournalParser m (Amount, String)
|
||||
amountandcommentp = do
|
||||
a <- amountp
|
||||
many spacenonewline
|
||||
@ -291,7 +291,7 @@ amountAndCommentWizard EntryState{..} = do
|
||||
--
|
||||
-- let -- (amt,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') amtcmt
|
||||
-- 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
|
||||
-- es2 = if defamtaccepted then es1 else es1{esHistoricalPostings=Nothing}
|
||||
-- mdefaultcommodityapplied = if acommodity a == acommodity awithoutjps then Nothing else Just $ acommodity a
|
||||
|
||||
@ -129,14 +129,14 @@ journalReloadIfChanged opts _d j = do
|
||||
-- | Has the journal's main data file changed since the journal was last
|
||||
-- read ?
|
||||
journalFileIsNewer :: Journal -> IO Bool
|
||||
journalFileIsNewer j@Journal{filereadtime=tread} = do
|
||||
journalFileIsNewer j@Journal{jlastreadtime=tread} = do
|
||||
tmod <- fileModificationTime $ journalFilePath j
|
||||
return $ diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0)
|
||||
|
||||
-- | Has the specified file (presumably one of journal's data files)
|
||||
-- changed since journal was last read ?
|
||||
journalSpecifiedFileIsNewer :: Journal -> FilePath -> IO Bool
|
||||
journalSpecifiedFileIsNewer Journal{filereadtime=tread} f = do
|
||||
journalSpecifiedFileIsNewer Journal{jlastreadtime=tread} f = do
|
||||
tmod <- fileModificationTime f
|
||||
return $ diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0)
|
||||
|
||||
|
||||
@ -28,10 +28,10 @@ include b.timedot
|
||||
2016/01/01
|
||||
(x) 1.00
|
||||
|
||||
2016/01/01 *
|
||||
(b.bb) 1.00
|
||||
|
||||
2016/01/01 * 12:00-16:00
|
||||
(a:aa) 4.00h
|
||||
|
||||
2016/01/01 *
|
||||
(b.bb) 1.00
|
||||
|
||||
>>>=0
|
||||
|
||||
@ -9,6 +9,6 @@ hledger -f- stats
|
||||
<<<
|
||||
include a.j
|
||||
include b.j
|
||||
>>> /Included files *: *\.\/a/
|
||||
>>> /Included files *: *\.\/a\.j/
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
Loading…
Reference in New Issue
Block a user