where
@@ -292,12 +316,21 @@
validate :: Hack.Env -> Day -> Failing Transaction
validate env today =
let inputs = Hack.Contrib.Request.inputs env
+#if __GLASGOW_HASKELL__ <= 610
date = decodeString $ fromMaybe "today" $ lookup "date" inputs
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs
amt1 = decodeString $ fromMaybe "" $ lookup "amt1" inputs
acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs
amt2 = decodeString $ fromMaybe "" $ lookup "amt2" inputs
+#else
+ date = fromMaybe "today" $ lookup "date" inputs
+ desc = fromMaybe "" $ lookup "desc" inputs
+ acct1 = fromMaybe "" $ lookup "acct1" inputs
+ amt1 = fromMaybe "" $ lookup "amt1" inputs
+ acct2 = fromMaybe "" $ lookup "acct2" inputs
+ amt2 = fromMaybe "" $ lookup "amt2" inputs
+#endif
validateDate "" = ["missing date"]
validateDate _ = []
validateDesc "" = ["missing description"]
@@ -311,8 +344,11 @@
validateAmt2 _ = []
amt1' = either (const missingamt) id $ parse someamount "" amt1
amt2' = either (const missingamt) id $ parse someamount "" amt2
+ (date', dateparseerr) = case fixSmartDateStrEither today date of
+ Right d -> (d, [])
+ Left e -> ("1900/01/01", [showDateParseError e])
t = Transaction {
- tdate = parsedate $ fixSmartDateStr today date
+ tdate = parsedate date' -- date' must be parseable
,teffectivedate=Nothing
,tstatus=False
,tcode=""
@@ -324,17 +360,19 @@
]
,tpreceding_comment_lines=""
}
- (t', berr) = case balanceTransaction t of
+ (t', balanceerr) = case balanceTransaction t of
Right t'' -> (t'', [])
- Left e -> (t, [e])
+ Left e -> (t, [head $ lines e]) -- show just the error not the transaction
errs = concat [
validateDate date
+ ,dateparseerr
,validateDesc desc
,validateAcct1 acct1
,validateAmt1 amt1
,validateAcct2 acct2
,validateAmt2 amt2
- ] ++ berr
+ ,balanceerr
+ ]
in
case null errs of
False -> Failure errs
@@ -347,3 +385,5 @@
ledgerpage [msg] l (showTransactions (optsToFilterSpec [] [] ti))
where msg = printf "Added transaction:\n%s" (show t)
+nbsp :: XML
+nbsp = cdata " "
diff --git a/HledgerMain.hs b/HledgerMain.hs
new file mode 100644
--- /dev/null
+++ b/HledgerMain.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE CPP #-}
+{-|
+The main function is in this separate module so it can be imported by
+benchmark scripts. As a side benefit, this avoids a weakness of sp, which
+doesn't allow both #! and \{\-\# lines.
+-}
+
+module HledgerMain where
+#if __GLASGOW_HASKELL__ <= 610
+import Prelude hiding (putStr, putStrLn)
+import System.IO.UTF8
+#endif
+
+import Commands.All
+import Ledger
+import Options
+import Tests
+import Utils (withLedgerDo)
+import Version (versionmsg, binaryfilename)
+
+main :: IO ()
+main = do
+ (opts, cmd, args) <- parseArguments
+ run cmd opts args
+ where
+ run cmd opts args
+ | Help `elem` opts = putStr usage
+ | Version `elem` opts = putStrLn versionmsg
+ | BinaryFilename `elem` opts = putStrLn binaryfilename
+ | cmd `isPrefixOf` "balance" = withLedgerDo opts args cmd balance
+ | cmd `isPrefixOf` "convert" = withLedgerDo opts args cmd convert
+ | cmd `isPrefixOf` "print" = withLedgerDo opts args cmd print'
+ | cmd `isPrefixOf` "register" = withLedgerDo opts args cmd register
+ | cmd `isPrefixOf` "histogram" = withLedgerDo opts args cmd histogram
+ | cmd `isPrefixOf` "add" = withLedgerDo opts args cmd add
+ | cmd `isPrefixOf` "stats" = withLedgerDo opts args cmd stats
+#ifdef VTY
+ | cmd `isPrefixOf` "ui" = withLedgerDo opts args cmd ui
+#endif
+#if defined(WEB) || defined(WEBHAPPSTACK)
+ | cmd `isPrefixOf` "web" = withLedgerDo opts args cmd web
+#endif
+#ifdef CHART
+ | cmd `isPrefixOf` "chart" = withLedgerDo opts args cmd chart
+#endif
+ | cmd `isPrefixOf` "test" = runtests opts args >> return ()
+ | otherwise = putStr usage
diff --git a/Ledger.hs b/Ledger.hs
deleted file mode 100644
--- a/Ledger.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-|
-
-The Ledger library allows parsing and querying of ledger files. It
-generally provides a compatible subset of C++ ledger's functionality.
-This package re-exports all the Ledger.* modules.
-
--}
-
-module Ledger (
- module Ledger.Account,
- module Ledger.AccountName,
- module Ledger.Amount,
- module Ledger.Commodity,
- module Ledger.Dates,
- module Ledger.IO,
- module Ledger.Transaction,
- module Ledger.Ledger,
- module Ledger.Parse,
- module Ledger.Journal,
- module Ledger.Posting,
- module Ledger.TimeLog,
- module Ledger.Types,
- module Ledger.Utils,
- )
-where
-import Ledger.Account
-import Ledger.AccountName
-import Ledger.Amount
-import Ledger.Commodity
-import Ledger.Dates
-import Ledger.IO
-import Ledger.Transaction
-import Ledger.Ledger
-import Ledger.Parse
-import Ledger.Journal
-import Ledger.Posting
-import Ledger.TimeLog
-import Ledger.Types
-import Ledger.Utils
diff --git a/Ledger/Account.hs b/Ledger/Account.hs
deleted file mode 100644
--- a/Ledger/Account.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-{-|
-
-A compound data type for efficiency. An 'Account' stores
-
-- an 'AccountName',
-
-- all 'Posting's in the account, excluding subaccounts
-
-- a 'MixedAmount' representing the account balance, including subaccounts.
-
--}
-
-module Ledger.Account
-where
-import Ledger.Utils
-import Ledger.Types
-import Ledger.Amount
-
-
-instance Show Account where
- show (Account a ts b) = printf "Account %s with %d txns and %s balance" a (length ts) (showMixedAmount b)
-
-instance Eq Account where
- (==) (Account n1 t1 b1) (Account n2 t2 b2) = n1 == n2 && t1 == t2 && b1 == b2
-
-nullacct = Account "" [] nullmixedamt
-
diff --git a/Ledger/AccountName.hs b/Ledger/AccountName.hs
deleted file mode 100644
--- a/Ledger/AccountName.hs
+++ /dev/null
@@ -1,171 +0,0 @@
-{-# LANGUAGE NoMonomorphismRestriction#-}
-{-|
-
-'AccountName's are strings like @assets:cash:petty@.
-From a set of these we derive the account hierarchy.
-
--}
-
-module Ledger.AccountName
-where
-import Ledger.Utils
-import Ledger.Types
-import Data.Map (Map)
-import qualified Data.Map as M
-
-
-
--- change to use a different separator for nested accounts
-acctsepchar = ':'
-
-accountNameComponents :: AccountName -> [String]
-accountNameComponents = splitAtElement acctsepchar
-
-accountNameFromComponents :: [String] -> AccountName
-accountNameFromComponents = concat . intersperse [acctsepchar]
-
-accountLeafName :: AccountName -> String
-accountLeafName = last . accountNameComponents
-
-accountNameLevel :: AccountName -> Int
-accountNameLevel "" = 0
-accountNameLevel a = length (filter (==acctsepchar) a) + 1
-
--- | ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"]
-expandAccountNames :: [AccountName] -> [AccountName]
-expandAccountNames as = nub $ concatMap expand as
- where expand = map accountNameFromComponents . tail . inits . accountNameComponents
-
--- | ["a:b:c","d:e"] -> ["a","d"]
-topAccountNames :: [AccountName] -> [AccountName]
-topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1]
-
-parentAccountName :: AccountName -> AccountName
-parentAccountName = accountNameFromComponents . init . accountNameComponents
-
-parentAccountNames :: AccountName -> [AccountName]
-parentAccountNames a = parentAccountNames' $ parentAccountName a
- where
- parentAccountNames' "" = []
- parentAccountNames' a = a : parentAccountNames' (parentAccountName a)
-
-isAccountNamePrefixOf :: AccountName -> AccountName -> Bool
-isAccountNamePrefixOf = isPrefixOf . (++ [acctsepchar])
-
-isSubAccountNameOf :: AccountName -> AccountName -> Bool
-s `isSubAccountNameOf` p =
- (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1))
-
--- | From a list of account names, select those which are direct
--- subaccounts of the given account name.
-subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName]
-subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts
-
--- | Convert a list of account names to a tree.
-accountNameTreeFrom :: [AccountName] -> Tree AccountName
-accountNameTreeFrom = accountNameTreeFrom1
-
-accountNameTreeFrom1 accts =
- Node "top" (accounttreesfrom (topAccountNames accts))
- where
- accounttreesfrom :: [AccountName] -> [Tree AccountName]
- accounttreesfrom [] = []
- accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as]
- subs = subAccountNamesFrom (expandAccountNames accts)
-
-nullaccountnametree = Node "top" []
-
-accountNameTreeFrom2 accts =
- Node "top" $ unfoldForest (\a -> (a, subs a)) $ topAccountNames accts
- where
- subs = subAccountNamesFrom allaccts
- allaccts = expandAccountNames accts
- -- subs' a = subsmap ! a
- -- subsmap :: Map AccountName [AccountName]
- -- subsmap = Data.Map.fromList [(a, subAccountNamesFrom allaccts a) | a <- allaccts]
-
-accountNameTreeFrom3 accts =
- Node "top" $ forestfrom allaccts $ topAccountNames accts
- where
- -- drop accts from the list of potential subs as we add them to the tree
- forestfrom :: [AccountName] -> [AccountName] -> Forest AccountName
- forestfrom subaccts accts =
- [let subaccts' = subaccts \\ accts in Node a $ forestfrom subaccts' (subAccountNamesFrom subaccts' a) | a <- accts]
- allaccts = expandAccountNames accts
-
-
--- a more efficient tree builder from Cale Gibbard
-newtype Tree' a = T (Map a (Tree' a))
- deriving (Show, Eq, Ord)
-
-mergeTrees :: (Ord a) => Tree' a -> Tree' a -> Tree' a
-mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m')
-
-emptyTree = T M.empty
-
-pathtree :: [a] -> Tree' a
-pathtree [] = T M.empty
-pathtree (x:xs) = T (M.singleton x (pathtree xs))
-
-fromPaths :: (Ord a) => [[a]] -> Tree' a
-fromPaths = foldl' mergeTrees emptyTree . map pathtree
-
--- the above, but trying to build Tree directly
-
--- mergeTrees' :: (Ord a) => Tree a -> Tree a -> Tree a
--- mergeTrees' (Node m ms) (Node m' ms') = Node undefined (ms `union` ms')
-
--- emptyTree' = Node "top" []
-
--- pathtree' :: [a] -> Tree a
--- pathtree' [] = Node undefined []
--- pathtree' (x:xs) = Node x [pathtree' xs]
-
--- fromPaths' :: (Ord a) => [[a]] -> Tree a
--- fromPaths' = foldl' mergeTrees' emptyTree' . map pathtree'
-
-
--- converttree :: [AccountName] -> Tree' AccountName -> [Tree AccountName]
--- converttree parents (T m) = [Node (accountNameFromComponents $ parents ++ [a]) (converttree (parents++[a]) b) | (a,b) <- M.toList m]
-
--- accountNameTreeFrom4 :: [AccountName] -> Tree AccountName
--- accountNameTreeFrom4 accts = Node "top" (converttree [] $ fromPaths $ map accountNameComponents accts)
-
-converttree :: Tree' AccountName -> [Tree AccountName]
-converttree (T m) = [Node a (converttree b) | (a,b) <- M.toList m]
-
-expandTreeNames :: Tree AccountName -> Tree AccountName
-expandTreeNames (Node x ts) = Node x (map (treemap (\n -> accountNameFromComponents [x,n]) . expandTreeNames) ts)
-
-accountNameTreeFrom4 :: [AccountName] -> Tree AccountName
-accountNameTreeFrom4 = Node "top" . map expandTreeNames . converttree . fromPaths . map accountNameComponents
-
-
--- | Elide an account name to fit in the specified width.
--- From the ledger 2.6 news:
---
--- @
--- What Ledger now does is that if an account name is too long, it will
--- start abbreviating the first parts of the account name down to two
--- letters in length. If this results in a string that is still too
--- long, the front will be elided -- not the end. For example:
---
--- Expenses:Cash ; OK, not too long
--- Ex:Wednesday:Cash ; "Expenses" was abbreviated to fit
--- Ex:We:Afternoon:Cash ; "Expenses" and "Wednesday" abbreviated
--- ; Expenses:Wednesday:Afternoon:Lunch:Snack:Candy:Chocolate:Cash
--- ..:Af:Lu:Sn:Ca:Ch:Cash ; Abbreviated and elided!
--- @
-elideAccountName :: Int -> AccountName -> AccountName
-elideAccountName width s =
- elideLeft width $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s
- where
- elideparts :: Int -> [String] -> [String] -> [String]
- elideparts width done ss
- | length (accountNameFromComponents $ done++ss) <= width = done++ss
- | length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss)
- | otherwise = done++ss
-
-clipAccountName :: Int -> AccountName -> AccountName
-clipAccountName n = accountNameFromComponents . take n . accountNameComponents
-
diff --git a/Ledger/Amount.hs b/Ledger/Amount.hs
deleted file mode 100644
--- a/Ledger/Amount.hs
+++ /dev/null
@@ -1,256 +0,0 @@
-{-# LANGUAGE StandaloneDeriving #-}
-{-|
-An 'Amount' is some quantity of money, shares, or anything else.
-
-A simple amount is a 'Commodity', quantity pair:
-
-@
- $1
- £-50
- EUR 3.44
- GOOG 500
- 1.5h
- 90 apples
- 0
-@
-
-An amount may also have a per-unit price, or conversion rate, in terms
-of some other commodity. If present, this is displayed after \@:
-
-@
- EUR 3 \@ $1.35
-@
-
-A 'MixedAmount' is zero or more simple amounts. Mixed amounts are
-usually normalised so that there is no more than one amount in each
-commodity, and no zero amounts (or, there is just a single zero amount
-and no others.):
-
-@
- $50 + EUR 3
- 16h + $13.55 + AAPL 500 + 6 oranges
- 0
-@
-
-We can do limited arithmetic with simple or mixed amounts: either
-price-preserving arithmetic with similarly-priced amounts, or
-price-discarding arithmetic which ignores and discards prices.
-
--}
-
-module Ledger.Amount
-where
-import Ledger.Utils
-import Ledger.Types
-import Ledger.Commodity
-
-
-instance Show Amount where show = showAmount
-instance Show MixedAmount where show = showMixedAmount
-deriving instance Show HistoricalPrice
-
-instance Num Amount where
- abs (Amount c q p) = Amount c (abs q) p
- signum (Amount c q p) = Amount c (signum q) p
- fromInteger i = Amount (comm "") (fromInteger i) Nothing
- (+) = amountop (+)
- (-) = amountop (-)
- (*) = amountop (*)
-
-instance Ord Amount where
- compare (Amount ac aq ap) (Amount bc bq bp) = compare (ac,aq,ap) (bc,bq,bp)
-
-instance Num MixedAmount where
- fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing]
- negate (Mixed as) = Mixed $ map negateAmountPreservingPrice as
- (+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs
- (*) = error "programming error, mixed amounts do not support multiplication"
- abs = error "programming error, mixed amounts do not support abs"
- signum = error "programming error, mixed amounts do not support signum"
-
-instance Ord MixedAmount where
- compare (Mixed as) (Mixed bs) = compare as bs
-
-negateAmountPreservingPrice a = (-a){price=price a}
-
--- | Apply a binary arithmetic operator to two amounts, converting to the
--- second one's commodity (and display precision), discarding any price
--- information. (Using the second commodity is best since sum and other
--- folds start with a no-commodity amount.)
-amountop :: (Double -> Double -> Double) -> Amount -> Amount -> Amount
-amountop op a@(Amount _ _ _) (Amount bc bq _) =
- Amount bc (quantity (convertAmountTo bc a) `op` bq) Nothing
-
--- | Convert an amount to the specified commodity using the appropriate
--- exchange rate (which is currently always 1).
-convertAmountTo :: Commodity -> Amount -> Amount
-convertAmountTo c2 (Amount c1 q _) = Amount c2 (q * conversionRate c1 c2) Nothing
-
--- | Convert mixed amount to the specified commodity
-convertMixedAmountTo :: Commodity -> MixedAmount -> Amount
-convertMixedAmountTo c2 (Mixed ams) = Amount c2 total Nothing
- where
- total = sum . map (quantity . convertAmountTo c2) $ ams
-
--- | Convert an amount to the commodity of its saved price, if any.
-costOfAmount :: Amount -> Amount
-costOfAmount a@(Amount _ _ Nothing) = a
-costOfAmount (Amount _ q (Just price))
- | isZeroMixedAmount price = nullamt
- | otherwise = Amount pc (pq*q) Nothing
- where (Amount pc pq _) = head $ amounts price
-
--- | Get the string representation of an amount, based on its commodity's
--- display settings.
-showAmount :: Amount -> String
-showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = "" -- can appear in an error message
-showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) _ pri) =
- case side of
- L -> printf "%s%s%s%s" sym space quantity price
- R -> printf "%s%s%s%s" quantity space sym price
- where
- space = if spaced then " " else ""
- quantity = showAmount' a
- price = case pri of (Just pamt) -> " @ " ++ showMixedAmount pamt
- Nothing -> ""
-
--- | Get the string representation of an amount, without any \@ price.
-showAmountWithoutPrice :: Amount -> String
-showAmountWithoutPrice a = showAmount a{price=Nothing}
-
--- | Get the string representation (of the number part of) of an amount
-showAmount' :: Amount -> String
-showAmount' (Amount (Commodity {comma=comma,precision=p}) q _) = quantity
- where
- quantity = commad $ printf ("%."++show p++"f") q
- commad = if comma then punctuatethousands else id
-
--- | Add thousands-separating commas to a decimal number string
-punctuatethousands :: String -> String
-punctuatethousands s =
- sign ++ addcommas int ++ frac
- where
- (sign,num) = break isDigit s
- (int,frac) = break (=='.') num
- addcommas = reverse . concat . intersperse "," . triples . reverse
- triples [] = []
- triples l = take 3 l : triples (drop 3 l)
-
--- | Does this amount appear to be zero when displayed with its given precision ?
-isZeroAmount :: Amount -> Bool
-isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPrice
-
--- | Is this amount "really" zero, regardless of the display precision ?
--- Since we are using floating point, for now just test to some high precision.
-isReallyZeroAmount :: Amount -> Bool
-isReallyZeroAmount = null . filter (`elem` "123456789") . printf "%.10f" . quantity
-
--- | Access a mixed amount's components.
-amounts :: MixedAmount -> [Amount]
-amounts (Mixed as) = as
-
--- | Does this mixed amount appear to be zero - empty, or
--- containing only simple amounts which appear to be zero ?
-isZeroMixedAmount :: MixedAmount -> Bool
-isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmount
-
--- | Is this mixed amount "really" zero ? See isReallyZeroAmount.
-isReallyZeroMixedAmount :: MixedAmount -> Bool
-isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmount
-
--- | MixedAmount derives Eq in Types.hs, but that doesn't know that we
--- want $0 = EUR0 = 0. Yet we don't want to drag all this code in there.
--- When zero equality is important, use this, for now; should be used
--- everywhere.
-mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool
-mixedAmountEquals a b = amounts a' == amounts b' || (isZeroMixedAmount a' && isZeroMixedAmount b')
- where a' = normaliseMixedAmount a
- b' = normaliseMixedAmount b
-
--- | Get the string representation of a mixed amount, showing each of
--- its component amounts. NB a mixed amount can have an empty amounts
--- list in which case it shows as \"\".
-showMixedAmount :: MixedAmount -> String
-showMixedAmount m = concat $ intersperse "\n" $ map showfixedwidth as
- where
- (Mixed as) = normaliseMixedAmount m
- width = maximum $ map (length . show) as
- showfixedwidth = printf (printf "%%%ds" width) . show
-
--- | Get the string representation of a mixed amount, but without
--- any \@ prices.
-showMixedAmountWithoutPrice :: MixedAmount -> String
-showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth as
- where
- (Mixed as) = normaliseMixedAmountIgnoringPrice m
- width = maximum $ map (length . show) as
- showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice
-
--- | Get the string representation of a mixed amount, and if it
--- appears to be all zero just show a bare 0, ledger-style.
-showMixedAmountOrZero :: MixedAmount -> String
-showMixedAmountOrZero a
- | isZeroMixedAmount a = "0"
- | otherwise = showMixedAmount a
-
--- | Get the string representation of a mixed amount, or a bare 0,
--- without any \@ prices.
-showMixedAmountOrZeroWithoutPrice :: MixedAmount -> String
-showMixedAmountOrZeroWithoutPrice a
- | isZeroMixedAmount a = "0"
- | otherwise = showMixedAmountWithoutPrice a
-
--- | Simplify a mixed amount by combining any component amounts which have
--- the same commodity and the same price. Also removes zero amounts,
--- or adds a single zero amount if there are no amounts at all.
-normaliseMixedAmount :: MixedAmount -> MixedAmount
-normaliseMixedAmount (Mixed as) = Mixed as''
- where
- as'' = map sumSamePricedAmountsPreservingPrice $ group $ sort as'
- sort = sortBy cmpsymbolandprice
- cmpsymbolandprice a1 a2 = compare (sym a1,price a1) (sym a2,price a2)
- group = groupBy samesymbolandprice
- samesymbolandprice a1 a2 = (sym a1 == sym a2) && (price a1 == price a2)
- sym = symbol . commodity
- as' | null nonzeros = [head $ zeros ++ [nullamt]]
- | otherwise = nonzeros
- (zeros,nonzeros) = partition isReallyZeroAmount as
-
-sumSamePricedAmountsPreservingPrice [] = nullamt
-sumSamePricedAmountsPreservingPrice as = (sum as){price=price $ head as}
-
--- | Simplify a mixed amount by combining any component amounts which have
--- the same commodity, ignoring and discarding their unit prices if any.
--- Also removes zero amounts, or adds a single zero amount if there are no
--- amounts at all.
-normaliseMixedAmountIgnoringPrice :: MixedAmount -> MixedAmount
-normaliseMixedAmountIgnoringPrice (Mixed as) = Mixed as''
- where
- as'' = map sumAmountsDiscardingPrice $ group $ sort as'
- group = groupBy samesymbol where samesymbol a1 a2 = sym a1 == sym a2
- sort = sortBy (comparing sym)
- sym = symbol . commodity
- as' | null nonzeros = [head $ zeros ++ [nullamt]]
- | otherwise = nonzeros
- where (zeros,nonzeros) = partition isZeroAmount as
-
-sumAmountsDiscardingPrice [] = nullamt
-sumAmountsDiscardingPrice as = (sum as){price=Nothing}
-
--- | Convert a mixed amount's component amounts to the commodity of their
--- saved price, if any.
-costOfMixedAmount :: MixedAmount -> MixedAmount
-costOfMixedAmount (Mixed as) = Mixed $ map costOfAmount as
-
--- | The empty simple amount.
-nullamt :: Amount
-nullamt = Amount unknown 0 Nothing
-
--- | The empty mixed amount.
-nullmixedamt :: MixedAmount
-nullmixedamt = Mixed []
-
--- | A temporary value for parsed transactions which had no amount specified.
-missingamt :: MixedAmount
-missingamt = Mixed [Amount Commodity {symbol="AUTO",side=L,spaced=False,comma=False,precision=0} 0 Nothing]
-
diff --git a/Ledger/Commodity.hs b/Ledger/Commodity.hs
deleted file mode 100644
--- a/Ledger/Commodity.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-|
-
-A 'Commodity' is a symbol representing a currency or some other kind of
-thing we are tracking, and some display preferences that tell how to
-display 'Amount's of the commodity - is the symbol on the left or right,
-are thousands separated by comma, significant decimal places and so on.
-
--}
-module Ledger.Commodity
-where
-import Ledger.Utils
-import Ledger.Types
-
-
--- convenient amount and commodity constructors, for tests etc.
-
-unknown = Commodity {symbol="", side=L,spaced=False,comma=False,precision=0}
-dollar = Commodity {symbol="$", side=L,spaced=False,comma=False,precision=2}
-euro = Commodity {symbol="EUR",side=L,spaced=False,comma=False,precision=2}
-pound = Commodity {symbol="£", side=L,spaced=False,comma=False,precision=2}
-hour = Commodity {symbol="h", side=R,spaced=False,comma=False,precision=1}
-
-dollars n = Amount dollar n Nothing
-euros n = Amount euro n Nothing
-pounds n = Amount pound n Nothing
-hours n = Amount hour n Nothing
-
-defaultcommodities = [dollar, euro, pound, hour, unknown]
-
--- | Look up one of the hard-coded default commodities. For use in tests.
-comm :: String -> Commodity
-comm sym = fromMaybe
- (error "commodity lookup failed")
- $ find (\(Commodity{symbol=s}) -> s==sym) defaultcommodities
-
--- | Find the conversion rate between two commodities. Currently returns 1.
-conversionRate :: Commodity -> Commodity -> Double
-conversionRate _ _ = 1
-
diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs
deleted file mode 100644
--- a/Ledger/Dates.hs
+++ /dev/null
@@ -1,428 +0,0 @@
-{-|
-
-Date parsing and utilities for hledger.
-
-For date and time values, we use the standard Day and UTCTime types.
-
-A 'SmartDate' is a date which may be partially-specified or relative.
-Eg 2008\/12\/31, but also 2008\/12, 12\/31, tomorrow, last week, next year.
-We represent these as a triple of strings like (\"2008\",\"12\",\"\"),
-(\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\").
-
-A 'DateSpan' is the span of time between two specific calendar dates, or
-an open-ended span where one or both dates are unspecified. (A date span
-with both ends unspecified matches all dates.)
-
-An 'Interval' is ledger's "reporting interval" - weekly, monthly,
-quarterly, etc.
-
--}
-
-module Ledger.Dates
-where
-
-import Data.Time.Format
-import Data.Time.Calendar.OrdinalDate
-import Locale (defaultTimeLocale)
-import Text.ParserCombinators.Parsec
-import Text.ParserCombinators.Parsec.Char
-import Text.ParserCombinators.Parsec.Combinator
-import Ledger.Types
-import Ledger.Utils
-
-
-showDate :: Day -> String
-showDate = formatTime defaultTimeLocale "%Y/%m/%d"
-
-getCurrentDay :: IO Day
-getCurrentDay = do
- t <- getZonedTime
- return $ localDay (zonedTimeToLocalTime t)
-
-elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a
-elapsedSeconds t1 = realToFrac . diffUTCTime t1
-
--- | Split a DateSpan into one or more consecutive spans at the specified interval.
-splitSpan :: Interval -> DateSpan -> [DateSpan]
-splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing]
-splitSpan NoInterval s = [s]
-splitSpan Daily s = splitspan startofday nextday s
-splitSpan Weekly s = splitspan startofweek nextweek s
-splitSpan Monthly s = splitspan startofmonth nextmonth s
-splitSpan Quarterly s = splitspan startofquarter nextquarter s
-splitSpan Yearly s = splitspan startofyear nextyear s
-
-splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
-splitspan _ _ (DateSpan Nothing Nothing) = []
-splitspan start next (DateSpan Nothing (Just e)) = [DateSpan (Just $ start e) (Just $ next $ start e)]
-splitspan start next (DateSpan (Just b) Nothing) = [DateSpan (Just $ start b) (Just $ next $ start b)]
-splitspan start next span@(DateSpan (Just b) (Just e))
- | b == e = [span]
- | otherwise = splitspan' start next span
- where
- splitspan' start next (DateSpan (Just b) (Just e))
- | b >= e = []
- | otherwise = DateSpan (Just s) (Just n)
- : splitspan' start next (DateSpan (Just n) (Just e))
- where s = start b
- n = next s
- splitspan' _ _ _ = error "won't happen, avoids warnings"
-
--- | Count the days in a DateSpan, or if it is open-ended return Nothing.
-daysInSpan :: DateSpan -> Maybe Integer
-daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays d2 d1
-daysInSpan _ = Nothing
-
--- | Parse a period expression to an Interval and overall DateSpan using
--- the provided reference date.
-parsePeriodExpr :: Day -> String -> (Interval, DateSpan)
-parsePeriodExpr refdate expr = (interval,span)
- where (interval,span) = fromparse $ parsewith (periodexpr refdate) expr
-
--- | Convert a single smart date string to a date span using the provided
--- reference date.
-spanFromSmartDateString :: Day -> String -> DateSpan
-spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate
- where
- sdate = fromparse $ parsewith smartdate s
-
-spanFromSmartDate :: Day -> SmartDate -> DateSpan
-spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)
- where
- (ry,rm,_) = toGregorian refdate
- (b,e) = span sdate
- span :: SmartDate -> (Day,Day)
- span ("","","today") = (refdate, nextday refdate)
- span ("","this","day") = (refdate, nextday refdate)
- span ("","","yesterday") = (prevday refdate, refdate)
- span ("","last","day") = (prevday refdate, refdate)
- span ("","","tomorrow") = (nextday refdate, addDays 2 refdate)
- span ("","next","day") = (nextday refdate, addDays 2 refdate)
- span ("","last","week") = (prevweek refdate, thisweek refdate)
- span ("","this","week") = (thisweek refdate, nextweek refdate)
- span ("","next","week") = (nextweek refdate, startofweek $ addDays 14 refdate)
- span ("","last","month") = (prevmonth refdate, thismonth refdate)
- span ("","this","month") = (thismonth refdate, nextmonth refdate)
- span ("","next","month") = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate)
- span ("","last","quarter") = (prevquarter refdate, thisquarter refdate)
- span ("","this","quarter") = (thisquarter refdate, nextquarter refdate)
- span ("","next","quarter") = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate)
- span ("","last","year") = (prevyear refdate, thisyear refdate)
- span ("","this","year") = (thisyear refdate, nextyear refdate)
- span ("","next","year") = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate)
- span ("","",d) = (day, nextday day) where day = fromGregorian ry rm (read d)
- span ("",m,"") = (startofmonth day, nextmonth day) where day = fromGregorian ry (read m) 1
- span ("",m,d) = (day, nextday day) where day = fromGregorian ry (read m) (read d)
- span (y,"","") = (startofyear day, nextyear day) where day = fromGregorian (read y) 1 1
- span (y,m,"") = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1
- span (y,m,d) = (day, nextday day) where day = fromGregorian (read y) (read m) (read d)
-
--- | Convert a smart date string to an explicit yyyy\/mm\/dd string using
--- the provided reference date.
-fixSmartDateStr :: Day -> String -> String
-fixSmartDateStr t s = printf "%04d/%02d/%02d" y m d
- where
- (y,m,d) = toGregorian $ fixSmartDate t sdate
- sdate = fromparse $ parsewith smartdate $ lowercase s
-
--- | Convert a SmartDate to an absolute date using the provided reference date.
-fixSmartDate :: Day -> SmartDate -> Day
-fixSmartDate refdate sdate = fix sdate
- where
- fix :: SmartDate -> Day
- fix ("","","today") = fromGregorian ry rm rd
- fix ("","this","day") = fromGregorian ry rm rd
- fix ("","","yesterday") = prevday refdate
- fix ("","last","day") = prevday refdate
- fix ("","","tomorrow") = nextday refdate
- fix ("","next","day") = nextday refdate
- fix ("","last","week") = prevweek refdate
- fix ("","this","week") = thisweek refdate
- fix ("","next","week") = nextweek refdate
- fix ("","last","month") = prevmonth refdate
- fix ("","this","month") = thismonth refdate
- fix ("","next","month") = nextmonth refdate
- fix ("","last","quarter") = prevquarter refdate
- fix ("","this","quarter") = thisquarter refdate
- fix ("","next","quarter") = nextquarter refdate
- fix ("","last","year") = prevyear refdate
- fix ("","this","year") = thisyear refdate
- fix ("","next","year") = nextyear refdate
- fix ("","",d) = fromGregorian ry rm (read d)
- fix ("",m,"") = fromGregorian ry (read m) 1
- fix ("",m,d) = fromGregorian ry (read m) (read d)
- fix (y,"","") = fromGregorian (read y) 1 1
- fix (y,m,"") = fromGregorian (read y) (read m) 1
- fix (y,m,d) = fromGregorian (read y) (read m) (read d)
- (ry,rm,rd) = toGregorian refdate
-
-prevday :: Day -> Day
-prevday = addDays (-1)
-nextday = addDays 1
-startofday = id
-
-thisweek = startofweek
-prevweek = startofweek . addDays (-7)
-nextweek = startofweek . addDays 7
-startofweek day = fromMondayStartWeek y w 1
- where
- (y,_,_) = toGregorian day
- (w,_) = mondayStartWeek day
-
-thismonth = startofmonth
-prevmonth = startofmonth . addGregorianMonthsClip (-1)
-nextmonth = startofmonth . addGregorianMonthsClip 1
-startofmonth day = fromGregorian y m 1 where (y,m,_) = toGregorian day
-
-thisquarter = startofquarter
-prevquarter = startofquarter . addGregorianMonthsClip (-3)
-nextquarter = startofquarter . addGregorianMonthsClip 3
-startofquarter day = fromGregorian y (firstmonthofquarter m) 1
- where
- (y,m,_) = toGregorian day
- firstmonthofquarter m = ((m-1) `div` 3) * 3 + 1
-
-thisyear = startofyear
-prevyear = startofyear . addGregorianYearsClip (-1)
-nextyear = startofyear . addGregorianYearsClip 1
-startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day
-
-----------------------------------------------------------------------
--- parsing
-
-firstJust ms = case dropWhile (==Nothing) ms of
- [] -> Nothing
- (md:_) -> md
-
-parsedatetimeM :: String -> Maybe LocalTime
-parsedatetimeM s = firstJust [
- parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s,
- parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s
- ]
-
--- | Parse a date-time string to a time type, or raise an error.
-parsedatetime :: String -> LocalTime
-parsedatetime s = fromMaybe (error $ "could not parse timestamp \"" ++ s ++ "\"")
- (parsedatetimeM s)
-
--- | Parse a date string to a time type, or raise an error.
-parsedateM :: String -> Maybe Day
-parsedateM s = firstJust [
- parseTime defaultTimeLocale "%Y/%m/%d" s,
- parseTime defaultTimeLocale "%Y-%m-%d" s
- ]
-
--- | Parse a date string to a time type, or raise an error.
-parsedate :: String -> Day
-parsedate s = fromMaybe (error $ "could not parse date \"" ++ s ++ "\"")
- (parsedateM s)
-
--- | Parse a time string to a time type using the provided pattern, or
--- return the default.
-parsetimewith :: ParseTime t => String -> String -> t -> t
-parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s
-
-{-|
-Parse a date in any of the formats allowed in ledger's period expressions,
-and maybe some others:
-
-> 2004
-> 2004/10
-> 2004/10/1
-> 10/1
-> 21
-> october, oct
-> yesterday, today, tomorrow
-> (not yet) 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.
--}
-smartdate :: GenParser Char st SmartDate
-smartdate = do
- let dateparsers = [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow,
- lastthisnextthing
- ]
- (y,m,d) <- choice $ map try dateparsers
- return (y,m,d)
-
-datesepchar = oneOf "/-."
-
-yyyymmdd :: GenParser Char st SmartDate
-yyyymmdd = do
- y <- count 4 digit
- m <- count 2 digit
- guard (read m <= 12)
- d <- count 2 digit
- guard (read d <= 31)
- return (y,m,d)
-
-ymd :: GenParser Char st SmartDate
-ymd = do
- y <- many1 digit
- datesepchar
- m <- try (count 2 digit) <|> count 1 digit
- guard (read m >= 1 && (read m <= 12))
- -- when (read m < 1 || (read m > 12)) $ fail "bad month number specified"
- datesepchar
- d <- try (count 2 digit) <|> count 1 digit
- when (read d < 1 || (read d > 31)) $ fail "bad day number specified"
- return $ (y,m,d)
-
-ym :: GenParser Char st SmartDate
-ym = do
- y <- many1 digit
- guard (read y > 12)
- datesepchar
- m <- try (count 2 digit) <|> count 1 digit
- guard (read m >= 1 && (read m <= 12))
- return (y,m,"")
-
-y :: GenParser Char st SmartDate
-y = do
- y <- many1 digit
- guard (read y >= 1000)
- return (y,"","")
-
-d :: GenParser Char st SmartDate
-d = do
- d <- many1 digit
- guard (read d <= 31)
- return ("","",d)
-
-md :: GenParser Char st SmartDate
-md = do
- m <- try (count 2 digit) <|> count 1 digit
- guard (read m >= 1 && (read m <= 12))
- datesepchar
- d <- try (count 2 digit) <|> count 1 digit
- when (read d < 1 || (read d > 31)) $ fail "bad day number specified"
- return ("",m,d)
-
-months = ["january","february","march","april","may","june",
- "july","august","september","october","november","december"]
-monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"]
-weekdays = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"]
-weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"]
-
-monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months
-monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs
-
-month :: GenParser Char st SmartDate
-month = do
- m <- choice $ map (try . string) months
- let i = monthIndex m
- return ("",show i,"")
-
-mon :: GenParser Char st SmartDate
-mon = do
- m <- choice $ map (try . string) monthabbrevs
- let i = monIndex m
- return ("",show i,"")
-
-today,yesterday,tomorrow :: GenParser Char st SmartDate
-today = string "today" >> return ("","","today")
-yesterday = string "yesterday" >> return ("","","yesterday")
-tomorrow = string "tomorrow" >> return ("","","tomorrow")
-
-lastthisnextthing :: GenParser Char st SmartDate
-lastthisnextthing = do
- r <- choice [
- string "last"
- ,string "this"
- ,string "next"
- ]
- many spacenonewline -- make the space optional for easier scripting
- p <- choice [
- string "day"
- ,string "week"
- ,string "month"
- ,string "quarter"
- ,string "year"
- ]
--- XXX support these in fixSmartDate
--- ++ (map string $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs)
-
- return ("",r,p)
-
-periodexpr :: Day -> GenParser Char st (Interval, DateSpan)
-periodexpr rdate = choice $ map try [
- intervalanddateperiodexpr rdate,
- intervalperiodexpr,
- dateperiodexpr rdate,
- (return (NoInterval,DateSpan Nothing Nothing))
- ]
-
-intervalanddateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan)
-intervalanddateperiodexpr rdate = do
- many spacenonewline
- i <- periodexprinterval
- many spacenonewline
- s <- periodexprdatespan rdate
- return (i,s)
-
-intervalperiodexpr :: GenParser Char st (Interval, DateSpan)
-intervalperiodexpr = do
- many spacenonewline
- i <- periodexprinterval
- return (i, DateSpan Nothing Nothing)
-
-dateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan)
-dateperiodexpr rdate = do
- many spacenonewline
- s <- periodexprdatespan rdate
- return (NoInterval, s)
-
-periodexprinterval :: GenParser Char st Interval
-periodexprinterval =
- choice $ map try [
- tryinterval "day" "daily" Daily,
- tryinterval "week" "weekly" Weekly,
- tryinterval "month" "monthly" Monthly,
- tryinterval "quarter" "quarterly" Quarterly,
- tryinterval "year" "yearly" Yearly
- ]
- where
- tryinterval s1 s2 v =
- choice [try (string $ "every "++s1), try (string s2)] >> return v
-
-periodexprdatespan :: Day -> GenParser Char st DateSpan
-periodexprdatespan rdate = choice $ map try [
- doubledatespan rdate,
- fromdatespan rdate,
- todatespan rdate,
- justdatespan rdate
- ]
-
-doubledatespan :: Day -> GenParser Char st DateSpan
-doubledatespan rdate = do
- optional (string "from" >> many spacenonewline)
- b <- smartdate
- many spacenonewline
- optional (string "to" >> many spacenonewline)
- e <- smartdate
- return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e)
-
-fromdatespan :: Day -> GenParser Char st DateSpan
-fromdatespan rdate = do
- string "from" >> many spacenonewline
- b <- smartdate
- return $ DateSpan (Just $ fixSmartDate rdate b) Nothing
-
-todatespan :: Day -> GenParser Char st DateSpan
-todatespan rdate = do
- string "to" >> many spacenonewline
- e <- smartdate
- return $ DateSpan Nothing (Just $ fixSmartDate rdate e)
-
-justdatespan :: Day -> GenParser Char st DateSpan
-justdatespan rdate = do
- optional (string "in" >> many spacenonewline)
- d <- smartdate
- return $ spanFromSmartDate rdate d
-
-nulldatespan = DateSpan Nothing Nothing
-
-mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate
-
-nulldate = parsedate "1900/01/01"
diff --git a/Ledger/IO.hs b/Ledger/IO.hs
deleted file mode 100644
--- a/Ledger/IO.hs
+++ /dev/null
@@ -1,96 +0,0 @@
-{-|
-Utilities for doing I/O with ledger files.
--}
-
-module Ledger.IO
-where
-import Control.Monad.Error
-import Ledger.Ledger (cacheLedger', nullledger)
-import Ledger.Parse (parseLedger)
-import Ledger.Types (FilterSpec(..),WhichDate(..),Journal(..),Ledger(..))
-import Ledger.Utils (getCurrentLocalTime)
-import Ledger.Dates (nulldatespan)
-import System.Directory (getHomeDirectory)
-import System.Environment (getEnv)
-import Prelude hiding (readFile)
-import System.IO.UTF8
-import System.FilePath (())
-import System.Time (getClockTime)
-
-
-ledgerenvvar = "LEDGER"
-timelogenvvar = "TIMELOG"
-ledgerdefaultfilename = ".ledger"
-timelogdefaultfilename = ".timelog"
-
-nullfilterspec = FilterSpec {
- datespan=nulldatespan
- ,cleared=Nothing
- ,real=False
- ,empty=False
- ,costbasis=False
- ,acctpats=[]
- ,descpats=[]
- ,whichdate=ActualDate
- ,depth=Nothing
- }
-
--- | Get the user's default ledger file path.
-myLedgerPath :: IO String
-myLedgerPath =
- getEnv ledgerenvvar `catch`
- (\_ -> do
- home <- getHomeDirectory `catch` (\_ -> return "")
- return $ home ledgerdefaultfilename)
-
--- | Get the user's default timelog file path.
-myTimelogPath :: IO String
-myTimelogPath =
- getEnv timelogenvvar `catch`
- (\_ -> do
- home <- getHomeDirectory
- return $ home timelogdefaultfilename)
-
--- | Read the user's default ledger file, or give an error.
-myLedger :: IO Ledger
-myLedger = myLedgerPath >>= readLedger
-
--- | Read the user's default timelog file, or give an error.
-myTimelog :: IO Ledger
-myTimelog = myTimelogPath >>= readLedger
-
--- | Read a ledger from this file, with no filtering, or give an error.
-readLedger :: FilePath -> IO Ledger
-readLedger f = do
- t <- getClockTime
- s <- readFile f
- j <- journalFromString s
- return $ cacheLedger' $ nullledger{journal=j{filepath=f,filereadtime=t,jtext=s}}
-
--- -- | Read a ledger from this file, filtering according to the filter spec.,
--- -- | or give an error.
--- readLedgerWithFilterSpec :: FilterSpec -> FilePath -> IO Ledger
--- readLedgerWithFilterSpec fspec f = do
--- s <- readFile f
--- t <- getClockTime
--- rl <- journalFromString s
--- return $ filterAndCacheLedger fspec s rl{filepath=f, filereadtime=t}
-
--- | Read a Journal from the given string, using the current time as
--- reference time, or give a parse error.
-journalFromString :: String -> IO Journal
-journalFromString s = do
- t <- getCurrentLocalTime
- liftM (either error id) $ runErrorT $ parseLedger t "(string)" s
-
--- -- | Expand ~ in a file path (does not handle ~name).
--- tildeExpand :: FilePath -> IO FilePath
--- tildeExpand ('~':[]) = getHomeDirectory
--- tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs))
--- --handle ~name, requires -fvia-C or ghc 6.8:
--- --import System.Posix.User
--- -- tildeExpand ('~':xs) = do let (user, path) = span (/= '/') xs
--- -- pw <- getUserEntryForName user
--- -- return (homeDirectory pw ++ path)
--- tildeExpand xs = return xs
-
diff --git a/Ledger/Journal.hs b/Ledger/Journal.hs
deleted file mode 100644
--- a/Ledger/Journal.hs
+++ /dev/null
@@ -1,321 +0,0 @@
-{-|
-
-A 'Journal' is a parsed ledger file, containing 'Transaction's.
-It can be filtered and massaged in various ways, then \"crunched\"
-to form a 'Ledger'.
-
--}
-
-module Ledger.Journal
-where
-import qualified Data.Map as Map
-import Data.Map (findWithDefault, (!))
-import System.Time (ClockTime(TOD))
-import Ledger.Utils
-import Ledger.Types
-import Ledger.AccountName
-import Ledger.Amount
-import Ledger.Transaction (ledgerTransactionWithDate)
-import Ledger.Posting
-import Ledger.TimeLog
-
-
-instance Show Journal where
- show j = printf "Journal with %d transactions, %d accounts: %s"
- (length (jtxns j) +
- length (jmodifiertxns j) +
- length (jperiodictxns j))
- (length accounts)
- (show accounts)
- -- ++ (show $ journalTransactions l)
- where accounts = flatten $ journalAccountNameTree j
-
-nulljournal :: Journal
-nulljournal = Journal { jmodifiertxns = []
- , jperiodictxns = []
- , jtxns = []
- , open_timelog_entries = []
- , historical_prices = []
- , final_comment_lines = []
- , filepath = ""
- , filereadtime = TOD 0 0
- , jtext = ""
- }
-
-addTransaction :: Transaction -> Journal -> Journal
-addTransaction t l0 = l0 { jtxns = t : jtxns l0 }
-
-addModifierTransaction :: ModifierTransaction -> Journal -> Journal
-addModifierTransaction mt l0 = l0 { jmodifiertxns = mt : jmodifiertxns l0 }
-
-addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal
-addPeriodicTransaction pt l0 = l0 { jperiodictxns = pt : jperiodictxns l0 }
-
-addHistoricalPrice :: HistoricalPrice -> Journal -> Journal
-addHistoricalPrice h l0 = l0 { historical_prices = h : historical_prices l0 }
-
-addTimeLogEntry :: TimeLogEntry -> Journal -> Journal
-addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : open_timelog_entries l0 }
-
-journalPostings :: Journal -> [Posting]
-journalPostings = concatMap tpostings . jtxns
-
-journalAccountNamesUsed :: Journal -> [AccountName]
-journalAccountNamesUsed = accountNamesFromPostings . journalPostings
-
-journalAccountNames :: Journal -> [AccountName]
-journalAccountNames = sort . expandAccountNames . journalAccountNamesUsed
-
-journalAccountNameTree :: Journal -> Tree AccountName
-journalAccountNameTree = accountNameTreeFrom . journalAccountNames
-
--- Various kinds of filtering on journals. We do it differently depending
--- on the command.
-
--- | Keep only transactions we are interested in, as described by
--- the filter specification. May also massage the data a little.
-filterJournalTransactions :: FilterSpec -> Journal -> Journal
-filterJournalTransactions FilterSpec{datespan=datespan
- ,cleared=cleared
- -- ,real=real
- -- ,empty=empty
- -- ,costbasis=_
- ,acctpats=apats
- ,descpats=dpats
- ,whichdate=whichdate
- ,depth=depth
- } =
- filterJournalTransactionsByClearedStatus cleared .
- filterJournalPostingsByDepth depth .
- filterJournalTransactionsByAccount apats .
- filterJournalTransactionsByDescription dpats .
- filterJournalTransactionsByDate datespan .
- journalSelectingDate whichdate
-
--- | Keep only postings we are interested in, as described by
--- the filter specification. May also massage the data a little.
--- This can leave unbalanced transactions.
-filterJournalPostings :: FilterSpec -> Journal -> Journal
-filterJournalPostings FilterSpec{datespan=datespan
- ,cleared=cleared
- ,real=real
- ,empty=empty
--- ,costbasis=costbasis
- ,acctpats=apats
- ,descpats=dpats
- ,whichdate=whichdate
- ,depth=depth
- } =
- filterJournalPostingsByRealness real .
- filterJournalPostingsByClearedStatus cleared .
- filterJournalPostingsByEmpty empty .
- filterJournalPostingsByDepth depth .
- filterJournalPostingsByAccount apats .
- filterJournalTransactionsByDescription dpats .
- filterJournalTransactionsByDate datespan .
- journalSelectingDate whichdate
-
--- | Keep only ledger transactions whose description matches the description patterns.
-filterJournalTransactionsByDescription :: [String] -> Journal -> Journal
-filterJournalTransactionsByDescription pats j@Journal{jtxns=ts} = j{jtxns=filter matchdesc ts}
- where matchdesc = matchpats pats . tdescription
-
--- | Keep only ledger transactions which fall between begin and end dates.
--- We include transactions on the begin date and exclude transactions on the end
--- date, like ledger. An empty date string means no restriction.
-filterJournalTransactionsByDate :: DateSpan -> Journal -> Journal
-filterJournalTransactionsByDate (DateSpan begin end) j@Journal{jtxns=ts} = j{jtxns=filter match ts}
- where match t = maybe True (tdate t>=) begin && maybe True (tdate t<) end
-
--- | Keep only ledger transactions which have the requested
--- cleared/uncleared status, if there is one.
-filterJournalTransactionsByClearedStatus :: Maybe Bool -> Journal -> Journal
-filterJournalTransactionsByClearedStatus Nothing j = j
-filterJournalTransactionsByClearedStatus (Just val) j@Journal{jtxns=ts} = j{jtxns=filter match ts}
- where match = (==val).tstatus
-
--- | Keep only postings which have the requested cleared/uncleared status,
--- if there is one.
-filterJournalPostingsByClearedStatus :: Maybe Bool -> Journal -> Journal
-filterJournalPostingsByClearedStatus Nothing j = j
-filterJournalPostingsByClearedStatus (Just c) j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}
- where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter ((==c) . postingCleared) ps}
-
--- | Strip out any virtual postings, if the flag is true, otherwise do
--- no filtering.
-filterJournalPostingsByRealness :: Bool -> Journal -> Journal
-filterJournalPostingsByRealness False l = l
-filterJournalPostingsByRealness True j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}
- where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter isReal ps}
-
--- | Strip out any postings with zero amount, unless the flag is true.
-filterJournalPostingsByEmpty :: Bool -> Journal -> Journal
-filterJournalPostingsByEmpty True l = l
-filterJournalPostingsByEmpty False j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}
- where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (not . isEmptyPosting) ps}
-
--- | Keep only transactions which affect accounts deeper than the specified depth.
-filterJournalTransactionsByDepth :: Maybe Int -> Journal -> Journal
-filterJournalTransactionsByDepth Nothing j = j
-filterJournalTransactionsByDepth (Just d) j@Journal{jtxns=ts} =
- j{jtxns=(filter (any ((<= d+1) . accountNameLevel . paccount) . tpostings) ts)}
-
--- | Strip out any postings to accounts deeper than the specified depth
--- (and any ledger transactions which have no postings as a result).
-filterJournalPostingsByDepth :: Maybe Int -> Journal -> Journal
-filterJournalPostingsByDepth Nothing j = j
-filterJournalPostingsByDepth (Just d) j@Journal{jtxns=ts} =
- j{jtxns=filter (not . null . tpostings) $ map filtertxns ts}
- where filtertxns t@Transaction{tpostings=ps} =
- t{tpostings=filter ((<= d) . accountNameLevel . paccount) ps}
-
--- | Keep only transactions which affect accounts matched by the account patterns.
-filterJournalTransactionsByAccount :: [String] -> Journal -> Journal
-filterJournalTransactionsByAccount apats j@Journal{jtxns=ts} = j{jtxns=filter match ts}
- where match = any (matchpats apats . paccount) . tpostings
-
--- | Keep only postings which affect accounts matched by the account patterns.
--- This can leave transactions unbalanced.
-filterJournalPostingsByAccount :: [String] -> Journal -> Journal
-filterJournalPostingsByAccount apats j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}
- where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (matchpats apats . paccount) ps}
-
--- | Convert this journal's transactions' primary date to either the
--- actual or effective date.
-journalSelectingDate :: WhichDate -> Journal -> Journal
-journalSelectingDate ActualDate j = j
-journalSelectingDate EffectiveDate j =
- j{jtxns=map (ledgerTransactionWithDate EffectiveDate) $ jtxns j}
-
--- | Convert all the journal's amounts to their canonical display settings.
--- Ie, in each commodity, amounts will use the display settings of the first
--- amount detected, and the greatest precision of the amounts detected.
--- Also, missing unit prices are added if known from the price history.
--- Also, amounts are converted to cost basis if that flag is active.
--- XXX refactor
-canonicaliseAmounts :: Bool -> Journal -> Journal
-canonicaliseAmounts costbasis j@Journal{jtxns=ts} = j{jtxns=map fixledgertransaction ts}
- where
- fixledgertransaction (Transaction d ed s c de co ts pr) = Transaction d ed s c de co (map fixrawposting ts) pr
- where
- fixrawposting (Posting s ac a c t txn) = Posting s ac (fixmixedamount a) c t txn
- fixmixedamount (Mixed as) = Mixed $ map fixamount as
- fixamount = (if costbasis then costOfAmount else id) . fixprice . fixcommodity
- fixcommodity a = a{commodity=c} where c = canonicalcommoditymap ! symbol (commodity a)
- canonicalcommoditymap =
- Map.fromList [(s,firstc{precision=maxp}) | s <- commoditysymbols,
- let cs = commoditymap ! s,
- let firstc = head cs,
- let maxp = maximum $ map precision cs
- ]
- commoditymap = Map.fromList [(s,commoditieswithsymbol s) | s <- commoditysymbols]
- commoditieswithsymbol s = filter ((s==) . symbol) commodities
- commoditysymbols = nub $ map symbol commodities
- commodities = map commodity (concatMap (amounts . pamount) (journalPostings j)
- ++ concatMap (amounts . hamount) (historical_prices j))
- fixprice :: Amount -> Amount
- fixprice a@Amount{price=Just _} = a
- fixprice a@Amount{commodity=c} = a{price=journalHistoricalPriceFor j d c}
-
- -- | Get the price for a commodity on the specified day from the price database, if known.
- -- Does only one lookup step, ie will not look up the price of a price.
- journalHistoricalPriceFor :: Journal -> Day -> Commodity -> Maybe MixedAmount
- journalHistoricalPriceFor j d Commodity{symbol=s} = do
- let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices j
- case ps of (HistoricalPrice{hamount=a}:_) -> Just $ canonicaliseCommodities a
- _ -> Nothing
- where
- canonicaliseCommodities (Mixed as) = Mixed $ map canonicaliseCommodity as
- where canonicaliseCommodity a@Amount{commodity=Commodity{symbol=s}} =
- a{commodity=findWithDefault (error "programmer error: canonicaliseCommodity failed") s canonicalcommoditymap}
-
--- | Get just the amounts from a ledger, in the order parsed.
-journalAmounts :: Journal -> [MixedAmount]
-journalAmounts = map pamount . journalPostings
-
--- | Get just the ammount commodities from a ledger, in the order parsed.
-journalCommodities :: Journal -> [Commodity]
-journalCommodities = map commodity . concatMap amounts . journalAmounts
-
--- | Get just the amount precisions from a ledger, in the order parsed.
-journalPrecisions :: Journal -> [Int]
-journalPrecisions = map precision . journalCommodities
-
--- | Close any open timelog sessions using the provided current time.
-journalConvertTimeLog :: LocalTime -> Journal -> Journal
-journalConvertTimeLog t l0 = l0 { jtxns = convertedTimeLog ++ jtxns l0
- , open_timelog_entries = []
- }
- where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0
-
--- | The (fully specified) date span containing all the raw ledger's transactions,
--- or DateSpan Nothing Nothing if there are none.
-journalDateSpan :: Journal -> DateSpan
-journalDateSpan j
- | null ts = DateSpan Nothing Nothing
- | otherwise = DateSpan (Just $ tdate $ head ts) (Just $ addDays 1 $ tdate $ last ts)
- where
- ts = sortBy (comparing tdate) $ jtxns j
-
--- | Check if a set of ledger account/description patterns matches the
--- given account name or entry description. Patterns are case-insensitive
--- regular expression strings; those beginning with - are anti-patterns.
-matchpats :: [String] -> String -> Bool
-matchpats pats str =
- (null positives || any match positives) && (null negatives || not (any match negatives))
- where
- (negatives,positives) = partition isnegativepat pats
- match "" = True
- match pat = containsRegex (abspat pat) str
- negateprefix = "not:"
- isnegativepat = (negateprefix `isPrefixOf`)
- abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat
-
--- | Calculate the account tree and account balances from a journal's
--- postings, and return the results for efficient lookup.
-crunchJournal :: Journal -> (Tree AccountName, Map.Map AccountName Account)
-crunchJournal j = (ant,amap)
- where
- (ant,psof,_,inclbalof) = (groupPostings . journalPostings) j
- amap = Map.fromList [(a, acctinfo a) | a <- flatten ant]
- acctinfo a = Account a (psof a) (inclbalof a)
-
--- | Given a list of postings, return an account name tree and three query
--- functions that fetch postings, balance, and subaccount-including
--- balance by account name. This factors out common logic from
--- cacheLedger and summarisePostingsInDateSpan.
-groupPostings :: [Posting] -> (Tree AccountName,
- (AccountName -> [Posting]),
- (AccountName -> MixedAmount),
- (AccountName -> MixedAmount))
-groupPostings ps = (ant,psof,exclbalof,inclbalof)
- where
- anames = sort $ nub $ map paccount ps
- ant = accountNameTreeFrom $ expandAccountNames anames
- allanames = flatten ant
- pmap = Map.union (postingsByAccount ps) (Map.fromList [(a,[]) | a <- allanames])
- psof = (pmap !)
- balmap = Map.fromList $ flatten $ calculateBalances ant psof
- exclbalof = fst . (balmap !)
- inclbalof = snd . (balmap !)
-
--- | Add subaccount-excluding and subaccount-including balances to a tree
--- of account names somewhat efficiently, given a function that looks up
--- transactions by account name.
-calculateBalances :: Tree AccountName -> (AccountName -> [Posting]) -> Tree (AccountName, (MixedAmount, MixedAmount))
-calculateBalances ant psof = addbalances ant
- where
- addbalances (Node a subs) = Node (a,(bal,bal+subsbal)) subs'
- where
- bal = sumPostings $ psof a
- subsbal = sum $ map (snd . snd . root) subs'
- subs' = map addbalances subs
-
--- | Convert a list of postings to a map from account name to that
--- account's postings.
-postingsByAccount :: [Posting] -> Map.Map AccountName [Posting]
-postingsByAccount ps = m'
- where
- sortedps = sortBy (comparing paccount) ps
- groupedps = groupBy (\p1 p2 -> paccount p1 == paccount p2) sortedps
- m' = Map.fromList [(paccount $ head g, g) | g <- groupedps]
diff --git a/Ledger/Ledger.hs b/Ledger/Ledger.hs
deleted file mode 100644
--- a/Ledger/Ledger.hs
+++ /dev/null
@@ -1,180 +0,0 @@
-{-|
-
-A compound data type for efficiency. A 'Ledger' caches information derived
-from a 'Journal' for easier querying. Also it typically has had
-uninteresting 'Transaction's and 'Posting's filtered out. It
-contains:
-
-- the original unfiltered 'Journal'
-
-- a tree of 'AccountName's
-
-- a map from account names to 'Account's
-
-- the full text of the journal file, when available
-
-This is the main object you'll deal with as a user of the Ledger
-library. The most useful functions also have shorter, lower-case
-aliases for easier interaction. Here's an example:
-
-> > import Ledger
-> > l <- readLedger "sample.ledger"
-> > accountnames l
-> ["assets","assets:bank","assets:bank:checking","assets:bank:saving",...
-> > accounts l
-> [Account assets with 0 txns and $-1 balance,Account assets:bank with...
-> > topaccounts l
-> [Account assets with 0 txns and $-1 balance,Account expenses with...
-> > account l "assets"
-> Account assets with 0 txns and $-1 balance
-> > accountsmatching ["ch"] l
-> accountsmatching ["ch"] l
-> [Account assets:bank:checking with 4 txns and $0 balance]
-> > subaccounts l (account l "assets")
-> subaccounts l (account l "assets")
-> [Account assets:bank with 0 txns and $1 balance,Account assets:cash...
-> > head $ transactions l
-> 2008/01/01 income assets:bank:checking $1 RegularPosting
-> > accounttree 2 l
-> Node {rootLabel = Account top with 0 txns and 0 balance, subForest = [...
-> > accounttreeat l (account l "assets")
-> Just (Node {rootLabel = Account assets with 0 txns and $-1 balance, ...
-> > datespan l -- disabled
-> DateSpan (Just 2008-01-01) (Just 2009-01-01)
-> > rawdatespan l
-> DateSpan (Just 2008-01-01) (Just 2009-01-01)
-> > ledgeramounts l
-> [$1,$-1,$1,$-1,$1,$-1,$1,$1,$-2,$1,$-1]
-> > commodities l
-> [Commodity {symbol = "$", side = L, spaced = False, comma = False, ...
-
-
--}
-
-module Ledger.Ledger
-where
-import qualified Data.Map as Map
-import Data.Map (findWithDefault, fromList)
-import Ledger.Utils
-import Ledger.Types
-import Ledger.Account (nullacct)
-import Ledger.AccountName
-import Ledger.Journal
-import Ledger.Posting
-
-
-instance Show Ledger where
- show l = printf "Ledger with %d transactions, %d accounts\n%s"
- (length (jtxns $ journal l) +
- length (jmodifiertxns $ journal l) +
- length (jperiodictxns $ journal l))
- (length $ accountnames l)
- (showtree $ accountnametree l)
-
-nullledger :: Ledger
-nullledger = Ledger{
- journal = nulljournal,
- accountnametree = nullaccountnametree,
- accountmap = fromList []
- }
-
--- | Convert a journal to a more efficient cached ledger, described above.
-cacheLedger :: Journal -> Ledger
-cacheLedger j = nullledger{journal=j,accountnametree=ant,accountmap=amap}
- where (ant, amap) = crunchJournal j
-
--- | Add (or recalculate) the cached journal info in a ledger.
-cacheLedger' :: Ledger -> CachedLedger
-cacheLedger' l = l{accountnametree=ant,accountmap=amap}
- where (ant, amap) = crunchJournal $ journal l
-
--- | Like cacheLedger, but filtering the journal first.
-cacheLedger'' filterspec l@Ledger{journal=j} = l{journal=j',accountnametree=ant,accountmap=amap}
- where (ant, amap) = crunchJournal j'
- j' = filterJournalPostings filterspec{depth=Nothing} j
-
-type CachedLedger = Ledger
-
--- | List a ledger's account names.
-ledgerAccountNames :: Ledger -> [AccountName]
-ledgerAccountNames = drop 1 . flatten . accountnametree
-
--- | Get the named account from a (cached) ledger.
--- If the ledger has not been cached (with crunchJournal or
--- cacheLedger'), this returns the null account.
-ledgerAccount :: Ledger -> AccountName -> Account
-ledgerAccount l a = findWithDefault nullacct a $ accountmap l
-
--- | List a ledger's accounts, in tree order
-ledgerAccounts :: Ledger -> [Account]
-ledgerAccounts = drop 1 . flatten . ledgerAccountTree 9999
-
--- | List a ledger's top-level accounts, in tree order
-ledgerTopAccounts :: Ledger -> [Account]
-ledgerTopAccounts = map root . branches . ledgerAccountTree 9999
-
--- | Accounts in ledger whose name matches the pattern, in tree order.
-ledgerAccountsMatching :: [String] -> Ledger -> [Account]
-ledgerAccountsMatching pats = filter (matchpats pats . aname) . accounts
-
--- | List a ledger account's immediate subaccounts
-ledgerSubAccounts :: Ledger -> Account -> [Account]
-ledgerSubAccounts l Account{aname=a} =
- map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ accountnames l
-
--- | List a ledger's postings, in the order parsed.
-ledgerPostings :: Ledger -> [Posting]
-ledgerPostings = journalPostings . journal
-
--- | Get a ledger's tree of accounts to the specified depth.
-ledgerAccountTree :: Int -> Ledger -> Tree Account
-ledgerAccountTree depth l = treemap (ledgerAccount l) $ treeprune depth $ accountnametree l
-
--- | Get a ledger's tree of accounts rooted at the specified account.
-ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account)
-ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l
-
--- | The (fully specified) date span containing all the ledger's (filtered) transactions,
--- or DateSpan Nothing Nothing if there are none.
-ledgerDateSpan :: Ledger -> DateSpan
-ledgerDateSpan = postingsDateSpan . ledgerPostings
-
--- | Convenience aliases.
-accountnames :: Ledger -> [AccountName]
-accountnames = ledgerAccountNames
-
-account :: Ledger -> AccountName -> Account
-account = ledgerAccount
-
-accounts :: Ledger -> [Account]
-accounts = ledgerAccounts
-
-topaccounts :: Ledger -> [Account]
-topaccounts = ledgerTopAccounts
-
-accountsmatching :: [String] -> Ledger -> [Account]
-accountsmatching = ledgerAccountsMatching
-
-subaccounts :: Ledger -> Account -> [Account]
-subaccounts = ledgerSubAccounts
-
-postings :: Ledger -> [Posting]
-postings = ledgerPostings
-
-commodities :: Ledger -> [Commodity]
-commodities = nub . journalCommodities . journal
-
-accounttree :: Int -> Ledger -> Tree Account
-accounttree = ledgerAccountTree
-
-accounttreeat :: Ledger -> Account -> Maybe (Tree Account)
-accounttreeat = ledgerAccountTreeAt
-
--- datespan :: Ledger -> DateSpan
--- datespan = ledgerDateSpan
-
-rawdatespan :: Ledger -> DateSpan
-rawdatespan = journalDateSpan . journal
-
-ledgeramounts :: Ledger -> [MixedAmount]
-ledgeramounts = journalAmounts . journal
diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs
deleted file mode 100644
--- a/Ledger/Parse.hs
+++ /dev/null
@@ -1,587 +0,0 @@
-{-|
-
-Parsers for standard ledger and timelog files.
-
--}
-
-module Ledger.Parse
-where
-import Prelude hiding (readFile, putStr, putStrLn, print, getContents)
-import Control.Monad.Error (ErrorT(..), MonadIO, liftIO, throwError, catchError)
-import Text.ParserCombinators.Parsec
-import Text.ParserCombinators.Parsec.Char
-import Text.ParserCombinators.Parsec.Combinator
-import System.Directory
-import System.IO.UTF8
-import Ledger.Utils
-import Ledger.Types
-import Ledger.Dates
-import Ledger.AccountName (accountNameFromComponents,accountNameComponents)
-import Ledger.Amount
-import Ledger.Transaction
-import Ledger.Posting
-import Ledger.Journal
-import System.FilePath(takeDirectory,combine)
-
-
--- utils
-
--- | Some context kept during parsing.
-data LedgerFileCtx = 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 "container" accounts specified by !account
- } deriving (Read, Show)
-
-emptyCtx :: LedgerFileCtx
-emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] }
-
--- containing accounts "nest" hierarchically
-
-pushParentAccount :: String -> GenParser tok LedgerFileCtx ()
-pushParentAccount parent = updateState addParentAccount
- where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 }
- normalize = (++ ":")
-
-popParentAccount :: GenParser tok LedgerFileCtx ()
-popParentAccount = do ctx0 <- getState
- case ctxAccount ctx0 of
- [] -> unexpected "End of account block with no beginning"
- (_:rest) -> setState $ ctx0 { ctxAccount = rest }
-
-getParentAccount :: GenParser tok LedgerFileCtx String
-getParentAccount = liftM (concat . reverse . ctxAccount) getState
-
-setYear :: Integer -> GenParser tok LedgerFileCtx ()
-setYear y = updateState (\ctx -> ctx{ctxYear=Just y})
-
-getYear :: GenParser tok LedgerFileCtx (Maybe Integer)
-getYear = liftM ctxYear getState
-
-printParseError :: (Show a) => a -> IO ()
-printParseError e = do putStr "ledger parse error at "; print e
-
--- let's get to it
-
-parseLedgerFile :: LocalTime -> FilePath -> ErrorT String IO Journal
-parseLedgerFile t "-" = liftIO getContents >>= parseLedger t "-"
-parseLedgerFile t f = liftIO (readFile f) >>= parseLedger t f
-
--- | Parses the contents of a ledger file, or gives an error. Requires
--- the current (local) time to calculate any unfinished timelog sessions,
--- we pass it in for repeatability.
-parseLedger :: LocalTime -> FilePath -> String -> ErrorT String IO Journal
-parseLedger reftime inname intxt =
- case runParser ledgerFile emptyCtx inname intxt of
- Right m -> liftM (journalConvertTimeLog reftime) $ m `ap` return nulljournal
- Left err -> throwError $ show err
-
-
-ledgerFile :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal))
-ledgerFile = do items <- many ledgerItem
- 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
- ledgerItem = choice [ ledgerDirective
- , liftM (return . addTransaction) ledgerTransaction
- , liftM (return . addModifierTransaction) ledgerModifierTransaction
- , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction
- , liftM (return . addHistoricalPrice) ledgerHistoricalPrice
- , ledgerDefaultYear
- , emptyLine >> return (return id)
- , liftM (return . addTimeLogEntry) timelogentry
- ]
-
-ledgerDirective :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal))
-ledgerDirective = do char '!' "directive"
- directive <- many nonspace
- case directive of
- "include" -> ledgerInclude
- "account" -> ledgerAccountBegin
- "end" -> ledgerAccountEnd
- _ -> mzero
-
-ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal))
-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 ledgerFile outerState 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"
-
-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
-
-ledgerAccountBegin :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal))
-ledgerAccountBegin = do many1 spacenonewline
- parent <- ledgeraccountname
- newline
- pushParentAccount parent
- return $ return id
-
-ledgerAccountEnd :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal))
-ledgerAccountEnd = popParentAccount >> return (return id)
-
--- parsers
-
--- | Parse a Journal from either a ledger file or a timelog file.
--- It tries first the timelog parser then the ledger parser; this means
--- parse errors for ledgers are useful while those for timelogs are not.
-
-{-| Parse a ledger file. Here is the ledger grammar 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.
-@
-
-See "Tests" for sample data.
--}
-
-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"
-
-ledgerModifierTransaction :: GenParser Char LedgerFileCtx ModifierTransaction
-ledgerModifierTransaction = do
- char '=' "modifier transaction"
- many spacenonewline
- valueexpr <- restofline
- postings <- ledgerpostings
- return $ ModifierTransaction valueexpr postings
-
-ledgerPeriodicTransaction :: GenParser Char LedgerFileCtx PeriodicTransaction
-ledgerPeriodicTransaction = do
- char '~' "periodic transaction"
- many spacenonewline
- periodexpr <- restofline
- postings <- ledgerpostings
- return $ PeriodicTransaction periodexpr postings
-
-ledgerHistoricalPrice :: GenParser Char LedgerFileCtx 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
-
--- like ledgerAccountBegin, updates the LedgerFileCtx
-ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal))
-ledgerDefaultYear = do
- char 'Y' "default year"
- many spacenonewline
- y <- many1 digit
- let y' = read y
- guard (y' >= 1000)
- setYear y'
- return $ return id
-
--- | Try to parse a ledger entry. If we successfully parse an entry, ensure it is balanced,
--- and if we cannot, raise an error.
-ledgerTransaction :: GenParser Char LedgerFileCtx Transaction
-ledgerTransaction = do
- date <- ledgerdate "transaction"
- edate <- try (ledgereffectivedate date "effective date") <|> return Nothing
- status <- ledgerstatus
- code <- ledgercode
- description <- many1 spacenonewline >> liftM rstrip (many1 (noneOf ";\n") "description")
- comment <- ledgercomment <|> return ""
- restofline
- 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 LedgerFileCtx Day
-ledgerdate = (try ledgerfulldate <|> ledgerpartialdate) "full or partial date"
-
-ledgerfulldate :: GenParser Char LedgerFileCtx Day
-ledgerfulldate = do
- (y,m,d) <- ymd
- return $ fromGregorian (read y) (read m) (read d)
-
--- | Match a partial M/D date in a ledger. Warning, this terminates the
--- program if it finds a match when there is no default year specified.
-ledgerpartialdate :: GenParser Char LedgerFileCtx Day
-ledgerpartialdate = do
- (_,m,d) <- md
- y <- getYear
- when (y==Nothing) $ fail "partial date found, but no default year specified"
- return $ fromGregorian (fromJust y) (read m) (read d)
-
-ledgerdatetime :: GenParser Char LedgerFileCtx 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 LedgerFileCtx (Maybe Day)
-ledgereffectivedate actualdate = do
- char '='
- -- kludgily 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 $ Just 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 ""
-
--- Complicated to handle intermixed comment lines.. please make me better.
-ledgerpostings :: GenParser Char LedgerFileCtx [Posting]
-ledgerpostings = do
- ctx <- getState
- let parses p = isRight . parseWithCtx ctx p
- ls <- many1 $ try linebeginningwithspaces
- let ls' = filter (not . (ledgercommentline `parses`)) ls
- guard (not $ null ls')
- return $ map (fromparse . parseWithCtx ctx 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 LedgerFileCtx Posting
-ledgerposting = do
- many1 spacenonewline
- status <- ledgerstatus
- account <- transactionaccountname
- let (ptype, account') = (postingTypeFromAccountName account, unbracket account)
- amount <- postingamount
- many spacenonewline
- comment <- ledgercomment <|> return ""
- restofline
- return (Posting status account' amount comment ptype Nothing)
-
--- Qualify with the parent account from parsing context
-transactionaccountname :: GenParser Char LedgerFileCtx AccountName
-transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname
-
--- | 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 String
-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)"
-
-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
- 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 $ 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 = many1 (noneOf "-.0123456789;\n ") "commodity symbol"
-
-priceamount :: GenParser Char st (Maybe MixedAmount)
-priceamount =
- try (do
- many spacenonewline
- char '@'
- many spacenonewline
- a <- someamount
- 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)
-
-
-{-| Parse a timelog entry. Here is the timelog grammar 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
-
--}
-timelogentry :: GenParser Char LedgerFileCtx TimeLogEntry
-timelogentry = do
- code <- oneOf "bhioO"
- many1 spacenonewline
- datetime <- ledgerdatetime
- comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline)
- return $ TimeLogEntry (read [code]) datetime (fromMaybe "" comment)
-
-
--- misc parsing
-
--- | Parse a --display expression which is a simple date predicate, like
--- "d>[DATE]" or "d<=[DATE]", and return a posting-matching predicate.
-datedisplayexpr :: GenParser Char st (Posting -> Bool)
-datedisplayexpr = do
- char 'd'
- op <- compareop
- char '['
- (y,m,d) <- smartdate
- char ']'
- let date = parsedate $ printf "%04s/%02s/%02s" y m d
- test op = return $ (`op` date) . postingDate
- case op of
- "<" -> test (<)
- "<=" -> test (<=)
- "=" -> test (==)
- "==" -> test (==)
- ">=" -> test (>=)
- ">" -> test (>)
- _ -> mzero
-
-compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"]
-
diff --git a/Ledger/Posting.hs b/Ledger/Posting.hs
deleted file mode 100644
--- a/Ledger/Posting.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-{-|
-
-A 'Posting' represents a 'MixedAmount' being added to or subtracted from a
-single 'Account'. Each 'Transaction' contains two or more postings which
-should add up to 0. Postings also reference their parent transaction, so
-we can get a date or description for a posting (from the transaction).
-
--}
-
-module Ledger.Posting
-where
-import Ledger.Utils
-import Ledger.Types
-import Ledger.Amount
-import Ledger.AccountName
-import Ledger.Dates (nulldate)
-
-
-instance Show Posting where show = showPosting
-
-nullposting = Posting False "" nullmixedamt "" RegularPosting Nothing
-
-showPosting :: Posting -> String
-showPosting (Posting{paccount=a,pamount=amt,pcomment=com,ptype=t}) =
- concatTopPadded [showaccountname a ++ " ", showamount amt, comment]
- where
- ledger3ishlayout = False
- acctnamewidth = if ledger3ishlayout then 25 else 22
- showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width
- (bracket,width) = case t of
- BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)
- VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)
- _ -> (id,acctnamewidth)
- showamount = padleft 12 . showMixedAmountOrZero
- comment = if null com then "" else " ; " ++ com
--- XXX refactor
-showPostingWithoutPrice (Posting{paccount=a,pamount=amt,pcomment=com,ptype=t}) =
- concatTopPadded [showaccountname a ++ " ", showamount amt, comment]
- where
- ledger3ishlayout = False
- acctnamewidth = if ledger3ishlayout then 25 else 22
- showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width
- (bracket,width) = case t of
- BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)
- VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)
- _ -> (id,acctnamewidth)
- showamount = padleft 12 . showMixedAmountOrZeroWithoutPrice
- comment = if null com then "" else " ; " ++ com
-
-isReal :: Posting -> Bool
-isReal p = ptype p == RegularPosting
-
-isVirtual :: Posting -> Bool
-isVirtual p = ptype p == VirtualPosting
-
-isBalancedVirtual :: Posting -> Bool
-isBalancedVirtual p = ptype p == BalancedVirtualPosting
-
-hasAmount :: Posting -> Bool
-hasAmount = (/= missingamt) . pamount
-
-postingTypeFromAccountName a
- | head a == '[' && last a == ']' = BalancedVirtualPosting
- | head a == '(' && last a == ')' = VirtualPosting
- | otherwise = RegularPosting
-
-accountNamesFromPostings :: [Posting] -> [AccountName]
-accountNamesFromPostings = nub . map paccount
-
-sumPostings :: [Posting] -> MixedAmount
-sumPostings = sum . map pamount
-
-postingDate :: Posting -> Day
-postingDate p = maybe nulldate tdate $ ptransaction p
-
-postingCleared :: Posting -> Bool
-postingCleared p = maybe False tstatus $ ptransaction p
-
--- | Does this posting fall within the given date span ?
-isPostingInDateSpan :: DateSpan -> Posting -> Bool
-isPostingInDateSpan (DateSpan Nothing Nothing) _ = True
-isPostingInDateSpan (DateSpan Nothing (Just e)) p = postingDate p < e
-isPostingInDateSpan (DateSpan (Just b) Nothing) p = postingDate p >= b
-isPostingInDateSpan (DateSpan (Just b) (Just e)) p = d >= b && d < e where d = postingDate p
-
-isEmptyPosting :: Posting -> Bool
-isEmptyPosting = isZeroMixedAmount . pamount
-
--- | Get the minimal date span which contains all the postings, or
--- DateSpan Nothing Nothing if there are none.
-postingsDateSpan :: [Posting] -> DateSpan
-postingsDateSpan [] = DateSpan Nothing Nothing
-postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps')
- where ps' = sortBy (comparing postingDate) ps
-
diff --git a/Ledger/TimeLog.hs b/Ledger/TimeLog.hs
deleted file mode 100644
--- a/Ledger/TimeLog.hs
+++ /dev/null
@@ -1,90 +0,0 @@
-{-|
-
-A 'TimeLogEntry' is a clock-in, clock-out, or other directive in a timelog
-file (see timeclock.el or the command-line version). These can be
-converted to 'Transactions' and queried like a ledger.
-
--}
-
-module Ledger.TimeLog
-where
-import Ledger.Utils
-import Ledger.Types
-import Ledger.Dates
-import Ledger.Commodity
-import Ledger.Transaction
-
-instance Show TimeLogEntry where
- show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t)
-
-instance Show TimeLogCode where
- show SetBalance = "b"
- show SetRequiredHours = "h"
- show In = "i"
- show Out = "o"
- show FinalOut = "O"
-
-instance Read TimeLogCode where
- readsPrec _ ('b' : xs) = [(SetBalance, xs)]
- readsPrec _ ('h' : xs) = [(SetRequiredHours, xs)]
- readsPrec _ ('i' : xs) = [(In, xs)]
- readsPrec _ ('o' : xs) = [(Out, xs)]
- readsPrec _ ('O' : xs) = [(FinalOut, xs)]
- readsPrec _ _ = []
-
--- | Convert time log entries to ledger transactions. When there is no
--- clockout, add one with the provided current time. Sessions crossing
--- midnight are split into days to give accurate per-day totals.
-entriesFromTimeLogEntries :: LocalTime -> [TimeLogEntry] -> [Transaction]
-entriesFromTimeLogEntries _ [] = []
-entriesFromTimeLogEntries now [i]
- | odate > idate = entryFromTimeLogInOut i o' : entriesFromTimeLogEntries now [i',o]
- | otherwise = [entryFromTimeLogInOut i o]
- where
- o = TimeLogEntry Out end ""
- end = if itime > now then itime else now
- (itime,otime) = (tldatetime i,tldatetime o)
- (idate,odate) = (localDay itime,localDay otime)
- o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}
- i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}
-entriesFromTimeLogEntries now (i:o:rest)
- | odate > idate = entryFromTimeLogInOut i o' : entriesFromTimeLogEntries now (i':o:rest)
- | otherwise = entryFromTimeLogInOut i o : entriesFromTimeLogEntries now rest
- where
- (itime,otime) = (tldatetime i,tldatetime o)
- (idate,odate) = (localDay itime,localDay otime)
- o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}
- i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}
-
--- | Convert a timelog clockin and clockout entry to an equivalent ledger
--- entry, representing the time expenditure. Note this entry is not balanced,
--- since we omit the \"assets:time\" transaction for simpler output.
-entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Transaction
-entryFromTimeLogInOut i o
- | otime >= itime = t
- | otherwise =
- error $ "clock-out time less than clock-in time in:\n" ++ showTransaction t
- where
- t = Transaction {
- tdate = idate,
- teffectivedate = Nothing,
- tstatus = True,
- tcode = "",
- tdescription = showtime itod ++ "-" ++ showtime otod,
- tcomment = "",
- tpostings = ps,
- tpreceding_comment_lines=""
- }
- showtime = take 5 . show
- acctname = tlcomment i
- itime = tldatetime i
- otime = tldatetime o
- itod = localTimeOfDay itime
- otod = localTimeOfDay otime
- idate = localDay itime
- 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=RegularPosting,ptransaction=Just t}
- --,Posting "assets:time" (-amount) "" RegularPosting
- ]
diff --git a/Ledger/Transaction.hs b/Ledger/Transaction.hs
deleted file mode 100644
--- a/Ledger/Transaction.hs
+++ /dev/null
@@ -1,142 +0,0 @@
-{-|
-
-A 'Transaction' represents a single balanced entry in the ledger file. It
-normally contains two or more balanced 'Posting's.
-
--}
-
-module Ledger.Transaction
-where
-import Ledger.Utils
-import Ledger.Types
-import Ledger.Dates
-import Ledger.Posting
-import Ledger.Amount
-
-
-instance Show Transaction where show = showTransactionUnelided
-
-instance Show ModifierTransaction where
- show t = "= " ++ mtvalueexpr t ++ "\n" ++ unlines (map show (mtpostings t))
-
-instance Show PeriodicTransaction where
- show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t))
-
-nulltransaction :: Transaction
-nulltransaction = Transaction {
- tdate=nulldate,
- teffectivedate=Nothing,
- tstatus=False,
- tcode="",
- tdescription="",
- tcomment="",
- tpostings=[],
- tpreceding_comment_lines=""
- }
-
-{-|
-Show a ledger entry, formatted for the print command. ledger 2.x's
-standard format looks like this:
-
-@
-yyyy/mm/dd[ *][ CODE] description......... [ ; comment...............]
- account name 1..................... ...$amount1[ ; comment...............]
- account name 2..................... ..$-amount1[ ; comment...............]
-
-pcodewidth = no limit -- 10 -- mimicking ledger layout.
-pdescwidth = no limit -- 20 -- I don't remember what these mean,
-pacctwidth = 35 minimum, no maximum -- they were important at the time.
-pamtwidth = 11
-pcommentwidth = no limit -- 22
-@
--}
-showTransaction :: Transaction -> String
-showTransaction = showTransaction' True False
-
-showTransactionUnelided :: Transaction -> String
-showTransactionUnelided = showTransaction' False False
-
-showTransactionForPrint :: Bool -> Transaction -> String
-showTransactionForPrint effective = showTransaction' False effective
-
-showTransaction' :: Bool -> Bool -> Transaction -> String
-showTransaction' elide effective t =
- unlines $ [description] ++ showpostings (tpostings t) ++ [""]
- where
- description = concat [date, status, code, desc, comment]
- date | effective = showdate $ fromMaybe (tdate t) $ teffectivedate t
- | otherwise = showdate (tdate t) ++ maybe "" showedate (teffectivedate t)
- status = if tstatus t then " *" else ""
- code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else ""
- desc = ' ' : tdescription t
- comment = if null com then "" else " ; " ++ com where com = tcomment t
- showdate = printf "%-10s" . showDate
- showedate = printf "=%s" . showdate
- showpostings ps
- | elide && length ps > 1 && isTransactionBalanced t
- = map showposting (init ps) ++ [showpostingnoamt (last ps)]
- | otherwise = map showposting ps
- where
- showposting p = showacct p ++ " " ++ showamount (pamount p) ++ showcomment (pcomment p)
- showpostingnoamt p = rstrip $ showacct p ++ " " ++ showcomment (pcomment p)
- showacct p = " " ++ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p))
- w = maximum $ map (length . paccount) ps
- showamount = printf "%12s" . showMixedAmount
- showcomment s = if null s then "" else " ; "++s
- showstatus p = if pstatus p then "* " else ""
-
--- | Show an account name, clipped to the given width if any, and
--- appropriately bracketed/parenthesised for the given posting type.
-showAccountName :: Maybe Int -> PostingType -> AccountName -> String
-showAccountName w = fmt
- where
- fmt RegularPosting = take w'
- fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse
- fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse
- w' = fromMaybe 999999 w
- parenthesise s = "("++s++")"
- bracket s = "["++s++"]"
-
-isTransactionBalanced :: Transaction -> Bool
-isTransactionBalanced (Transaction {tpostings=ps}) =
- all (isReallyZeroMixedAmount . costOfMixedAmount . sum . map pamount)
- [filter isReal ps, filter isBalancedVirtual ps]
-
--- | 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}
- | length missingamounts' > 1 = Left $ printerr "could not balance this transaction, too many missing amounts"
- | not $ isTransactionBalanced t' = Left $ printerr nonzerobalanceerror
- | otherwise = Right t'
- where
- (withamounts, missingamounts) = partition hasAmount $ filter isReal ps
- (_, missingamounts') = partition hasAmount ps
- t' = t{tpostings=ps'}
- ps' | length missingamounts == 1 = map balance ps
- | otherwise = ps
- where
- balance p | isReal p && not (hasAmount p) = p{pamount = costOfMixedAmount (-otherstotal)}
- | otherwise = p
- where otherstotal = sum $ map pamount withamounts
- printerr s = printf "%s:\n%s" s (showTransactionUnelided t)
-
-nonzerobalanceerror = "could not balance this transaction, amounts do not add up to zero"
-
--- | Convert the primary date to either the actual or effective date.
-ledgerTransactionWithDate :: WhichDate -> Transaction -> Transaction
-ledgerTransactionWithDate ActualDate t = t
-ledgerTransactionWithDate EffectiveDate t = txnTieKnot t{tdate=fromMaybe (tdate t) (teffectivedate t)}
-
-
--- | Ensure a transaction's postings refer back to it.
-txnTieKnot :: Transaction -> Transaction
-txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (settxn t) ps}
-
--- | Set a posting's parent transaction.
-settxn :: Transaction -> Posting -> Posting
-settxn t p = p{ptransaction=Just t}
-
diff --git a/Ledger/Types.hs b/Ledger/Types.hs
deleted file mode 100644
--- a/Ledger/Types.hs
+++ /dev/null
@@ -1,153 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-|
-
-Most data types are defined here to avoid import cycles.
-Here is an overview of the hledger data model:
-
-> Ledger -- hledger's ledger is a journal file plus cached/derived data
-> Journal -- a representation of the journal file, containing..
-> [Transaction] -- ..journal transactions, which have date, status, code, description and..
-> [Posting] -- ..two or more account postings (account name and amount)
-> Tree AccountName -- all account names as a tree
-> Map AccountName Account -- a map from account name to account info (postings and balances)
-
-For more detailed documentation on each type, see the corresponding modules.
-
-Terminology has been in flux:
-
- - ledger 2 had entries containing transactions.
-
- - hledger 0.4 had Entrys containing RawTransactions, which were flattened to Transactions.
-
- - ledger 3 has transactions containing postings.
-
- - hledger 0.5 had LedgerTransactions containing Postings, which were flattened to Transactions.
-
- - hledger 0.8 has Transactions containing Postings, and no flattened type.
-
--}
-
-module Ledger.Types
-where
-import Ledger.Utils
-import qualified Data.Map as Map
-import System.Time (ClockTime)
-import Data.Typeable (Typeable)
-
-
-type SmartDate = (String,String,String)
-
-data WhichDate = ActualDate | EffectiveDate deriving (Eq,Show)
-
-data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord)
-
-data Interval = NoInterval | Daily | Weekly | Monthly | Quarterly | Yearly
- deriving (Eq,Show,Ord)
-
-type AccountName = String
-
-data Side = L | R deriving (Eq,Show,Ord)
-
-data Commodity = Commodity {
- symbol :: String, -- ^ the commodity's symbol
- -- display preferences for amounts of this commodity
- side :: Side, -- ^ should the symbol appear on the left or the right
- 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)
-
-data Amount = Amount {
- commodity :: Commodity,
- quantity :: Double,
- price :: Maybe MixedAmount -- ^ unit price/conversion rate for this amount at posting time
- } deriving (Eq)
-
-newtype MixedAmount = Mixed [Amount] deriving (Eq)
-
-data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting
- deriving (Eq,Show)
-
-data Posting = Posting {
- pstatus :: Bool,
- paccount :: AccountName,
- pamount :: MixedAmount,
- pcomment :: String,
- ptype :: PostingType,
- ptransaction :: Maybe Transaction -- ^ this posting's parent transaction (co-recursive types).
- -- Tying this knot gets tedious, Maybe makes it easier/optional.
- } deriving (Eq)
-
-data Transaction = Transaction {
- tdate :: Day,
- teffectivedate :: Maybe Day,
- tstatus :: Bool, -- XXX tcleared ?
- tcode :: String,
- tdescription :: String,
- tcomment :: String,
- tpostings :: [Posting],
- tpreceding_comment_lines :: String
- } deriving (Eq)
-
-data ModifierTransaction = ModifierTransaction {
- mtvalueexpr :: String,
- mtpostings :: [Posting]
- } deriving (Eq)
-
-data PeriodicTransaction = PeriodicTransaction {
- ptperiodicexpr :: String,
- ptpostings :: [Posting]
- } deriving (Eq)
-
-data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord)
-
-data TimeLogEntry = TimeLogEntry {
- tlcode :: TimeLogCode,
- tldatetime :: LocalTime,
- tlcomment :: String
- } deriving (Eq,Ord)
-
-data HistoricalPrice = HistoricalPrice {
- hdate :: Day,
- hsymbol :: String,
- hamount :: MixedAmount
- } deriving (Eq) -- & Show (in Amount.hs)
-
-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
- } deriving (Eq)
-
-data Account = Account {
- aname :: AccountName,
- apostings :: [Posting], -- ^ transactions in this account
- abalance :: MixedAmount -- ^ sum of transactions in this account and subaccounts
- }
-
-data Ledger = Ledger {
- journal :: Journal,
- accountnametree :: Tree AccountName,
- accountmap :: Map.Map AccountName Account
- } deriving Typeable
-
--- | A generic, pure specification of how to filter transactions/postings.
--- This exists to keep app-specific options out of the hledger library.
-data FilterSpec = FilterSpec {
- datespan :: DateSpan -- ^ only include if in this date span
- ,cleared :: Maybe Bool -- ^ only include if cleared\/uncleared\/don't care
- ,real :: Bool -- ^ only include if real\/don't care
- ,empty :: Bool -- ^ include if empty (ie amount is zero)
- ,costbasis :: Bool -- ^ convert all amounts to cost basis
- ,acctpats :: [String] -- ^ only include if matching these account patterns
- ,descpats :: [String] -- ^ only include if matching these description patterns
- ,whichdate :: WhichDate -- ^ which dates to use (actual or effective)
- ,depth :: Maybe Int
- } deriving (Show)
-
diff --git a/Ledger/Utils.hs b/Ledger/Utils.hs
deleted file mode 100644
--- a/Ledger/Utils.hs
+++ /dev/null
@@ -1,270 +0,0 @@
-{-|
-
-Provide standard imports and utilities which are useful everywhere, or
-needed low in the module hierarchy. This is the bottom of the dependency graph.
-
--}
-
-module Ledger.Utils (
-module Char,
-module Control.Monad,
-module Data.List,
---module Data.Map,
-module Data.Maybe,
-module Data.Ord,
-module Data.Tree,
-module Data.Time.Clock,
-module Data.Time.Calendar,
-module Data.Time.LocalTime,
-module Debug.Trace,
-module Ledger.Utils,
-module Text.Printf,
-module Text.RegexPR,
-module Test.HUnit,
-)
-where
-import Prelude hiding (readFile)
-import Char
-import Control.Exception
-import Control.Monad
-import Data.List
---import qualified Data.Map as Map
-import Data.Maybe
-import Data.Ord
-import Data.Tree
-import Data.Time.Clock
-import Data.Time.Calendar
-import Data.Time.LocalTime
-import Debug.Trace
-import System.IO.UTF8
-import Test.HUnit
-import Text.Printf
-import Text.RegexPR
-import Text.ParserCombinators.Parsec
-
-
--- strings
-
-lowercase = map toLower
-uppercase = map toUpper
-
-strip = lstrip . rstrip
-lstrip = dropws
-rstrip = reverse . dropws . reverse
-dropws = dropWhile (`elem` " \t")
-
-elideLeft width s =
- if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s
-
-elideRight width s =
- if length s > width then take (width - 2) s ++ ".." else s
-
-underline :: String -> String
-underline s = s' ++ replicate (length s) '-' ++ "\n"
- where s'
- | last s == '\n' = s
- | otherwise = s ++ "\n"
-
-unbracket :: String -> String
-unbracket s
- | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s
- | otherwise = s
-
--- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded.
-concatTopPadded :: [String] -> String
-concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded
- where
- lss = map lines strs
- h = maximum $ map length lss
- ypad ls = replicate (difforzero h (length ls)) "" ++ ls
- xpad ls = map (padleft w) ls where w | null ls = 0
- | otherwise = maximum $ map length ls
- padded = map (xpad . ypad) lss
-
--- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.
-concatBottomPadded :: [String] -> String
-concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded
- where
- lss = map lines strs
- h = maximum $ map length lss
- ypad ls = ls ++ replicate (difforzero h (length ls)) ""
- xpad ls = map (padleft w) ls where w | null ls = 0
- | otherwise = maximum $ map length ls
- padded = map (xpad . ypad) lss
-
--- | Convert a multi-line string to a rectangular string top-padded to the specified height.
-padtop :: Int -> String -> String
-padtop h s = intercalate "\n" xpadded
- where
- ls = lines s
- sh = length ls
- sw | null ls = 0
- | otherwise = maximum $ map length ls
- ypadded = replicate (difforzero h sh) "" ++ ls
- xpadded = map (padleft sw) ypadded
-
--- | Convert a multi-line string to a rectangular string bottom-padded to the specified height.
-padbottom :: Int -> String -> String
-padbottom h s = intercalate "\n" xpadded
- where
- ls = lines s
- sh = length ls
- sw | null ls = 0
- | otherwise = maximum $ map length ls
- ypadded = ls ++ replicate (difforzero h sh) ""
- xpadded = map (padleft sw) ypadded
-
--- | Convert a multi-line string to a rectangular string left-padded to the specified width.
-padleft :: Int -> String -> String
-padleft w "" = concat $ replicate w " "
-padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s
-
--- | Convert a multi-line string to a rectangular string right-padded to the specified width.
-padright :: Int -> String -> String
-padright w "" = concat $ replicate w " "
-padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s
-
--- | Clip a multi-line string to the specified width and height from the top left.
-cliptopleft :: Int -> Int -> String -> String
-cliptopleft w h = intercalate "\n" . take h . map (take w) . lines
-
--- | Clip and pad a multi-line string to fill the specified width and height.
-fitto :: Int -> Int -> String -> String
-fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline
- where
- rows = map (fit w) $ lines s
- fit w = take w . (++ repeat ' ')
- blankline = replicate w ' '
-
--- math
-
-difforzero :: (Num a, Ord a) => a -> a -> a
-difforzero a b = maximum [(a - b), 0]
-
--- regexps
-
-containsRegex :: String -> String -> Bool
-containsRegex r s = case matchRegexPR ("(?i)"++r) s of
- Just _ -> True
- _ -> False
-
-
--- lists
-
-splitAtElement :: Eq a => a -> [a] -> [[a]]
-splitAtElement e l =
- case dropWhile (e==) l of
- [] -> []
- l' -> first : splitAtElement e rest
- where
- (first,rest) = break (e==) l'
-
--- trees
-
-root = rootLabel
-subs = subForest
-branches = subForest
-
--- | List just the leaf nodes of a tree
-leaves :: Tree a -> [a]
-leaves (Node v []) = [v]
-leaves (Node _ branches) = concatMap leaves branches
-
--- | get the sub-tree rooted at the first (left-most, depth-first) occurrence
--- of the specified node value
-subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a)
-subtreeat v t
- | root t == v = Just t
- | otherwise = subtreeinforest v $ subs t
-
--- | get the sub-tree for the specified node value in the first tree in
--- forest in which it occurs.
-subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a)
-subtreeinforest _ [] = Nothing
-subtreeinforest v (t:ts) = case (subtreeat v t) of
- Just t' -> Just t'
- Nothing -> subtreeinforest v ts
-
--- | remove all nodes past a certain depth
-treeprune :: Int -> Tree a -> Tree a
-treeprune 0 t = Node (root t) []
-treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t)
-
--- | apply f to all tree nodes
-treemap :: (a -> b) -> Tree a -> Tree b
-treemap f t = Node (f $ root t) (map (treemap f) $ branches t)
-
--- | remove all subtrees whose nodes do not fulfill predicate
-treefilter :: (a -> Bool) -> Tree a -> Tree a
-treefilter f t = Node
- (root t)
- (map (treefilter f) $ filter (treeany f) $ branches t)
-
--- | is predicate true in any node of tree ?
-treeany :: (a -> Bool) -> Tree a -> Bool
-treeany f t = f (root t) || any (treeany f) (branches t)
-
--- treedrop -- remove the leaves which do fulfill predicate.
--- treedropall -- do this repeatedly.
-
--- | show a compact ascii representation of a tree
-showtree :: Show a => Tree a -> String
-showtree = unlines . filter (containsRegex "[^ \\|]") . lines . drawTree . treemap show
-
--- | show a compact ascii representation of a forest
-showforest :: Show a => Forest a -> String
-showforest = concatMap showtree
-
--- debugging
-
--- | trace (print on stdout at runtime) a showable expression
--- (for easily tracing in the middle of a complex expression)
-strace :: Show a => a -> a
-strace a = trace (show a) a
-
--- | labelled trace - like strace, with a newline and a label prepended
-ltrace :: Show a => String -> a -> a
-ltrace l a = trace (l ++ ": " ++ show a) a
-
--- | trace an expression using a custom show function
-tracewith f e = trace (f e) e
-
--- parsing
-
-parsewith :: Parser a -> String -> Either ParseError a
-parsewith p = parse p ""
-
-parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a
-parseWithCtx ctx p = runParser p ctx ""
-
-fromparse :: Either ParseError a -> a
-fromparse = either (\e -> error $ "parse error at "++ show e) id
-
-nonspace :: GenParser Char st Char
-nonspace = satisfy (not . isSpace)
-
-spacenonewline :: GenParser Char st Char
-spacenonewline = satisfy (`elem` " \v\f\t")
-
-restofline :: GenParser Char st String
-restofline = anyChar `manyTill` newline
-
--- time
-
-getCurrentLocalTime :: IO LocalTime
-getCurrentLocalTime = do
- t <- getCurrentTime
- tz <- getCurrentTimeZone
- return $ utcToLocalTime tz t
-
--- misc
-
-isLeft :: Either a b -> Bool
-isLeft (Left _) = True
-isLeft _ = False
-
-isRight :: Either a b -> Bool
-isRight = not . isLeft
-
-strictReadFile :: FilePath -> IO String
-strictReadFile f = readFile f >>= \s -> Control.Exception.evaluate (length s) >> return s
diff --git a/Options.hs b/Options.hs
--- a/Options.hs
+++ b/Options.hs
@@ -11,7 +11,9 @@
import Ledger.Utils
import Ledger.Types
import Ledger.Dates
+#if __GLASGOW_HASKELL__ <= 610
import Codec.Binary.UTF8.String (decodeString)
+#endif
import Control.Monad (liftM)
progname = "hledger"
@@ -24,11 +26,10 @@
usagehdr =
"Usage: hledger [OPTIONS] [COMMAND [PATTERNS]]\n" ++
- " hours [OPTIONS] [COMMAND [PATTERNS]]\n" ++
- " hledger convert CSVFILE\n" ++
+ " hledger [OPTIONS] convert CSVFILE\n" ++
+ " hledger [OPTIONS] stats\n" ++
"\n" ++
- "hledger uses your ~/.ledger or $LEDGER file (or another specified with -f),\n" ++
- "while hours uses your ~/.timelog or $TIMELOG file.\n" ++
+ "hledger uses your ~/.ledger or $LEDGER file, or another specified with -f\n" ++
"\n" ++
"COMMAND is one of (may be abbreviated):\n" ++
" add - prompt for new transactions and add them to the ledger\n" ++
@@ -149,7 +150,11 @@
-- YYYY/MM/DD format based on the current time.
parseArguments :: IO ([Opt], String, [String])
parseArguments = do
+#if __GLASGOW_HASKELL__ <= 610
args <- liftM (map decodeString) getArgs
+#else
+ args <- getArgs
+#endif
let (os,as,es) = getOpt Permute options args
-- istimequery <- usingTimeProgramName
-- let os' = if istimequery then (Period "today"):os else os
diff --git a/README b/README
--- a/README
+++ b/README
@@ -14,12 +14,13 @@
- get accurate numbers for client billing and tax filing
- track invoices
-Here is a **demo_** of the web interface.
+Here is a demo_ of the web interface.
-Here are ready-to-run **binaries_** for mac, windows and gnu/linux.
+Here are ready-to-run binaries_ for mac, windows and gnu/linux.
+They are not always the `latest release`_, sorry about that.
-Here is the **manual_**.
-For support and more technical info, see **`hledger for techies`_** or **`email me`_**.
+Here is the manual_.
+For support and more technical info, see `hledger for techies`_ or `email me`_.
.. (If you're reading this in plain text, see also README2, MANUAL etc., or http://hledger.org)
@@ -32,3 +33,4 @@
.. _32 bit intel: http://hledger.org/binaries/hledger-0.6.1+9-linux-i386.gz
.. _64 bit intel: http://hledger.org/binaries/hledger-0.6-linux-x86_64.gz
.. _email me: mailto:simon@joyful.com
+.. _latest release: http://hledger.org/MANUAL.html#installing
diff --git a/Tests.hs b/Tests.hs
--- a/Tests.hs
+++ b/Tests.hs
@@ -30,18 +30,19 @@
where
import qualified Data.Map as Map
import Data.Time.Format
-import Locale (defaultTimeLocale)
-import Text.ParserCombinators.Parsec
+import System.Locale (defaultTimeLocale)
import Test.HUnit.Tools (runVerboseTests)
import System.Exit (exitFailure, exitWith, ExitCode(ExitSuccess)) -- base 3 compatible
import System.Time (ClockTime(TOD))
import Commands.All
-import Ledger
+import Ledger -- including testing utils in Ledger.Utils
import Options
import Utils
+-- | Run unit tests.
+runtests :: [Opt] -> [String] -> IO ()
runtests opts args = do
(counts,_) <- runner ts
if errors counts > 0 || (failures counts > 0)
@@ -50,41 +51,18 @@
where
runner | Verbose `elem` opts = runVerboseTests
| otherwise = liftM (flip (,) 0) . runTestTT
- ts = TestList $ filter matchname $ concatMap tflatten tests
- --ts = tfilter matchname $ TestList tests -- unflattened
+ ts = TestList $ filter matchname $ tflatten tests -- show flat test names
+ -- ts = tfilter matchname $ TestList tests -- show hierarchical test names
matchname = matchpats args . tname
--- | Get a Test's label, or the empty string.
-tname :: Test -> String
-tname (TestLabel n _) = n
-tname _ = ""
-
--- | Flatten a Test containing TestLists into a list of single tests.
-tflatten :: Test -> [Test]
-tflatten (TestLabel _ t@(TestList _)) = tflatten t
-tflatten (TestList ts) = concatMap tflatten ts
-tflatten t = [t]
-
--- | Filter TestLists in a Test, recursively, preserving the structure.
-tfilter :: (Test -> Bool) -> Test -> Test
-tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts)
-tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts
-tfilter _ t = t
-
--- | Simple way to assert something is some expected value, with no label.
-is :: (Eq a, Show a) => a -> a -> Assertion
-a `is` e = assertEqual "" e a
-
--- | Assert a parse result is some expected value, or print a parse error.
-parseis :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion
-parse `parseis` expected = either printParseError (`is` expected) parse
-
-------------------------------------------------------------------------------
--- | Tests for any function or topic. Mostly ordered by test name.
-tests :: [Test]
-tests = [
+-- | unit tests, augmenting the ones defined in each module. Where that is
+-- inconvenient due to import cycles or whatever, we define them here.
+tests :: Test
+tests = TestList [
+ tests_Ledger,
+ tests_Commands,
- "account directive" ~:
+ "account directive" ~:
let sameParse str1 str2 = do l1 <- journalFromString str1
l2 <- journalFromString str2
l1 `is` l2
@@ -129,29 +107,6 @@
accountNameTreeFrom ["a","a:b"] `is` Node "top" [Node "a" [Node "a:b" []]]
accountNameTreeFrom ["a:b:c"] `is` Node "top" [Node "a" [Node "a:b" [Node "a:b:c" []]]]
- ,"amount arithmetic" ~: do
- let a1 = dollars 1.23
- let a2 = Amount (comm "$") (-1.23) Nothing
- let a3 = Amount (comm "$") (-1.23) Nothing
- (a1 + a2) `is` Amount (comm "$") 0 Nothing
- (a1 + a3) `is` Amount (comm "$") 0 Nothing
- (a2 + a3) `is` Amount (comm "$") (-2.46) Nothing
- (a3 + a3) `is` Amount (comm "$") (-2.46) Nothing
- sum [a2,a3] `is` Amount (comm "$") (-2.46) Nothing
- sum [a3,a3] `is` Amount (comm "$") (-2.46) Nothing
- sum [a1,a2,a3,-a3] `is` Amount (comm "$") 0 Nothing
- let dollar0 = dollar{precision=0}
- (sum [Amount dollar 1.25 Nothing, Amount dollar0 (-1) Nothing, Amount dollar (-0.25) Nothing])
- `is` (Amount dollar 0 Nothing)
-
- ,"mixed amount arithmetic" ~: do
- let dollar0 = dollar{precision=0}
- (sum $ map (Mixed . (\a -> [a]))
- [Amount dollar 1.25 Nothing,
- Amount dollar0 (-1) Nothing,
- Amount dollar (-0.25) Nothing])
- `is` Mixed [Amount dollar 0 Nothing]
-
,"balance report tests" ~:
let (opts,args) `gives` es = do
l <- sampleledgerwithopts opts args
@@ -458,27 +413,8 @@
r <- journalFromString "" -- don't know how to get it from ledgerFile
assertBool "ledgerFile parsing an empty file should give an empty ledger" $ null $ jtxns r
- ,"ledgerHistoricalPrice" ~:
- parseWithCtx emptyCtx ledgerHistoricalPrice price1_str `parseis` price1
-
- ,"ledgerTransaction" ~: do
- parseWithCtx emptyCtx ledgerTransaction entry1_str `parseis` 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
-
- ,"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" ~:
- parseWithCtx emptyCtx ledgerposting rawposting1_str `parseis` rawposting1
+ ,"normaliseMixedAmount" ~: do
+ normaliseMixedAmount (Mixed []) ~?= Mixed [nullamt]
,"parsedate" ~: do
parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1
@@ -672,65 +608,6 @@
,"show hours" ~: show (hours 1) ~?= "1.0h"
- ,"showTransaction" ~: do
- assertEqual "show a balanced transaction, eliding last amount"
- (unlines
- ["2007/01/28 coopportunity"
- ," expenses:food:groceries $47.18"
- ," 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)
- ] ""
- in showTransaction t)
- assertEqual "show a balanced transaction, no eliding"
- (unlines
- ["2007/01/28 coopportunity"
- ," expenses:food:groceries $47.18"
- ," 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)
- ] ""
- in showTransactionUnelided t)
- -- document some cases that arise in debug/testing:
- assertEqual "show an unbalanced transaction, should not elide"
- (unlines
- ["2007/01/28 coopportunity"
- ," expenses:food:groceries $47.18"
- ," assets:checking $-47.19"
- ,""
- ])
- (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
- ] ""))
- assertEqual "show an unbalanced transaction with one posting, should not elide"
- (unlines
- ["2007/01/28 coopportunity"
- ," expenses:food:groceries $47.18"
- ,""
- ])
- (showTransaction
- (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""
- [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing
- ] ""))
- assertEqual "show a transaction with one posting and a missing amount"
- (unlines
- ["2007/01/28 coopportunity"
- ," expenses:food:groceries "
- ,""
- ])
- (showTransaction
- (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""
- [Posting False "expenses:food:groceries" missingamt "" RegularPosting Nothing
- ] ""))
-
,"unicode in balance layout" ~: do
l <- ledgerFromStringWithOpts []
"2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n"
@@ -780,23 +657,6 @@
-- "next friday" `gives` "2008/11/28"
-- "next january" `gives` "2009/01/01"
- ,"splitSpan" ~: do
- let gives (interval, span) = (splitSpan interval span `is`)
- (NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives`
- [mkdatespan "2008/01/01" "2009/01/01"]
- (Quarterly,mkdatespan "2008/01/01" "2009/01/01") `gives`
- [mkdatespan "2008/01/01" "2008/04/01"
- ,mkdatespan "2008/04/01" "2008/07/01"
- ,mkdatespan "2008/07/01" "2008/10/01"
- ,mkdatespan "2008/10/01" "2009/01/01"
- ]
- (Quarterly,nulldatespan) `gives`
- [nulldatespan]
- (Daily,mkdatespan "2008/01/01" "2008/01/01") `gives`
- [mkdatespan "2008/01/01" "2008/01/01"]
- (Quarterly,mkdatespan "2008/01/01" "2008/01/01") `gives`
- [mkdatespan "2008/01/01" "2008/01/01"]
-
,"subAccounts" ~: do
l <- liftM cacheLedger' sampleledger
let a = ledgerAccount l "assets"
@@ -837,16 +697,10 @@
-- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [dollars 15]}
-- ]
- ,"postingamount" ~: do
- parseWithCtx emptyCtx postingamount " $47.18" `parseis` Mixed [dollars 47.18]
- parseWithCtx emptyCtx postingamount " $1." `parseis`
- Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing]
-
]
-------------------------------------------------------------------------------
--- test data
+-- fixtures/test data
date1 = parsedate "2008/11/26"
t1 = LocalTime date1 midday
@@ -907,23 +761,6 @@
write_sample_ledger = writeFile "sample.ledger" sample_ledger_str
-rawposting1_str = " expenses:food:dining $10.00\n"
-
-rawposting1 = Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting 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] ""
-
-
entry2_str = unlines
["2007/01/27 * joes diner"
," expenses:food:dining $10.00"
@@ -1256,9 +1093,6 @@
timelogentry2_str = "o 2007/03/11 16:30:00\n"
timelogentry2 = TimeLogEntry Out (parsedatetime "2007/03/11 16:30:00") ""
-
-price1_str = "P 2004/05/01 XYZ $55.00\n"
-price1 = HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55]
a1 = Mixed [(hours 1){price=Just $ Mixed [Amount (comm "$") 10 Nothing]}]
a2 = Mixed [(hours 2){price=Just $ Mixed [Amount (comm "EUR") 10 Nothing]}]
diff --git a/Utils.hs b/Utils.hs
--- a/Utils.hs
+++ b/Utils.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-|
Utilities for top-level modules and ghci. See also "Ledger.IO" and
@@ -12,9 +13,13 @@
import Options (Opt(..),ledgerFilePathFromOpts) -- ,optsToFilterSpec)
import System.Directory (doesFileExist)
import System.IO (stderr)
+#if __GLASGOW_HASKELL__ <= 610
import System.IO.UTF8 (hPutStrLn)
+#else
+import System.IO (hPutStrLn)
+#endif
import System.Exit
-import System.Cmd (system)
+import System.Process (readProcessWithExitCode)
import System.Info (os)
import System.Time (ClockTime,getClockTime)
@@ -69,7 +74,7 @@
openBrowserOn u = trybrowsers browsers u
where
trybrowsers (b:bs) u = do
- e <- system $ printf "%s %s" b u
+ (e,_,_) <- readProcessWithExitCode b [u] ""
case e of
ExitSuccess -> return ExitSuccess
ExitFailure _ -> trybrowsers bs u
@@ -78,8 +83,8 @@
putStrLn $ printf "Please open your browser and visit %s" u
return $ ExitFailure 127
browsers | os=="darwin" = ["open"]
- | os=="mingw32" = ["start","firefox","safari","opera","iexplore"]
- | otherwise = ["sensible-browser","firefox"]
+ | os=="mingw32" = ["start"]
+ | otherwise = ["sensible-browser","gnome-www-browser","firefox"]
-- jeffz: write a ffi binding for it using the Win32 package as a basis
-- start by adding System/Win32/Shell.hsc and follow the style of any
-- other module in that directory for types, headers, error handling and
diff --git a/Version.hs b/Version.hs
--- a/Version.hs
+++ b/Version.hs
@@ -61,13 +61,15 @@
| otherwise = " with " ++ intercalate ", " configflags
configflags = tail [""
+#ifdef CHART
+ ,"chart"
+#endif
#ifdef VTY
,"vty"
#endif
-#ifdef WEB
- ,"web"
-#endif
-#ifdef CHART
- ,"chart"
+#if defined(WEB)
+ ,"web (using simpleserver)"
+#elif defined(WEBHAPPSTACK)
+ ,"web (using happstack)"
#endif
]
diff --git a/hledger.cabal b/hledger.cabal
--- a/hledger.cabal
+++ b/hledger.cabal
@@ -1,6 +1,5 @@
name: hledger
--- Version is set by the makefile
-version: 0.8
+version: 0.9
category: Finance
synopsis: A command-line (or curses or web-based) double-entry accounting tool.
description:
@@ -19,7 +18,7 @@
homepage: http://hledger.org
bug-reports: http://code.google.com/p/hledger/issues
stability: experimental
-tested-with: GHC==6.8, GHC==6.10
+tested-with: GHC==6.10
cabal-version: >= 1.2
build-type: Custom
data-dir: data
@@ -36,45 +35,41 @@
default: False
flag web
- description: enable the web ui
+ description: enable the web ui (using simpleserver)
default: False
+flag webhappstack
+ description: enable the web ui (using happstack)
+ default: False
+
flag chart
description: enable the pie chart generation
default: False
+-- minimal library so cabal list and ghc-pkg list will show this package
library
exposed-modules:
- Ledger
- Ledger.Account
- Ledger.AccountName
- Ledger.Amount
- Ledger.Commodity
- Ledger.Dates
- Ledger.IO
- Ledger.Transaction
- Ledger.Journal
- Ledger.Ledger
- Ledger.Posting
- Ledger.Parse
- Ledger.TimeLog
- Ledger.Types
- Ledger.Utils
- Build-Depends:
- base >= 3 && < 5
- ,containers
- ,directory
- ,filepath
- ,haskell98
- ,old-time
- ,parsec
- ,time
- ,utf8-string >= 0.3
- ,HUnit
+ Version
+-- Build-Depends:
+-- base >= 3 && < 5
+-- ,containers
+-- ,directory
+-- ,filepath
+-- ,old-time
+-- ,parsec
+-- ,time
+-- ,utf8-string >= 0.3
+-- ,HUnit
executable hledger
main-is: hledger.hs
other-modules:
+ HledgerMain
+ Options
+ Paths_hledger
+ Tests
+ Utils
+ Version
Commands.Add
Commands.All
Commands.Balance
@@ -83,45 +78,24 @@
Commands.Print
Commands.Register
Commands.Stats
- Ledger
- Ledger.Account
- Ledger.AccountName
- Ledger.Amount
- Ledger.Commodity
- Ledger.Dates
- Ledger.IO
- Ledger.Transaction
- Ledger.Ledger
- Ledger.Parse
- Ledger.Journal
- Ledger.Posting
- Ledger.TimeLog
- Ledger.Types
- Ledger.Utils
- Options
- Paths_hledger
- Tests
- Utils
- Version
build-depends:
- base >= 3 && < 5
- ,bytestring
+ hledger-lib == 0.9
+ ,HUnit
+ ,base >= 3 && < 5
,containers
,csv
,directory
,filepath
- ,haskell98
,mtl
+ ,old-locale
,old-time
,parsec
,process
,regexpr >= 0.5.1
- ,split
+ ,safe >= 0.2
,testpack
,time
,utf8-string >= 0.3
- ,HUnit
- ,safe >= 0.2
-- should set patchlevel here as in Makefile
cpp-options: -DPATCHLEVEL=0
@@ -134,6 +108,21 @@
if flag(web)
cpp-options: -DWEB
+ other-modules:Commands.Web
+ build-depends:
+ hsp
+ ,hsx
+ ,xhtml >= 3000.2
+ ,loli
+ ,io-storage
+ ,hack-contrib
+ ,hack
+ ,hack-handler-simpleserver
+ ,HTTP >= 4000.0
+ ,applicative-extras
+
+ if flag(webhappstack)
+ cpp-options: -DWEBHAPPSTACK
other-modules:Commands.Web
build-depends:
hsp
diff --git a/hledger.hs b/hledger.hs
--- a/hledger.hs
+++ b/hledger.hs
@@ -1,9 +1,8 @@
--- #!/usr/bin/env runhaskell <- sp doesn't like
-{-# LANGUAGE CPP #-}
+#!/usr/bin/env runhaskell
{-|
hledger - a ledger-compatible text-based accounting tool.
-Copyright (c) 2007-2009 Simon Michael
+Copyright (c) 2007-2010 Simon Michael
Released under GPL version 3 or later.
hledger is a partial haskell clone of John Wiegley's "ledger" text-based
@@ -33,43 +32,8 @@
> > t <- myTimelog
See "Ledger.Ledger" for more examples.
+
-}
module Main where
-import Prelude hiding (putStr, putStrLn)
-import System.IO.UTF8
-
-import Commands.All
-import Ledger
-import Options
-import Tests
-import Utils (withLedgerDo)
-import Version (versionmsg, binaryfilename)
-
-main :: IO ()
-main = do
- (opts, cmd, args) <- parseArguments
- run cmd opts args
- where
- run cmd opts args
- | Help `elem` opts = putStr usage
- | Version `elem` opts = putStrLn versionmsg
- | BinaryFilename `elem` opts = putStrLn binaryfilename
- | cmd `isPrefixOf` "balance" = withLedgerDo opts args cmd balance
- | cmd `isPrefixOf` "convert" = withLedgerDo opts args cmd convert
- | cmd `isPrefixOf` "print" = withLedgerDo opts args cmd print'
- | cmd `isPrefixOf` "register" = withLedgerDo opts args cmd register
- | cmd `isPrefixOf` "histogram" = withLedgerDo opts args cmd histogram
- | cmd `isPrefixOf` "add" = withLedgerDo opts args cmd add
- | cmd `isPrefixOf` "stats" = withLedgerDo opts args cmd stats
-#ifdef VTY
- | cmd `isPrefixOf` "ui" = withLedgerDo opts args cmd ui
-#endif
-#ifdef WEB
- | cmd `isPrefixOf` "web" = withLedgerDo opts args cmd web
-#endif
-#ifdef CHART
- | cmd `isPrefixOf` "chart" = withLedgerDo opts args cmd chart
-#endif
- | cmd `isPrefixOf` "test" = runtests opts args >> return ()
- | otherwise = putStr usage
+import HledgerMain (main)