hledger 0.2 → 0.3

raw patch · 23 files changed

+1981/−685 lines, 23 filesdep +bytestringdep +mtldep +regexprPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, mtl, regexpr, vty

API changes (from Hackage documentation)

Files

• BalanceCommand.hs +67/−4
• Ledger.hs +2/−0
• Ledger/AccountName.hs +7/−29
• Ledger/Amount.hs +28/−8
• Ledger/Dates.hs +375/−42
• Ledger/Entry.hs +15/−11
• Ledger/Ledger.hs +59/−14
• Ledger/Parse.hs +178/−179
• Ledger/RawLedger.hs +65/−37
• Ledger/TimeLog.hs +18/−17
• Ledger/Transaction.hs +2/−1
• Ledger/Types.hs +24/−6
• Ledger/Utils.hs +49/−8
• Options.hs +147/−95
• PrintCommand.hs +1/−1
• README +57/−39
• RegisterCommand.hs +88/−22
• Tests.hs +315/−89
• UICommand.hs +390/−0
• Utils.hs +32/−39
• hledger.cabal +21/−8
• hledger.hs +28/−24
• sample.ledger +13/−12

@@ -125,7 +125,7 @@       showatree t = showAccountTreeWithBalances matchedacctnames t       matchedacctnames = balancereportacctnames l sub apats t       t = (if empty then id else pruneZeroBalanceLeaves) $ ledgerAccountTree maxdepth l-      apats = fst $ parseAccountDescriptionArgs args+      apats = fst $ parseAccountDescriptionArgs opts args       maxdepth = fromMaybe 9999 $ depthFromOpts opts       sub = SubTotal `elem` opts || (isJust $ depthFromOpts opts)       empty = Empty `elem` opts@@ -180,8 +180,71 @@             spaces = "  " ++ replicate (indent * 2) ' '             leafname = accountLeafName fullname             ismatched = fullname `elem` matchednames-            isboringparent = numsubs >= 1 && (bal == subbal || not matched)-            numsubs = length subs++            -- XXX +            isboringparent = numsubs >= 1 && (bal == subbal || not ismatched)             subbal = abalance $ root $ head subs-            matched = fullname `elem` matchednames+            numsubs = length subs+            {- gives:+### Failure in: 52:balance report elides zero-balance root account(s)+expected: ""+ but got: "                   0  test\n"+Cases: 58  Tried: 58  Errors: 0  Failures: 1+Eg:+~/src/hledger$ hledger -f sample2.ledger  -s bal+                   0  test+                  $2    a:aa+                 $-2    b+~/src/hledger$ ledger -f sample2.ledger  -s bal+                  $2  test:a:aa+                 $-2  test:b+-} ++--          isboringparent = hassubs && (not ismatched || (bal `mixedAmountEquals` subsbal))+--          hassubs = not $ null subs+--          subsbal = sum $ map (abalance . root) subs+            {- gives:+### Failure in: 37:balance report with -s+expected: "                 $-1  assets\n                  $1    bank:saving\n                 $-2    cash\n                  $2  expenses\n                  $1    food\n                  $1    supplies\n                 $-2  income\n                 $-1    gifts\n                 $-1    salary\n                  $1  liabilities:debts\n"+ but got: "                  $1  assets:bank:saving\n                 $-2  assets:cash\n                  $1  expenses:food\n                  $1  expenses:supplies\n                 $-1  income:gifts\n                 $-1  income:salary\n                  $1  liabilities:debts\n"+### Failure in: 39:balance report --depth activates -s+expected: "                 $-1  assets\n                  $1    bank\n                 $-2    cash\n                  $2  expenses\n                  $1    food\n                  $1    supplies\n                 $-2  income\n                 $-1    gifts\n                 $-1    salary\n                  $1  liabilities:debts\n"+ but got: "                  $1  assets:bank\n                 $-2  assets:cash\n                  $1  expenses:food\n                  $1  expenses:supplies\n                 $-1  income:gifts\n                 $-1  income:salary\n                  $1  liabilities:debts\n"+### Failure in: 41:balance report with account pattern o and -s+expected: "                  $1  expenses:food\n                 $-2  income\n                 $-1    gifts\n                 $-1    salary\n--------------------\n                 $-1\n"+ but got: "                  $1  expenses:food\n                 $-1  income:gifts\n                 $-1  income:salary\n--------------------\n                 $-1\n"+### Failure in: 42:balance report with account pattern a+expected: "                 $-1  assets\n                  $1    bank:saving\n                 $-2    cash\n                 $-1  income:salary\n                  $1  liabilities\n--------------------\n                 $-1\n"+ but got: "                  $1  assets:bank:saving\n                 $-2  assets:cash\n                 $-1  income:salary\n                  $1  liabilities\n--------------------\n                 $-1\n"+### Failure in: 43:balance report with account pattern e+expected: "                 $-1  assets\n                  $2  expenses\n                  $1    supplies\n                 $-2  income\n                  $1  liabilities:debts\n"+ but got: "                 $-1  assets\n                  $1  expenses:supplies\n                 $-2  income\n                  $1  liabilities:debts\n"+### Failure in: 49:balance report with -E shows zero-balance accounts+expected: "                 $-1  assets\n                  $1    bank\n                  $0      checking\n                  $1      saving\n                 $-2    cash\n--------------------\n                 $-1\n"+ but got: "                  $0  assets:bank:checking\n                  $1  assets:bank:saving\n                 $-2  assets:cash\n--------------------\n                 $-1\n"+### Failure in: 52:balance report elides zero-balance root account(s)+expected: ""+ but got: "                   0  test\n"+Cases: 58  Tried: 58  Errors: 0  Failures: 7+Eg:+~/src/hledger$ hledger -f sample.ledger  -s bal+                  $1  assets:bank:saving+                 $-2  assets:cash+                  $1  expenses:food+                  $1  expenses:supplies+                 $-1  income:gifts+                 $-1  income:salary+                  $1  liabilities:debts+~/src/hledger$ ledger -f sample.ledger  -s bal+                 $-1  assets+                  $1    bank:saving+                 $-2    cash+                  $2  expenses+                  $1    food+                  $1    supplies+                 $-2  income+                 $-1    gifts+                 $-1    salary+                  $1  liabilities:debts+-}

@@ -10,6 +10,7 @@                module Ledger.AccountName,                module Ledger.Amount,                module Ledger.Commodity,+               module Ledger.Dates,                module Ledger.Entry,                module Ledger.Ledger,                module Ledger.Parse,@@ -25,6 +26,7 @@ import Ledger.AccountName import Ledger.Amount import Ledger.Commodity+import Ledger.Dates import Ledger.Entry import Ledger.Ledger import Ledger.Parse

@@ -11,20 +11,21 @@ import Ledger.Types  -sepchar = ':'+-- change to use a different separator for nested accounts+acctsepchar = ':'  accountNameComponents :: AccountName -> [String]-accountNameComponents = splitAtElement sepchar+accountNameComponents = splitAtElement acctsepchar  accountNameFromComponents :: [String] -> AccountName-accountNameFromComponents = concat . intersperse [sepchar]+accountNameFromComponents = concat . intersperse [acctsepchar]  accountLeafName :: AccountName -> String accountLeafName = last . accountNameComponents  accountNameLevel :: AccountName -> Int accountNameLevel "" = 0-accountNameLevel a = (length $ filter (==sepchar) a) + 1+accountNameLevel a = (length $ filter (==acctsepchar) a) + 1  -- | ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"] expandAccountNames :: [AccountName] -> [AccountName]@@ -45,7 +46,7 @@       parentAccountNames' a = [a] ++ (parentAccountNames' $ parentAccountName a)  isAccountNamePrefixOf :: AccountName -> AccountName -> Bool-p `isAccountNamePrefixOf` s = ((p ++ [sepchar]) `isPrefixOf` s)+p `isAccountNamePrefixOf` s = ((p ++ [acctsepchar]) `isPrefixOf` s)  isSubAccountNameOf :: AccountName -> AccountName -> Bool s `isSubAccountNameOf` p = @@ -101,27 +102,6 @@           | otherwise = done++ss  --- -- | 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.--- -- --- -- Call with forbalancereport=True to mimic ledger's balance report--- -- matching. Account patterns usually match the full account name, but in--- -- balance reports when the pattern does not contain : and is not an--- -- anti-pattern, it matches only the leaf name.--- matchpats :: Bool -> [String] -> String -> Bool--- matchpats forbalancereport pats str =---     (null positives || any ismatch positives) && (null negatives || not (any ismatch negatives))---     where ---       isnegative = (== negativepatternchar) . head---       (negatives,positives) = partition isnegative pats---       ismatch pat = containsRegex (mkRegexWithOpts pat' True True) matchee---           where ---             pat' = if isnegative pat then drop 1 pat else pat---             matchee = if forbalancereport && not (':' `elem` pat) && not (isnegative pat)---                       then accountLeafName str---                       else str- -- | 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.@@ -167,10 +147,8 @@       match "" = True       match p = matchregex (abspat p) str -negativepatternchar = '-'-isnegativepat pat = (== [negativepatternchar]) $ take 1 pat+isnegativepat pat = take 1 pat `elem` ["-","^"] abspat pat = if isnegativepat pat then drop 1 pat else pat positivepats = filter (not . isnegativepat) negativepats = filter isnegativepat matchregex pat str = containsRegex (mkRegexWithOpts pat True True) str-

@@ -62,7 +62,7 @@ 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 $ filter (not . isZeroAmount) $ as ++ bs+    (+) (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"@@ -96,17 +96,23 @@ -- | Get the string representation of an amount, based on its commodity's -- display settings. showAmount :: Amount -> String-showAmount (Amount (Commodity {symbol=sym,side=side,spaced=spaced,comma=comma,precision=p}) q pri)+showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) q pri)     | sym=="AUTO" = "" -- can display one of these in an error message     | side==L = printf "%s%s%s%s" sym space quantity price     | side==R = printf "%s%s%s%s" quantity space sym price     where        space = if spaced then " " else ""-      quantity = commad $ printf ("%."++show p++"f") q-      commad = if comma then punctuatethousands else id+      quantity = showAmount' a       price = case pri of (Just pamt) -> " @ " ++ showMixedAmount pamt                           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 =@@ -132,8 +138,18 @@ isZeroMixedAmount :: MixedAmount -> Bool isZeroMixedAmount = all isZeroAmount . 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.+-- 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 @@ -149,16 +165,20 @@     | otherwise = showMixedAmount a  -- | Simplify a mixed amount by combining any component amounts which have--- the same commodity and the same price.+-- the same commodity and the same price. Also removes redundant zero amounts+-- and adds a single zero amount if there are no amounts at all. normaliseMixedAmount :: MixedAmount -> MixedAmount-normaliseMixedAmount (Mixed as) = Mixed as'+normaliseMixedAmount (Mixed as) = Mixed as''     where -      as' = map sumAmountsPreservingPrice $ group $ sort as+      as'' = map sumAmountsPreservingPrice $ 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 isZeroAmount as  sumAmountsPreservingPrice [] = nullamt sumAmountsPreservingPrice as = (sum as){price=price $ head as}

@@ -1,59 +1,211 @@ {-| -Types for Dates and DateTimes, implemented in terms of UTCTime+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---(---     Date,                    ---     DateTime,---     mkDate,---     mkDateTime,---     parsedatetime,---     parsedate,---     datetimeToDate,---     elapsedSeconds,---     today---    )  where  import Data.Time.Clock import Data.Time.Format import Data.Time.Calendar+import Data.Time.Calendar.MonthDay+import Data.Time.Calendar.OrdinalDate+import Data.Time.Calendar.WeekDate import Data.Time.LocalTime import System.Locale (defaultTimeLocale) import Text.Printf import Data.Maybe+import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Char+import Text.ParserCombinators.Parsec.Combinator+import Ledger.Types+import Ledger.Utils -newtype Date = Date UTCTime-    deriving (Ord, Eq) -newtype DateTime = DateTime UTCTime-    deriving (Ord, Eq)+showDate :: Day -> String+showDate d = formatTime defaultTimeLocale "%Y/%m/%d" d -instance Show Date where-   show (Date t) = formatTime defaultTimeLocale "%Y/%m/%d" t+mkUTCTime :: Day -> TimeOfDay -> UTCTime+mkUTCTime day tod = localTimeToUTC utc (LocalTime day tod) -instance Show DateTime where -   show (DateTime t) = formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" t+today :: IO Day+today = do+    t <- getZonedTime+    return $ localDay (zonedTimeToLocalTime t) -mkDate :: Day -> Date-mkDate day = Date (localTimeToUTC utc (LocalTime day midnight))+now :: IO UTCTime+now = getCurrentTime  -mkDateTime :: Day -> TimeOfDay -> DateTime-mkDateTime day tod = DateTime (localTimeToUTC utc (LocalTime day tod))+elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a+elapsedSeconds t1 t2 = realToFrac $ diffUTCTime t1 t2 +dayToUTC :: Day -> UTCTime+dayToUTC d = localTimeToUTC utc (LocalTime d midnight)++-- | Split a DateSpan into one or more consecutive spans at the specified interval.+splitSpan :: Interval -> DateSpan -> [DateSpan]+splitSpan i (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing]+splitSpan NoInterval s = [s]+splitSpan Daily s      = splitspan start next s where (start,next) = (startofday,nextday)+splitSpan Weekly s     = splitspan start next s where (start,next) = (startofweek,nextweek)+splitSpan Monthly s    = splitspan start next s where (start,next) = (startofmonth,nextmonth)+splitSpan Quarterly s  = splitspan start next s where (start,next) = (startofquarter,nextquarter)+splitSpan Yearly s     = splitspan start next s where (start,next) = (startofyear,nextyear)++splitspan _ _ (DateSpan Nothing Nothing) = []+splitspan startof next (DateSpan Nothing (Just e)) = [DateSpan (Just $ startof e) (Just $ next $ startof e)]+splitspan startof next (DateSpan (Just b) Nothing) = [DateSpan (Just $ startof b) (Just $ next $ startof b)]+splitspan startof next s@(DateSpan (Just b) (Just e))+    | b == e = [s]+    | otherwise = splitspan' startof next s+    where splitspan' startof next (DateSpan (Just b) (Just e))+              | b >= e = []+              | otherwise = [DateSpan (Just $ startof b) (Just $ next $ startof b)] +                            ++ splitspan' startof next (DateSpan (Just $ next $ startof b) (Just e))+    +-- | 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,rd) = 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+ -- | Parse a date-time string to a time type, or raise an error.-parsedatetime :: String -> DateTime-parsedatetime s = DateTime $+parsedatetime :: String -> UTCTime+parsedatetime s =      parsetimewith "%Y/%m/%d %H:%M:%S" s $+    parsetimewith "%Y-%m-%d %H:%M:%S" s $     error $ printf "could not parse timestamp \"%s\"" s  -- | Parse a date string to a time type, or raise an error.-parsedate :: String -> Date-parsedate s =  Date $+parsedate :: String -> Day+parsedate s =       parsetimewith "%Y/%m/%d" s $+    parsetimewith "%Y-%m-%d" s $     error $ printf "could not parse date \"%s\"" s  -- | Parse a time string to a time type using the provided pattern, or@@ -61,23 +213,204 @@ parsetimewith :: ParseTime t => String -> String -> t -> t parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s -datetimeToDate :: DateTime -> Date-datetimeToDate (DateTime (UTCTime{utctDay=day})) = Date (UTCTime day 0)+{-| +Parse a date in any of the formats allowed in ledger's period expressions,+and maybe some others: -elapsedSeconds :: Fractional a => DateTime -> DateTime -> a-elapsedSeconds (DateTime dt1) (DateTime dt2) = realToFrac $ diffUTCTime dt1 dt2+> 2004+> 2004/10+> 2004/10/1+> 10/1+> 21+> october, oct+> yesterday, today, tomorrow+> (not yet) this/next/last week/day/month/quarter/year -today :: IO Date-today = getCurrentTime >>= return . Date+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) -dateToUTC :: Date -> UTCTime-dateToUTC (Date u) = u+datesepchar = oneOf "/-." -dateComponents :: Date -> (Integer,Int,Int)-dateComponents = toGregorian . utctDay . dateToUTC+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) --- dateDay :: Date -> Day-dateDay date = d where (_,_,d) = dateComponents date+ymd :: GenParser Char st SmartDate+ymd = do+  y <- many1 digit+  datesepchar+  m <- many1 digit+  guard (read m <= 12)+  datesepchar+  d <- many1 digit+  guard (read d <= 31)+  return (y,m,d) --- dateMonth :: Date -> Day-dateMonth date = m where (_,m,_) = dateComponents date+ym :: GenParser Char st SmartDate+ym = do+  y <- many1 digit+  guard (read y > 12)+  datesepchar+  m <- many1 digit+  guard (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 <- many1 digit+  guard (read m <= 12)+  datesepchar+  d <- many1 digit+  guard (read d <= 31)+  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 e = DateSpan (Just $ parsedate b) (Just $ parsedate e)

@@ -9,6 +9,7 @@ where import Ledger.Utils import Ledger.Types+import Ledger.Dates import Ledger.RawTransaction import Ledger.Amount @@ -19,7 +20,7 @@     show e = "= " ++ (valueexpr e) ++ "\n" ++ unlines (map show (m_transactions e))  instance Show PeriodicEntry where -    show e = "~ " ++ (periodexpr e) ++ "\n" ++ unlines (map show (p_transactions e))+    show e = "~ " ++ (periodicexpr e) ++ "\n" ++ unlines (map show (p_transactions e))  nullentry = Entry {               edate=parsedate "1900/1/1", @@ -53,7 +54,7 @@     where       precedingcomment = epreceding_comment_lines e       description = concat [date, status, code, desc] -- , comment]-      date = showDate $ edate e+      date = showdate $ edate e       status = if estatus e then " *" else ""       code = if (length $ ecode e) > 0 then (printf " (%s)" $ ecode e) else ""       desc = " " ++ edescription e@@ -66,20 +67,23 @@       showamount = printf "%12s" . showMixedAmount       showaccountname s = printf "%-34s" s       showcomment s = if (length s) > 0 then "  ; "++s else ""--showDate d = printf "%-10s" (show d)+      showdate d = printf "%-10s" (showDate d)  isEntryBalanced :: Entry -> Bool isEntryBalanced (Entry {etransactions=ts}) = -    isZeroMixedAmount $ sum $ map tamount $ filter isReal ts+    isZeroMixedAmount $ costOfMixedAmount $ sum $ map tamount $ filter isReal ts --- | Fill in a missing balance in this entry, if we have enough--- information to do that. Excluding virtual transactions, there should be--- at most one missing balance. Otherwise, raise an error.--- The new balance will be converted to cost basis if possible.+-- | 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,+-- raise an error. balanceEntry :: Entry -> Entry-balanceEntry e@Entry{etransactions=ts} = e{etransactions=ts'}-    where +balanceEntry e@Entry{etransactions=ts} = (e{etransactions=ts'})+    where+      check e+          | isEntryBalanced e = e+          | otherwise = error $ "could not balance this entry:\n" ++ show e       (withamounts, missingamounts) = partition hasAmount $ filter isReal ts       ts' = case (length missingamounts) of               0 -> ts

@@ -2,7 +2,8 @@  A 'Ledger' stores, for efficiency, a 'RawLedger' plus its tree of account names, and a map from account names to 'Account's. It may also have had-uninteresting 'Entry's and 'Transaction's filtered out.+uninteresting 'Entry's and 'Transaction's filtered out. It also stores+the complete ledger file text for the ui command.  -} @@ -30,23 +31,59 @@  -- | Convert a raw ledger to a more efficient cached type, described above.   cacheLedger :: [String] -> RawLedger -> Ledger-cacheLedger apats l = Ledger l ant amap+cacheLedger apats l = Ledger{rawledgertext="",rawledger=l,accountnametree=ant,accountmap=acctmap}     where-      ant = rawLedgerAccountNameTree l-      anames = flatten ant+      acctmap = Map.fromList [(a, mkacct a) | a <- flatten ant]+      mkacct a = Account a (txnsof a) (inclbalof a)       ts = filtertxns apats $ rawLedgerTransactions l+      (ant,txnsof,_,inclbalof) = groupTransactions ts++-- | Given a list of transactions, return an account name tree and three+-- query functions that fetch transactions, balance, and+-- subaccount-including balance by account name. +-- This is to factor out common logic from cacheLedger and+-- summariseTransactionsInDateSpan.+groupTransactions :: [Transaction] -> (Tree AccountName,+                                     (AccountName -> [Transaction]), +                                     (AccountName -> MixedAmount), +                                     (AccountName -> MixedAmount))+groupTransactions ts = (ant,txnsof,exclbalof,inclbalof)+    where+      txnanames = sort $ nub $ map account ts+      ant = accountNameTreeFrom $ expandAccountNames $ txnanames+      allanames = flatten ant+      txnmap = Map.union (transactionsByAccount ts) (Map.fromList [(a,[]) | a <- allanames])+      balmap = Map.fromList $ flatten $ calculateBalances ant txnsof+      txnsof = (txnmap !) +      exclbalof = fst . (balmap !)+      inclbalof = snd . (balmap !)+-- debug+--       txnsof a = (txnmap ! (trace ("ts "++a) a))+--       exclbalof a = fst $ (balmap ! (trace ("eb "++a) a))+--       inclbalof a = snd $ (balmap ! (trace ("ib "++a) a))++-- | 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 -> [Transaction]) -> Tree (AccountName, (MixedAmount, MixedAmount))+calculateBalances ant txnsof = addbalances ant+    where +      addbalances (Node a subs) = Node (a,(bal,bal+subsbal)) subs'+          where+            bal         = sumTransactions $ txnsof a+            subsbal     = sum $ map (snd . snd . root) subs'+            subs'       = map addbalances subs++-- | Convert a list of transactions to a map from account name to the list+-- of all transactions in that account. +transactionsByAccount :: [Transaction] -> Map.Map AccountName [Transaction]+transactionsByAccount ts = m'+    where       sortedts = sortBy (comparing account) ts       groupedts = groupBy (\t1 t2 -> account t1 == account t2) sortedts-      txnmap = Map.union -               (Map.fromList [(account $ head g, g) | g <- groupedts])-               (Map.fromList [(a,[]) | a <- anames])-      txnsof = (txnmap !)-      subacctsof a = filter (a `isAccountNamePrefixOf`) anames-      subtxnsof a = concat [txnsof a | a <- [a] ++ subacctsof a]-      balmap = Map.union -               (Map.fromList [(a,(sumTransactions $ subtxnsof a)) | a <- anames])-               (Map.fromList [(a,Mixed []) | a <- anames])-      amap = Map.fromList [(a, Account a (txnmap ! a) (balmap ! a)) | a <- anames]+      m' = Map.fromList [(account $ head g, g) | g <- groupedts]+-- The special account name "top" can be used to look up all transactions. ?+--      m' = Map.insert "top" sortedts m  filtertxns :: [String] -> [Transaction] -> [Transaction] filtertxns apats ts = filter (matchpats apats . account) ts@@ -87,3 +124,11 @@ -- | 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 (explicit) date span containing all the ledger's transactions,+-- or DateSpan Nothing Nothing if there are no transactions.+ledgerDateSpan l+    | null ts = DateSpan Nothing Nothing+    | otherwise = DateSpan (Just $ date $ head ts) (Just $ addDays 1 $ date $ last ts)+    where+      ts = sortBy (comparing date) $ ledgerTransactions l

@@ -6,64 +6,126 @@  module Ledger.Parse where+import Control.Monad+import Control.Monad.Error import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Char import Text.ParserCombinators.Parsec.Language import Text.ParserCombinators.Parsec.Combinator import qualified Text.ParserCombinators.Parsec.Token as P+import System.Directory import System.IO import qualified Data.Map as Map import Ledger.Utils import Ledger.Types+import Ledger.Dates import Ledger.Amount import Ledger.Entry import Ledger.Commodity import Ledger.TimeLog+import Ledger.RawLedger import Data.Time.LocalTime import Data.Time.Calendar   -- utils -parseLedgerFile :: String -> IO (Either ParseError RawLedger)-parseLedgerFile "-" = fmap (parse ledgerfile "-") $ hGetContents stdin-parseLedgerFile f   = parseFromFile ledgerfile f+parseLedgerFile :: FilePath -> ErrorT String IO RawLedger+parseLedgerFile "-" = liftIO (hGetContents stdin) >>= parseLedger "-"+parseLedgerFile f   = liftIO (readFile f)         >>= parseLedger f      printParseError :: (Show a) => a -> IO () printParseError e = do putStr "ledger parse error at "; print e --- set up token parsing, though we're not yet using these much-ledgerLanguageDef = LanguageDef {-   commentStart   = ""-   , commentEnd     = ""-   , commentLine    = ";"-   , nestedComments = False-   , identStart     = letter <|> char '_'-   , identLetter    = alphaNum <|> oneOf "_':"-   , opStart        = opLetter emptyDef-   , opLetter       = oneOf "!#$%&*+./<=>?@\\^|-~"-   , reservedOpNames= []-   , reservedNames  = []-   , caseSensitive  = False-   }-lexer      = P.makeTokenParser ledgerLanguageDef-whiteSpace = P.whiteSpace lexer-lexeme     = P.lexeme lexer---symbol     = P.symbol lexer-natural    = P.natural lexer-parens     = P.parens lexer-semi       = P.semi lexer-identifier = P.identifier lexer-reserved   = P.reserved lexer-reservedOp = P.reservedOp lexer+-- Default accounts "nest" hierarchically +data LedgerFileCtx = Ctx { ctxYear    :: !(Maybe Integer)+                         , ctxCommod  :: !(Maybe String)+                         , ctxAccount :: ![String]+                         } deriving (Read, Show)++emptyCtx :: LedgerFileCtx+emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] }++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++parseLedger :: FilePath -> String -> ErrorT String IO RawLedger+parseLedger inname intxt = case runParser ledgerFile emptyCtx inname intxt of+                             Right m  -> liftM rawLedgerConvertTimeLog $ m `ap` (return rawLedgerEmpty)+                             Left err -> throwError $ show err++-- 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++ledgerFile :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))+ledgerFile = do entries <- many1 ledgerAnyEntry +                eof+                return $ liftM (foldr1 (.)) $ sequence entries+    where ledgerAnyEntry = choice [ ledgerDirective+                                  , liftM (return . addEntry)         ledgerEntry+                                  , liftM (return . addModifierEntry) ledgerModifierEntry+                                  , liftM (return . addPeriodicEntry) ledgerPeriodicEntry+                                  , liftM (return . addHistoricalPrice) ledgerHistoricalPrice+                                  , emptyLine >> return (return id)+                                  , liftM (return . addTimeLogEntry)  timelogentry+                                  ]++ledgerDirective :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))+ledgerDirective = do char '!'+                     directive <- many nonspace+                     case directive of+                       "include" -> ledgerInclude+                       "account" -> ledgerAccountBegin+                       "end"     -> ledgerAccountEnd++ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))+ledgerInclude = do many1 spacenonewline+                   filename <- restofline+                   outerState <- getState+                   outerPos <- getPosition+                   let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"+                   return $ do contents <- expandPath filename >>= readFileE outerPos+                               case runParser ledgerFile outerState filename contents of+                                 Right l   -> l `catchError` (\err -> throwError $ inIncluded ++ err)+                                 Left perr -> throwError $ inIncluded ++ show perr+    where readFileE outerPos filename = ErrorT $ do (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) => FilePath -> m FilePath+expandPath inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory+                                                  return $ homedir ++ drop 1 inname+                  | otherwise                = return inname++ledgerAccountBegin :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))+ledgerAccountBegin = do many1 spacenonewline+                        parent <- ledgeraccountname+                        newline+                        pushParentAccount parent+                        return $ return id++ledgerAccountEnd :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))+ledgerAccountEnd = popParentAccount >> return (return id)+ -- parsers  -- | Parse a RawLedger 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.-ledgerfile :: Parser RawLedger-ledgerfile = try ledgerfromtimelog <|> ledger  {-| Parse a ledger file. Here is the ledger grammar from the ledger 2.5 manual: @@ -165,38 +227,14 @@  See "Tests" for sample data. -}-ledger :: Parser RawLedger-ledger = do-  -- we expect these to come first, unlike ledger-  modifier_entries <- many ledgermodifierentry-  periodic_entries <- many ledgerperiodicentry -  entries <- (many $ try ledgerentry) <?> "entry"-  final_comment_lines <- ledgernondatalines-  eof-  return $ RawLedger modifier_entries periodic_entries entries (unlines final_comment_lines)--ledgernondatalines :: Parser [String]-ledgernondatalines = many (try ledgerdirective <|> -- treat as comments-                           try commentline <|> -                           blankline)--ledgerdirective :: Parser String-ledgerdirective = char '!' >> restofline <?> "directive"--blankline :: Parser String-blankline =-  do {s <- many1 spacenonewline; newline; return s} <|> -  do {newline; return ""} <?> "blank line"--commentline :: Parser String-commentline = do-  many spacenonewline-  char ';' <?> "comment line"-  l <- restofline-  return $ ";" ++ l+emptyLine :: GenParser Char st ()+emptyLine = do many spacenonewline+               optional $ char ';' >> many (noneOf "\n")+               newline+               return () -ledgercomment :: Parser String+ledgercomment :: GenParser Char st String ledgercomment =      try (do           char ';'@@ -205,25 +243,36 @@         )      <|> return "" <?> "comment" -ledgermodifierentry :: Parser ModifierEntry-ledgermodifierentry = do-  char '=' <?> "entry"+ledgerModifierEntry :: GenParser Char LedgerFileCtx ModifierEntry+ledgerModifierEntry = do+  char '=' <?> "modifier entry"   many spacenonewline   valueexpr <- restofline   transactions <- ledgertransactions-  return (ModifierEntry valueexpr transactions)+  return $ ModifierEntry valueexpr transactions -ledgerperiodicentry :: Parser PeriodicEntry-ledgerperiodicentry = do+ledgerPeriodicEntry :: GenParser Char LedgerFileCtx PeriodicEntry+ledgerPeriodicEntry = do   char '~' <?> "entry"   many spacenonewline   periodexpr <- restofline   transactions <- ledgertransactions-  return (PeriodicEntry periodexpr transactions)+  return $ PeriodicEntry periodexpr transactions -ledgerentry :: Parser Entry-ledgerentry = do-  preceding <- ledgernondatalines+ledgerHistoricalPrice :: GenParser Char LedgerFileCtx HistoricalPrice+ledgerHistoricalPrice = do+  char 'P' <?> "hprice"+  many spacenonewline+  date <- ledgerdate+  many spacenonewline+  symbol1 <- commoditysymbol+  many spacenonewline+  (Mixed [Amount c price pri]) <- someamount+  restofline+  return $ HistoricalPrice date symbol1 (symbol c) price++ledgerEntry :: GenParser Char LedgerFileCtx Entry+ledgerEntry = do   date <- ledgerdate <?> "entry"   status <- ledgerstatus   code <- ledgercode@@ -234,10 +283,10 @@   comment <- ledgercomment   restofline   transactions <- ledgertransactions-  return $ balanceEntry $ Entry date status code description comment transactions (unlines preceding)+  return $ balanceEntry $ Entry date status code description comment transactions "" -ledgerday :: Parser Day-ledgerday = do +ledgerdate :: GenParser Char st Day+ledgerdate = do    y <- many1 digit   char '/'   m <- many1 digit@@ -246,12 +295,9 @@   many spacenonewline   return (fromGregorian (read y) (read m) (read d)) -ledgerdate :: Parser Date-ledgerdate = fmap mkDate ledgerday--ledgerdatetime :: Parser DateTime+ledgerdatetime :: GenParser Char st UTCTime ledgerdatetime = do -  day <- ledgerday+  day <- ledgerdate   h <- many1 digit   char ':'   m <- many1 digit@@ -259,47 +305,47 @@       char ':'       many1 digit   many spacenonewline-  return (mkDateTime day (TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)))+  return $ mkUTCTime day (TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s))  -ledgerstatus :: Parser Bool+ledgerstatus :: GenParser Char st Bool ledgerstatus = try (do { char '*'; many1 spacenonewline; return True } ) <|> return False -ledgercode :: Parser String+ledgercode :: GenParser Char st String ledgercode = try (do { char '('; code <- anyChar `manyTill` char ')'; many1 spacenonewline; return code } ) <|> return "" -ledgertransactions :: Parser [RawTransaction]-ledgertransactions = -    ((try virtualtransaction <|> try balancedvirtualtransaction <|> ledgertransaction) <?> "transaction") -    `manyTill` (do {newline <?> "blank line"; return ()} <|> eof)+ledgertransactions :: GenParser Char LedgerFileCtx [RawTransaction]+ledgertransactions = many $ try ledgertransaction -ledgertransaction :: Parser RawTransaction-ledgertransaction = do-  many1 spacenonewline-  account <- ledgeraccountname+ledgertransaction :: GenParser Char LedgerFileCtx RawTransaction+ledgertransaction = many1 spacenonewline >> choice [ normaltransaction, virtualtransaction, balancedvirtualtransaction ]++normaltransaction :: GenParser Char LedgerFileCtx RawTransaction+normaltransaction = do+  account <- transactionaccountname   amount <- transactionamount   many spacenonewline   comment <- ledgercomment   restofline+  parent <- getParentAccount   return (RawTransaction account amount comment RegularTransaction) -virtualtransaction :: Parser RawTransaction+virtualtransaction :: GenParser Char LedgerFileCtx RawTransaction virtualtransaction = do-  many1 spacenonewline   char '('-  account <- ledgeraccountname+  account <- transactionaccountname   char ')'   amount <- transactionamount   many spacenonewline   comment <- ledgercomment   restofline+  parent <- getParentAccount   return (RawTransaction account amount comment VirtualTransaction) -balancedvirtualtransaction :: Parser RawTransaction+balancedvirtualtransaction :: GenParser Char LedgerFileCtx RawTransaction balancedvirtualtransaction = do-  many1 spacenonewline   char '['-  account <- ledgeraccountname+  account <- transactionaccountname   char ']'   amount <- transactionamount   many spacenonewline@@ -307,8 +353,12 @@   restofline   return (RawTransaction account amount comment BalancedVirtualTransaction) +-- 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-ledgeraccountname :: Parser String+ledgeraccountname :: GenParser Char st String ledgeraccountname = do     accountname <- many1 (accountnamechar <|> singlespace)     return $ striptrailingspace accountname@@ -320,7 +370,7 @@ accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace     <?> "account name character (non-bracket, non-parenthesis, non-whitespace)" -transactionamount :: Parser MixedAmount+transactionamount :: GenParser Char st MixedAmount transactionamount =   try (do         many1 spacenonewline@@ -330,7 +380,7 @@  someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount  -leftsymbolamount :: Parser MixedAmount+leftsymbolamount :: GenParser Char st MixedAmount leftsymbolamount = do   sym <- commoditysymbol    sp <- many spacenonewline@@ -340,7 +390,7 @@   return $ Mixed [Amount c q pri]   <?> "left-symbol amount" -rightsymbolamount :: Parser MixedAmount+rightsymbolamount :: GenParser Char st MixedAmount rightsymbolamount = do   (q,p,comma) <- amountquantity   sp <- many spacenonewline@@ -350,7 +400,7 @@   return $ Mixed [Amount c q pri]   <?> "right-symbol amount" -nosymbolamount :: Parser MixedAmount+nosymbolamount :: GenParser Char st MixedAmount nosymbolamount = do   (q,p,comma) <- amountquantity   pri <- priceamount@@ -358,10 +408,10 @@   return $ Mixed [Amount c q pri]   <?> "no-symbol amount" -commoditysymbol :: Parser String+commoditysymbol :: GenParser Char st String commoditysymbol = many1 (noneOf "-.0123456789;\n ") <?> "commodity symbol" -priceamount :: Parser (Maybe MixedAmount)+priceamount :: GenParser Char st (Maybe MixedAmount) priceamount =     try (do           many spacenonewline@@ -376,7 +426,7 @@ -- | 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 :: Parser (Double, Int, Bool)+amountquantity :: GenParser Char st (Double, Int, Bool) amountquantity = do   sign <- optionMaybe $ string "-"   (intwithcommas,frac) <- numberparts@@ -394,10 +444,10 @@ -- | 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 :: Parser (String,String)+numberparts :: GenParser Char st (String,String) numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint -numberpartsstartingwithdigit :: Parser (String,String)+numberpartsstartingwithdigit :: GenParser Char st (String,String) numberpartsstartingwithdigit = do   let digitorcomma = digit <|> char ','   first <- digit@@ -405,25 +455,13 @@   frac <- try (do {char '.'; many digit >>= return}) <|> return ""   return (first:rest,frac)                      -numberpartsstartingwithpoint :: Parser (String,String)+numberpartsstartingwithpoint :: GenParser Char st (String,String) numberpartsstartingwithpoint = do   char '.'   frac <- many1 digit   return ("",frac)                       -spacenonewline :: Parser Char-spacenonewline = satisfy (\c -> c `elem` " \v\f\t")--restofline :: Parser String-restofline = anyChar `manyTill` newline--whiteSpace1 :: Parser ()-whiteSpace1 = do space; whiteSpace--nonspace = satisfy (not . isSpace)-- {-| Parse a timelog file. Here is the timelog grammar, from timeclock.el 2.6:  @@@ -460,81 +498,42 @@ o 2007/03/10 17:26:02  -}-timelog :: Parser TimeLog+timelog :: GenParser Char LedgerFileCtx TimeLog timelog = do   entries <- many timelogentry <?> "timelog entry"   eof   return $ TimeLog entries -timelogentry :: Parser TimeLogEntry+timelogentry :: GenParser Char LedgerFileCtx TimeLogEntry timelogentry = do-  many (commentline <|> blankline)   code <- oneOf "bhioO"   many1 spacenonewline   datetime <- ledgerdatetime-  comment <- restofline+  comment <- liftM2 (++) getParentAccount restofline   return $ TimeLogEntry code datetime comment -ledgerfromtimelog :: Parser RawLedger-ledgerfromtimelog = do -  tl <- timelog-  return $ ledgerFromTimeLog tl - -- misc parsing-{-| -Parse a date in any of the formats allowed in ledger's period expressions: -> 2004-> 2004/10-> 2004/10/1-> 10/1-> october-> oct-> this week  # or day, month, quarter, year-> next week-> last week--}-smartdate :: Parser (String,String,String)-smartdate = do-  (y,m,d) <- (-             try ymd -             <|> try ym -             <|> try y---              <|> try md---              <|> try month---              <|> try mon---              <|> try thiswhatever---              <|> try nextwhatever---              <|> try lastwhatever-            )-  return $ (y,m,d)--datesep = oneOf "/-."--ymd :: Parser (String,String,String)-ymd = do-  y <- many digit-  datesep-  m <- many digit-  datesep-  d <- many digit-  return (y,m,d)--ym :: Parser (String,String,String)-ym = do-  y <- many digit-  datesep-  m <- many digit-  return (y,m,"1")+-- | Parse a --display expression which is a simple date predicate, like+-- "d>[DATE]" or "d<=[DATE]", and return a transaction-matching predicate.+datedisplayexpr :: GenParser Char st (Transaction -> Bool)+datedisplayexpr = do+  char 'd'+  op <- compareop+  char '['+  (y,m,d) <- smartdate+  char ']'+  let edate = parsedate $ printf "%04s/%02s/%02s" y m d+  let matcher = \(Transaction{date=tdate}) -> +                  case op of+                    "<"  -> tdate <  edate+                    "<=" -> tdate <= edate+                    "="  -> tdate == edate+                    "==" -> tdate == edate -- just in case+                    ">=" -> tdate >= edate+                    ">"  -> tdate >  edate+  return matcher               -y :: Parser (String,String,String)-y = do-  y <- many digit-  return (y,"1","1")+compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] --- | Parse a flexible date string, with awareness of the current time,--- | and return a Date or raise an error.-smartparsedate :: String -> Date-smartparsedate s = parsedate $ printf "%04s/%02s/%02s" y m d-    where (y,m,d) = fromparse $ parsewith smartdate s

@@ -8,6 +8,7 @@ module Ledger.RawLedger where import qualified Data.Map as Map+import Data.Map ((!)) import Ledger.Utils import Ledger.Types import Ledger.AccountName@@ -15,6 +16,7 @@ import Ledger.Entry import Ledger.Transaction import Ledger.RawTransaction+import Ledger.TimeLog   instance Show RawLedger where@@ -27,6 +29,30 @@              -- ++ (show $ rawLedgerTransactions l)              where accounts = flatten $ rawLedgerAccountNameTree l +rawLedgerEmpty :: RawLedger+rawLedgerEmpty = RawLedger { modifier_entries = []+                           , periodic_entries = []+                           , entries = []+                           , open_timelog_entries = []+                           , historical_prices = []+                           , final_comment_lines = []+                           }++addEntry :: Entry -> RawLedger -> RawLedger+addEntry e l0 = l0 { entries = e : (entries l0) }++addModifierEntry :: ModifierEntry -> RawLedger -> RawLedger+addModifierEntry me l0 = l0 { modifier_entries = me : (modifier_entries l0) }++addPeriodicEntry :: PeriodicEntry -> RawLedger -> RawLedger+addPeriodicEntry pe l0 = l0 { periodic_entries = pe : (periodic_entries l0) }++addHistoricalPrice :: HistoricalPrice -> RawLedger -> RawLedger+addHistoricalPrice h l0 = l0 { historical_prices = h : (historical_prices l0) }++addTimeLogEntry :: TimeLogEntry -> RawLedger -> RawLedger+addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : (open_timelog_entries l0) }+ rawLedgerTransactions :: RawLedger -> [Transaction] rawLedgerTransactions = txnsof . entries     where txnsof es = concat $ map flattenEntry $ zip es [1..]@@ -43,25 +69,25 @@ -- | Remove ledger entries we are not interested in. -- Keep only those which fall between the begin and end dates, and match -- the description pattern, and are cleared or real if those options are active.-filterRawLedger :: Maybe Date -> Maybe Date -> [String] -> Bool -> Bool -> RawLedger -> RawLedger-filterRawLedger begin end pats clearedonly realonly = +filterRawLedger :: DateSpan -> [String] -> Bool -> Bool -> RawLedger -> RawLedger+filterRawLedger span pats clearedonly realonly =      filterRawLedgerTransactionsByRealness realonly .     filterRawLedgerEntriesByClearedStatus clearedonly .-    filterRawLedgerEntriesByDate begin end .+    filterRawLedgerEntriesByDate span .     filterRawLedgerEntriesByDescription pats  -- | Keep only entries whose description matches the description patterns. filterRawLedgerEntriesByDescription :: [String] -> RawLedger -> RawLedger-filterRawLedgerEntriesByDescription pats (RawLedger ms ps es f) = -    RawLedger ms ps (filter matchdesc es) f+filterRawLedgerEntriesByDescription pats (RawLedger ms ps es tls hs f) = +    RawLedger ms ps (filter matchdesc es) tls hs f     where matchdesc = matchpats pats . edescription  -- | Keep only entries which fall between begin and end dates.  -- We include entries on the begin date and exclude entries on the end -- date, like ledger.  An empty date string means no restriction.-filterRawLedgerEntriesByDate :: Maybe Date -> Maybe Date -> RawLedger -> RawLedger-filterRawLedgerEntriesByDate begin end (RawLedger ms ps es f) = -    RawLedger ms ps (filter matchdate es) f+filterRawLedgerEntriesByDate :: DateSpan -> RawLedger -> RawLedger+filterRawLedgerEntriesByDate (DateSpan begin end) (RawLedger ms ps es tls hs f) = +    RawLedger ms ps (filter matchdate es) tls hs f     where        matchdate e = (maybe True (edate e>=) begin) && (maybe True (edate e<) end) @@ -69,21 +95,21 @@ -- do no filtering. filterRawLedgerEntriesByClearedStatus :: Bool -> RawLedger -> RawLedger filterRawLedgerEntriesByClearedStatus False l = l-filterRawLedgerEntriesByClearedStatus True  (RawLedger ms ps es f) =-    RawLedger ms ps (filter estatus es) f+filterRawLedgerEntriesByClearedStatus True  (RawLedger ms ps es tls hs f) =+    RawLedger ms ps (filter estatus es) tls hs f  -- | Strip out any virtual transactions, if the flag is true, otherwise do -- no filtering. filterRawLedgerTransactionsByRealness :: Bool -> RawLedger -> RawLedger filterRawLedgerTransactionsByRealness False l = l-filterRawLedgerTransactionsByRealness True (RawLedger ms ps es f) =-    RawLedger ms ps (map filtertxns es) f+filterRawLedgerTransactionsByRealness True (RawLedger ms ps es tls hs f) =+    RawLedger ms ps (map filtertxns es) tls hs f     where filtertxns e@Entry{etransactions=ts} = e{etransactions=filter isReal ts}  -- | Keep only entries which affect accounts matched by the account patterns. filterRawLedgerEntriesByAccount :: [String] -> RawLedger -> RawLedger-filterRawLedgerEntriesByAccount apats (RawLedger ms ps es f) =-    RawLedger ms ps (filter (any (matchpats apats . taccount) . etransactions) es) f+filterRawLedgerEntriesByAccount apats (RawLedger ms ps es tls hs f) =+    RawLedger ms ps (filter (any (matchpats apats . taccount) . etransactions) es) tls hs f  -- | Give all a ledger's amounts their canonical display settings.  That -- is, in each commodity, amounts will use the display settings of the@@ -91,37 +117,39 @@ -- detected. Also, amounts are converted to cost basis if that flag is -- active. canonicaliseAmounts :: Bool -> RawLedger -> RawLedger-canonicaliseAmounts costbasis l@(RawLedger ms ps es f) = RawLedger ms ps (map fixEntryAmounts es) f+canonicaliseAmounts costbasis l@(RawLedger ms ps es tls hs f) = RawLedger ms ps (map fixentry es) tls hs f     where -      fixEntryAmounts (Entry d s c de co ts pr) = Entry d s c de co (map fixRawTransactionAmounts ts) pr-      fixRawTransactionAmounts (RawTransaction ac a c t) = RawTransaction ac (fixMixedAmount a) c t-      fixMixedAmount (Mixed as) = Mixed $ map fixAmount as-      fixAmount | costbasis = fixcommodity . costOfAmount-                | otherwise = fixcommodity-      fixcommodity a = a{commodity=canonicalcommodity $ commodity a}-      canonicalcommodity c = (firstoccurrenceof c){precision=maxprecision c}-          where-            firstoccurrenceof c = head $ rawLedgerCommoditiesWithSymbol l (symbol c)-            maxprecision c = maximum $ map precision $ rawLedgerCommoditiesWithSymbol l (symbol c)+      fixentry (Entry d s c de co ts pr) = Entry d s c de co (map fixrawtransaction ts) pr+      fixrawtransaction (RawTransaction ac a c t) = RawTransaction ac (fixmixedamount a) c t+      fixmixedamount (Mixed as) = Mixed $ map fixamount as+      fixamount = fixcommodity . (if costbasis then costOfAmount else id)+      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 . amount) $ rawLedgerTransactions l --- | Get all amount commodities with a given symbol, in the order parsed.--- Must be called with a good symbol or it will fail.-rawLedgerCommoditiesWithSymbol :: RawLedger -> String -> [Commodity]-rawLedgerCommoditiesWithSymbol l s = -    fromMaybe (error $ "no such commodity "++s) (Map.lookup s map)-    where-      map = Map.fromList [(symbol $ head cs,cs) | cs <- groupBy same $ rawLedgerCommodities l]-      same c1 c2 = symbol c1 == symbol c2+-- | Get just the amounts from a ledger, in the order parsed.+rawLedgerAmounts :: RawLedger -> [MixedAmount]+rawLedgerAmounts = map amount . rawLedgerTransactions  -- | Get just the ammount commodities from a ledger, in the order parsed. rawLedgerCommodities :: RawLedger -> [Commodity] rawLedgerCommodities = map commodity . concatMap amounts . rawLedgerAmounts --- | Get just the amounts from a ledger, in the order parsed.-rawLedgerAmounts :: RawLedger -> [MixedAmount]-rawLedgerAmounts = map amount . rawLedgerTransactions- -- | Get just the amount precisions from a ledger, in the order parsed. rawLedgerPrecisions :: RawLedger -> [Int] rawLedgerPrecisions = map precision . rawLedgerCommodities++rawLedgerConvertTimeLog :: RawLedger -> RawLedger+rawLedgerConvertTimeLog l0 = l0 { entries = convertedTimeLog ++ entries l0+                                , open_timelog_entries = []+                                }+    where convertedTimeLog = entriesFromTimeLogEntries $ open_timelog_entries l0 

@@ -10,9 +10,10 @@ where import Ledger.Utils import Ledger.Types+import Ledger.Dates import Ledger.Commodity import Ledger.Amount-+import Ledger.Entry  instance Show TimeLogEntry where      show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t)@@ -20,10 +21,6 @@ instance Show TimeLog where     show tl = printf "TimeLog with %d entries" $ length $ timelog_entries tl --- | Convert a time log to a ledger.-ledgerFromTimeLog :: TimeLog -> RawLedger-ledgerFromTimeLog tl = RawLedger [] [] (entriesFromTimeLogEntries $ timelog_entries tl) ""- -- | Convert time log entries to ledger entries. entriesFromTimeLogEntries :: [TimeLogEntry] -> [Entry] entriesFromTimeLogEntries [] = []@@ -40,20 +37,24 @@ -- entry, representing the time expenditure. Note this entry is  not balanced, -- since we omit the \"assets:time\" transaction for simpler output. entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Entry-entryFromTimeLogInOut i o =-    Entry {-      edate         = indate, -- ledger uses outdate-      estatus       = True,-      ecode         = "",-      edescription  = "",-      ecomment      = "",-      etransactions = txns,-      epreceding_comment_lines=""-    }+entryFromTimeLogInOut i o+    | outtime >= intime = e+    | otherwise = +        error $ "clock-out time less than clock-in time in:\n" ++ showEntry e     where+      e = Entry {+            edate         = outdate, -- like ledger+            estatus       = True,+            ecode         = "",+            edescription  = showtime intime ++ " - " ++ showtime outtime,+            ecomment      = "",+            etransactions = txns,+            epreceding_comment_lines=""+          }+      showtime = show . timeToTimeOfDay . utctDayTime       acctname = tlcomment i-      indate   = datetimeToDate intime-      outdate  = datetimeToDate outtime+      indate   = utctDay intime+      outdate  = utctDay outtime       intime   = tldatetime i       outtime  = tldatetime o       amount   = Mixed [hours $ elapsedSeconds outtime intime / 3600]

@@ -9,6 +9,7 @@ where import Ledger.Utils import Ledger.Types+import Ledger.Dates import Ledger.Entry import Ledger.RawTransaction import Ledger.Amount@@ -17,7 +18,7 @@ instance Show Transaction where show=showTransaction  showTransaction :: Transaction -> String-showTransaction (Transaction eno d desc a amt ttype) = unwords [show d,desc,a,show amt,show ttype]+showTransaction (Transaction eno d desc a amt ttype) = unwords [showDate d,desc,a,show amt,show ttype]  -- | Convert a 'Entry' to two or more 'Transaction's. An id number -- is attached to the transactions to preserve their grouping - it should

@@ -1,7 +1,8 @@ {-| -All the main data types, defined here to avoid import cycles.-See the corresponding modules for documentation.+This is the next layer up from Ledger.Utils. All main data types are+defined here to avoid import cycles; see the corresponding modules for+documentation.  -} @@ -11,6 +12,13 @@ import qualified Data.Map as Map  +type SmartDate = (String,String,String)++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) @@ -51,12 +59,12 @@  -- | a ledger "periodic" entry. Currently ignored. data PeriodicEntry = PeriodicEntry {-      periodexpr :: String,+      periodicexpr :: String,       p_transactions :: [RawTransaction]     } deriving (Eq)  data Entry = Entry {-      edate :: Date,+      edate :: Day,       estatus :: Bool,       ecode :: String,       edescription :: String,@@ -65,16 +73,25 @@       epreceding_comment_lines :: String     } deriving (Eq) +data HistoricalPrice = HistoricalPrice {+     hdate :: Day,+     hsymbol1 :: String,+     hsymbol2 :: String,+     hprice :: Double+} deriving (Eq,Show)+ data RawLedger = RawLedger {       modifier_entries :: [ModifierEntry],       periodic_entries :: [PeriodicEntry],       entries :: [Entry],+      open_timelog_entries :: [TimeLogEntry],+      historical_prices :: [HistoricalPrice],       final_comment_lines :: String     } deriving (Eq)  data TimeLogEntry = TimeLogEntry {       tlcode :: Char,-      tldatetime :: DateTime,+      tldatetime :: UTCTime,       tlcomment :: String     } deriving (Eq,Ord) @@ -84,7 +101,7 @@  data Transaction = Transaction {       entryno :: Int,-      date :: Date,+      date :: Day,       description :: String,       account :: AccountName,       amount :: MixedAmount,@@ -98,6 +115,7 @@     }  data Ledger = Ledger {+      rawledgertext :: String,       rawledger :: RawLedger,       accountnametree :: Tree AccountName,       accountmap :: Map.Map AccountName Account

@@ -1,6 +1,8 @@ {-| -Provide a number of standard modules and utilities.+This is the bottom of the module hierarchy. It provides a number of+standard modules and utilities which are useful everywhere (or, are needed+low in the hierarchy). The "hledger prelude".  -} @@ -14,12 +16,13 @@ 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.Regex,+module Text.RegexPR, module Test.HUnit,-module Ledger.Dates, ) where import Char@@ -31,17 +34,23 @@ import Data.Tree import Data.Time.Clock import Data.Time.Calendar+import Data.Time.LocalTime import Debug.Trace import Test.HUnit--- import Test.QuickCheck hiding (test, Testable) import Text.Printf import Text.Regex-import Text.ParserCombinators.Parsec (parse)-import Ledger.Dates+import Text.RegexPR+import Text.ParserCombinators.Parsec   -- strings +lowercase = map toLower+uppercase = map toUpper++strip = dropspaces . reverse . dropspaces . reverse+    where dropspaces = dropWhile (`elem` " \t")+ elideLeft width s =     case length s > width of       True -> ".." ++ (reverse $ take (width - 2) $ reverse s)@@ -106,6 +115,18 @@ 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 s = intercalate "\n" $ take h $ map (take w) $ lines s++-- | 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 s = take w $ s ++ repeat ' '+      blankline = replicate w ' '+ -- math  difforzero :: (Num a, Ord a) => a -> a -> a@@ -120,6 +141,7 @@                       Just _ -> True                       otherwise -> False + -- lists  splitAtElement :: Eq a => a -> [a] -> [[a]]@@ -136,6 +158,11 @@ 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)@@ -183,7 +210,9 @@  -- debugging --- | trace a showable expression+-- | 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  p = putStr@@ -193,8 +222,20 @@ assertequal e a = assertEqual "" e a assertnotequal e a = assertBool "expected inequality, got equality" (e /= a) --- parsewith :: Parser a+-- parsing++parsewith :: Parser a -> String -> Either ParseError a parsewith p ts = parse p "" ts-fromparse = either (\_ -> error "parse error") id +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 (\c -> c `elem` " \v\f\t")++restofline :: GenParser Char st String+restofline = anyChar `manyTill` newline 

@@ -4,85 +4,178 @@ import System.Console.GetOpt import System.Directory import Text.Printf-import Ledger.AccountName (negativepatternchar)-import Ledger.Parse (smartparsedate)+import Ledger.Parse+import Ledger.Utils+import Ledger.Types import Ledger.Dates -usagehdr    = "Usage: hledger [OPTS] balance|print|register [ACCTPATS] [-- DESCPATS]\n\nOptions"++warning++":"-warning     = if negativepatternchar=='-' then " (must appear before command)" else " (can appear anywhere)"++versionno   = "0.3"+version     = printf "hledger version %s \n" versionno :: String+defaultfile = "~/.ledger"+fileenvvar  = "LEDGER"+usagehdr    = "Usage: hledger [OPTS] COMMAND [ACCTPATTERNS] [-- DESCPATTERNS]\n" +++              "\n" +++              "Options (before command, unless using --options-anywhere):" usageftr    = "\n" ++-              "Commands (may be abbreviated):\n" ++-              "balance  - show account balances\n" ++-              "print    - show formatted ledger entries\n" ++-              "register - show register transactions\n" +++              "Commands (can be abbreviated):\n" +++              "  balance  - show account balances\n" +++              "  print    - show formatted ledger entries\n" +++              "  register - show register transactions\n" ++               "\n" ++-              "Account and description patterns are regular expressions, optionally prefixed\n" ++-              "with " ++ [negativepatternchar] ++ " to make them negative.\n" +++              "All dates can be y/m/d or ledger-style smart dates like \"last month\".\n" +++              "Account and description patterns are regular expressions which filter by\n" +++              "account name and entry description. Prefix a pattern with - to negate it,\n" +++              "and separate account and description patterns with --.\n" +++              "(With --options-anywhere, use ^ and ^^.)\n" ++               "\n" ++-              "Also: hledger [-v] test [TESTPATS] to run some or all self-tests.\n"-defaultfile = "~/.ledger"-fileenvvar  = "LEDGER"-optionorder = if negativepatternchar=='-' then RequireOrder else Permute+              "Also: hledger [-v] test [TESTPATTERNS] to run self-tests.\n" +++              "\n"+usage = usageInfo usagehdr options ++ usageftr  -- | Command-line options we accept. options :: [OptDescr Opt] options = [- Option ['f'] ["file"]         (ReqArg File "FILE")        "ledger file; - means use standard input",- Option ['b'] ["begin"]        (ReqArg Begin "YYYY/MM/DD") "report on entries on or after this date",- Option ['e'] ["end"]          (ReqArg End "YYYY/MM/DD")   "report on entries prior to this date",- Option ['C'] ["cleared"]      (NoArg  Cleared)            "report only on cleared entries",- Option ['B'] ["cost","basis"] (NoArg  CostBasis)          "report cost basis of commodities",- Option []    ["depth"]        (ReqArg Depth "N")          "balance report: maximum account depth to show",- Option ['E'] ["empty"]        (NoArg  Empty)              "balance report: show accounts with zero balance",- Option ['R'] ["real"]         (NoArg  Real)               "report only on real (non-virtual) transactions",- Option ['n'] ["collapse"]     (NoArg  Collapse)           "balance report: no grand total",- Option ['s'] ["subtotal"]     (NoArg  SubTotal)           "balance report: show subaccounts",- Option ['h'] ["help"] (NoArg  Help)                       "show this help",- Option ['v'] ["verbose"]      (NoArg  Verbose)            "verbose test output",- Option ['V'] ["version"]      (NoArg  Version)            "show version"+  Option ['f'] ["file"]         (ReqArg File "FILE")   filehelp+ ,Option ['b'] ["begin"]        (ReqArg Begin "DATE")  "report on entries on or after this date"+ ,Option ['e'] ["end"]          (ReqArg End "DATE")    "report on entries prior to this date"+ ,Option ['p'] ["period"]       (ReqArg Period "EXPR") ("report on entries during the specified period\n" +++                                                       "and/or with the specified reporting interval\n")+ ,Option ['C'] ["cleared"]      (NoArg  Cleared)       "report only on cleared entries"+ ,Option ['B'] ["cost","basis"] (NoArg  CostBasis)     "report cost basis of commodities"+ ,Option []    ["depth"]        (ReqArg Depth "N")     "balance report: maximum account depth to show"+ ,Option ['d'] ["display"]      (ReqArg Display "EXPR") ("display only transactions matching simple EXPR\n" +++                                                        "(where EXPR is 'dOP[DATE]', OP is <, <=, =, >=, >)")+ ,Option ['E'] ["empty"]        (NoArg  Empty)         "balance report: show accounts with zero balance"+ ,Option ['R'] ["real"]         (NoArg  Real)          "report only on real (non-virtual) transactions"+ ,Option []    ["options-anywhere"] (NoArg OptionsAnywhere) "allow options anywhere, use ^ to negate patterns"+ ,Option ['n'] ["collapse"]     (NoArg  Collapse)      "balance report: no grand total"+ ,Option ['s'] ["subtotal"]     (NoArg  SubTotal)      "balance report: show subaccounts"+ ,Option ['W'] ["weekly"]       (NoArg  WeeklyOpt)     "register report: show weekly summary"+ ,Option ['M'] ["monthly"]      (NoArg  MonthlyOpt)    "register report: show monthly summary"+ ,Option ['Y'] ["yearly"]       (NoArg  YearlyOpt)     "register report: show yearly summary"+ ,Option ['h'] ["help"] (NoArg  Help)                  "show this help"+ ,Option ['v'] ["verbose"]      (NoArg  Verbose)       "verbose test output"+ ,Option ['V'] ["version"]      (NoArg  Version)       "show version"+ ,Option []    ["debug-no-ui"]  (NoArg  DebugNoUI)     "when running in ui mode, don't display anything (mostly)"  ]+    where +      filehelp = printf "ledger file; - means use standard input. Defaults\nto the %s environment variable or %s"+                 fileenvvar defaultfile  -- | An option value from a command-line flag. data Opt = -    File String | -    Begin String | -    End String | +    File    {value::String} | +    Begin   {value::String} | +    End     {value::String} | +    Period  {value::String} |      Cleared |      CostBasis | -    Depth String | +    Depth   {value::String} | +    Display {value::String} |      Empty |      Real | +    OptionsAnywhere |      Collapse |     SubTotal |+    WeeklyOpt |+    MonthlyOpt |+    YearlyOpt |     Help |     Verbose |     Version+    | DebugNoUI     deriving (Show,Eq) -usage = usageInfo usagehdr options ++ usageftr+-- yow..+optsWithConstructor f opts = concatMap get opts+    where get o = if f v == o then [o] else [] where v = value o -versionno = "0.2"-version = printf "hledger version %s \n" versionno :: String+optValuesForConstructor f opts = concatMap get opts+    where get o = if f v == o then [v] else [] where v = value o +optValuesForConstructors fs opts = concatMap get opts+    where get o = if any (\f -> f v == o) fs then [v] else [] where v = value o+ -- | Parse the command-line arguments into ledger options, ledger command--- name, and ledger command arguments+-- name, and ledger command arguments. Also any dates in the options are+-- converted to full YYYY/MM/DD format, while we are in the IO monad+-- and can get the current time. parseArguments :: IO ([Opt], String, [String]) parseArguments = do   args <- getArgs-  case (getOpt optionorder options args) of-    (opts,cmd:args,[]) -> return (opts, cmd, args)-    (opts,[],[])       -> return (opts, [], [])-    (_,_,errs)         -> ioError (userError (concat errs ++ usage))+  let order = if "--options-anywhere" `elem` args then Permute else RequireOrder+  case (getOpt order options args) of+    (opts,cmd:args,[]) -> do {opts' <- fixOptDates opts; return (opts',cmd,args)}+    (opts,[],[])       -> do {opts' <- fixOptDates opts; return (opts',[],[])}+    (opts,_,errs)      -> ioError (userError (concat errs ++ usage)) +-- | Convert any fuzzy dates within these option values to explicit ones,+-- based on today's date.+fixOptDates :: [Opt] -> IO [Opt]+fixOptDates opts = do+  t <- today+  return $ map (fixopt t) opts+  where+    fixopt t (Begin s)   = Begin $ fixSmartDateStr t s+    fixopt t (End s)     = End $ fixSmartDateStr t s+    fixopt t (Display s) = -- hacky+        Display $ gsubRegexPRBy "\\[.+?\\]" fixbracketeddatestr s+        where fixbracketeddatestr s = "[" ++ (fixSmartDateStr t $ init $ tail s) ++ "]"+    fixopt _ o            = o++-- | Figure out the overall date span we should report on, based on any+-- begin/end/period options provided. If there is a period option, the+-- others are ignored.+dateSpanFromOpts :: Day -> [Opt] -> DateSpan+dateSpanFromOpts refdate opts+    | not $ null popts = snd $ parsePeriodExpr refdate $ last popts+    | otherwise = DateSpan lastb laste+    where+      popts = optValuesForConstructor Period opts+      bopts = optValuesForConstructor Begin opts+      eopts = optValuesForConstructor End opts+      lastb = listtomaybeday bopts+      laste = listtomaybeday eopts+      listtomaybeday vs = if null vs then Nothing else Just $ parse $ last vs+          where parse = parsedate . fixSmartDateStr refdate++-- | Figure out the reporting interval, if any, specified by the options.+-- If there is a period option, the others are ignored.+intervalFromOpts :: [Opt] -> Interval+intervalFromOpts opts+    | not $ null popts = fst $ parsePeriodExpr refdate $ last popts+    | null otheropts = NoInterval+    | otherwise = case last otheropts of+                    WeeklyOpt  -> Weekly+                    MonthlyOpt -> Monthly+                    YearlyOpt  -> Yearly+    where+      popts = optValuesForConstructor Period opts+      otheropts = filter (`elem` [WeeklyOpt,MonthlyOpt,YearlyOpt]) opts +      -- doesn't affect the interval, but parsePeriodExpr needs something+      refdate = parsedate "0001/01/01"++-- | Get the value of the (last) depth option, if any.+depthFromOpts :: [Opt] -> Maybe Int+depthFromOpts opts = listtomaybeint $ optValuesForConstructor Depth opts+    where+      listtomaybeint [] = Nothing+      listtomaybeint vs = Just $ read $ last vs++-- | Get the value of the (last) display option, if any.+displayFromOpts :: [Opt] -> Maybe String+displayFromOpts opts = listtomaybe $ optValuesForConstructor Display opts+    where+      listtomaybe [] = Nothing+      listtomaybe vs = Just $ last vs+ -- | Get the ledger file path from options, an environment variable, or a default ledgerFilePathFromOpts :: [Opt] -> IO String ledgerFilePathFromOpts opts = do   envordefault <- getEnv fileenvvar `catch` \_ -> return defaultfile-  paths <- mapM tildeExpand $ [envordefault] ++ (concatMap getfile opts)+  paths <- mapM tildeExpand $ [envordefault] ++ optValuesForConstructor File opts   return $ last paths-    where-      getfile (File s) = [s]-      getfile _ = []  -- | Expand ~ in a file path (does not handle ~name). tildeExpand :: FilePath -> IO FilePath@@ -95,57 +188,16 @@ --                                return (homeDirectory pw ++ path) tildeExpand xs           =  return xs --- | Get the value of the begin date option, if any.-beginDateFromOpts :: [Opt] -> Maybe Date-beginDateFromOpts opts = -    case beginopts of-      (x:_) -> Just $ smartparsedate $ last beginopts-      _     -> Nothing-    where-      beginopts = concatMap getbegindate opts-      getbegindate (Begin s) = [s]-      getbegindate _ = []-      defaultdate = ""---- | Get the value of the end date option, if any.-endDateFromOpts :: [Opt] -> Maybe Date-endDateFromOpts opts = -    case endopts of-      (x:_) -> Just $ smartparsedate $ last endopts-      _      -> Nothing-    where-      endopts = concatMap getenddate opts-      getenddate (End s) = [s]-      getenddate _ = []-      defaultdate = ""---- | Get the value of the depth option, if any.-depthFromOpts :: [Opt] -> Maybe Int-depthFromOpts opts =-    case depthopts of-      (x:_) -> Just $ read x-      _     -> Nothing-    where-      depthopts = concatMap getdepth opts-      getdepth (Depth s) = [s]-      getdepth _ = []- -- | Gather any ledger-style account/description pattern arguments into -- two lists.  These are 0 or more account patterns optionally followed by--- -- and 0 or more description patterns.-parseAccountDescriptionArgs :: [String] -> ([String],[String])-parseAccountDescriptionArgs args = (as, ds')-    where (as, ds) = break (=="--") args-          ds' = dropWhile (=="--") ds---- testoptions RequireOrder ["foo","-v"]--- testoptions Permute ["foo","-v"]--- testoptions (ReturnInOrder Arg) ["foo","-v"]--- testoptions Permute ["foo","--","-v"]--- testoptions Permute ["-?o","--name","bar","--na=baz"]--- testoptions Permute ["--ver","foo"]-testoptions order cmdline = putStr $ -    case getOpt order options cmdline of-      (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n-      (_,_,errs) -> concat errs ++ usage-+-- a separator and then 0 or more description patterns. The separator is+-- usually -- but with --options-anywhere is ^^ so we need to provide the+-- options as well.+parseAccountDescriptionArgs :: [Opt] -> [String] -> ([String],[String])+parseAccountDescriptionArgs opts args = (as, ds')+    where (as, ds) = break (==patseparator) args+          ds' = dropWhile (==patseparator) ds+          patseparator = replicate 2 negchar+          negchar+              | OptionsAnywhere `elem` opts = '^'+              | otherwise = '-'

@@ -18,4 +18,4 @@ showEntries opts args l = concatMap showEntry $ filteredentries     where        filteredentries = entries $ filterRawLedgerEntriesByAccount apats $ rawledger l-      (apats,_) = parseAccountDescriptionArgs args+      (apats,_) = parseAccountDescriptionArgs opts args

@@ -3,30 +3,41 @@  Welcome to hledger!  -hledger is a minimal haskell clone of John Wiegley's "ledger" text-based-accounting tool (http://newartisans.com/software/ledger.html).  hledger-generates ledger-compatible register & balance reports from a plain text-ledger file, and demonstrates a functional implementation of ledger.  For-more information, see the hledger home page: http://joyful.com/hledger+hledger is a haskell clone of John Wiegley's "ledger" text-based+accounting tool (http://newartisans.com/software/ledger.html).  +It generates ledger-compatible register & balance reports from a plain+text ledger file, and demonstrates a functional implementation of ledger.+For more information, see hledger's home page: http://joyful.com/hledger -Copyright (c) 2007-2008 Simon Michael <simon@joyful.com>+Copyright (c) 2007-2009 Simon Michael <simon@joyful.com> Released under GPL version 3 or later.  -INSTALLATION+Installation -------------In the hledger directory, do::+hledger requires GHC. It is known to build with 6.8 and 6.10.+If you have cabal-install, do:: - cabal install+ cabal update+ cabal install hledger -or::+Otherwise, unpack the latest tarball from+http://hackage.haskell.org/cgi-bin/hackage-scripts/package/hledger and do::   runhaskell Setup.hs configure  runhaskell Setup.hs build  sudo runhaskell Setup.hs install  +This will complain about any missing libraries, which you can download and+install manually from hackage.haskell.org. (The Build-Depends: in+hledger.cabal has the full package list.) -EXAMPLES+To get the latest development code do::++ darcs get http://joyful.com/repos/hledger+++Examples -------- Here are some commands to try:: @@ -37,19 +48,20 @@  hledger register  hledger reg cash  hledger reg -- shop+ hledger ui +hledger looks for your ledger file at ~/.ledger by default. To use a different file,+specify it with -f or the LEDGER environment variable. -FEATURES++Features ---------This version of hledger mimics a subset of ledger 2.6.1: -- regular ledger entries-- multiple commodities-- virtual transactions-- balance, print, register commands-- positive and negative account & description patterns-- LEDGER environment variable-- and::+This version of hledger mimics a subset of ledger 2.6.1, and adds some+features of its own. We currently support: the balance, print, and+register commands, regular ledger entries, multiple commodities, virtual+transactions, account and description patterns, the LEDGER environment+variable, and these options::     Basic options:    -h, --help             display summarized help text@@ -59,13 +71,15 @@    Report filtering:    -b, --begin DATE       set report begin date    -e, --end DATE         set report end date+   -p, --period EXPR      report using the given period    -C, --cleared          consider only cleared transactions    -R, --real             consider only real (non-virtual) transactions      Output customization:-   -s, --subtotal         balance report: show sub-accounts-   -E, --empty            balance report: show accounts with zero balance    -n, --collapse         balance report: no grand total+   -d, --display EXPR     display only transactions matching EXPR (limited support)+   -E, --empty            balance report: show accounts with zero balance+   -s, --subtotal         balance report: show sub-accounts      Commodity reporting:    -B, --basis, --cost    report cost basis of commodities@@ -75,20 +89,20 @@    register [REGEXP]...   show register of matching transactions    print    [REGEXP]...   print all matching entries -hledger-specific features:+We handle (almost) the full period expression syntax, and simple display+expressions consisting of a date predicate.  Also the following+hledger-specific features are supported:: +   ui                     interactive text ui    --depth=N              balance report: maximum account depth to show-   --cost                 alias for basis+   --options-anywhere     allow options anywhere, use ^ for negative patterns -ledger features not supported:+ledger features not supported+............................. -- !include-- modifier entries-- periodic entries-- commodity pricing-- counting an unfinished timelog session-- parsing gnucash files-- and::+ledger features not yet supported include: modifier and periodic entries,+!include and other special directives, price history entries, parsing+gnucash files, and the following options::     Basic options:    -o, --output FILE      write output to FILE@@ -99,7 +113,6 @@      Report filtering:    -c, --current          show only current and past entries (not future)-   -p, --period STR       report using the given period        --period-sort EXPR sort each report period's entries by EXPR    -U, --uncleared        consider only uncleared transactions    -L, --actual           consider only actual (non-automated) transactions@@ -132,7 +145,6 @@        --totals           in the "xml" report, include running total    -j, --amount-data      print only raw amount data (useful for scripting)    -J, --total-data       print only raw total data-   -d, --display EXPR     display only transactions matching EXPR    -y, --date-format STR  use STR as the date format (default: %Y/%m/%d)    -F, --format STR       use STR as the format; for each report type, use:        --balance-format      --register-format       --print-format@@ -154,9 +166,15 @@    prices   [REGEXP]...   display price history for matching commodities    entry DATE PAYEE AMT   output a derived entry, based on the arguments -Some other differences:+Other differences+................. -- hledger talks about the entry and transaction "description", which ledger calls "note"-- hledger always shows timelog balances in hours-- hledger doesn't require a space after flags like -f-- hledger keeps differently-priced amounts of the same commodity separate, at the moment+* hledger keeps differently-priced amounts of the same commodity separate at the moment+* hledger refers to the entry's and transaction's "description", ledger calls it "note"+* hledger doesn't require a space before command-line option values+* hledger provides "--cost" as a synonym for "--basis"+* hledger's "weekly" reporting intervals always start on mondays+* hledger shows start and end dates of full intervals, not just the span containing data+* hledger period expressions don't support "biweekly", "bimonthly", or "every N days/weeks/..." +* hledger always shows timelog balances in hours+* hledger doesn't count an unfinished timelog session

@@ -6,6 +6,8 @@  module RegisterCommand where+import qualified Data.Map as Map+import Data.Map ((!)) import Ledger import Options @@ -26,28 +28,92 @@ @ -} showRegisterReport :: [Opt] -> [String] -> Ledger -> String-showRegisterReport opts args l = showtxns ts nulltxn nullmixedamt+showRegisterReport opts args l+    | interval == NoInterval = showtxns displayedts nulltxn startbal+    | otherwise = showtxns summaryts nulltxn startbal     where-      ts = filter matchtxn $ ledgerTransactions l-      matchtxn Transaction{account=a} = matchpats apats a-      apats = fst $ parseAccountDescriptionArgs args+      interval = intervalFromOpts opts+      ts = filter (not . isZeroMixedAmount . amount) $ filter matchapats $ ledgerTransactions l+      (precedingts, ts') = break (matchdisplayopt dopt) ts+      (displayedts, _) = span (matchdisplayopt dopt) ts'+      startbal = sumTransactions precedingts+      matchapats t = matchpats apats $ account t+      apats = fst $ parseAccountDescriptionArgs opts args+      matchdisplayopt Nothing t = True+      matchdisplayopt (Just e) t = (fromparse $ parsewith datedisplayexpr e) t+      dopt = displayFromOpts opts+      empty = Empty `elem` opts+      depth = depthFromOpts opts+      summaryts = concatMap summarisespan (zip spans [1..])+      summarisespan (s,n) = summariseTransactionsInDateSpan s n depth empty (transactionsinspan s)+      transactionsinspan s = filter (isTransactionInDateSpan s) displayedts+      spans = splitSpan interval (ledgerDateSpan l)+                        +-- | Convert a date span (representing a reporting interval) and a list of+-- transactions within it to a new list of transactions aggregated by+-- account, which showtxns will render as a summary for this interval.+-- +-- As usual with date spans the end date is exclusive, but for display+-- purposes we show the previous day as end date, like ledger.+-- +-- A unique entryno value is provided so that the new transactions will be+-- grouped as one entry.+-- +-- When a depth argument is present, transactions to accounts of greater+-- depth are aggregated where possible.+-- +-- The showempty flag forces the display of a zero-transaction span+-- and also zero-transaction accounts within the span.+summariseTransactionsInDateSpan :: DateSpan -> Int -> Maybe Int -> Bool -> [Transaction] -> [Transaction]+summariseTransactionsInDateSpan (DateSpan b e) entryno depth showempty ts+    | null ts && showempty = [txn]+    | null ts = []+    | otherwise = summaryts'+    where+      txn = nulltxn{entryno=entryno, date=b', description="- "++(showDate $ addDays (-1) e')}+      b' = fromMaybe (date $ head ts) b+      e' = fromMaybe (date $ last ts) e+      summaryts'+          | showempty = summaryts+          | otherwise = filter (not . isZeroMixedAmount . amount) summaryts+      txnanames = sort $ nub $ map account ts+      -- aggregate balances by account, like cacheLedger, then do depth-clipping+      (_,_,exclbalof,inclbalof) = groupTransactions ts+      clippedanames = clipAccountNames depth txnanames+      isclipped a = accountNameLevel a >= fromMaybe 9999 depth+      balancetoshowfor a =+          (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a)+      summaryts = [txn{account=a,amount=balancetoshowfor a} | a <- clippedanames] -      -- show transactions, one per line, with a running balance-      showtxns [] _ _ = ""-      showtxns (t@Transaction{amount=a}:ts) tprev bal =-          (if isZeroMixedAmount a then "" else this) ++ showtxns ts t bal'-          where-            this = showtxn (t `issame` tprev) t bal'-            issame t1 t2 = entryno t1 == entryno t2-            bal' = bal + amount t+clipAccountNames :: Maybe Int -> [AccountName] -> [AccountName]+clipAccountNames Nothing as = as+clipAccountNames (Just d) as = nub $ map (clip d) as +    where clip d = accountNameFromComponents . take d . accountNameComponents -      -- show one transaction line, with or without the entry details-      showtxn :: Bool -> Transaction -> MixedAmount -> String-      showtxn omitdesc t b = concatBottomPadded [entrydesc ++ txn ++ " ", bal] ++ "\n"-          where-            entrydesc = if omitdesc then replicate 32 ' ' else printf "%s %s " date desc-            date = show $ da-            desc = printf "%-20s" $ elideRight 20 de :: String-            txn = showRawTransaction $ RawTransaction a amt "" tt-            bal = padleft 12 (showMixedAmountOrZero b)-            Transaction{date=da,description=de,account=a,amount=amt,ttype=tt} = t+-- | Does the given transaction fall within the given date span ?+isTransactionInDateSpan :: DateSpan -> Transaction -> Bool+isTransactionInDateSpan (DateSpan Nothing Nothing)   _ = True+isTransactionInDateSpan (DateSpan Nothing (Just e))  (Transaction{date=d}) = d<e+isTransactionInDateSpan (DateSpan (Just b) Nothing)  (Transaction{date=d}) = d>=b+isTransactionInDateSpan (DateSpan (Just b) (Just e)) (Transaction{date=d}) = d>=b && d<e++-- | Show transactions one per line, with each date/description appearing+-- only once, and a running balance.+showtxns [] _ _ = ""+showtxns (t@Transaction{amount=a}:ts) tprev bal = this ++ showtxns ts t bal'+    where+      this = showtxn (t `issame` tprev) t bal'+      issame t1 t2 = entryno t1 == entryno t2+      bal' = bal + amount t++-- | Show one transaction line and balance with or without the entry details.+showtxn :: Bool -> Transaction -> MixedAmount -> String+showtxn omitdesc t b = concatBottomPadded [entrydesc ++ txn ++ " ", bal] ++ "\n"+    where+      entrydesc = if omitdesc then replicate 32 ' ' else printf "%s %s " date desc+      date = showDate $ da+      desc = printf "%-20s" $ elideRight 20 de :: String+      txn = showRawTransaction $ RawTransaction a amt "" tt+      bal = padleft 12 (showMixedAmountOrZero b)+      Transaction{date=da,description=de,account=a,amount=amt,ttype=tt} = t+

@@ -31,6 +31,7 @@  tests = [TestList []         ,misc_tests+        ,newparse_tests         ,balancereportacctnames_tests         ,balancecommand_tests         ,printcommand_tests@@ -55,10 +56,10 @@     assertequal (Amount (comm "$") 0 Nothing) (sum [a1,a2,a3,-a3])   ,   "ledgertransaction"  ~: do-    assertparseequal rawtransaction1 (parsewith ledgertransaction rawtransaction1_str)+    assertparseequal rawtransaction1 (parseWithCtx ledgertransaction rawtransaction1_str)   ,                     "ledgerentry"        ~: do-    assertparseequal entry1 (parsewith ledgerentry entry1_str)+    assertparseequal entry1 (parseWithCtx ledgerEntry entry1_str)   ,   "balanceEntry"      ~: do     assertequal@@ -76,7 +77,7 @@       ["assets","assets:cash","assets:checking","expenses","expenses:vacation"]       (expandAccountNames ["assets:cash","assets:checking","expenses:vacation"])   ,-  "ledgerAccountNames" ~: do+  "accountnames" ~: do     assertequal       ["assets","assets:cash","assets:checking","assets:saving","equity","equity:opening balances",        "expenses","expenses:food","expenses:food:dining","expenses:phone","expenses:vacation",@@ -87,25 +88,173 @@     assertequal 15 (length $ Map.keys $ accountmap $ cacheLedger [] rawledger7)   ,   "transactionamount"       ~: do-    assertparseequal (Mixed [dollars 47.18]) (parsewith transactionamount " $47.18")-    assertparseequal (Mixed [Amount (Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0}) 1 Nothing]) (parsewith transactionamount " $1.")+    assertparseequal (Mixed [dollars 47.18]) (parseWithCtx transactionamount " $47.18")+    assertparseequal (Mixed [Amount (Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0}) 1 Nothing]) (parseWithCtx transactionamount " $1.")   ,   "canonicaliseAmounts" ~: do     -- all amounts use the greatest precision     assertequal [2,2] (rawLedgerPrecisions $ canonicaliseAmounts False $ rawLedgerWithAmounts ["1","2.00"])   ,   "timeLog" ~: do-    assertparseequal timelog1 (parsewith timelog timelog1_str)+    assertparseequal timelog1 (parseWithCtx timelog timelog1_str)+  ,+  "parsedate" ~: do+    assertequal (parsetimewith "%Y/%m/%d" "2008/02/03" refdate) (parsedate "2008/02/03")+    assertequal (parsetimewith "%Y/%m/%d" "2008/02/03" refdate) (parsedate "2008-02-03")   ,                  -  "smartparsedate"     ~: do-    assertequal (1999,12,13) (dateComponents $ smartparsedate "1999/12/13")-    assertequal (2008,2,1)   (dateComponents $ smartparsedate "2008-2")-    assertequal (2008,1,1)   (dateComponents $ smartparsedate "2008")+  "smart dates"     ~: do+    let todaysdate = parsedate "2008/11/26" -- wednesday+    let str `gives` datestr = assertequal datestr (fixSmartDateStr todaysdate str)+    -- for now at least, a fuzzy date always refers to the start of the period+    "1999-12-02"   `gives` "1999/12/02"+    "1999.12.02"   `gives` "1999/12/02"+    "1999/3/2"     `gives` "1999/03/02"+    "19990302"     `gives` "1999/03/02"+    "2008/2"       `gives` "2008/02/01"+    "20/2"         `gives` "0020/02/01"+    "1000"         `gives` "1000/01/01"+    "4/2"          `gives` "2008/04/02"+    "2"            `gives` "2008/11/02"+    "January"      `gives` "2008/01/01"+    "feb"          `gives` "2008/02/01"+    "today"        `gives` "2008/11/26"+    "yesterday"    `gives` "2008/11/25"+    "tomorrow"     `gives` "2008/11/27"+    "this day"     `gives` "2008/11/26"+    "last day"     `gives` "2008/11/25"+    "next day"     `gives` "2008/11/27"+    "this week"    `gives` "2008/11/24" -- last monday+    "last week"    `gives` "2008/11/17" -- previous monday+    "next week"    `gives` "2008/12/01" -- next monday+    "this month"   `gives` "2008/11/01"+    "last month"   `gives` "2008/10/01"+    "next month"   `gives` "2008/12/01"+    "this quarter" `gives` "2008/10/01"+    "last quarter" `gives` "2008/07/01"+    "next quarter" `gives` "2009/01/01"+    "this year"    `gives` "2008/01/01"+    "last year"    `gives` "2007/01/01"+    "next year"    `gives` "2009/01/01"+--     "last wed"     `gives` "2008/11/19"+--     "next friday"  `gives` "2008/11/28"+--     "next january" `gives` "2009/01/01"+  ,+  "dateSpanFromOpts"     ~: do+    let todaysdate = parsedate "2008/11/26"+    let opts `gives` spans = assertequal spans (show $ dateSpanFromOpts todaysdate opts)+    [] `gives` "DateSpan Nothing Nothing"+    [Begin "2008", End "2009"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)"+    [Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)"+    [Begin "2005", End "2007",Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)"+  ,+  "intervalFromOpts"     ~: do+    let opts `gives` interval = assertequal interval (intervalFromOpts opts)+    [] `gives` NoInterval+    [WeeklyOpt] `gives` Weekly+    [MonthlyOpt] `gives` Monthly+    [YearlyOpt] `gives` Yearly+    [Period "weekly"] `gives` Weekly+    [Period "monthly"] `gives` Monthly+    [WeeklyOpt, Period "yearly"] `gives` Yearly+  ,                  +  "period expressions"     ~: do+    let todaysdate = parsedate "2008/11/26"+    let str `gives` result = assertequal ("Right "++result) (show $ parsewith (periodexpr todaysdate) str)+    "from aug to oct"           `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))"+    "aug to oct"                `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))"+    "every day from aug to oct" `gives` "(Daily,DateSpan (Just 2008-08-01) (Just 2008-10-01))"+    "daily from aug"            `gives` "(Daily,DateSpan (Just 2008-08-01) Nothing)"+    "every week to 2009"        `gives` "(Weekly,DateSpan Nothing (Just 2009-01-01))"+  ,                  +  "splitSpan"     ~: do+    let (interval,span) `gives` spans = assertequal spans (splitSpan interval span)+    (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"]+  ,                  +  "summariseTransactionsInDateSpan"     ~: do+    let (b,e,entryno,depth,showempty,ts) `gives` summaryts = assertequal (summaryts) (summariseTransactionsInDateSpan (mkdatespan b e) entryno depth showempty ts)++    ("2008/01/01","2009/01/01",0,Nothing,False,[]) `gives` +     []++    ("2008/01/01","2009/01/01",0,Nothing,True,[]) `gives` +     [+      nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31"}+     ]++    let ts = [nulltxn{description="desc",account="expenses:food:groceries",amount=Mixed [dollars 1]}+             ,nulltxn{description="desc",account="expenses:food:dining",   amount=Mixed [dollars 2]}+             ,nulltxn{description="desc",account="expenses:food",          amount=Mixed [dollars 4]}+             ,nulltxn{description="desc",account="expenses:food:dining",   amount=Mixed [dollars 8]}+             ]+    ("2008/01/01","2009/01/01",0,Nothing,False,ts) `gives` +     [+      nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses:food",          amount=Mixed [dollars 4]}+     ,nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses:food:dining",   amount=Mixed [dollars 10]}+     ,nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses:food:groceries",amount=Mixed [dollars 1]}+     ]++    ("2008/01/01","2009/01/01",0,Just 2,False,ts) `gives` +     [+      nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses:food",amount=Mixed [dollars 15]}+     ]++    ("2008/01/01","2009/01/01",0,Just 1,False,ts) `gives` +     [+      nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses",amount=Mixed [dollars 15]}+     ]++    ("2008/01/01","2009/01/01",0,Just 0,False,ts) `gives` +     [+      nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="",amount=Mixed [dollars 15]}+     ]+  ,+  "ledgerentry"        ~: do+    assertparseequal price1 (parseWithCtx ledgerHistoricalPrice price1_str)   ] +newparse_tests = TestList [ sameParseTests ]+    where sameParseTests = TestList $ map sameParse [ account1, account2, account3, account4 ]+          sameParse (str1, str2) +              = TestCase $ do l1 <- rawledgerfromstring str1                         +                              l2 <- rawledgerfromstring str2+                              (l1 @=? l2)+          account1 = ( "2008/12/07 One\n  test:from  $-1\n  test:to  $1\n"+                     , "!account test\n2008/12/07 One\n  from  $-1\n  to  $1\n"+                     )+          account2 = ( "2008/12/07 One\n  test:foo:from  $-1\n  test:foo:to  $1\n"+                     , "!account test\n!account foo\n2008/12/07 One\n  from  $-1\n  to  $1\n"+                     )+          account3 = ( "2008/12/07 One\n  test:from  $-1\n  test:to  $1\n"+                     , "!account test\n!account foo\n!end\n2008/12/07 One\n  from  $-1\n  to  $1\n"+                     )+          account4 = ( "2008/12/07 One\n  alpha  $-1\n  beta  $1\n" +++                       "!account outer\n2008/12/07 Two\n  aigh  $-2\n  bee  $2\n" +++                       "!account inner\n2008/12/07 Three\n  gamma  $-3\n  delta  $3\n" +++                       "!end\n2008/12/07 Four\n  why  $-4\n  zed  $4\n" +++                       "!end\n2008/12/07 Five\n  foo  $-5\n  bar  $5\n"+                     , "2008/12/07 One\n  alpha  $-1\n  beta  $1\n" +++                       "2008/12/07 Two\n  outer:aigh  $-2\n  outer:bee  $2\n" +++                       "2008/12/07 Three\n  outer:inner:gamma  $-3\n  outer:inner:delta  $3\n" +++                       "2008/12/07 Four\n  outer:why  $-4\n  outer:zed  $4\n" +++                       "2008/12/07 Five\n  foo  $-5\n  bar  $5\n"+                     )+ balancereportacctnames_tests = TestList    [-   "balancereportacctnames0" ~: ("-s",[])              `gives` ["assets","assets:cash","assets:checking","assets:saving",+   "balancereportacctnames0" ~: ("-s",[])              `gives` ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash",                                                                 "expenses","expenses:food","expenses:supplies","income",                                                                 "income:gifts","income:salary","liabilities","liabilities:debts"]   ,"balancereportacctnames1" ~: ("",  [])              `gives` ["assets","expenses","income","liabilities"]@@ -114,11 +263,11 @@   ,"balancereportacctnames4" ~: ("",  ["assets:cash"]) `gives` ["assets:cash"]   ,"balancereportacctnames5" ~: ("",  ["-assets"])     `gives` ["expenses","income","liabilities"]   ,"balancereportacctnames6" ~: ("",  ["-e"])          `gives` []-  ,"balancereportacctnames7" ~: ("-s",["assets"])      `gives` ["assets","assets:cash","assets:checking","assets:saving"]+  ,"balancereportacctnames7" ~: ("-s",["assets"])      `gives` ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"]   ,"balancereportacctnames8" ~: ("-s",["-e"])          `gives` []   ] where     gives (opt,pats) e = do -      l <- ledgerfromfile pats "sample.ledger"+      l <- sampleledger       let t = pruneZeroBalanceLeaves $ ledgerAccountTree 999 l       assertequal e (balancereportacctnames l (opt=="-s") pats t) @@ -134,8 +283,8 @@   "balance report with -s" ~:   ([SubTotal], []) `gives`   ("                 $-1  assets\n" +++   "                  $1    bank:saving\n" ++    "                 $-2    cash\n" ++-   "                  $1    saving\n" ++    "                  $2  expenses\n" ++    "                  $1    food\n" ++    "                  $1    supplies\n" ++@@ -156,8 +305,8 @@   "balance report --depth activates -s" ~:   ([Depth "2"], []) `gives`   ("                 $-1  assets\n" +++   "                  $1    bank\n" ++    "                 $-2    cash\n" ++-   "                  $1    saving\n" ++    "                  $2  expenses\n" ++    "                  $1    food\n" ++    "                  $1    supplies\n" ++@@ -188,8 +337,8 @@   "balance report with account pattern a" ~:   ([], ["a"]) `gives`   ("                 $-1  assets\n" +++   "                  $1    bank:saving\n" ++    "                 $-2    cash\n" ++-   "                  $1    saving\n" ++    "                 $-1  income:salary\n" ++    "                  $1  liabilities\n" ++    "--------------------\n" ++@@ -207,8 +356,8 @@  ,   "balance report with unmatched parent of two matched subaccounts" ~:    ([], ["cash","saving"]) `gives`-  ("                 $-2  assets:cash\n" ++-   "                  $1  assets:saving\n" +++  ("                  $1  assets:bank:saving\n" +++   "                 $-2  assets:cash\n" ++    "--------------------\n" ++    "                 $-1\n" ++    "")@@ -242,9 +391,10 @@   "balance report with -E shows zero-balance accounts" ~:   ([SubTotal,Empty], ["assets"]) `gives`   ("                 $-1  assets\n" +++   "                  $1    bank\n" +++   "                  $0      checking\n" +++   "                  $1      saving\n" ++    "                 $-2    cash\n" ++-   "                  $0    checking\n" ++-   "                  $1    saving\n" ++    "--------------------\n" ++    "                 $-1\n" ++    "")@@ -255,66 +405,181 @@    "")  ,   "balance report with cost basis" ~: do-    let l = cacheLedger [] $ -            filterRawLedger Nothing Nothing [] False False $ -            canonicaliseAmounts True $ -- enable cost basis adjustment-            rawledgerfromstring+    rl <- rawledgerfromstring              ("" ++               "2008/1/1 test           \n" ++               "  a:b          10h @ $50\n" ++               "  c:d                   \n" ++               "\n")+    let l = cacheLedger [] $ +            filterRawLedger (DateSpan Nothing Nothing) [] False False $ +            canonicaliseAmounts True rl -- enable cost basis adjustment                 assertequal               ("                $500  a\n" ++               "               $-500  c\n" ++               ""              )              (showBalanceReport [] [] l)+ ,+  "balance report elides zero-balance root account(s)" ~: do+    l <- ledgerfromstringwithopts [] [] refdate+             ("2008/1/1 one\n" +++              "  test:a  1\n" +++              "  test:b\n"+             )+    assertequal "" (showBalanceReport [] [] l)+    assertequal +             ("                1  test:a\n" +++              "               -1  test:b\n" +++              ""+             )+             (showBalanceReport [SubTotal] [] l)  ] where-    gives (opts,pats) e = do -      l <- ledgerfromfile pats "sample.ledger"-      assertequal e (showBalanceReport opts pats l)+    gives (opts,args) e = do +      l <- sampleledgerwithopts [] args+      assertequal e (showBalanceReport opts args l)  printcommand_tests = TestList [   "print with account patterns" ~:   do -    let pats = ["expenses"]-    l <- ledgerfromfile pats "sample.ledger"+    let args = ["expenses"]+    l <- sampleledgerwithopts [] args     assertequal (-     "2007/01/01 * eat & shop\n" +++     "2008/06/03 * eat & shop\n" ++      "    expenses:food                                 $1\n" ++      "    expenses:supplies                             $1\n" ++      "    assets:cash                                  $-2\n" ++      "\n")-     $ showEntries [] pats l+     $ showEntries [] args l   ]  registercommand_tests = TestList [   "register report" ~:   do -    l <- ledgerfromfile [] "sample.ledger"+    l <- sampleledger     assertequal (-     "2007/01/01 income               assets:checking                  $1           $1\n" +++     "2008/01/01 income               assets:bank:checking             $1           $1\n" ++      "                                income:salary                   $-1            0\n" ++-     "2007/01/01 gift                 assets:checking                  $1           $1\n" +++     "2008/06/01 gift                 assets:bank:checking             $1           $1\n" ++      "                                income:gifts                    $-1            0\n" ++-     "2007/01/01 save                 assets:saving                    $1           $1\n" ++-     "                                assets:checking                 $-1            0\n" ++-     "2007/01/01 eat & shop           expenses:food                    $1           $1\n" +++     "2008/06/02 save                 assets:bank:saving               $1           $1\n" +++     "                                assets:bank:checking            $-1            0\n" +++     "2008/06/03 eat & shop           expenses:food                    $1           $1\n" ++      "                                expenses:supplies                $1           $2\n" ++      "                                assets:cash                     $-2            0\n" ++-     "2008/01/01 pay off              liabilities:debts                $1           $1\n" ++-     "                                assets:checking                 $-1            0\n" +++     "2008/12/31 pay off              liabilities:debts                $1           $1\n" +++     "                                assets:bank:checking            $-1            0\n" ++      "")      $ showRegisterReport [] [] l-  ]+  ,+  "register report with account pattern" ~:+  do +    l <- sampleledger+    assertequal (+     "2008/06/03 eat & shop           assets:cash                     $-2          $-2\n" +++     "")+     $ showRegisterReport [] ["cash"] l+  ,+  "register report with display expression" ~:+  do +    l <- sampleledger+    let expr `displayexprgives` dates = assertequal dates (datesfromregister r)+            where r = showRegisterReport [Display expr] [] l+    "d<[2008/6/2]"  `displayexprgives` ["2008/01/01","2008/06/01"]+    "d<=[2008/6/2]" `displayexprgives` ["2008/01/01","2008/06/01","2008/06/02"]+    "d=[2008/6/2]"  `displayexprgives` ["2008/06/02"]+    "d>=[2008/6/2]" `displayexprgives` ["2008/06/02","2008/06/03","2008/12/31"]+    "d>[2008/6/2]"  `displayexprgives` ["2008/06/03","2008/12/31"]+  ,+  "register report with period expression" ~:+  do +    l <- sampleledger    +    let expr `displayexprgives` dates = assertequal dates (datesfromregister r)+            where r = showRegisterReport [Display expr] [] l+    ""     `periodexprgives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]+    "2008" `periodexprgives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]+    "2007" `periodexprgives` []+    "june" `periodexprgives` ["2008/06/01","2008/06/02","2008/06/03"]+    "monthly" `periodexprgives` ["2008/01/01","2008/06/01","2008/12/01"]+    assertequal (+     "2008/01/01 - 2008/12/31         assets:bank:saving               $1           $1\n" +++     "                                assets:cash                     $-2          $-1\n" +++     "                                expenses:food                    $1            0\n" +++     "                                expenses:supplies                $1           $1\n" +++     "                                income:gifts                    $-1            0\n" +++     "                                income:salary                   $-1          $-1\n" +++     "                                liabilities:debts                $1            0\n" +++     "")+     (showRegisterReport [Period "yearly"] [] l)+    assertequal ["2008/01/01","2008/04/01","2008/10/01"] +                    (datesfromregister $ showRegisterReport [Period "quarterly"] [] l)+    assertequal ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]+                    (datesfromregister $ showRegisterReport [Period "quarterly",Empty] [] l)++ ]+  where datesfromregister = filter (not . null) .  map (strip . take 10) . lines+        expr `periodexprgives` dates = do lopts <- sampleledgerwithopts [Period expr] []+                                          let r = showRegisterReport [Period expr] [] lopts+                                          assertequal dates (datesfromregister r)++    ------------------------------------------------------------------------------ -- test data +refdate = parsedate "2008/11/26"+sampleledger = ledgerfromstringwithopts [] [] refdate sample_ledger_str+sampleledgerwithopts opts args = ledgerfromstringwithopts opts args refdate sample_ledger_str+--sampleledgerwithoptsanddate opts args date = unsafePerformIO $ ledgerfromstringwithopts opts args date sample_ledger_str++sample_ledger_str = (+ "; A sample ledger file.\n" +++ ";\n" +++ "; Sets up this account tree:\n" +++ "; assets\n" +++ ";   bank\n" +++ ";     checking\n" +++ ";     saving\n" +++ ";   cash\n" +++ "; expenses\n" +++ ";   food\n" +++ ";   supplies\n" +++ "; income\n" +++ ";   gifts\n" +++ ";   salary\n" +++ "; liabilities\n" +++ ";   debts\n" +++ "\n" +++ "2008/01/01 income\n" +++ "    assets:bank:checking  $1\n" +++ "    income:salary\n" +++ "\n" +++ "2008/06/01 gift\n" +++ "    assets:bank:checking  $1\n" +++ "    income:gifts\n" +++ "\n" +++ "2008/06/02 save\n" +++ "    assets:bank:saving  $1\n" +++ "    assets:bank:checking\n" +++ "\n" +++ "2008/06/03 * eat & shop\n" +++ "    expenses:food      $1\n" +++ "    expenses:supplies  $1\n" +++ "    assets:cash\n" +++ "\n" +++ "2008/12/31 * pay off\n" +++ "    liabilities:debts  $1\n" +++ "    assets:bank:checking\n" +++ "\n" +++ "\n" +++ ";final comment\n" +++ "")++write_sample_ledger = writeFile "sample.ledger" sample_ledger_str+ rawtransaction1_str  = "  expenses:food:dining  $10.00\n" -rawtransaction1 = RawTransaction "expenses:food:dining"(Mixed  [dollars 10]) "" RegularTransaction+rawtransaction1 = RawTransaction "expenses:food:dining" (Mixed [dollars 10]) "" RegularTransaction  entry1_str = "" ++  "2007/01/28 coopportunity\n" ++@@ -597,7 +862,9 @@              ],              epreceding_comment_lines=""            }-          ]+          ] +          []+          []           ""  ledger7 = cacheLedger [] rawledger7 @@ -608,52 +875,6 @@  "  c:d                   \n" ++  "\n" -sample_ledger_str = (- "; A sample ledger file.\n" ++- ";\n" ++- "; Sets up this account tree:\n" ++- "; assets\n" ++- ";   cash\n" ++- ";   checking\n" ++- ";   saving\n" ++- "; expenses\n" ++- ";   food\n" ++- ";   supplies\n" ++- "; income\n" ++- ";   gifts\n" ++- ";   salary\n" ++- "; liabilities\n" ++- ";   debts\n" ++- "\n" ++- "2007/01/01 income\n" ++- "    assets:checking  $1\n" ++- "    income:salary\n" ++- "\n" ++- "2007/01/01 gift\n" ++- "    assets:checking  $1\n" ++- "    income:gifts\n" ++- "\n" ++- "2007/01/01 save\n" ++- "    assets:saving  $1\n" ++- "    assets:checking\n" ++- "\n" ++- "2007/01/01 * eat & shop\n" ++- "    expenses:food      $1\n" ++- "    expenses:supplies  $1\n" ++- "    assets:cash\n" ++- "\n" ++- "2008/1/1 * pay off\n" ++- "    liabilities:debts  $1\n" ++- "    assets:checking\n" ++- "\n" ++- "\n" ++- ";final comment\n" ++- "")--write_sample_ledger = writeFile "sample.ledger" sample_ledger_str--read_sample_ledger = readFile "sample.ledger"- timelogentry1_str  = "i 2007/03/11 16:19:00 hledger\n" timelogentry1 = TimeLogEntry 'i' (parsedatetime "2007/03/11 16:19:00") "hledger" @@ -669,6 +890,9 @@             timelogentry2            ] +price1_str = "P 2004/05/01 XYZ $55\n"+price1 = HistoricalPrice (parsedate "2004/05/01") "XYZ" "$" 55+ a1 = Mixed [(hours 1){price=Just $ Mixed [Amount (comm "$") 10 Nothing]}] a2 = Mixed [(hours 2){price=Just $ Mixed [Amount (comm "EUR") 10 Nothing]}] a3 = Mixed $ (amounts a1) ++ (amounts a2)@@ -706,6 +930,8 @@         []          []          [nullentry{edescription=a,etransactions=[nullrawtxn{tamount=parse a}]} | a <- as]+        []+        []         ""-            where parse = fromparse . parsewith transactionamount . (" "++)+            where parse = fromparse . parseWithCtx transactionamount . (" "++) 

@@ -0,0 +1,390 @@+{-| ++A simple text UI for hledger.++-}++module UICommand+where+import qualified Data.Map as Map+import Data.Map ((!))+import Graphics.Vty+import qualified Data.ByteString.Char8 as B+import Ledger+import Options+import BalanceCommand+import RegisterCommand+import PrintCommand+++helpmsg = "Welcome to hledger. (b)alances, (r)egister, (p)rint entries, (l)edger, (right) to drill down, (left) to back up, or (q)uit"++instance Show Vty where show v = "a Vty"++-- | The application state when running the ui command.+data AppState = AppState {+     av :: Vty                   -- ^ the vty context+    ,aw :: Int                   -- ^ window width+    ,ah :: Int                   -- ^ window height+    ,amsg :: String              -- ^ status message+    ,aopts :: [Opt]              -- ^ command-line opts+    ,aargs :: [String]           -- ^ command-line args+    ,aledger :: Ledger           -- ^ parsed ledger+    ,abuf :: [String]            -- ^ lines of the current buffered view+    ,alocs :: [Loc]              -- ^ user's navigation trail within the UI+                                -- ^ never null, head is current location+    } deriving (Show)++-- | A location within the user interface.+data Loc = Loc {+     scr :: Screen               -- ^ one of the available screens+    ,sy :: Int                   -- ^ viewport y scroll position+    ,cy :: Int                   -- ^ cursor y position+    } deriving (Show)++-- | The screens available within the user interface.+data Screen = BalanceScreen     -- ^ like hledger balance, shows accounts+            | RegisterScreen    -- ^ like hledger register, shows transactions+            | PrintScreen       -- ^ like hledger print, shows entries+            | LedgerScreen      -- ^ shows the raw ledger+              deriving (Eq,Show)++-- | Run the interactive text ui.+ui :: [Opt] -> [String] -> Ledger -> IO ()+ui opts args l = do+  v <- mkVty+  (w,h) <- getSize v+  let opts' = SubTotal:opts+  let a = enter BalanceScreen $ +          AppState {+                  av=v+                 ,aw=w+                 ,ah=h+                 ,amsg=helpmsg+                 ,aopts=opts'+                 ,aargs=args+                 ,aledger=l+                 ,abuf=[]+                 ,alocs=[]+                 }+  go a ++-- | Update the screen, wait for the next event, repeat.+go :: AppState -> IO ()+go a@AppState{av=av,aw=aw,ah=ah,abuf=buf,amsg=amsg,aopts=opts,aargs=args,aledger=l} = do+  when (not $ DebugNoUI `elem` opts) $ update av (renderScreen a)+  k <- getEvent av+  case k of +    EvResize x y                -> go $ resize x y a+    EvKey (KASCII 'l') [MCtrl]  -> refresh av >> go a{amsg=helpmsg}+    EvKey (KASCII 'b') []       -> go $ resetTrailAndEnter BalanceScreen a+    EvKey (KASCII 'r') []       -> go $ resetTrailAndEnter RegisterScreen a+    EvKey (KASCII 'p') []       -> go $ resetTrailAndEnter PrintScreen a+    EvKey (KASCII 'l') []       -> go $ resetTrailAndEnter LedgerScreen a+    EvKey KRight []             -> go $ drilldown a+    EvKey KEnter []             -> go $ drilldown a+    EvKey KLeft  []             -> go $ backout a+    EvKey KUp    []             -> go $ moveUpAndPushEdge a+    EvKey KDown  []             -> go $ moveDownAndPushEdge a+    EvKey KHome  []             -> go $ moveToTop a+    EvKey KUp    [MCtrl]        -> go $ moveToTop a+    EvKey KUp    [MShift]       -> go $ moveToTop a+    EvKey KEnd   []             -> go $ moveToBottom a+    EvKey KDown  [MCtrl]        -> go $ moveToBottom a+    EvKey KDown  [MShift]       -> go $ moveToBottom a+    EvKey KPageUp []            -> go $ prevpage a+    EvKey KBS []                -> go $ prevpage a+    EvKey (KASCII ' ') [MShift] -> go $ prevpage a+    EvKey KPageDown []          -> go $ nextpage a+    EvKey (KASCII ' ') []       -> go $ nextpage a+    EvKey (KASCII 'q') []       -> shutdown av >> return ()+--    EvKey KEsc   []           -> shutdown av >> return ()+    _                           -> go a+    where+      bh = length buf+      y = posY a++-- app state modifiers++-- | The number of lines currently available for the main data display area.+pageHeight :: AppState -> Int+pageHeight a = ah a - 1++setLocCursorY, setLocScrollY :: Int -> Loc -> Loc+setLocCursorY y l = l{cy=y}+setLocScrollY y l = l{sy=y}++cursorY, scrollY, posY :: AppState -> Int+cursorY = cy . loc+scrollY = sy . loc+posY a = scrollY a + cursorY a++setCursorY, setScrollY, setPosY :: Int -> AppState -> AppState+setCursorY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocCursorY y l+setScrollY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocScrollY y l+setPosY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)}+    where +      l' = setLocScrollY sy $ setLocCursorY cy l+      ph = pageHeight a+      cy = y `mod` ph+      sy = y - cy++updateCursorY, updateScrollY, updatePosY :: (Int -> Int) -> AppState -> AppState+updateCursorY f a = setCursorY (f $ cursorY a) a+updateScrollY f a = setScrollY (f $ scrollY a) a+updatePosY f a = setPosY (f $ posY a) a++resize :: Int -> Int -> AppState -> AppState+resize x y a = setCursorY cy' a{aw=x,ah=y}+    where+      cy = cursorY a+      cy' = min cy (y-2)++moveToTop :: AppState -> AppState+moveToTop a = setPosY 0 a++moveToBottom :: AppState -> AppState+moveToBottom a = setPosY (length $ abuf a) a++moveUpAndPushEdge :: AppState -> AppState+moveUpAndPushEdge a@AppState{alocs=(Loc{sy=sy,cy=cy}:_)}+    | cy > 0 = updateCursorY (subtract 1) a+    | sy > 0 = updateScrollY (subtract 1) a+    | otherwise = a++moveDownAndPushEdge :: AppState -> AppState+moveDownAndPushEdge a@AppState{alocs=(Loc{sy=sy,cy=cy}:_)}+    | sy+cy >= bh = a+    | cy < ph-1 = updateCursorY (+1) a+    | otherwise = updateScrollY (+1) a+    where +      ph = pageHeight a+      bh = length $ abuf a++-- | Scroll down by page height or until we can just see the last line,+-- without moving the cursor, or if we are already scrolled as far as+-- possible then move the cursor to the last line.+nextpage :: AppState -> AppState+nextpage (a@AppState{abuf=b})+    | sy < bh-jump = setScrollY sy' a+    | otherwise    = setCursorY (bh-sy) a+    where+      sy = scrollY a+      jump = pageHeight a - 1+      bh = length b+      sy' = min (sy+jump) (bh-jump)++-- | Scroll up by page height or until we can just see the first line,+-- without moving the cursor, or if we are scrolled as far as possible+-- then move the cursor to the first line.+prevpage :: AppState -> AppState+prevpage (a@AppState{abuf=b})+    | sy > 0    = setScrollY sy' a+    | otherwise = setCursorY 0 a+    where+      sy = scrollY a+      jump = pageHeight a - 1+      sy' = max (sy-jump) 0++-- | Push a new UI location on to the stack.+pushLoc :: Loc -> AppState -> AppState+pushLoc l a = a{alocs=(l:alocs a)}++popLoc :: AppState -> AppState+popLoc a@AppState{alocs=locs}+    | length locs > 1 = a{alocs=drop 1 locs}+    | otherwise = a++clearLocs :: AppState -> AppState+clearLocs a = a{alocs=[]}++exit :: AppState -> AppState +exit = popLoc++loc :: AppState -> Loc+loc = head . alocs++screen :: AppState -> Screen+screen a = scr where (Loc scr _ _) = loc a++-- | Enter a new screen, saving the old ui location on the stack.+enter :: Screen -> AppState -> AppState +enter scr@BalanceScreen a  = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a+enter scr@RegisterScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a+enter scr@PrintScreen a    = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a+enter scr@LedgerScreen a   = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a++resetTrailAndEnter scr a = enter scr $ clearLocs a++-- | Regenerate the display data appropriate for the current screen.+updateData :: AppState -> AppState+updateData a@AppState{aopts=opts,aargs=args,aledger=l}+    | scr == BalanceScreen  = a{abuf=lines $ showBalanceReport opts [] l, aargs=[]}+    | scr == RegisterScreen = a{abuf=lines $ showRegisterReport opts args l}+    | scr == PrintScreen    = a{abuf=lines $ showEntries opts args l}+    | scr == LedgerScreen   = a{abuf=lines $ rawledgertext l}+    where scr = screen a++backout :: AppState -> AppState+backout a+    | screen a == BalanceScreen = a+    | otherwise = updateData $ popLoc a++drilldown :: AppState -> AppState+drilldown a+    | screen a == BalanceScreen  = enter RegisterScreen a{aargs=[currentAccountName a]}+    | screen a == RegisterScreen = scrollToEntry e $ enter PrintScreen a+    | screen a == PrintScreen   = enter LedgerScreen a+    | screen a == LedgerScreen   = a+    where e = currentEntry a++-- | Get the account name currently highlighted by the cursor on the+-- balance screen. Results undefined while on other screens.+currentAccountName :: AppState -> AccountName+currentAccountName a = accountNameAt (abuf a) (posY a)++-- | Get the full name of the account being displayed at a specific line+-- within the balance command's output.+accountNameAt :: [String] -> Int -> AccountName+accountNameAt buf lineno = accountNameFromComponents anamecomponents+    where+      namestohere = map (drop 22) $ take (lineno+1) buf+      (indented, nonindented) = span (" " `isPrefixOf`) $ reverse namestohere+      thisbranch = indented ++ take 1 nonindented+      anamecomponents = reverse $ map strip $ dropsiblings thisbranch++      dropsiblings :: [AccountName] -> [AccountName]+      dropsiblings [] = []+      dropsiblings (x:xs) = [x] ++ dropsiblings xs'+          where+            xs' = dropWhile moreindented xs+            moreindented = (>= myindent) . indentof+            myindent = indentof x+            indentof = length . takeWhile (==' ')++-- | If on the print screen, move the cursor to highlight the specified entry+-- (or a reasonable guess). Doesn't work.+scrollToEntry :: Entry -> AppState -> AppState+scrollToEntry e a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a+    where+      entryfirstline = head $ lines $ showEntry $ e+      halfph = pageHeight a `div` 2+      y = fromMaybe 0 $ findIndex (== entryfirstline) buf+      sy = max 0 $ y - halfph+      cy = y - sy++-- | Get the entry containing the transaction currently highlighted by the+-- cursor on the register screen (or best guess). Results undefined while+-- on other screens. Doesn't work.+currentEntry :: AppState -> Entry+currentEntry a@AppState{aledger=l,abuf=buf} = entryContainingTransaction a t+    where+      t = safehead nulltxn $ filter ismatch $ ledgerTransactions l+      ismatch t = date t == (parsedate $ take 10 datedesc)+                  && (take 70 $ showtxn False t nullmixedamt) == (datedesc ++ acctamt)+      datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ [safehead "" rest] ++ reverse above+      acctamt = drop 32 $ safehead "" rest+      safehead d ls = if null ls then d else head ls+      (above,rest) = splitAt y buf+      y = posY a++-- | Get the entry which contains the given transaction.+-- Will raise an error if there are problems.+entryContainingTransaction :: AppState -> Transaction -> Entry+entryContainingTransaction AppState{aledger=l} t = (entries $ rawledger l) !! entryno t++-- renderers++renderScreen :: AppState -> Picture+renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) =+    pic {pCursor = Cursor cx cy,+         pImage = mainimg+                  <->+                  renderStatus w msg+        }+    where +      (cx, cy) = (0, cursorY a)+      sy = scrollY a+      -- trying for more speed+      mainimg = (vertcat $ map (render defaultattr) above)+               <->+               (render currentlineattr thisline)+               <->+               (vertcat $ map (render defaultattr) below)+      render attr = renderBS attr . B.pack+      (thisline,below) | null rest = (blankline,[])+                       | otherwise = (head rest, tail rest)+      (above,rest) = splitAt cy linestorender+      linestorender = map padclipline $ take (h-1) $ drop sy $ buf ++ replicate h blankline+      padclipline l = take w $ l ++ blankline+      blankline = replicate w ' '+--       mainimg = (renderString attr $ unlines $ above)+--           <->+--           (renderString reverseattr $ thisline)+--           <->+--           (renderString attr $ unlines $ below)+--       (above,(thisline:below)) +--           | null ls   = ([],[""])+--           | otherwise = splitAt y ls+--       ls = lines $ fitto w (h-1) $ unlines $ drop as $ buf++padClipString :: Int -> Int -> String -> [String]+padClipString h w s = rows+    where+      rows = map padclipline $ take h $ lines s ++ replicate h blankline+      padclipline l = take w $ l ++ blankline+      blankline = replicate w ' '++renderString :: Attr -> String -> Image+renderString attr s = vertcat $ map (renderBS attr . B.pack) rows+    where+      rows = lines $ fitto w h s+      w = maximum $ map length $ ls+      h = length ls+      ls = lines s++renderStatus :: Int -> String -> Image+renderStatus w s = renderBS statusattr (B.pack $ take w (s ++ repeat ' ')) +++-- the all-important theming engine++theme = 1++(defaultattr, + currentlineattr, + statusattr+ ) = +    case theme of+      1 -> ( -- restrained+           attr+          ,setBold attr+          ,setRV attr+          )+      2 -> ( -- colorful+           setRV attr+          ,setFG white $ setBG red $ attr+          ,setFG black $ setBG green $ attr+          )+      3 -> ( -- +           setRV attr+          ,setFG white $ setBG red $ attr+          ,setRV attr+          )++halfbrightattr = setHalfBright attr+reverseattr = setRV attr+redattr = setFG red attr+greenattr = setFG green attr+reverseredattr = setRV $ setFG red attr+reversegreenattr= setRV $ setFG green attr++--     pic { pCursor = Cursor x y,+--           pImage = renderFill pieceA ' ' w y +--           <->+--           renderHFill pieceA ' ' x <|> renderChar pieceA '@' <|> renderHFill pieceA ' ' (w - x - 1) +--           <->+--           renderFill pieceA ' ' w (h - y - 1) +--           <->+--           renderStatus w msg+--         }

@@ -6,54 +6,47 @@  module Utils where+import Control.Monad.Error import qualified Data.Map as Map (lookup) import Text.ParserCombinators.Parsec+import System.IO import Options import Ledger  +-- | Convert a RawLedger to a canonicalised, cached and filtered Ledger+-- based on the command-line options/arguments and today's date.+prepareLedger ::  [Opt] -> [String] -> Day -> String -> RawLedger -> Ledger+prepareLedger opts args refdate rawtext rl = l{rawledgertext=rawtext}+    where+      l = cacheLedger apats $ filterRawLedger span dpats c r $ canonicaliseAmounts cb rl+      (apats,dpats) = parseAccountDescriptionArgs [] args+      span = dateSpanFromOpts refdate opts+      c = Cleared `elem` opts+      r = Real `elem` opts+      cb = CostBasis `elem` opts+ -- | Get a RawLedger from the given string, or raise an error.-rawledgerfromstring :: String -> RawLedger-rawledgerfromstring = fromparse . parsewith ledgerfile+rawledgerfromstring :: String -> IO RawLedger+rawledgerfromstring = liftM (either error id) . runErrorT . parseLedger "(string)" --- | Get a filtered and cached Ledger from the given string, or raise an error.-ledgerfromstring :: [String] -> String -> Ledger-ledgerfromstring args s =-  cacheLedger apats $ filterRawLedger Nothing Nothing dpats False False l-      where-        (apats,dpats) = parseAccountDescriptionArgs args-        l = rawledgerfromstring s-           --- | Get a RawLedger from the given file path, or a dummy one if there was an error.-rawledgerfromfile :: FilePath -> IO RawLedger-rawledgerfromfile f = do-  parsed <- parseLedgerFile f-  return $ either (\_ -> RawLedger [] [] [] "") id parsed+-- | Get a Ledger from the given string and options, or raise an error.+ledgerfromstringwithopts :: [Opt] -> [String] -> Day -> String -> IO Ledger+ledgerfromstringwithopts opts args refdate s =+    liftM (prepareLedger opts args refdate s) $ rawledgerfromstring s --- | Get a filtered and cached Ledger from the given file path, or a dummy--- one if there was an error.-ledgerfromfile :: [String] -> FilePath -> IO Ledger-ledgerfromfile args f = do-  l  <- rawledgerfromfile f-  return $ cacheLedger apats $ filterRawLedger Nothing Nothing dpats False False l-      where-        (apats,dpats) = parseAccountDescriptionArgs args+-- | Get a Ledger from the given file path and options, or raise an error.+ledgerfromfilewithopts :: [Opt] -> [String] -> FilePath -> IO Ledger+ledgerfromfilewithopts opts args f = do+  refdate <- today+  s <- readFile f +  rl <- rawledgerfromstring s+  return $ prepareLedger opts args refdate s rl            --- | Get a RawLedger from the file your LEDGER environment variable--- variable points to, or a dummy one if there was a problem.-myrawledger :: IO RawLedger-myrawledger = do-  parsed <- ledgerFilePathFromOpts [] >>= parseLedgerFile-  return $ either (\_ -> RawLedger [] [] [] "") id parsed---- | Get a cached Ledger from the file your LEDGER environment variable--- variable points to, or a dummy one if there was a problem.+-- | Get a Ledger from your default ledger file, or raise an error.+-- Assumes no options. myledger :: IO Ledger-myledger = do-  l <- myrawledger-  return $ cacheLedger [] $ filterRawLedger Nothing Nothing [] False False l---- | Get a named account from your ledger file.-myaccount :: AccountName -> IO Account-myaccount a = myledger >>= (return . fromMaybe nullacct . Map.lookup a . accountmap)+myledger = ledgerFilePathFromOpts [] >>= ledgerfromfilewithopts [] [] +parseWithCtx :: GenParser Char LedgerFileCtx a -> String -> Either ParseError a+parseWithCtx p ts = runParser p emptyCtx "" ts

@@ -1,13 +1,13 @@ Name:           hledger-Version:        0.2+Version:        0.3 Category:       Finance Synopsis:       A ledger-compatible text-based accounting tool.-Description:    hledger is a minimal haskell clone of John Wiegley's "ledger" text-based-                accounting tool (http://newartisans.com/software/ledger.html).  hledger-                generates ledger-compatible register & balance reports from a plain text-                ledger file, and demonstrates a functional implementation of ledger.+Description:    hledger is a haskell clone of John Wiegley's "ledger" text-based+                accounting tool (http://newartisans.com/software/ledger.html).  +                It generates ledger-compatible register & balance reports from a plain+                text ledger file, and demonstrates a functional implementation of ledger. License:        GPL-Stability:      alpha+Stability:      beta Author:         Simon Michael <simon@joyful.com> Maintainer:     Simon Michael <simon@joyful.com> Homepage:       http://joyful.com/hledger@@ -19,9 +19,21 @@ Cabal-Version:  >= 1.2  Executable hledger-  Build-Depends:  base, containers, haskell98, directory, parsec, regex-compat,-                  old-locale, time, HUnit   Main-Is:        hledger.hs+  Build-Depends:  +                  base,+                  containers, +                  haskell98, +                  directory, +                  parsec, +                  regex-compat, +                  regexpr>=0.5.1,+                  old-locale, +                  time, +                  HUnit, +                  mtl, +                  bytestring,+                  vty>=3.1.8.2   Other-Modules:                     BalanceCommand                   Options@@ -29,6 +41,7 @@                   RegisterCommand                   Setup                   Tests+                  UICommand                   Utils                   Ledger                   Ledger.Account

@@ -2,14 +2,14 @@ {-| hledger - a ledger-compatible text-based accounting tool. -Copyright (c) 2007-2008 Simon Michael <simon@joyful.com>+Copyright (c) 2007-2009 Simon Michael <simon@joyful.com> Released under GPL version 3 or later. -hledger is a minimal haskell clone of John Wiegley's "ledger" text-based-accounting tool (http://newartisans.com/software/ledger.html).  hledger-generates ledger-compatible register & balance reports from a plain text-ledger file, and demonstrates a functional implementation of ledger.  For-more information, see the hledger home page: http://joyful.com/hledger+hledger is a haskell clone of John Wiegley's "ledger" text-based+accounting tool (http://newartisans.com/software/ledger.html).  +It generates ledger-compatible register & balance reports from a plain+text ledger file, and demonstrates a functional implementation of ledger.+For more information, see hledger's home page: http://joyful.com/hledger  You can use the command line: @@ -18,16 +18,16 @@ or ghci:  > $ ghci hledger-> > l <- ledgerfromfile [] "sample.ledger"+> > l <- ledgerfromfilewithopts [] [] "sample.ledger" > > balance [] [] l >                  $-1  assets >                   $2  expenses >                  $-2  income->                   $1  liabilities:debts+>                   $1  liabilities > > register [] ["income","expenses"] l-> 2007/01/01 income               income:salary                   $-1          $-1-> 2007/01/01 gift                 income:gifts                    $-1          $-2-> 2007/01/01 eat & shop           expenses:food                    $1          $-1+> 2008/01/01 income               income:salary                   $-1          $-1+> 2008/06/01 gift                 income:gifts                    $-1          $-2+> 2008/06/03 eat & shop           expenses:food                    $1          $-1 >                                 expenses:supplies                $1            0  -}@@ -39,15 +39,20 @@              module BalanceCommand,              module PrintCommand,              module RegisterCommand,+             module UICommand, ) where+import Control.Monad.Error import qualified Data.Map as Map (lookup)+import System.IO+ import Ledger import Utils import Options import BalanceCommand import PrintCommand import RegisterCommand+import UICommand import Tests  @@ -57,25 +62,24 @@   run cmd opts args     where        run cmd opts args-       | Help `elem` opts            = putStr usage+       | Help `elem` opts            = putStr $ usage        | Version `elem` opts         = putStr version        | cmd `isPrefixOf` "balance"  = parseLedgerAndDo opts args balance        | cmd `isPrefixOf` "print"    = parseLedgerAndDo opts args print'        | cmd `isPrefixOf` "register" = parseLedgerAndDo opts args register+       | cmd `isPrefixOf` "ui"       = parseLedgerAndDo opts args ui        | cmd `isPrefixOf` "test"     = runtests opts args >> return ()-       | otherwise                   = putStr usage+       | otherwise                   = putStr $ usage  -- | parse the user's specified ledger file and do some action with it -- (or report a parse error). This function makes the whole thing go. parseLedgerAndDo :: [Opt] -> [String] -> ([Opt] -> [String] -> Ledger -> IO ()) -> IO ()-parseLedgerAndDo opts args cmd = -    ledgerFilePathFromOpts opts >>= parseLedgerFile >>= either printParseError runcmd-    where-      runcmd = cmd opts args . cacheLedger apats . filterRawLedger b e dpats c r . canonicaliseAmounts costbasis-      b = beginDateFromOpts opts-      e = endDateFromOpts opts-      (apats,dpats) = parseAccountDescriptionArgs args-      c = Cleared `elem` opts-      r = Real `elem` opts-      costbasis = CostBasis `elem` opts-+parseLedgerAndDo opts args cmd = do+  refdate <- today+  f <- ledgerFilePathFromOpts opts+  -- XXX we read the file twice - inelegant+  -- and, doesn't work with stdin. kludge it, stdin won't work with ui command+  let f' = if f == "-" then "/dev/null" else f+  rawtext <- readFile f'+  let runcmd = cmd opts args . prepareLedger opts args refdate rawtext+  return f >>= runErrorT . parseLedgerFile >>= either (hPutStrLn stderr) runcmd

@@ -2,9 +2,10 @@ ; ; Sets up this account tree: ; assets+;   bank+;     checking+;     saving ;   cash-;   checking-;   saving ; expenses ;   food ;   supplies@@ -14,26 +15,26 @@ ; liabilities ;   debts -2007/01/01 income-    assets:checking  $1+2008/01/01 income+    assets:bank:checking  $1     income:salary -2007/01/01 gift-    assets:checking  $1+2008/06/01 gift+    assets:bank:checking  $1     income:gifts -2007/01/01 save-    assets:saving  $1-    assets:checking+2008/06/02 save+    assets:bank:saving  $1+    assets:bank:checking -2007/01/01 * eat & shop+2008/06/03 * eat & shop     expenses:food      $1     expenses:supplies  $1     assets:cash -2008/1/1 * pay off+2008/12/31 * pay off     liabilities:debts  $1-    assets:checking+    assets:bank:checking   ;final comment