diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -40,6 +40,9 @@ module Hledger.Data.Amount where +import qualified Data.Map as Map +import Data.Map (findWithDefault) + import Hledger.Data.Utils import Hledger.Data.Types import Hledger.Data.Commodity @@ -110,11 +113,18 @@ R -> printf "%s%s%s%s" quantity space sym' price where sym' = quoteCommoditySymbolIfNeeded sym - space = if spaced then " " else "" + space = if (spaced && not (null sym')) then " " else "" quantity = showAmount' a price = case pri of (Just pamt) -> " @ " ++ showMixedAmount pamt Nothing -> "" +-- | Get the string representation of an amount, based on its commodity's +-- display settings except using the specified precision. +showAmountWithPrecision :: Int -> Amount -> String +showAmountWithPrecision p = showAmount . setAmountPrecision p + +setAmountPrecision p a@Amount{commodity=c} = a{commodity=c{precision=p}} + -- XXX refactor -- | Get the unambiguous string representation of an amount, for debugging. showAmountDebug :: Amount -> String @@ -125,13 +135,23 @@ showAmountWithoutPrice :: Amount -> String showAmountWithoutPrice a = showAmount a{price=Nothing} --- | Get the string representation (of the number part of) of an amount +-- | Get the string representation of an amount, without any price or commodity symbol. +showAmountWithoutPriceOrCommodity :: Amount -> String +showAmountWithoutPriceOrCommodity a@Amount{commodity=c} = showAmount a{commodity=c{symbol=""}, price=Nothing} + +-- | Get the string representation of the number part of of an amount, +-- using the display precision from its commodity. showAmount' :: Amount -> String -showAmount' (Amount (Commodity {comma=comma,precision=p}) q _) = quantity +showAmount' (Amount (Commodity {comma=comma,precision=p}) q _) = addthousandsseparators $ qstr where - quantity = commad $ printf ("%."++show p++"f") q - commad = if comma then punctuatethousands else id + addthousandsseparators = if comma then punctuatethousands else id + qstr | p == maxprecision && isint q = printf "%d" (round q::Integer) + | p == maxprecision = printf "%f" q + | otherwise = printf ("%."++show p++"f") q + isint n = fromIntegral (round n) == n +maxprecision = 999999 + -- | Add thousands-separating commas to a decimal number string punctuatethousands :: String -> String punctuatethousands s = @@ -145,7 +165,7 @@ -- | Does this amount appear to be zero when displayed with its given precision ? isZeroAmount :: Amount -> Bool -isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPrice +isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPriceOrCommodity -- | Is this amount "really" zero, regardless of the display precision ? -- Since we are using floating point, for now just test to some high precision. @@ -197,6 +217,17 @@ showMixedAmount :: MixedAmount -> String showMixedAmount m = vConcatRightAligned $ map show $ amounts $ normaliseMixedAmount m +setMixedAmountPrecision :: Int -> MixedAmount -> MixedAmount +setMixedAmountPrecision p (Mixed as) = Mixed $ map (setAmountPrecision p) as + +-- | Get the string representation of a mixed amount, showing each of its +-- component amounts with the specified precision, ignoring their +-- commoditys' display precision settings. NB a mixed amount can have an +-- empty amounts list in which case it shows as \"\". +showMixedAmountWithPrecision :: Int -> MixedAmount -> String +showMixedAmountWithPrecision p m = + vConcatRightAligned $ map (showAmountWithPrecision p) $ amounts $ normaliseMixedAmount m + -- | Get an unambiguous string representation of a mixed amount for debugging. showMixedAmountDebug :: MixedAmount -> String showMixedAmountDebug m = printf "Mixed [%s]" as @@ -240,6 +271,21 @@ as' | null nonzeros = [head $ zeros ++ [nullamt]] | otherwise = nonzeros (zeros,nonzeros) = partition isReallyZeroAmount as + +-- | Set a mixed amount's commodity to the canonicalised commodity from +-- the provided commodity map. +canonicaliseMixedAmount :: Maybe (Map.Map String Commodity) -> MixedAmount -> MixedAmount +canonicaliseMixedAmount canonicalcommoditymap (Mixed as) = Mixed $ map (canonicaliseAmount canonicalcommoditymap) as + +-- | Set an amount's commodity to the canonicalised commodity from +-- the provided commodity map. +canonicaliseAmount :: Maybe (Map.Map String Commodity) -> Amount -> Amount +canonicaliseAmount Nothing = id +canonicaliseAmount (Just canonicalcommoditymap) = fixamount + where + -- like journalCanonicaliseAmounts + fixamount a@Amount{commodity=c} = a{commodity=fixcommodity c} + fixcommodity c@Commodity{symbol=s} = findWithDefault c s canonicalcommoditymap -- various sum variants.. diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -258,7 +258,7 @@ > 21 > october, oct > yesterday, today, tomorrow -> (not yet) this/next/last week/day/month/quarter/year +> this/next/last week/day/month/quarter/year Returns a SmartDate, to be converted to a full date later (see fixSmartDate). Assumes any text in the parse stream has been lowercased. diff --git a/Hledger/Data/Journal.hs b/Hledger/Data/Journal.hs --- a/Hledger/Data/Journal.hs +++ b/Hledger/Data/Journal.hs @@ -10,6 +10,7 @@ where import qualified Data.Map as Map import Data.Map (findWithDefault, (!)) +import Safe (headDef) import System.Time (ClockTime(TOD)) import Hledger.Data.Utils import Hledger.Data.Types @@ -17,14 +18,14 @@ import Hledger.Data.Amount import Hledger.Data.Commodity (canonicaliseCommodities) import Hledger.Data.Dates (nulldatespan) -import Hledger.Data.Transaction (journalTransactionWithDate) +import Hledger.Data.Transaction (journalTransactionWithDate,balanceTransaction) import Hledger.Data.Posting import Hledger.Data.TimeLog instance Show Journal where show j = printf "Journal %s with %d transactions, %d accounts: %s" - (filepath j) + (journalFilePath j) (length (jtxns j) + length (jmodifiertxns j) + length (jperiodictxns j)) @@ -40,11 +41,14 @@ , open_timelog_entries = [] , historical_prices = [] , final_comment_lines = [] - , filepath = "" + , jContext = nullctx + , files = [] , filereadtime = TOD 0 0 - , jtext = "" } +nullctx :: JournalContext +nullctx = Ctx { ctxYear = Nothing, ctxCommodity = Nothing, ctxAccount = [] } + nullfilterspec = FilterSpec { datespan=nulldatespan ,cleared=Nothing @@ -57,6 +61,15 @@ ,depth=Nothing } +journalFilePath :: Journal -> FilePath +journalFilePath = fst . mainfile + +journalFilePaths :: Journal -> [FilePath] +journalFilePaths = map fst . files + +mainfile :: Journal -> (FilePath, String) +mainfile = headDef ("", "") . files + addTransaction :: Transaction -> Journal -> Journal addTransaction t l0 = l0 { jtxns = t : jtxns l0 } @@ -212,12 +225,24 @@ j{jtxns=map (journalTransactionWithDate EffectiveDate) $ jtxns j} -- | Do post-parse processing on a journal, to make it ready for use. -journalFinalise :: ClockTime -> LocalTime -> FilePath -> String -> Journal -> Journal -journalFinalise tclock tlocal path txt j = journalCanonicaliseAmounts $ - journalApplyHistoricalPrices $ - journalCloseTimeLogEntries tlocal - j{filepath=path, filereadtime=tclock, jtext=txt} +journalFinalise :: ClockTime -> LocalTime -> FilePath -> String -> JournalContext -> Journal -> Either String Journal +journalFinalise tclock tlocal path txt ctx j@Journal{files=fs} = + journalBalanceTransactions $ + journalCanonicaliseAmounts $ + journalApplyHistoricalPrices $ + journalCloseTimeLogEntries tlocal + j{files=(path,txt):fs, filereadtime=tclock, jContext=ctx} +-- | Fill in any missing amounts and check that all journal transactions +-- balance, or return an error message. This is done after parsing all +-- 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} = + case sequence $ map balance ts of Right ts' -> Right j{jtxns=ts'} + Left e -> Left e + where balance = balanceTransaction (Just $ journalCanonicalCommodities j) + -- | Convert all the journal's amounts to their canonical display -- settings. Ie, all amounts in a given commodity will use (a) the -- display settings of the first, and (b) the greatest precision, of the @@ -229,7 +254,7 @@ 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 a@Amount{commodity=c,price=p} = a{commodity=fixcommodity c, price=maybe Nothing (Just . fixmixedamount) p} + fixamount a@Amount{commodity=c} = a{commodity=fixcommodity c} fixcommodity c@Commodity{symbol=s} = findWithDefault c s canonicalcommoditymap canonicalcommoditymap = journalCanonicalCommodities j @@ -262,14 +287,15 @@ journalConvertAmountsToCost :: Journal -> Journal journalConvertAmountsToCost j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} where + -- similar to journalCanonicaliseAmounts 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 = costOfAmount + fixamount = canonicaliseAmount (Just $ journalCanonicalCommodities j) . costOfAmount -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol. journalCanonicalCommodities :: Journal -> Map.Map String Commodity -journalCanonicalCommodities j = canonicaliseCommodities $ journalAmountAndPriceCommodities j +journalCanonicalCommodities j = canonicaliseCommodities $ journalAmountCommodities j -- | Get all this journal's amounts' commodities, in the order parsed. journalAmountCommodities :: Journal -> [Commodity] diff --git a/Hledger/Data/Posting.hs b/Hledger/Data/Posting.hs --- a/Hledger/Data/Posting.hs +++ b/Hledger/Data/Posting.hs @@ -19,7 +19,7 @@ instance Show Posting where show = showPosting -nullposting = Posting False "" nullmixedamt "" RegularPosting Nothing +nullposting = Posting False "" nullmixedamt "" RegularPosting [] Nothing showPosting :: Posting -> String showPosting (Posting{paccount=a,pamount=amt,pcomment=com,ptype=t}) = diff --git a/Hledger/Data/TimeLog.hs b/Hledger/Data/TimeLog.hs --- a/Hledger/Data/TimeLog.hs +++ b/Hledger/Data/TimeLog.hs @@ -74,6 +74,7 @@ tcode = "", tdescription = showtime itod ++ "-" ++ showtime otod, tcomment = "", + tmetadata = [], tpostings = ps, tpreceding_comment_lines="" } @@ -87,7 +88,7 @@ hrs = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc amount = Mixed [hours hrs] ps = [Posting{pstatus=False,paccount=acctname,pamount=amount, - pcomment="",ptype=VirtualPosting,ptransaction=Just t}] + pcomment="",ptype=VirtualPosting,pmetadata=[],ptransaction=Just t}] tests_TimeLog = TestList [ diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -8,6 +8,8 @@ module Hledger.Data.Transaction where +import qualified Data.Map as Map + import Hledger.Data.Utils import Hledger.Data.Types import Hledger.Data.Dates @@ -31,6 +33,7 @@ tcode="", tdescription="", tcomment="", + tmetadata=[], tpostings=[], tpreceding_comment_lines="" } @@ -74,7 +77,7 @@ showdate = printf "%-10s" . showDate showedate = printf "=%s" . showdate showpostings ps - | elide && length ps > 1 && isTransactionBalanced t + | elide && length ps > 1 && isTransactionBalanced Nothing t -- imprecise balanced check = map showposting (init ps) ++ [showpostingnoamt (last ps)] | otherwise = map showposting ps where @@ -121,20 +124,25 @@ -- | Is this transaction balanced ? A balanced transaction's real -- (non-virtual) postings sum to 0, and any balanced virtual postings -- also sum to 0. -isTransactionBalanced :: Transaction -> Bool -isTransactionBalanced t = isReallyZeroMixedAmountCost rsum && isReallyZeroMixedAmountCost bvsum - where (rsum, _, bvsum) = transactionPostingBalances t +isTransactionBalanced :: Maybe (Map.Map String Commodity) -> Transaction -> Bool +isTransactionBalanced canonicalcommoditymap t = + -- isReallyZeroMixedAmountCost rsum && isReallyZeroMixedAmountCost bvsum + isZeroMixedAmount rsum' && isZeroMixedAmount bvsum' + where + (rsum, _, bvsum) = transactionPostingBalances t + rsum' = canonicaliseMixedAmount canonicalcommoditymap $ costOfMixedAmount rsum + bvsum' = canonicaliseMixedAmount canonicalcommoditymap $ costOfMixedAmount bvsum -- | Ensure that this entry is balanced, possibly auto-filling a missing -- amount first. We can auto-fill if there is just one non-virtual -- transaction without an amount. The auto-filled balance will be -- converted to cost basis if possible. If the entry can not be balanced, -- return an error message instead. -balanceTransaction :: Transaction -> Either String Transaction -balanceTransaction t@Transaction{tpostings=ps} +balanceTransaction :: Maybe (Map.Map String Commodity) -> Transaction -> Either String Transaction +balanceTransaction canonicalcommoditymap t@Transaction{tpostings=ps} | length rwithoutamounts > 1 || length bvwithoutamounts > 1 = Left $ printerr "could not balance this transaction (too many missing amounts)" - | not $ isTransactionBalanced t' = Left $ printerr $ nonzerobalanceerror t' + | not $ isTransactionBalanced canonicalcommoditymap t' = Left $ printerr $ nonzerobalanceerror t' | otherwise = Right t' where rps = filter isReal ps @@ -144,9 +152,9 @@ t' = t{tpostings=map balance ps} where balance p | not (hasAmount p) && isReal p - = p{pamount = costOfMixedAmount (-(sum $ map pamount rwithamounts))} + = p{pamount = (-(sum $ map pamount rwithamounts))} | not (hasAmount p) && isBalancedVirtual p - = p{pamount = costOfMixedAmount (-(sum $ map pamount bvwithamounts))} + = p{pamount = (-(sum $ map pamount bvwithamounts))} | otherwise = p printerr s = intercalate "\n" [s, showTransactionUnelided t] @@ -183,9 +191,9 @@ ," assets:checking" ,"" ]) - (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting (Just t) - ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting (Just t) + (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] (Just t) + ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] (Just t) ] "" in showTransaction t) @@ -197,9 +205,9 @@ ," assets:checking $-47.18" ,"" ]) - (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting (Just t) - ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting (Just t) + (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] (Just t) + ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] (Just t) ] "" in showTransactionUnelided t) @@ -213,9 +221,9 @@ ,"" ]) (showTransaction - (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing - ,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting Nothing + (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing + ,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting [] Nothing ] "")) ,"showTransaction" ~: do @@ -226,8 +234,8 @@ ,"" ]) (showTransaction - (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing + (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing ] "")) ,"showTransaction" ~: do @@ -238,8 +246,8 @@ ,"" ]) (showTransaction - (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" missingamt "" RegularPosting Nothing + (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] + [Posting False "expenses:food:groceries" missingamt "" RegularPosting [] Nothing ] "")) ,"showTransaction" ~: do @@ -251,9 +259,9 @@ ,"" ]) (showTransaction - (txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" - [Posting False "a" (Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])]) "" RegularPosting Nothing - ,Posting False "b" missingamt "" RegularPosting Nothing + (txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" [] + [Posting False "a" (Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])]) "" RegularPosting [] Nothing + ,Posting False "b" missingamt "" RegularPosting [] Nothing ] "")) ] diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -32,12 +32,14 @@ module Hledger.Data.Types where -import Hledger.Data.Utils +import Control.Monad.Error (ErrorT) +import Data.Typeable (Typeable) import qualified Data.Map as Map import System.Time (ClockTime) -import Data.Typeable (Typeable) +import Hledger.Data.Utils + type SmartDate = (String,String,String) data WhichDate = ActualDate | EffectiveDate deriving (Eq,Show) @@ -49,7 +51,7 @@ type AccountName = String -data Side = L | R deriving (Eq,Show,Ord) +data Side = L | R deriving (Eq,Show,Read,Ord) data Commodity = Commodity { symbol :: String, -- ^ the commodity's symbol @@ -58,7 +60,7 @@ spaced :: Bool, -- ^ should there be a space between symbol and quantity comma :: Bool, -- ^ should thousands be comma-separated precision :: Int -- ^ number of decimal places to display - } deriving (Eq,Show,Ord) + } deriving (Eq,Show,Read,Ord) data Amount = Amount { commodity :: Commodity, @@ -77,6 +79,7 @@ pamount :: MixedAmount, pcomment :: String, ptype :: PostingType, + pmetadata :: [(String,String)], ptransaction :: Maybe Transaction -- ^ this posting's parent transaction (co-recursive types). -- Tying this knot gets tedious, Maybe makes it easier/optional. } @@ -84,7 +87,7 @@ -- The equality test for postings ignores the parent transaction's -- identity, to avoid infinite loops. instance Eq Posting where - (==) (Posting a1 b1 c1 d1 e1 _) (Posting a2 b2 c2 d2 e2 _) = a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 + (==) (Posting a1 b1 c1 d1 e1 f1 _) (Posting a2 b2 c2 d2 e2 f2 _) = a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 && f1==f2 data Transaction = Transaction { tdate :: Day, @@ -93,6 +96,7 @@ tcode :: String, tdescription :: String, tcomment :: String, + tmetadata :: [(String,String)], tpostings :: [Posting], -- ^ this transaction's postings (co-recursive types). tpreceding_comment_lines :: String } deriving (Eq) @@ -121,17 +125,43 @@ hamount :: MixedAmount } deriving (Eq) -- & Show (in Amount.hs) +type Year = Integer + +-- | A journal "context" is some data which can change 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 context +-- is saved for later use by eg the add command. +data JournalContext = Ctx { + ctxYear :: !(Maybe Year) -- ^ the default year most recently specified with Y + , ctxCommodity :: !(Maybe Commodity) -- ^ the default commodity most recently specified with D + , ctxAccount :: ![AccountName] -- ^ the current stack of parent accounts specified by !account + } deriving (Read, Show, Eq) + data Journal = Journal { jmodifiertxns :: [ModifierTransaction], jperiodictxns :: [PeriodicTransaction], jtxns :: [Transaction], open_timelog_entries :: [TimeLogEntry], historical_prices :: [HistoricalPrice], - final_comment_lines :: String, - filepath :: FilePath, - filereadtime :: ClockTime, - jtext :: String + final_comment_lines :: String, -- ^ any trailing comments from the journal file + jContext :: JournalContext, -- ^ the context (parse state) at the end of parsing + 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) + +-- | A JournalUpdate is some transformation of a Journal. It can do I/O or +-- raise an error. +type JournalUpdate = ErrorT String IO (Journal -> Journal) + +-- | A hledger journal reader is a triple of format name, format-detecting +-- predicate, and a parser to Journal. +data Reader = Reader {rFormat :: String + ,rDetector :: FilePath -> String -> Bool + ,rParser :: FilePath -> String -> ErrorT String IO Journal + } data Ledger = Ledger { journal :: Journal, diff --git a/Hledger/Data/Utils.hs b/Hledger/Data/Utils.hs --- a/Hledger/Data/Utils.hs +++ b/Hledger/Data/Utils.hs @@ -26,7 +26,6 @@ where import Data.Char import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded) -import Control.Exception import Control.Monad import Data.List --import qualified Data.Map as Map @@ -360,9 +359,6 @@ isRight :: Either a b -> Bool isRight = not . isLeft - -strictReadFile :: FilePath -> IO String -strictReadFile f = readFile f >>= \s -> Control.Exception.evaluate (length s) >> return s -- -- | Expand ~ in a file path (does not handle ~name). -- tildeExpand :: FilePath -> IO FilePath diff --git a/Hledger/Read.hs b/Hledger/Read.hs --- a/Hledger/Read.hs +++ b/Hledger/Read.hs @@ -17,11 +17,11 @@ ) where import Hledger.Data.Dates (getCurrentDay) -import Hledger.Data.Types (Journal(..)) +import Hledger.Data.Types (Journal(..), Reader(..)) +import Hledger.Data.Journal (nullctx) import Hledger.Data.Utils -import Hledger.Read.Common -import Hledger.Read.Journal as Journal -import Hledger.Read.Timelog as Timelog +import Hledger.Read.JournalReader as JournalReader +import Hledger.Read.TimelogReader as TimelogReader import Control.Monad.Error import Data.Either (partitionEithers) @@ -46,8 +46,8 @@ -- Here are the available readers. The first is the default, used for unknown data formats. readers :: [Reader] readers = [ - Journal.reader - ,Timelog.reader + JournalReader.reader + ,TimelogReader.reader ] formats = map rFormat readers @@ -139,10 +139,10 @@ [ "journalFile" ~: do - assertBool "journalFile should parse an empty file" (isRight $ parseWithCtx emptyCtx Journal.journalFile "") + assertBool "journalFile should parse an empty file" (isRight $ parseWithCtx nullctx JournalReader.journalFile "") jE <- readJournal Nothing "" -- don't know how to get it from journalFile either error' (assertBool "journalFile parsing an empty file should give an empty journal" . null . jtxns) jE - ,Journal.tests_Journal - ,Timelog.tests_Timelog + ,JournalReader.tests_JournalReader + ,TimelogReader.tests_TimelogReader ] diff --git a/Hledger/Read/Common.hs b/Hledger/Read/Common.hs deleted file mode 100644 --- a/Hledger/Read/Common.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-| - -Common utilities for hledger data readers, such as the context (state) -that is kept while parsing a journal. - --} - -module Hledger.Read.Common -where - -import Control.Monad.Error -import Hledger.Data.Utils -import Hledger.Data.Types (Journal) -import Hledger.Data.Journal -import System.Directory (getHomeDirectory) -import System.FilePath(takeDirectory,combine) -import System.Time (getClockTime) -import Text.ParserCombinators.Parsec - - --- | A hledger data reader is a triple of format name, format-detecting predicate, and a parser to Journal. -data Reader = Reader {rFormat :: String - ,rDetector :: FilePath -> String -> Bool - ,rParser :: FilePath -> String -> ErrorT String IO Journal - } - --- | A JournalUpdate is some transformation of a "Journal". It can do I/O --- or raise an error. -type JournalUpdate = ErrorT String IO (Journal -> Journal) - --- | 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. -parseJournalWith :: (GenParser Char JournalContext JournalUpdate) -> FilePath -> String -> ErrorT String IO Journal -parseJournalWith p f s = do - tc <- liftIO getClockTime - tl <- liftIO getCurrentLocalTime - case runParser p emptyCtx f s of - Right updates -> liftM (journalFinalise tc tl f s) $ updates `ap` return nulljournal - Left err -> throwError $ show err - --- | Some state kept while parsing a journal file. -data JournalContext = Ctx { - ctxYear :: !(Maybe Integer) -- ^ the default year most recently specified with Y - , ctxCommod :: !(Maybe String) -- ^ I don't know - , ctxAccount :: ![String] -- ^ the current stack of parent accounts specified by !account - } deriving (Read, Show) - -emptyCtx :: JournalContext -emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] } - -setYear :: Integer -> GenParser tok JournalContext () -setYear y = updateState (\ctx -> ctx{ctxYear=Just y}) - -getYear :: GenParser tok JournalContext (Maybe Integer) -getYear = liftM ctxYear getState - -pushParentAccount :: String -> GenParser tok JournalContext () -pushParentAccount parent = updateState addParentAccount - where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 } - normalize = (++ ":") - -popParentAccount :: GenParser tok JournalContext () -popParentAccount = do ctx0 <- getState - case ctxAccount ctx0 of - [] -> unexpected "End of account block with no beginning" - (_:rest) -> setState $ ctx0 { ctxAccount = rest } - -getParentAccount :: GenParser tok JournalContext String -getParentAccount = liftM (concat . reverse . ctxAccount) getState - -expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath -expandPath pos fp = liftM mkRelative (expandHome fp) - where - mkRelative = combine (takeDirectory (sourceName pos)) - expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory - return $ homedir ++ drop 1 inname - | otherwise = return inname - -fileSuffix :: FilePath -> String -fileSuffix = reverse . takeWhile (/='.') . reverse . dropWhile (/='.') diff --git a/Hledger/Read/Journal.hs b/Hledger/Read/Journal.hs deleted file mode 100644 --- a/Hledger/Read/Journal.hs +++ /dev/null @@ -1,647 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| - -A reader for hledger's (and c++ ledger's) journal file format. - -From the ledger 2.5 manual: - -@ -The ledger file format is quite simple, but also very flexible. It supports -many options, though typically the user can ignore most of them. They are -summarized below. The initial character of each line determines what the -line means, and how it should be interpreted. Allowable initial characters -are: - -NUMBER A line beginning with a number denotes an entry. It may be followed by any - number of lines, each beginning with whitespace, to denote the entry’s account - transactions. The format of the first line is: - - DATE[=EDATE] [*|!] [(CODE)] DESC - - If ‘*’ appears after the date (with optional effective date), it indicates the entry - is “cleared”, which can mean whatever the user wants it t omean. If ‘!’ appears - after the date, it indicates d the entry is “pending”; i.e., tentatively cleared from - the user’s point of view, but not yet actually cleared. If a ‘CODE’ appears in - parentheses, it may be used to indicate a check number, or the type of the - transaction. Following these is the payee, or a description of the transaction. - The format of each following transaction is: - - ACCOUNT AMOUNT [; NOTE] - - The ‘ACCOUNT’ may be surrounded by parentheses if it is a virtual - transactions, or square brackets if it is a virtual transactions that must - balance. The ‘AMOUNT’ can be followed by a per-unit transaction cost, - by specifying ‘ AMOUNT’, or a complete transaction cost with ‘\@ AMOUNT’. - Lastly, the ‘NOTE’ may specify an actual and/or effective date for the - transaction by using the syntax ‘[ACTUAL_DATE]’ or ‘[=EFFECTIVE_DATE]’ or - ‘[ACTUAL_DATE=EFFECtIVE_DATE]’. - -= An automated entry. A value expression must appear after the equal sign. - After this initial line there should be a set of one or more transactions, just as - if it were normal entry. If the amounts of the transactions have no commodity, - they will be applied as modifiers to whichever real transaction is matched by - the value expression. - -~ A period entry. A period expression must appear after the tilde. - After this initial line there should be a set of one or more transactions, just as - if it were normal entry. - -! A line beginning with an exclamation mark denotes a command directive. It - must be immediately followed by the command word. The supported commands - are: - - ‘!include’ - Include the stated ledger file. - ‘!account’ - The account name is given is taken to be the parent of all transac- - tions that follow, until ‘!end’ is seen. - ‘!end’ Ends an account block. - -; A line beginning with a colon indicates a comment, and is ignored. - -Y If a line begins with a capital Y, it denotes the year used for all subsequent - entries that give a date without a year. The year should appear immediately - after the Y, for example: ‘Y2004’. This is useful at the beginning of a file, to - specify the year for that file. If all entries specify a year, however, this command - has no effect. - - -P Specifies a historical price for a commodity. These are usually found in a pricing - history file (see the ‘-Q’ option). The syntax is: - - P DATE SYMBOL PRICE - -N SYMBOL Indicates that pricing information is to be ignored for a given symbol, nor will - quotes ever be downloaded for that symbol. Useful with a home currency, such - as the dollar ($). It is recommended that these pricing options be set in the price - database file, which defaults to ‘~/.pricedb’. The syntax for this command is: - - N SYMBOL - - -D AMOUNT Specifies the default commodity to use, by specifying an amount in the expected - format. The entry command will use this commodity as the default when none - other can be determined. This command may be used multiple times, to set - the default flags for different commodities; whichever is seen last is used as the - default commodity. For example, to set US dollars as the default commodity, - while also setting the thousands flag and decimal flag for that commodity, use: - - D $1,000.00 - -C AMOUNT1 = AMOUNT2 - Specifies a commodity conversion, where the first amount is given to be equiv- - alent to the second amount. The first amount should use the decimal precision - desired during reporting: - - C 1.00 Kb = 1024 bytes - -i, o, b, h - These four relate to timeclock support, which permits ledger to read timelog - files. See the timeclock’s documentation for more info on the syntax of its - timelog files. -@ - --} - -module Hledger.Read.Journal ( - tests_Journal, - reader, - journalFile, - someamount, - ledgeraccountname, - ledgerExclamationDirective, - ledgerHistoricalPrice, - ledgerDefaultYear, - emptyLine, - ledgerdatetime, -) -where -import Control.Monad.Error (ErrorT(..), throwError, catchError) -import Data.List.Split (wordsBy) -import Text.ParserCombinators.Parsec hiding (parse) -#if __GLASGOW_HASKELL__ <= 610 -import Prelude hiding (readFile, putStr, putStrLn, print, getContents) -import System.IO.UTF8 -#endif -import System.FilePath -import Hledger.Data.Utils -import Hledger.Data.Types -import Hledger.Data.Dates -import Hledger.Data.AccountName (accountNameFromComponents,accountNameComponents) -import Hledger.Data.Amount -import Hledger.Data.Transaction -import Hledger.Data.Posting -import Hledger.Data.Journal -import Hledger.Data.Commodity (dollars,dollar,unknown,nonsimplecommoditychars) -import Hledger.Read.Common - - --- let's get to it - -reader :: Reader -reader = Reader format detect parse - -format :: String -format = "journal" - --- | Does the given file path and data provide hledger's journal file format ? -detect :: FilePath -> String -> Bool -detect f _ = fileSuffix f == format - --- | Parse and post-process a "Journal" from hledger's journal file --- format, or give an error. -parse :: FilePath -> String -> ErrorT String IO Journal -parse = parseJournalWith journalFile - --- | Top-level journal parser. Returns a single composite, I/O performing, --- error-raising "JournalUpdate" which can be applied to an empty journal --- to get the final result. -journalFile :: GenParser Char JournalContext JournalUpdate -journalFile = do items <- many journalItem - eof - return $ liftM (foldr (.) id) $ sequence items - 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 [ ledgerExclamationDirective - , liftM (return . addTransaction) ledgerTransaction - , liftM (return . addModifierTransaction) ledgerModifierTransaction - , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction - , liftM (return . addHistoricalPrice) ledgerHistoricalPrice - , ledgerDefaultYear - , ledgerIgnoredPriceCommodity - , ledgerTagDirective - , ledgerEndTagDirective - , emptyLine >> return (return id) - ] "journal transaction or directive" - -emptyLine :: GenParser Char st () -emptyLine = do many spacenonewline - optional $ (char ';' "comment") >> many (noneOf "\n") - newline - return () - -ledgercomment :: GenParser Char st String -ledgercomment = do - many1 $ char ';' - many spacenonewline - many (noneOf "\n") - "comment" - -ledgercommentline :: GenParser Char st String -ledgercommentline = do - many spacenonewline - s <- ledgercomment - optional newline - eof - return s - "comment" - -ledgerExclamationDirective :: GenParser Char JournalContext JournalUpdate -ledgerExclamationDirective = do - char '!' "directive" - directive <- many nonspace - case directive of - "include" -> ledgerInclude - "account" -> ledgerAccountBegin - "end" -> ledgerAccountEnd - _ -> mzero - -ledgerInclude :: GenParser Char JournalContext JournalUpdate -ledgerInclude = do many1 spacenonewline - filename <- restofline - outerState <- getState - outerPos <- getPosition - let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n" - return $ do contents <- expandPath outerPos filename >>= readFileE outerPos - case runParser journalFile outerState (combine ((takeDirectory . sourceName) outerPos) filename) contents of - Right l -> l `catchError` (throwError . (inIncluded ++)) - Left perr -> throwError $ inIncluded ++ show perr - where readFileE outerPos filename = ErrorT $ liftM Right (readFile filename) `catch` leftError - where leftError err = return $ Left $ currentPos ++ whileReading ++ show err - currentPos = show outerPos - whileReading = " reading " ++ show filename ++ ":\n" - -ledgerAccountBegin :: GenParser Char JournalContext JournalUpdate -ledgerAccountBegin = do many1 spacenonewline - parent <- ledgeraccountname - newline - pushParentAccount parent - return $ return id - -ledgerAccountEnd :: GenParser Char JournalContext JournalUpdate -ledgerAccountEnd = popParentAccount >> return (return id) - -ledgerModifierTransaction :: GenParser Char JournalContext ModifierTransaction -ledgerModifierTransaction = do - char '=' "modifier transaction" - many spacenonewline - valueexpr <- restofline - postings <- ledgerpostings - return $ ModifierTransaction valueexpr postings - -ledgerPeriodicTransaction :: GenParser Char JournalContext PeriodicTransaction -ledgerPeriodicTransaction = do - char '~' "periodic transaction" - many spacenonewline - periodexpr <- restofline - postings <- ledgerpostings - return $ PeriodicTransaction periodexpr postings - -ledgerHistoricalPrice :: GenParser Char JournalContext HistoricalPrice -ledgerHistoricalPrice = do - char 'P' "historical price" - many spacenonewline - date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate -- a time is ignored - many1 spacenonewline - symbol <- commoditysymbol - many spacenonewline - price <- someamount - restofline - return $ HistoricalPrice date symbol price - -ledgerIgnoredPriceCommodity :: GenParser Char JournalContext JournalUpdate -ledgerIgnoredPriceCommodity = do - char 'N' "ignored-price commodity" - many1 spacenonewline - commoditysymbol - restofline - return $ return id - -ledgerDefaultCommodity :: GenParser Char JournalContext JournalUpdate -ledgerDefaultCommodity = do - char 'D' "default commodity" - many1 spacenonewline - someamount - restofline - return $ return id - -ledgerCommodityConversion :: GenParser Char JournalContext JournalUpdate -ledgerCommodityConversion = do - char 'C' "commodity conversion" - many1 spacenonewline - someamount - many spacenonewline - char '=' - many spacenonewline - someamount - restofline - return $ return id - -ledgerTagDirective :: GenParser Char JournalContext JournalUpdate -ledgerTagDirective = do - string "tag" "tag directive" - many1 spacenonewline - _ <- many1 nonspace - restofline - return $ return id - -ledgerEndTagDirective :: GenParser Char JournalContext JournalUpdate -ledgerEndTagDirective = do - string "end tag" "end tag directive" - restofline - return $ return id - --- like ledgerAccountBegin, updates the JournalContext -ledgerDefaultYear :: GenParser Char JournalContext JournalUpdate -ledgerDefaultYear = do - char 'Y' "default year" - many spacenonewline - y <- many1 digit - let y' = read y - failIfInvalidYear y - setYear y' - return $ return id - --- | Try to parse a ledger entry. If we successfully parse an entry, --- check it can be balanced, and fail if not. -ledgerTransaction :: GenParser Char JournalContext Transaction -ledgerTransaction = do - date <- ledgerdate "transaction" - edate <- optionMaybe (ledgereffectivedate date) "effective date" - status <- ledgerstatus "cleared flag" - code <- ledgercode "transaction code" - (description, comment) <- - (do {many1 spacenonewline; d <- liftM rstrip (many (noneOf ";\n")); c <- ledgercomment <|> return ""; newline; return (d, c)} <|> - do {many spacenonewline; c <- ledgercomment <|> return ""; newline; return ("", c)} - ) "description and/or comment" - postings <- ledgerpostings - let t = txnTieKnot $ Transaction date edate status code description comment postings "" - case balanceTransaction t of - Right t' -> return t' - Left err -> fail err - -ledgerdate :: GenParser Char JournalContext Day -ledgerdate = do - -- hacky: try to ensure precise errors for invalid dates - -- XXX reported error position is not too good - -- pos <- getPosition - datestr <- many1 $ choice' [digit, datesepchar] - let dateparts = wordsBy (`elem` datesepchars) datestr - case dateparts of - [y,m,d] -> do - failIfInvalidYear y - failIfInvalidMonth m - failIfInvalidDay d - return $ fromGregorian (read y) (read m) (read d) - [m,d] -> do - y <- getYear - case y of Nothing -> fail "partial date found, but no default year specified" - Just y' -> do failIfInvalidYear $ show y' - failIfInvalidMonth m - failIfInvalidDay d - return $ fromGregorian y' (read m) (read d) - _ -> fail $ "bad date: " ++ datestr - "full or partial date" - -ledgerdatetime :: GenParser Char JournalContext LocalTime -ledgerdatetime = do - day <- ledgerdate - many1 spacenonewline - h <- many1 digit - char ':' - m <- many1 digit - s <- optionMaybe $ do - char ':' - many1 digit - let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s) - return $ LocalTime day tod - -ledgereffectivedate :: Day -> GenParser Char JournalContext Day -ledgereffectivedate actualdate = do - char '=' - -- kludgy way to use actual date for default year - let withDefaultYear d p = do - y <- getYear - let (y',_,_) = toGregorian d in setYear y' - r <- p - when (isJust y) $ setYear $ fromJust y - return r - edate <- withDefaultYear actualdate ledgerdate - return edate - -ledgerstatus :: GenParser Char st Bool -ledgerstatus = try (do { many1 spacenonewline; char '*' "status"; return True } ) <|> return False - -ledgercode :: GenParser Char st String -ledgercode = try (do { many1 spacenonewline; char '(' "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" - -ledgerpostings :: GenParser Char JournalContext [Posting] -ledgerpostings = do - -- complicated to handle intermixed comment lines.. please make me better. - ctx <- getState - let parses p = isRight . parseWithCtx ctx p - -- parse the following non-comment whitespace-beginning lines as postings - -- make sure the sub-parse starts from the current position, for useful errors - pos <- getPosition - ls <- many1 $ try linebeginningwithspaces - let ls' = filter (not . (ledgercommentline `parses`)) ls - when (null ls') $ fail "no postings" - return $ map (fromparse . parseWithCtx ctx (setPosition pos >> ledgerposting)) ls' - "postings" - -linebeginningwithspaces :: GenParser Char st String -linebeginningwithspaces = do - sp <- many1 spacenonewline - c <- nonspace - cs <- restofline - return $ sp ++ (c:cs) ++ "\n" - -ledgerposting :: GenParser Char JournalContext Posting -ledgerposting = do - many1 spacenonewline - status <- ledgerstatus - account <- transactionaccountname - let (ptype, account') = (postingTypeFromAccountName account, unbracket account) - amount <- postingamount - many spacenonewline - comment <- ledgercomment <|> return "" - newline - return (Posting status account' amount comment ptype Nothing) - --- qualify with the parent account from parsing context -transactionaccountname :: GenParser Char JournalContext AccountName -transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname - --- | Parse an account name. Account names may have single spaces inside --- them, and are terminated by two or more spaces. They should have one or --- more components of at least one character, separated by the account --- separator char. -ledgeraccountname :: GenParser Char st AccountName -ledgeraccountname = do - a <- many1 (nonspace <|> singlespace) - let a' = striptrailingspace a - when (accountNameFromComponents (accountNameComponents a') /= a') - (fail $ "accountname seems ill-formed: "++a') - return a' - where - singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}) - -- couldn't avoid consuming a final space sometimes, harmless - striptrailingspace s = if last s == ' ' then init s else s - --- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace --- "account name character (non-bracket, non-parenthesis, non-whitespace)" - --- | Parse an amount, with an optional left or right currency symbol and --- optional price. -postingamount :: GenParser Char st MixedAmount -postingamount = - try (do - many1 spacenonewline - someamount <|> return missingamt - ) <|> return missingamt - -someamount :: GenParser Char st MixedAmount -someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount - -leftsymbolamount :: GenParser Char st MixedAmount -leftsymbolamount = do - sign <- optionMaybe $ string "-" - let applysign = if isJust sign then negate else id - sym <- commoditysymbol - sp <- many spacenonewline - (q,p,comma) <- amountquantity - pri <- priceamount - let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,comma=comma,precision=p} - return $ applysign $ Mixed [Amount c q pri] - "left-symbol amount" - -rightsymbolamount :: GenParser Char st MixedAmount -rightsymbolamount = do - (q,p,comma) <- amountquantity - sp <- many spacenonewline - sym <- commoditysymbol - pri <- priceamount - let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,comma=comma,precision=p} - return $ Mixed [Amount c q pri] - "right-symbol amount" - -nosymbolamount :: GenParser Char st MixedAmount -nosymbolamount = do - (q,p,comma) <- amountquantity - pri <- priceamount - let c = Commodity {symbol="",side=L,spaced=False,comma=comma,precision=p} - return $ Mixed [Amount c q pri] - "no-symbol amount" - -commoditysymbol :: GenParser Char st String -commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) "commodity symbol" - -quotedcommoditysymbol :: GenParser Char st String -quotedcommoditysymbol = do - char '"' - s <- many1 $ noneOf ";\n\"" - char '"' - return s - -simplecommoditysymbol :: GenParser Char st String -simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars) - -priceamount :: GenParser Char st (Maybe MixedAmount) -priceamount = - try (do - many spacenonewline - char '@' - many spacenonewline - a <- someamount -- XXX could parse more prices ad infinitum, shouldn't - return $ Just a - ) <|> return Nothing - --- gawd.. trying to parse a ledger number without error: - --- | Parse a ledger-style numeric quantity and also return the number of --- digits to the right of the decimal point and whether thousands are --- separated by comma. -amountquantity :: GenParser Char st (Double, Int, Bool) -amountquantity = do - sign <- optionMaybe $ string "-" - (intwithcommas,frac) <- numberparts - let comma = ',' `elem` intwithcommas - let precision = length frac - -- read the actual value. We expect this read to never fail. - let int = filter (/= ',') intwithcommas - let int' = if null int then "0" else int - let frac' = if null frac then "0" else frac - let sign' = fromMaybe "" sign - let quantity = read $ sign'++int'++"."++frac' - return (quantity, precision, comma) - "commodity quantity" - --- | parse the two strings of digits before and after a possible decimal --- point. The integer part may contain commas, or either part may be --- empty, or there may be no point. -numberparts :: GenParser Char st (String,String) -numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint - -numberpartsstartingwithdigit :: GenParser Char st (String,String) -numberpartsstartingwithdigit = do - let digitorcomma = digit <|> char ',' - first <- digit - rest <- many digitorcomma - frac <- try (do {char '.'; many digit}) <|> return "" - return (first:rest,frac) - -numberpartsstartingwithpoint :: GenParser Char st (String,String) -numberpartsstartingwithpoint = do - char '.' - frac <- many1 digit - return ("",frac) - - -tests_Journal = TestList [ - - "ledgerTransaction" ~: do - assertParseEqual (parseWithCtx emptyCtx ledgerTransaction entry1_str) entry1 - assertBool "ledgerTransaction should not parse just a date" - $ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1\n" - assertBool "ledgerTransaction should require some postings" - $ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a\n" - let t = parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a ;comment\n b 1\n" - assertBool "ledgerTransaction should not include a comment in the description" - $ either (const False) ((== "a") . tdescription) t - - ,"ledgerModifierTransaction" ~: do - assertParse (parseWithCtx emptyCtx ledgerModifierTransaction "= (some value expr)\n some:postings 1\n") - - ,"ledgerPeriodicTransaction" ~: do - assertParse (parseWithCtx emptyCtx ledgerPeriodicTransaction "~ (some period expr)\n some:postings 1\n") - - ,"ledgerExclamationDirective" ~: do - assertParse (parseWithCtx emptyCtx ledgerExclamationDirective "!include /some/file.x\n") - assertParse (parseWithCtx emptyCtx ledgerExclamationDirective "!account some:account\n") - assertParse (parseWithCtx emptyCtx (ledgerExclamationDirective >> ledgerExclamationDirective) "!account a\n!end\n") - - ,"ledgercommentline" ~: do - assertParse (parseWithCtx emptyCtx ledgercommentline "; some comment \n") - assertParse (parseWithCtx emptyCtx ledgercommentline " \t; x\n") - assertParse (parseWithCtx emptyCtx ledgercommentline ";x") - - ,"ledgerDefaultYear" ~: do - assertParse (parseWithCtx emptyCtx ledgerDefaultYear "Y 2010\n") - assertParse (parseWithCtx emptyCtx ledgerDefaultYear "Y 10001\n") - - ,"ledgerHistoricalPrice" ~: - assertParseEqual (parseWithCtx emptyCtx ledgerHistoricalPrice "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55]) - - ,"ledgerIgnoredPriceCommodity" ~: do - assertParse (parseWithCtx emptyCtx ledgerIgnoredPriceCommodity "N $\n") - - ,"ledgerDefaultCommodity" ~: do - assertParse (parseWithCtx emptyCtx ledgerDefaultCommodity "D $1,000.0\n") - - ,"ledgerCommodityConversion" ~: do - assertParse (parseWithCtx emptyCtx ledgerCommodityConversion "C 1h = $50.00\n") - - ,"ledgerTagDirective" ~: do - assertParse (parseWithCtx emptyCtx ledgerTagDirective "tag foo \n") - - ,"ledgerEndTagDirective" ~: do - assertParse (parseWithCtx emptyCtx ledgerEndTagDirective "end tag \n") - - ,"ledgeraccountname" ~: do - assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c") - assertBool "ledgeraccountname rejects an empty inner component" (isLeft $ parsewith ledgeraccountname "a::c") - assertBool "ledgeraccountname rejects an empty leading component" (isLeft $ parsewith ledgeraccountname ":b:c") - assertBool "ledgeraccountname rejects an empty trailing component" (isLeft $ parsewith ledgeraccountname "a:b:") - - ,"ledgerposting" ~: do - assertParseEqual (parseWithCtx emptyCtx ledgerposting " expenses:food:dining $10.00\n") - (Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting Nothing) - assertBool "ledgerposting parses a quoted commodity with numbers" - (isRight $ parseWithCtx emptyCtx ledgerposting " a 1 \"DE123\"\n") - - ,"someamount" ~: do - let -- | compare a parse result with a MixedAmount, showing the debug representation for clarity - assertMixedAmountParse parseresult mixedamount = - (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount) - assertMixedAmountParse (parsewith someamount "1 @ $2") - (Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])]) - - ,"postingamount" ~: do - assertParseEqual (parseWithCtx emptyCtx postingamount " $47.18") (Mixed [dollars 47.18]) - assertParseEqual (parseWithCtx emptyCtx postingamount " $1.") - (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing]) - - ,"leftsymbolamount" ~: do - assertParseEqual (parseWithCtx emptyCtx leftsymbolamount "$1") - (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing]) - assertParseEqual (parseWithCtx emptyCtx leftsymbolamount "$-1") - (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} (-1) Nothing]) - assertParseEqual (parseWithCtx emptyCtx leftsymbolamount "-$1") - (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} (-1) Nothing]) - - ] - -entry1_str = unlines - ["2007/01/28 coopportunity" - ," expenses:food:groceries $47.18" - ," assets:checking $-47.18" - ,"" - ] - -entry1 = - txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing, - Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting Nothing] "" - diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs new file mode 100644 --- /dev/null +++ b/Hledger/Read/JournalReader.hs @@ -0,0 +1,681 @@ +{-# LANGUAGE CPP #-} +{-| + +A reader for hledger's (and c++ ledger's) journal file format. + +From the ledger 2.5 manual: + +@ +The ledger file format is quite simple, but also very flexible. It supports +many options, though typically the user can ignore most of them. They are +summarized below. The initial character of each line determines what the +line means, and how it should be interpreted. Allowable initial characters +are: + +NUMBER A line beginning with a number denotes an entry. It may be followed by any + number of lines, each beginning with whitespace, to denote the entry’s account + transactions. The format of the first line is: + + DATE[=EDATE] [*|!] [(CODE)] DESC + + If ‘*’ appears after the date (with optional effective date), it indicates the entry + is “cleared”, which can mean whatever the user wants it t omean. If ‘!’ appears + after the date, it indicates d the entry is “pending”; i.e., tentatively cleared from + the user’s point of view, but not yet actually cleared. If a ‘CODE’ appears in + parentheses, it may be used to indicate a check number, or the type of the + transaction. Following these is the payee, or a description of the transaction. + The format of each following transaction is: + + ACCOUNT AMOUNT [; NOTE] + + The ‘ACCOUNT’ may be surrounded by parentheses if it is a virtual + transactions, or square brackets if it is a virtual transactions that must + balance. The ‘AMOUNT’ can be followed by a per-unit transaction cost, + by specifying ‘ AMOUNT’, or a complete transaction cost with ‘\@ AMOUNT’. + Lastly, the ‘NOTE’ may specify an actual and/or effective date for the + transaction by using the syntax ‘[ACTUAL_DATE]’ or ‘[=EFFECTIVE_DATE]’ or + ‘[ACTUAL_DATE=EFFECtIVE_DATE]’. + += An automated entry. A value expression must appear after the equal sign. + After this initial line there should be a set of one or more transactions, just as + if it were normal entry. If the amounts of the transactions have no commodity, + they will be applied as modifiers to whichever real transaction is matched by + the value expression. + +~ A period entry. A period expression must appear after the tilde. + After this initial line there should be a set of one or more transactions, just as + if it were normal entry. + +! A line beginning with an exclamation mark denotes a command directive. It + must be immediately followed by the command word. The supported commands + are: + + ‘!include’ + Include the stated ledger file. + ‘!account’ + The account name is given is taken to be the parent of all transac- + tions that follow, until ‘!end’ is seen. + ‘!end’ Ends an account block. + +; A line beginning with a colon indicates a comment, and is ignored. + +Y If a line begins with a capital Y, it denotes the year used for all subsequent + entries that give a date without a year. The year should appear immediately + after the Y, for example: ‘Y2004’. This is useful at the beginning of a file, to + specify the year for that file. If all entries specify a year, however, this command + has no effect. + + +P Specifies a historical price for a commodity. These are usually found in a pricing + history file (see the ‘-Q’ option). The syntax is: + + P DATE SYMBOL PRICE + +N SYMBOL Indicates that pricing information is to be ignored for a given symbol, nor will + quotes ever be downloaded for that symbol. Useful with a home currency, such + as the dollar ($). It is recommended that these pricing options be set in the price + database file, which defaults to ‘~/.pricedb’. The syntax for this command is: + + N SYMBOL + + +D AMOUNT Specifies the default commodity to use, by specifying an amount in the expected + format. The entry command will use this commodity as the default when none + other can be determined. This command may be used multiple times, to set + the default flags for different commodities; whichever is seen last is used as the + default commodity. For example, to set US dollars as the default commodity, + while also setting the thousands flag and decimal flag for that commodity, use: + + D $1,000.00 + +C AMOUNT1 = AMOUNT2 + Specifies a commodity conversion, where the first amount is given to be equiv- + alent to the second amount. The first amount should use the decimal precision + desired during reporting: + + C 1.00 Kb = 1024 bytes + +i, o, b, h + These four relate to timeclock support, which permits ledger to read timelog + files. See the timeclock’s documentation for more info on the syntax of its + timelog files. +@ + +-} + +module Hledger.Read.JournalReader ( + tests_JournalReader, + reader, + journalFile, + journalAddFile, + someamount, + ledgeraccountname, + ledgerExclamationDirective, + ledgerHistoricalPrice, + ledgerDefaultYear, + emptyLine, + ledgerdatetime, +) +where +import Control.Monad.Error (ErrorT(..), throwError, catchError) +import Data.List.Split (wordsBy) +import Text.ParserCombinators.Parsec hiding (parse) +#if __GLASGOW_HASKELL__ <= 610 +import Prelude hiding (readFile, putStr, putStrLn, print, getContents) +import System.IO.UTF8 +#endif + +import Hledger.Data +import Hledger.Read.Utils + + +-- let's get to it + +reader :: Reader +reader = Reader format detect parse + +format :: String +format = "journal" + +-- | Does the given file path and data provide hledger's journal file format ? +detect :: FilePath -> String -> Bool +detect f _ = fileSuffix f == format + +-- | Parse and post-process a "Journal" from hledger's journal file +-- format, or give an error. +parse :: FilePath -> String -> ErrorT String IO Journal +parse = parseJournalWith journalFile + +-- | Top-level journal parser. Returns a single composite, I/O performing, +-- error-raising "JournalUpdate" (and final "JournalContext") which can be +-- applied to an empty journal to get the final result. +journalFile :: GenParser Char JournalContext (JournalUpdate,JournalContext) +journalFile = do + journalupdates <- many journalItem + eof + finalctx <- getState + return $ (juSequence journalupdates, finalctx) + 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 [ ledgerExclamationDirective + , liftM (return . addTransaction) ledgerTransaction + , liftM (return . addModifierTransaction) ledgerModifierTransaction + , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction + , liftM (return . addHistoricalPrice) ledgerHistoricalPrice + , ledgerDefaultYear + , ledgerDefaultCommodity + , ledgerCommodityConversion + , ledgerIgnoredPriceCommodity + , ledgerTagDirective + , ledgerEndTagDirective + , emptyLine >> return (return id) + ] "journal transaction or directive" + +journalAddFile :: (FilePath,String) -> Journal -> Journal +journalAddFile f j@Journal{files=fs} = j{files=fs++[f]} + +emptyLine :: GenParser Char JournalContext () +emptyLine = do many spacenonewline + optional $ (char ';' "comment") >> many (noneOf "\n") + newline + return () + +ledgercomment :: GenParser Char JournalContext String +ledgercomment = do + many1 $ char ';' + many spacenonewline + many (noneOf "\n") + "comment" + +ledgercommentline :: GenParser Char JournalContext String +ledgercommentline = do + many spacenonewline + s <- ledgercomment + optional newline + eof + return s + "comment" + +ledgerExclamationDirective :: GenParser Char JournalContext JournalUpdate +ledgerExclamationDirective = do + char '!' "directive" + directive <- many nonspace + case directive of + "include" -> ledgerInclude + "account" -> ledgerAccountBegin + "end" -> ledgerAccountEnd + _ -> mzero + +ledgerInclude :: GenParser Char JournalContext JournalUpdate +ledgerInclude = do + many1 spacenonewline + filename <- restofline + outerState <- getState + outerPos <- getPosition + return $ do filepath <- expandPath outerPos filename + txt <- readFileOrError outerPos filepath + let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n" + case runParser journalFile outerState filepath txt of + Right (ju,_) -> juSequence [return $ journalAddFile (filepath,txt), ju] `catchError` (throwError . (inIncluded ++)) + Left err -> throwError $ inIncluded ++ show err + where readFileOrError pos fp = + ErrorT $ liftM Right (readFile fp) `catch` + \err -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show err) + +ledgerAccountBegin :: GenParser Char JournalContext JournalUpdate +ledgerAccountBegin = do many1 spacenonewline + parent <- ledgeraccountname + newline + pushParentAccount parent + return $ return id + +ledgerAccountEnd :: GenParser Char JournalContext JournalUpdate +ledgerAccountEnd = popParentAccount >> return (return id) + +ledgerModifierTransaction :: GenParser Char JournalContext ModifierTransaction +ledgerModifierTransaction = do + char '=' "modifier transaction" + many spacenonewline + valueexpr <- restofline + postings <- ledgerpostings + return $ ModifierTransaction valueexpr postings + +ledgerPeriodicTransaction :: GenParser Char JournalContext PeriodicTransaction +ledgerPeriodicTransaction = do + char '~' "periodic transaction" + many spacenonewline + periodexpr <- restofline + postings <- ledgerpostings + return $ PeriodicTransaction periodexpr postings + +ledgerHistoricalPrice :: GenParser Char JournalContext HistoricalPrice +ledgerHistoricalPrice = do + char 'P' "historical price" + many spacenonewline + date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate -- a time is ignored + many1 spacenonewline + symbol <- commoditysymbol + many spacenonewline + price <- someamount + restofline + return $ HistoricalPrice date symbol price + +ledgerIgnoredPriceCommodity :: GenParser Char JournalContext JournalUpdate +ledgerIgnoredPriceCommodity = do + char 'N' "ignored-price commodity" + many1 spacenonewline + commoditysymbol + restofline + return $ return id + +ledgerCommodityConversion :: GenParser Char JournalContext JournalUpdate +ledgerCommodityConversion = do + char 'C' "commodity conversion" + many1 spacenonewline + someamount + many spacenonewline + char '=' + many spacenonewline + someamount + restofline + return $ return id + +ledgerTagDirective :: GenParser Char JournalContext JournalUpdate +ledgerTagDirective = do + string "tag" "tag directive" + many1 spacenonewline + _ <- many1 nonspace + restofline + return $ return id + +ledgerEndTagDirective :: GenParser Char JournalContext JournalUpdate +ledgerEndTagDirective = do + string "end tag" "end tag directive" + restofline + return $ return id + +-- like ledgerAccountBegin, updates the JournalContext +ledgerDefaultYear :: GenParser Char JournalContext JournalUpdate +ledgerDefaultYear = do + char 'Y' "default year" + many spacenonewline + y <- many1 digit + let y' = read y + failIfInvalidYear y + setYear y' + return $ return id + +ledgerDefaultCommodity :: GenParser Char JournalContext JournalUpdate +ledgerDefaultCommodity = do + char 'D' "default commodity" + many1 spacenonewline + a <- someamount + -- someamount always returns a MixedAmount containing one Amount, but let's be safe + let as = amounts a + when (not $ null as) $ setCommodity $ commodity $ head as + restofline + return $ return id + +-- | Try to parse a ledger entry. If we successfully parse an entry, +-- check it can be balanced, and fail if not. +ledgerTransaction :: GenParser Char JournalContext Transaction +ledgerTransaction = do + date <- ledgerdate "transaction" + edate <- optionMaybe (ledgereffectivedate date) "effective date" + status <- ledgerstatus "cleared flag" + code <- ledgercode "transaction code" + (description, comment) <- + (do {many1 spacenonewline; d <- liftM rstrip (many (noneOf ";\n")); c <- ledgercomment <|> return ""; newline; return (d, c)} <|> + do {many spacenonewline; c <- ledgercomment <|> return ""; newline; return ("", c)} + ) "description and/or comment" + md <- try ledgermetadata <|> return [] + postings <- ledgerpostings + let t = txnTieKnot $ Transaction date edate status code description comment md postings "" + -- case balanceTransaction Nothing t of + -- Right t' -> return t' + -- Left err -> fail err + -- check it later, after we have worked out commodity display precisions + return t + +ledgerdate :: GenParser Char JournalContext Day +ledgerdate = do + -- hacky: try to ensure precise errors for invalid dates + -- XXX reported error position is not too good + -- pos <- getPosition + datestr <- many1 $ choice' [digit, datesepchar] + let dateparts = wordsBy (`elem` datesepchars) datestr + case dateparts of + [y,m,d] -> do + failIfInvalidYear y + failIfInvalidMonth m + failIfInvalidDay d + return $ fromGregorian (read y) (read m) (read d) + [m,d] -> do + y <- getYear + case y of Nothing -> fail "partial date found, but no default year specified" + Just y' -> do failIfInvalidYear $ show y' + failIfInvalidMonth m + failIfInvalidDay d + return $ fromGregorian y' (read m) (read d) + _ -> fail $ "bad date: " ++ datestr + "full or partial date" + +ledgerdatetime :: GenParser Char JournalContext LocalTime +ledgerdatetime = do + day <- ledgerdate + many1 spacenonewline + h <- many1 digit + char ':' + m <- many1 digit + s <- optionMaybe $ do + char ':' + many1 digit + let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s) + return $ LocalTime day tod + +ledgereffectivedate :: Day -> GenParser Char JournalContext Day +ledgereffectivedate actualdate = do + char '=' + -- kludgy way to use actual date for default year + let withDefaultYear d p = do + y <- getYear + let (y',_,_) = toGregorian d in setYear y' + r <- p + when (isJust y) $ setYear $ fromJust y + return r + edate <- withDefaultYear actualdate ledgerdate + return edate + +ledgerstatus :: GenParser Char JournalContext Bool +ledgerstatus = try (do { many spacenonewline; char '*' "status"; return True } ) <|> return False + +ledgercode :: GenParser Char JournalContext String +ledgercode = try (do { many1 spacenonewline; char '(' "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" + +ledgermetadata :: GenParser Char JournalContext [(String,String)] +ledgermetadata = many ledgermetadataline + +-- a comment line containing a metadata declaration, eg: +-- ; name: value +ledgermetadataline :: GenParser Char JournalContext (String,String) +ledgermetadataline = do + many1 spacenonewline + many1 $ char ';' + many spacenonewline + name <- many1 $ noneOf ": \t" + char ':' + many spacenonewline + value <- many (noneOf "\n") + optional newline +-- eof + return (name,value) + "metadata line" + +-- Parse the following whitespace-beginning lines as postings, posting metadata, and/or comments. +-- complicated to handle intermixed comment and metadata lines.. make me better ? +ledgerpostings :: GenParser Char JournalContext [Posting] +ledgerpostings = do + ctx <- getState + -- pass current position to the sub-parses for more useful errors + pos <- getPosition + ls <- many1 $ try linebeginningwithspaces + let parses p = isRight . parseWithCtx ctx p + postinglines = filter (not . (ledgercommentline `parses`)) ls + postinglinegroups :: [String] -> [String] + postinglinegroups [] = [] + postinglinegroups (pline:ls) = (unlines $ pline:mdlines):postinglinegroups rest + where (mdlines,rest) = span (ledgermetadataline `parses`) ls + pstrs = postinglinegroups postinglines + when (null pstrs) $ fail "no postings" + return $ map (fromparse . parseWithCtx ctx (setPosition pos >> ledgerposting)) pstrs + "postings" + +linebeginningwithspaces :: GenParser Char JournalContext String +linebeginningwithspaces = do + sp <- many1 spacenonewline + c <- nonspace + cs <- restofline + return $ sp ++ (c:cs) ++ "\n" + +ledgerposting :: GenParser Char JournalContext Posting +ledgerposting = do + many1 spacenonewline + status <- ledgerstatus + many spacenonewline + account <- transactionaccountname + let (ptype, account') = (postingTypeFromAccountName account, unbracket account) + amount <- postingamount + many spacenonewline + comment <- ledgercomment <|> return "" + newline + md <- ledgermetadata + return (Posting status account' amount comment ptype md Nothing) + +-- qualify with the parent account from parsing context +transactionaccountname :: GenParser Char JournalContext AccountName +transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname + +-- | Parse an account name. Account names may have single spaces inside +-- them, and are terminated by two or more spaces. They should have one or +-- more components of at least one character, separated by the account +-- separator char. +ledgeraccountname :: GenParser Char st AccountName +ledgeraccountname = do + a <- many1 (nonspace <|> singlespace) + let a' = striptrailingspace a + when (accountNameFromComponents (accountNameComponents a') /= a') + (fail $ "accountname seems ill-formed: "++a') + return a' + where + singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}) + -- couldn't avoid consuming a final space sometimes, harmless + striptrailingspace s = if last s == ' ' then init s else s + +-- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace +-- "account name character (non-bracket, non-parenthesis, non-whitespace)" + +-- | Parse an amount, with an optional left or right currency symbol and +-- optional price. +postingamount :: GenParser Char JournalContext MixedAmount +postingamount = + try (do + many1 spacenonewline + someamount <|> return missingamt + ) <|> return missingamt + +someamount :: GenParser Char JournalContext MixedAmount +someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount + +leftsymbolamount :: GenParser Char JournalContext MixedAmount +leftsymbolamount = do + sign <- optionMaybe $ string "-" + let applysign = if isJust sign then negate else id + sym <- commoditysymbol + sp <- many spacenonewline + (q,p,comma) <- amountquantity + pri <- priceamount + let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,comma=comma,precision=p} + return $ applysign $ Mixed [Amount c q pri] + "left-symbol amount" + +rightsymbolamount :: GenParser Char JournalContext MixedAmount +rightsymbolamount = do + (q,p,comma) <- amountquantity + sp <- many spacenonewline + sym <- commoditysymbol + pri <- priceamount + let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,comma=comma,precision=p} + return $ Mixed [Amount c q pri] + "right-symbol amount" + +nosymbolamount :: GenParser Char JournalContext MixedAmount +nosymbolamount = do + (q,p,comma) <- amountquantity + pri <- priceamount + defc <- getCommodity + let c = fromMaybe Commodity{symbol="",side=L,spaced=False,comma=comma,precision=p} defc + return $ Mixed [Amount c q pri] + "no-symbol amount" + +commoditysymbol :: GenParser Char JournalContext String +commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) "commodity symbol" + +quotedcommoditysymbol :: GenParser Char JournalContext String +quotedcommoditysymbol = do + char '"' + s <- many1 $ noneOf ";\n\"" + char '"' + return s + +simplecommoditysymbol :: GenParser Char JournalContext String +simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars) + +priceamount :: GenParser Char JournalContext (Maybe MixedAmount) +priceamount = + try (do + many spacenonewline + char '@' + many spacenonewline + a <- someamount -- XXX could parse more prices ad infinitum, shouldn't + return $ Just a + ) <|> return Nothing + +-- gawd.. trying to parse a ledger number without error: + +-- | Parse a ledger-style numeric quantity and also return the number of +-- digits to the right of the decimal point and whether thousands are +-- separated by comma. +amountquantity :: GenParser Char JournalContext (Double, Int, Bool) +amountquantity = do + sign <- optionMaybe $ string "-" + (intwithcommas,frac) <- numberparts + let comma = ',' `elem` intwithcommas + let precision = length frac + -- read the actual value. We expect this read to never fail. + let int = filter (/= ',') intwithcommas + let int' = if null int then "0" else int + let frac' = if null frac then "0" else frac + let sign' = fromMaybe "" sign + let quantity = read $ sign'++int'++"."++frac' + return (quantity, precision, comma) + "commodity quantity" + +-- | parse the two strings of digits before and after a possible decimal +-- point. The integer part may contain commas, or either part may be +-- empty, or there may be no point. +numberparts :: GenParser Char JournalContext (String,String) +numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint + +numberpartsstartingwithdigit :: GenParser Char JournalContext (String,String) +numberpartsstartingwithdigit = do + let digitorcomma = digit <|> char ',' + first <- digit + rest <- many digitorcomma + frac <- try (do {char '.'; many digit}) <|> return "" + return (first:rest,frac) + +numberpartsstartingwithpoint :: GenParser Char JournalContext (String,String) +numberpartsstartingwithpoint = do + char '.' + frac <- many1 digit + return ("",frac) + + +tests_JournalReader = TestList [ + + "ledgerTransaction" ~: do + assertParseEqual (parseWithCtx nullctx ledgerTransaction entry1_str) entry1 + assertBool "ledgerTransaction should not parse just a date" + $ isLeft $ parseWithCtx nullctx ledgerTransaction "2009/1/1\n" + assertBool "ledgerTransaction should require some postings" + $ isLeft $ parseWithCtx nullctx ledgerTransaction "2009/1/1 a\n" + let t = parseWithCtx nullctx ledgerTransaction "2009/1/1 a ;comment\n b 1\n" + assertBool "ledgerTransaction should not include a comment in the description" + $ either (const False) ((== "a") . tdescription) t + + ,"ledgerModifierTransaction" ~: do + assertParse (parseWithCtx nullctx ledgerModifierTransaction "= (some value expr)\n some:postings 1\n") + + ,"ledgerPeriodicTransaction" ~: do + assertParse (parseWithCtx nullctx ledgerPeriodicTransaction "~ (some period expr)\n some:postings 1\n") + + ,"ledgerExclamationDirective" ~: do + assertParse (parseWithCtx nullctx ledgerExclamationDirective "!include /some/file.x\n") + assertParse (parseWithCtx nullctx ledgerExclamationDirective "!account some:account\n") + assertParse (parseWithCtx nullctx (ledgerExclamationDirective >> ledgerExclamationDirective) "!account a\n!end\n") + + ,"ledgercommentline" ~: do + assertParse (parseWithCtx nullctx ledgercommentline "; some comment \n") + assertParse (parseWithCtx nullctx ledgercommentline " \t; x\n") + assertParse (parseWithCtx nullctx ledgercommentline ";x") + + ,"ledgerDefaultYear" ~: do + assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 2010\n") + assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 10001\n") + + ,"ledgerHistoricalPrice" ~: + assertParseEqual (parseWithCtx nullctx ledgerHistoricalPrice "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55]) + + ,"ledgerIgnoredPriceCommodity" ~: do + assertParse (parseWithCtx nullctx ledgerIgnoredPriceCommodity "N $\n") + + ,"ledgerDefaultCommodity" ~: do + assertParse (parseWithCtx nullctx ledgerDefaultCommodity "D $1,000.0\n") + + ,"ledgerCommodityConversion" ~: do + assertParse (parseWithCtx nullctx ledgerCommodityConversion "C 1h = $50.00\n") + + ,"ledgerTagDirective" ~: do + assertParse (parseWithCtx nullctx ledgerTagDirective "tag foo \n") + + ,"ledgerEndTagDirective" ~: do + assertParse (parseWithCtx nullctx ledgerEndTagDirective "end tag \n") + + ,"ledgeraccountname" ~: do + assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c") + assertBool "ledgeraccountname rejects an empty inner component" (isLeft $ parsewith ledgeraccountname "a::c") + assertBool "ledgeraccountname rejects an empty leading component" (isLeft $ parsewith ledgeraccountname ":b:c") + assertBool "ledgeraccountname rejects an empty trailing component" (isLeft $ parsewith ledgeraccountname "a:b:") + + ,"ledgerposting" ~: do + assertParseEqual (parseWithCtx nullctx ledgerposting " expenses:food:dining $10.00\n") + (Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting [] Nothing) + assertBool "ledgerposting parses a quoted commodity with numbers" + (isRight $ parseWithCtx nullctx ledgerposting " a 1 \"DE123\"\n") + + ,"someamount" ~: do + let -- | compare a parse result with a MixedAmount, showing the debug representation for clarity + assertMixedAmountParse parseresult mixedamount = + (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount) + assertMixedAmountParse (parseWithCtx nullctx someamount "1 @ $2") + (Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])]) + + ,"postingamount" ~: do + assertParseEqual (parseWithCtx nullctx postingamount " $47.18") (Mixed [dollars 47.18]) + assertParseEqual (parseWithCtx nullctx postingamount " $1.") + (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing]) + + ,"leftsymbolamount" ~: do + assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1") + (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing]) + assertParseEqual (parseWithCtx nullctx leftsymbolamount "$-1") + (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} (-1) Nothing]) + assertParseEqual (parseWithCtx nullctx leftsymbolamount "-$1") + (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} (-1) Nothing]) + + ] + +entry1_str = unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ," assets:checking $-47.18" + ,"" + ] + +entry1 = + txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing, + Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] Nothing] "" + diff --git a/Hledger/Read/Timelog.hs b/Hledger/Read/Timelog.hs deleted file mode 100644 --- a/Hledger/Read/Timelog.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| - -A reader for the timelog file format generated by timeclock.el. - -From timeclock.el 2.6: - -@ -A timelog contains data in the form of a single entry per line. -Each entry has the form: - - CODE YYYY/MM/DD HH:MM:SS [COMMENT] - -CODE is one of: b, h, i, o or O. COMMENT is optional when the code is -i, o or O. The meanings of the codes are: - - b Set the current time balance, or \"time debt\". Useful when - archiving old log data, when a debt must be carried forward. - The COMMENT here is the number of seconds of debt. - - h Set the required working time for the given day. This must - be the first entry for that day. The COMMENT in this case is - the number of hours in this workday. Floating point amounts - are allowed. - - i Clock in. The COMMENT in this case should be the name of the - project worked on. - - o Clock out. COMMENT is unnecessary, but can be used to provide - a description of how the period went, for example. - - O Final clock out. Whatever project was being worked on, it is - now finished. Useful for creating summary reports. -@ - -Example: - -@ -i 2007/03/10 12:26:00 hledger -o 2007/03/10 17:26:02 -@ - --} - -module Hledger.Read.Timelog ( - tests_Timelog, - reader, -) -where -import Control.Monad.Error (ErrorT(..)) -import Text.ParserCombinators.Parsec hiding (parse) -import Hledger.Data -import Hledger.Read.Common -import Hledger.Read.Journal (ledgerExclamationDirective, ledgerHistoricalPrice, - ledgerDefaultYear, emptyLine, ledgerdatetime) - - -reader :: Reader -reader = Reader format detect parse - -format :: String -format = "timelog" - --- | Does the given file path and data provide timeclock.el's timelog format ? -detect :: FilePath -> String -> Bool -detect f _ = fileSuffix f == format - --- | Parse and post-process a "Journal" from timeclock.el's timelog --- format, saving the provided file path and the current time, or give an --- error. -parse :: FilePath -> String -> ErrorT String IO Journal -parse = parseJournalWith timelogFile - -timelogFile :: GenParser Char JournalContext JournalUpdate -timelogFile = do items <- many timelogItem - eof - return $ liftM (foldr (.) id) $ sequence items - 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 - timelogItem = choice [ ledgerExclamationDirective - , liftM (return . addHistoricalPrice) ledgerHistoricalPrice - , ledgerDefaultYear - , emptyLine >> return (return id) - , liftM (return . addTimeLogEntry) timelogentry - ] "timelog entry, or default year or historical price directive" - --- | Parse a timelog entry. -timelogentry :: GenParser Char JournalContext TimeLogEntry -timelogentry = do - code <- oneOf "bhioO" - many1 spacenonewline - datetime <- ledgerdatetime - comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline) - return $ TimeLogEntry (read [code]) datetime (maybe "" rstrip comment) - -tests_Timelog = TestList [ - ] - diff --git a/Hledger/Read/TimelogReader.hs b/Hledger/Read/TimelogReader.hs new file mode 100644 --- /dev/null +++ b/Hledger/Read/TimelogReader.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE CPP #-} +{-| + +A reader for the timelog file format generated by timeclock.el. + +From timeclock.el 2.6: + +@ +A timelog contains data in the form of a single entry per line. +Each entry has the form: + + CODE YYYY/MM/DD HH:MM:SS [COMMENT] + +CODE is one of: b, h, i, o or O. COMMENT is optional when the code is +i, o or O. The meanings of the codes are: + + b Set the current time balance, or \"time debt\". Useful when + archiving old log data, when a debt must be carried forward. + The COMMENT here is the number of seconds of debt. + + h Set the required working time for the given day. This must + be the first entry for that day. The COMMENT in this case is + the number of hours in this workday. Floating point amounts + are allowed. + + i Clock in. The COMMENT in this case should be the name of the + project worked on. + + o Clock out. COMMENT is unnecessary, but can be used to provide + a description of how the period went, for example. + + O Final clock out. Whatever project was being worked on, it is + now finished. Useful for creating summary reports. +@ + +Example: + +@ +i 2007/03/10 12:26:00 hledger +o 2007/03/10 17:26:02 +@ + +-} + +module Hledger.Read.TimelogReader ( + tests_TimelogReader, + reader, +) +where +import Control.Monad.Error (ErrorT(..)) +import Text.ParserCombinators.Parsec hiding (parse) +import Hledger.Data +import Hledger.Read.Utils +import Hledger.Read.JournalReader (ledgerExclamationDirective, ledgerHistoricalPrice, + ledgerDefaultYear, emptyLine, ledgerdatetime) + + +reader :: Reader +reader = Reader format detect parse + +format :: String +format = "timelog" + +-- | Does the given file path and data provide timeclock.el's timelog format ? +detect :: FilePath -> String -> Bool +detect f _ = fileSuffix f == format + +-- | Parse and post-process a "Journal" from timeclock.el's timelog +-- format, saving the provided file path and the current time, or give an +-- error. +parse :: FilePath -> String -> ErrorT String IO Journal +parse = parseJournalWith timelogFile + +timelogFile :: GenParser Char JournalContext (JournalUpdate,JournalContext) +timelogFile = do items <- many timelogItem + eof + ctx <- getState + return (liftM (foldr (.) id) $ sequence items, ctx) + 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 + timelogItem = choice [ ledgerExclamationDirective + , liftM (return . addHistoricalPrice) ledgerHistoricalPrice + , ledgerDefaultYear + , emptyLine >> return (return id) + , liftM (return . addTimeLogEntry) timelogentry + ] "timelog entry, or default year or historical price directive" + +-- | Parse a timelog entry. +timelogentry :: GenParser Char JournalContext TimeLogEntry +timelogentry = do + code <- oneOf "bhioO" + many1 spacenonewline + datetime <- ledgerdatetime + comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline) + return $ TimeLogEntry (read [code]) datetime (maybe "" rstrip comment) + +tests_TimelogReader = TestList [ + ] + diff --git a/Hledger/Read/Utils.hs b/Hledger/Read/Utils.hs new file mode 100644 --- /dev/null +++ b/Hledger/Read/Utils.hs @@ -0,0 +1,73 @@ +{-| +Utilities common to hledger journal readers. +-} + +module Hledger.Read.Utils +where + +import Control.Monad.Error +import System.Directory (getHomeDirectory) +import System.FilePath(takeDirectory,combine) +import System.Time (getClockTime) +import Text.ParserCombinators.Parsec + +import Hledger.Data.Types (Journal, JournalContext(..), Commodity, JournalUpdate) +import Hledger.Data.Utils +import Hledger.Data.Journal (nullctx, nulljournal, journalFinalise) + + +juSequence :: [JournalUpdate] -> JournalUpdate +juSequence us = liftM (foldr (.) id) $ sequence us + +-- | 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. +parseJournalWith :: (GenParser Char JournalContext (JournalUpdate,JournalContext)) -> FilePath -> String -> ErrorT String IO Journal +parseJournalWith p f s = do + tc <- liftIO getClockTime + tl <- liftIO getCurrentLocalTime + case runParser p nullctx f s of + Right (updates,ctx) -> do + j <- updates `ap` return nulljournal + case journalFinalise tc tl f s ctx j of + Right j' -> return j' + Left estr -> throwError estr + Left e -> throwError $ show e + +setYear :: Integer -> GenParser tok JournalContext () +setYear y = updateState (\ctx -> ctx{ctxYear=Just y}) + +getYear :: GenParser tok JournalContext (Maybe Integer) +getYear = liftM ctxYear getState + +setCommodity :: Commodity -> GenParser tok JournalContext () +setCommodity c = updateState (\ctx -> ctx{ctxCommodity=Just c}) + +getCommodity :: GenParser tok JournalContext (Maybe Commodity) +getCommodity = liftM ctxCommodity getState + +pushParentAccount :: String -> GenParser tok JournalContext () +pushParentAccount parent = updateState addParentAccount + where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 } + normalize = (++ ":") + +popParentAccount :: GenParser tok JournalContext () +popParentAccount = do ctx0 <- getState + case ctxAccount ctx0 of + [] -> unexpected "End of account block with no beginning" + (_:rest) -> setState $ ctx0 { ctxAccount = rest } + +getParentAccount :: GenParser tok JournalContext String +getParentAccount = liftM (concat . reverse . ctxAccount) getState + +-- | Convert a possibly relative, possibly tilde-containing file path to an absolute one. +-- using the current directory from a parsec source position. ~username is not supported. +expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath +expandPath pos fp = liftM mkAbsolute (expandHome fp) + where + mkAbsolute = combine (takeDirectory (sourceName pos)) + expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory + return $ homedir ++ drop 1 inname + | otherwise = return inname + +fileSuffix :: FilePath -> String +fileSuffix = reverse . takeWhile (/='.') . reverse . dropWhile (/='.') diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -1,5 +1,5 @@ name: hledger-lib -version: 0.12.1 +version: 0.13 category: Finance synopsis: Core types and utilities for working with hledger (or c++ ledger) data. description: @@ -12,11 +12,11 @@ maintainer: Simon Michael homepage: http://hledger.org bug-reports: http://code.google.com/p/hledger/issues -stability: experimental +stability: beta tested-with: GHC==6.10 cabal-version: >= 1.6 build-type: Simple --- data-dir: +-- data-dir: data -- data-files: -- extra-tmp-files: -- extra-source-files: @@ -42,9 +42,9 @@ Hledger.Data.Types Hledger.Data.Utils Hledger.Read - Hledger.Read.Common - Hledger.Read.Journal - Hledger.Read.Timelog + Hledger.Read.Utils + Hledger.Read.JournalReader + Hledger.Read.TimelogReader Build-Depends: base >= 3 && < 5 ,containers