diff --git a/BalanceCommand.hs b/BalanceCommand.hs --- a/BalanceCommand.hs +++ b/BalanceCommand.hs @@ -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 +-} diff --git a/Ledger.hs b/Ledger.hs --- a/Ledger.hs +++ b/Ledger.hs @@ -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 diff --git a/Ledger/AccountName.hs b/Ledger/AccountName.hs --- a/Ledger/AccountName.hs +++ b/Ledger/AccountName.hs @@ -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 - diff --git a/Ledger/Amount.hs b/Ledger/Amount.hs --- a/Ledger/Amount.hs +++ b/Ledger/Amount.hs @@ -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} diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs --- a/Ledger/Dates.hs +++ b/Ledger/Dates.hs @@ -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) diff --git a/Ledger/Entry.hs b/Ledger/Entry.hs --- a/Ledger/Entry.hs +++ b/Ledger/Entry.hs @@ -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 diff --git a/Ledger/Ledger.hs b/Ledger/Ledger.hs --- a/Ledger/Ledger.hs +++ b/Ledger/Ledger.hs @@ -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 diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs --- a/Ledger/Parse.hs +++ b/Ledger/Parse.hs @@ -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 diff --git a/Ledger/RawLedger.hs b/Ledger/RawLedger.hs --- a/Ledger/RawLedger.hs +++ b/Ledger/RawLedger.hs @@ -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 diff --git a/Ledger/TimeLog.hs b/Ledger/TimeLog.hs --- a/Ledger/TimeLog.hs +++ b/Ledger/TimeLog.hs @@ -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] diff --git a/Ledger/Transaction.hs b/Ledger/Transaction.hs --- a/Ledger/Transaction.hs +++ b/Ledger/Transaction.hs @@ -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 diff --git a/Ledger/Types.hs b/Ledger/Types.hs --- a/Ledger/Types.hs +++ b/Ledger/Types.hs @@ -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 diff --git a/Ledger/Utils.hs b/Ledger/Utils.hs --- a/Ledger/Utils.hs +++ b/Ledger/Utils.hs @@ -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 diff --git a/Options.hs b/Options.hs --- a/Options.hs +++ b/Options.hs @@ -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 = '-' diff --git a/PrintCommand.hs b/PrintCommand.hs --- a/PrintCommand.hs +++ b/PrintCommand.hs @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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 +Copyright (c) 2007-2009 Simon Michael 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 diff --git a/RegisterCommand.hs b/RegisterCommand.hs --- a/RegisterCommand.hs +++ b/RegisterCommand.hs @@ -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=b +isTransactionInDateSpan (DateSpan (Just b) (Just e)) (Transaction{date=d}) = d>=b && d 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 + diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -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 . (" "++) diff --git a/UICommand.hs b/UICommand.hs new file mode 100644 --- /dev/null +++ b/UICommand.hs @@ -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 +-- } diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -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 diff --git a/hledger.cabal b/hledger.cabal --- a/hledger.cabal +++ b/hledger.cabal @@ -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 Maintainer: Simon Michael 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 diff --git a/hledger.hs b/hledger.hs --- a/hledger.hs +++ b/hledger.hs @@ -2,14 +2,14 @@ {-| hledger - a ledger-compatible text-based accounting tool. -Copyright (c) 2007-2008 Simon Michael +Copyright (c) 2007-2009 Simon Michael 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 diff --git a/sample.ledger b/sample.ledger --- a/sample.ledger +++ b/sample.ledger @@ -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