hledger 0.3 → 0.4

raw patch · 23 files changed

+1967/−1481 lines, 23 filesdep +filepathdep +happstackdep +happstack-datadep ~vtyPVP ok

version bump matches the API change (PVP)

Dependencies added: filepath, happstack, happstack-data, happstack-server, happstack-state, process, testpack, utf8-string

Dependency ranges changed: vty

API changes (from Hackage documentation)

Files

• BalanceCommand.hs +104/−195
• Ledger/AccountName.hs +5/−11
• Ledger/Dates.hs +27/−23
• Ledger/Entry.hs +28/−18
• Ledger/Ledger.hs +3/−4
• Ledger/Parse.hs +86/−39
• Ledger/RawLedger.hs +15/−6
• Ledger/RawTransaction.hs +2/−2
• Ledger/TimeLog.hs +36/−21
• Ledger/Transaction.hs +6/−4
• Ledger/Types.hs +3/−1
• Ledger/Utils.hs +21/−10
• Options.hs +109/−65
• PrintCommand.hs +5/−1
• README +103/−72
• RegisterCommand.hs +13/−8
• Tests.hs +1136/−936
• UICommand.hs +6/−5
• Utils.hs +15/−10
• Version.hs +46/−0
• WebCommand.hs +117/−0
• hledger.cabal +55/−38
• hledger.hs +26/−12

@@ -1,104 +1,96 @@ {-|  -A ledger-compatible @balance@ command. Here's how it should work:+A ledger-compatible @balance@ command.  -A sample account tree (as in the sample.ledger file):+ledger's balance command is easy to use but not easy to describe+precisely.  In the examples below we'll use sample.ledger, which has the+following account tree:  @  assets-  cash-  checking-  saving+   bank+     checking+     saving+   cash  expenses-  food-  supplies+   food+   supplies  income-  gifts-  salary+   gifts+   salary  liabilities-  debts-@--The balance command shows top-level accounts by default:--@- \> ledger balance- $-1  assets-  $2  expenses- $-2  income-  $1  liabilities+   debts @ -With -s (--subtotal), also show the subaccounts:+The balance command shows accounts with their aggregate balances.+Subaccounts are displayed indented below their parent. Each balance is the+sum of any transactions in that account plus any balances from+subaccounts:  @- $-1  assets- $-2    cash-  $1    saving-  $2  expenses-  $1    food-  $1    supplies- $-2  income- $-1    gifts- $-1    salary-  $1  liabilities:debts+ $ hledger -f sample.ledger balance+                 $-1  assets+                  $1    bank:saving+                 $-2    cash+                  $2  expenses+                  $1    food+                  $1    supplies+                 $-2  income+                 $-1    gifts+                 $-1    salary+                  $1  liabilities:debts @ -- @checking@ is not shown because it has a zero balance and no interesting-  subaccounts.  --- @liabilities@ is displayed only as a prefix because it has the same balance-  as its single subaccount.+Usually, the non-interesting accounts are elided or omitted. Above,+@checking@ is omitted because it has no subaccounts and a zero balance.+@bank@ is elided because it has only a single displayed subaccount+(@saving@) and it would be showing the same balance as that ($1). Ditto+for @liabilities@. We will return to this in a moment. -With an account pattern, show only the accounts with matching names:+The --depth argument can be used to limit the depth of the balance report.+So, to see just the top level accounts:  @- \> ledger balance o-  $1  expenses:food- $-2  income---------------------- $-1  +$ hledger -f sample.ledger balance --depth 1+                 $-1  assets+                  $2  expenses+                 $-2  income+                  $1  liabilities @ -- The o matched @food@ and @income@, so they are shown.--- Parents of matched accounts are also shown for context (@expenses@).--- This time the grand total is also shown, because it is not zero.+This time liabilities has no displayed subaccounts (due to --depth) and+is not elided. -Again, -s adds the subaccounts:+With one or more account pattern arguments, the balance command shows+accounts whose name matches one of the patterns, plus their parents+(elided) and subaccounts. So with the pattern o we get:  @-\> ledger -s balance o-  $1  expenses:food- $-2  income- $-1    gifts- $-1    salary+ $ hledger -f sample.ledger balance o+                  $1  expenses:food+                 $-2  income+                 $-1    gifts+                 $-1    salary --------------------- $-1  +                 $-1 @ -- @food@ has no subaccounts. @income@ has two, so they are shown. --- We do not add the subaccounts of parents included for context (@expenses@).--Some notes for the implementation:--- a simple balance report shows top-level accounts--- with an account pattern, it shows accounts whose leafname matches, plus their parents--- with the subtotal option, it also shows all subaccounts of the above+The o pattern matched @food@ and @income@, so they are shown. Unmatched+parents of matched accounts are also shown (elided) for context (@expenses@). -- zero-balance leaf accounts are removed+Also, the balance report shows the total of all displayed accounts, when+that is non-zero. Here, it is displayed because the accounts shown add up+to $-1. -- the resulting account tree is displayed with each account's aggregated-  balance, with boring parents prefixed to the next line+Here is a more precise definition of \"interesting\" accounts in ledger's+balance report: -- a boring parent has the same balance as its child and is not explicitly-  matched by the display options.+- an account which has just one interesting subaccount branch, and which+  is not at the report's maximum depth, is interesting if the balance is+  different from the subaccount's, and otherwise boring. -- the sum of the balances shown is displayed at the end, if it is non-zero+- any other account is interesting if it has a non-zero balance, or the -E+  flag is used.  -} @@ -108,7 +100,9 @@ import Ledger.Types import Ledger.Amount import Ledger.AccountName+import Ledger.Transaction import Ledger.Ledger+import Ledger.Parse import Options import Utils @@ -117,134 +111,49 @@ balance :: [Opt] -> [String] -> Ledger -> IO () balance opts args l = putStr $ showBalanceReport opts args l --- | Generate balance report output for a ledger.+-- | Generate a balance report with the specified options for this ledger. showBalanceReport :: [Opt] -> [String] -> Ledger -> String-showBalanceReport opts args l = acctsstr ++ (if collapse then "" else totalstr)-    where -      acctsstr = concatMap showatree $ subs t-      showatree t = showAccountTreeWithBalances matchedacctnames t-      matchedacctnames = balancereportacctnames l sub apats t-      t = (if empty then id else pruneZeroBalanceLeaves) $ ledgerAccountTree maxdepth l-      apats = fst $ parseAccountDescriptionArgs opts args-      maxdepth = fromMaybe 9999 $ depthFromOpts opts-      sub = SubTotal `elem` opts || (isJust $ depthFromOpts opts)-      empty = Empty `elem` opts-      collapse = Collapse `elem` opts-      totalstr = if isZeroMixedAmount total -                 then "" -                 else printf "--------------------\n%s\n" $ padleft 20 $ showMixedAmount total-      total = sum $ map (abalance . ledgerAccount l) $ nonredundantaccts-      nonredundantaccts = filter (not . hasparentshowing) matchedacctnames-      hasparentshowing aname = (parentAccountName $ aname) `elem` matchedacctnames---- | Identify the accounts we are interested in seeing balances for in the--- balance report, based on the -s flag and account patterns. See Tests.hs.-balancereportacctnames :: Ledger -> Bool -> [String] -> Tree Account -> [AccountName]-balancereportacctnames l False [] t   = filter (/= "top") $ map aname $ flatten $ treeprune 1 t-balancereportacctnames l False pats t = filter (/= "top") $ ns-    where -      ns = filter (matchpats_balance pats) $ map aname $ flatten t'-      t' | null $ positivepats pats = treeprune 1 t-         | otherwise = t-balancereportacctnames l True pats t  = nub $ map aname $ addsubaccts l $ as+showBalanceReport opts args l = acctsstr ++ totalstr     where -      as = map (ledgerAccount l) ns-      ns = balancereportacctnames l False pats t-      -- add (in tree order) any missing subaccounts to a list of accounts-      addsubaccts :: Ledger -> [Account] -> [Account]-      addsubaccts l as = concatMap addsubs as where addsubs = maybe [] flatten . ledgerAccountTreeAt l+      acctsstr = unlines $ map showacct interestingaccts+          where+            showacct = showInterestingAccount l interestingaccts+            interestingaccts = filter (isInteresting opts l) acctnames+            acctnames = sort $ tail $ flatten $ treemap aname accttree+            accttree = ledgerAccountTree (depthFromOpts opts) l+      totalstr | NoTotal `elem` opts = ""+               | not (Empty `elem` opts) && isZeroMixedAmount total = ""+               | otherwise = printf "--------------------\n%s\n" $ padleft 20 $ showMixedAmount total+          where+            total = sum $ map abalance $ topAccounts l --- | Remove all sub-trees whose accounts have a zero balance.-pruneZeroBalanceLeaves :: Tree Account -> Tree Account-pruneZeroBalanceLeaves = treefilter (not . isZeroMixedAmount . abalance)+-- | Display one line of the balance report with appropriate indenting and eliding.+showInterestingAccount :: Ledger -> [AccountName] -> AccountName -> String+showInterestingAccount l interestingaccts a = concatTopPadded [amt, "  ", depthspacer ++ partialname]+    where+      amt = padleft 20 $ showMixedAmount $ abalance $ ledgerAccount l a+      -- the depth spacer (indent) is two spaces for each interesting parent+      parents = parentAccountNames a+      interestingparents = filter (`elem` interestingaccts) parents+      depthspacer = replicate (2 * length interestingparents) ' '+      -- the partial name is the account's leaf name, prefixed by the+      -- names of any boring parents immediately above+      partialname = accountNameFromComponents $ (reverse $ map accountLeafName ps) ++ [accountLeafName a]+          where ps = takeWhile boring parents where boring = not . (`elem` interestingparents) --- | Show this tree of accounts with balances, eliding boring parent--- accounts and omitting uninteresting subaccounts based on the provided--- list of account names we want to see balances for.-showAccountTreeWithBalances :: [AccountName] -> Tree Account -> String-showAccountTreeWithBalances matchednames t = showAccountTreeWithBalances' matchednames 0 "" t+-- | Is the named account considered interesting for this ledger's balance report ?+isInteresting :: [Opt] -> Ledger -> AccountName -> Bool+isInteresting opts l a+    | numinterestingsubs==1 && not atmaxdepth = notlikesub+    | otherwise = notzero || emptyflag     where-      showAccountTreeWithBalances' :: [AccountName] -> Int -> String -> Tree Account -> String-      showAccountTreeWithBalances' matchednames indent prefix (Node (Account fullname _ bal) subs)-          | isboringparent && hasmatchedsubs = subsprefixed-          | ismatched = this ++ subsindented-          | otherwise = subsnoindent+      atmaxdepth = accountNameLevel a == depthFromOpts opts+      emptyflag = Empty `elem` opts+      acct = ledgerAccount l a+      notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct+      notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumTransactions $ atransactions acct+      numinterestingsubs = length $ filter isInterestingTree subtrees           where-            subsprefixed = showsubs indent (prefix++leafname++":")-            subsnoindent = showsubs indent ""-            subsindented = showsubs (indent+1) ""-            showsubs i p = concatMap (showAccountTreeWithBalances' matchednames i p) subs-            hasmatchedsubs = any ((`elem` matchednames) . aname) $ concatMap flatten subs-            amt = padleft 20 $ showMixedAmount bal-            this = concatTopPadded [amt, spaces ++ prefix ++ leafname] ++ "\n"-            spaces = "  " ++ replicate (indent * 2) ' '-            leafname = accountLeafName fullname-            ismatched = fullname `elem` matchednames--            -- XXX -            isboringparent = numsubs >= 1 && (bal == subbal || not ismatched)-            subbal = abalance $ root $ head subs-            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--}-+            isInterestingTree t = treeany (isInteresting opts l . aname) t+            subtrees = map (fromJust . ledgerAccountTreeAt l) $ subAccounts l $ ledgerAccount l a ---          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--}

@@ -60,13 +60,6 @@ -- tree with boring accounts elided.  This converts a list of -- AccountName to a tree (later we will convert that to a tree of -- 'Account'.)-accountNameTreeFrom_props =-    [-     accountNameTreeFrom ["a"]       == Node "top" [Node "a" []],-     accountNameTreeFrom ["a","b"]   == Node "top" [Node "a" [], Node "b" []],-     accountNameTreeFrom ["a","a:b"] == Node "top" [Node "a" [Node "a:b" []]],-     accountNameTreeFrom ["a:b"]     == Node "top" [Node "a" [Node "a:b" []]]-    ] accountNameTreeFrom :: [AccountName] -> Tree AccountName accountNameTreeFrom accts =      Node "top" (accountsFrom (topAccountNames accts))@@ -74,7 +67,7 @@           accountsFrom :: [AccountName] -> [Tree AccountName]           accountsFrom [] = []           accountsFrom as = [Node a (accountsFrom $ subs a) | a <- as]-          subs = (subAccountNamesFrom accts)+          subs = subAccountNamesFrom (expandAccountNames accts)  -- | Elide an account name to fit in the specified width. -- From the ledger 2.6 news:@@ -147,8 +140,9 @@       match "" = True       match p = matchregex (abspat p) str -isnegativepat pat = take 1 pat `elem` ["-","^"]-abspat pat = if isnegativepat pat then drop 1 pat else pat+negateprefix = "not:"+isnegativepat pat = negateprefix `isPrefixOf` pat+abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat positivepats = filter (not . isnegativepat) negativepats = filter isnegativepat-matchregex pat str = containsRegex (mkRegexWithOpts pat True True) str+matchregex pat str = containsRegex (mkRegexWithOpts pat True False) str

@@ -39,23 +39,14 @@ showDate :: Day -> String showDate d = formatTime defaultTimeLocale "%Y/%m/%d" d -mkUTCTime :: Day -> TimeOfDay -> UTCTime-mkUTCTime day tod = localTimeToUTC utc (LocalTime day tod)--today :: IO Day-today = do+getCurrentDay :: IO Day+getCurrentDay = do     t <- getZonedTime     return $ localDay (zonedTimeToLocalTime t) -now :: IO UTCTime-now = getCurrentTime - 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]@@ -194,19 +185,32 @@ ---------------------------------------------------------------------- -- parsing +firstJust ms = case dropWhile (==Nothing) ms of+    [] -> Nothing+    (md:_) -> md++parsedatetimeM :: String -> Maybe LocalTime+parsedatetimeM s = firstJust [+    parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s,+    parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s+    ]+ -- | Parse a date-time string to a time type, or raise an error.-parsedatetime :: String -> 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+parsedatetime :: String -> LocalTime+parsedatetime s = fromMaybe (error $ "could not parse timestamp \"" ++ s ++ "\"")+                            (parsedatetimeM s)  -- | Parse a date string to a time type, or raise an error.+parsedateM :: String -> Maybe Day+parsedateM s = firstJust [ +     parseTime defaultTimeLocale "%Y/%m/%d" s,+     parseTime defaultTimeLocale "%Y-%m-%d" s +     ]++-- | Parse a date string to a time type, or raise an error. parsedate :: String -> Day-parsedate s =  -    parsetimewith "%Y/%m/%d" s $-    parsetimewith "%Y-%m-%d" s $-    error $ printf "could not parse date \"%s\"" s+parsedate s =  fromMaybe (error $ "could not parse date \"" ++ s ++ "\"")+                         (parsedateM s)  -- | Parse a time string to a time type using the provided pattern, or -- return the default.@@ -231,7 +235,7 @@ -} smartdate :: GenParser Char st SmartDate smartdate = do-  let dateparsers = [yyyymmdd, ymd, ym, md, y, d, month, mon, today', yesterday, tomorrow,+  let dateparsers = [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow,                      lastthisnextthing                     ]   (y,m,d) <- choice $ map try dateparsers@@ -310,8 +314,8 @@   let i = monIndex m   return ("",show i,"") -today',yesterday,tomorrow :: GenParser Char st SmartDate-today'    = string "today"     >> return ("","","today")+today,yesterday,tomorrow :: GenParser Char st SmartDate+today     = string "today"     >> return ("","","today") yesterday = string "yesterday" >> return ("","","yesterday") tomorrow  = string "tomorrow"  >> return ("","","tomorrow") 

@@ -49,7 +49,13 @@ @ -} showEntry :: Entry -> String-showEntry e = +showEntry = showEntry' True++showEntryUnelided :: Entry -> String+showEntryUnelided = showEntry' False++showEntry' :: Bool -> Entry -> String+showEntry' elide e =      unlines $ [{-precedingcomment ++ -}description] ++ (showtxns $ etransactions e) ++ [""]     where       precedingcomment = epreceding_comment_lines e@@ -59,15 +65,19 @@       code = if (length $ ecode e) > 0 then (printf " (%s)" $ ecode e) else ""       desc = " " ++ edescription e       comment = if (length $ ecomment e) > 0 then "  ; "++(ecomment e) else ""-      showtxns (t1:t2:[]) = [showtxn t1, showtxnnoamt t2]-      showtxns ts = map showtxn ts+      showtxns ts+          | elide && length ts == 2 = [showtxn (ts !! 0), showtxnnoamt (ts !! 1)]+          | otherwise = map showtxn ts       showtxn t = showacct t ++ "  " ++ (showamount $ tamount t) ++ (showcomment $ tcomment t)       showtxnnoamt t = showacct t ++ "              " ++ (showcomment $ tcomment t)-      showacct t = "    " ++ (showaccountname $ taccount t)+      showacct t = "    " ++ showstatus t ++ (showaccountname $ taccount t)       showamount = printf "%12s" . showMixedAmount       showaccountname s = printf "%-34s" s       showcomment s = if (length s) > 0 then "  ; "++s else ""       showdate d = printf "%-10s" (showDate d)+      showstatus t = case tstatus t of+                       True -> "* "+                       False -> ""  isEntryBalanced :: Entry -> Bool isEntryBalanced (Entry {etransactions=ts}) = @@ -77,19 +87,19 @@ -- 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'})+-- return an error message instead.+balanceEntry :: Entry -> Either String Entry+balanceEntry e@Entry{etransactions=ts}+    | length missingamounts > 1 = Left $ showerr "could not balance this entry, too many missing amounts"+    | not $ isEntryBalanced e' = Left $ showerr "could not balance this entry, amounts do not balance"+    | otherwise = Right e'     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-              1 -> map balance ts-              otherwise -> error $ "could not balance this entry, too many missing amounts:\n" ++ show e-      otherstotal = sum $ map tamount withamounts-      balance t-          | isReal t && not (hasAmount t) = t{tamount = costOfMixedAmount (-otherstotal)}-          | otherwise = t+      e' = e{etransactions=ts'}+      ts' | length missingamounts == 1 = map balance ts+          | otherwise = ts+          where +            balance t | isReal t && not (hasAmount t) = t{tamount = costOfMixedAmount (-otherstotal)}+                      | otherwise = t+                      where otherstotal = sum $ map tamount withamounts+      showerr s = printf "%s:\n%s" s (showEntryUnelided e)

@@ -33,10 +33,9 @@ cacheLedger :: [String] -> RawLedger -> Ledger cacheLedger apats l = Ledger{rawledgertext="",rawledger=l,accountnametree=ant,accountmap=acctmap}     where+      (ant,txnsof,_,inclbalof) = groupTransactions $ filtertxns apats $ rawLedgerTransactions l       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+          where mkacct a = Account a (txnsof a) (inclbalof a)  -- | Given a list of transactions, return an account name tree and three -- query functions that fetch transactions, balance, and@@ -111,7 +110,7 @@ -- | List a ledger account's immediate subaccounts subAccounts :: Ledger -> Account -> [Account] subAccounts l Account{aname=a} = -    map (ledgerAccount l) $ filter (a `isAccountNamePrefixOf`) $ accountnames l+    map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ accountnames l  -- | List a ledger's transactions. ledgerTransactions :: Ledger -> [Transaction]

@@ -16,6 +16,8 @@ import System.Directory import System.IO import qualified Data.Map as Map+import Data.Time.LocalTime+import Data.Time.Calendar import Ledger.Utils import Ledger.Types import Ledger.Dates@@ -24,29 +26,23 @@ import Ledger.Commodity import Ledger.TimeLog import Ledger.RawLedger-import Data.Time.LocalTime-import Data.Time.Calendar+import System.FilePath(takeDirectory,combine)   -- utils -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---- Default accounts "nest" hierarchically--data LedgerFileCtx = Ctx { ctxYear    :: !(Maybe Integer)-                         , ctxCommod  :: !(Maybe String)-                         , ctxAccount :: ![String]-                         } deriving (Read, Show)+-- | Some context kept during parsing.+data LedgerFileCtx = Ctx {+      ctxYear     :: !(Maybe Integer)  -- ^ the default year most recently specified with Y+    , ctxCommod   :: !(Maybe String)   -- ^ I don't know+    , ctxAccount  :: ![String]         -- ^ the current stack of "container" accounts specified by !account+    } deriving (Read, Show)  emptyCtx :: LedgerFileCtx emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] } +-- containing accounts "nest" hierarchically+ pushParentAccount :: String -> GenParser tok LedgerFileCtx () pushParentAccount parent = updateState addParentAccount     where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 }@@ -61,11 +57,30 @@ 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+setYear :: Integer -> GenParser tok LedgerFileCtx ()+setYear y = updateState (\ctx -> ctx{ctxYear=Just y}) +getYear :: GenParser tok LedgerFileCtx (Maybe Integer)+getYear = liftM ctxYear getState++printParseError :: (Show a) => a -> IO ()+printParseError e = do putStr "ledger parse error at "; print e++-- let's get to it++parseLedgerFile :: LocalTime -> FilePath -> ErrorT String IO RawLedger+parseLedgerFile t "-" = liftIO (hGetContents stdin) >>= parseLedger t "-"+parseLedgerFile t f   = liftIO (readFile f)         >>= parseLedger t f++-- | Parses the contents of a ledger file, or gives an error.  Requires+-- the current (local) time to calculate any unfinished timelog sessions,+-- we pass it in for repeatability.+parseLedger :: LocalTime -> FilePath -> String -> ErrorT String IO RawLedger+parseLedger reftime inname intxt = do+  case runParser ledgerFile emptyCtx inname intxt of+    Right m  -> liftM (rawLedgerConvertTimeLog reftime) $ 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@@ -79,6 +94,7 @@                                   , liftM (return . addModifierEntry) ledgerModifierEntry                                   , liftM (return . addPeriodicEntry) ledgerPeriodicEntry                                   , liftM (return . addHistoricalPrice) ledgerHistoricalPrice+                                  , ledgerDefaultYear                                   , emptyLine >> return (return id)                                   , liftM (return . addTimeLogEntry)  timelogentry                                   ]@@ -97,7 +113,7 @@                    outerState <- getState                    outerPos <- getPosition                    let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"-                   return $ do contents <- expandPath filename >>= readFileE outerPos+                   return $ do contents <- expandPath outerPos filename >>= readFileE outerPos                                case runParser ledgerFile outerState filename contents of                                  Right l   -> l `catchError` (\err -> throwError $ inIncluded ++ err)                                  Left perr -> throwError $ inIncluded ++ show perr@@ -106,10 +122,13 @@                     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+expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath+expandPath pos fp = liftM mkRelative (expandHome fp)+  where+    mkRelative = combine (takeDirectory (sourceName pos))+    expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory+                                                      return $ homedir ++ drop 1 inname+                      | otherwise                = return inname  ledgerAccountBegin :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) ledgerAccountBegin = do many1 spacenonewline@@ -271,6 +290,19 @@   restofline   return $ HistoricalPrice date symbol1 (symbol c) price +-- like ledgerAccountBegin, updates the LedgerFileCtx+ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))+ledgerDefaultYear = do+  char 'Y' <?> "default year"+  many spacenonewline+  y <- many1 digit+  let y' = read y+  guard (y' >= 1000)+  setYear y'+  return $ return id++-- | Try to parse a ledger entry. If we successfully parse an entry, ensure it is balanced,+-- and if we cannot, raise an error. ledgerEntry :: GenParser Char LedgerFileCtx Entry ledgerEntry = do   date <- ledgerdate <?> "entry"@@ -283,19 +315,31 @@   comment <- ledgercomment   restofline   transactions <- ledgertransactions-  return $ balanceEntry $ Entry date status code description comment transactions ""+  let e = Entry date status code description comment transactions ""+  case balanceEntry e of+    Right e' -> return e'+    Left err -> error err -ledgerdate :: GenParser Char st Day-ledgerdate = do -  y <- many1 digit-  char '/'-  m <- many1 digit-  char '/'-  d <- many1 digit+ledgerdate :: GenParser Char LedgerFileCtx Day+ledgerdate = try ledgerfulldate <|> ledgerpartialdate++ledgerfulldate :: GenParser Char LedgerFileCtx Day+ledgerfulldate = do+  (y,m,d) <- ymd   many spacenonewline-  return (fromGregorian (read y) (read m) (read d))+  return $ fromGregorian (read y) (read m) (read d) -ledgerdatetime :: GenParser Char st UTCTime+-- | Match a partial M/D date in a ledger. Warning, this terminates the+-- program if it finds a match when there is no default year specified.+ledgerpartialdate :: GenParser Char LedgerFileCtx Day+ledgerpartialdate = do+  (_,m,d) <- md+  many spacenonewline+  y <- getYear+  when (y==Nothing) $ error "partial date found, but no default year specified"+  return $ fromGregorian (fromJust y) (read m) (read d)++ledgerdatetime :: GenParser Char LedgerFileCtx LocalTime ledgerdatetime = do    day <- ledgerdate   h <- many1 digit@@ -305,8 +349,8 @@       char ':'       many1 digit   many spacenonewline-  return $ mkUTCTime day (TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s))-+  let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)+  return $ LocalTime day tod  ledgerstatus :: GenParser Char st Bool ledgerstatus = try (do { char '*'; many1 spacenonewline; return True } ) <|> return False@@ -322,16 +366,18 @@  normaltransaction :: GenParser Char LedgerFileCtx RawTransaction normaltransaction = do+  status <- ledgerstatus   account <- transactionaccountname   amount <- transactionamount   many spacenonewline   comment <- ledgercomment   restofline   parent <- getParentAccount-  return (RawTransaction account amount comment RegularTransaction)+  return (RawTransaction status account amount comment RegularTransaction)  virtualtransaction :: GenParser Char LedgerFileCtx RawTransaction virtualtransaction = do+  status <- ledgerstatus   char '('   account <- transactionaccountname   char ')'@@ -340,10 +386,11 @@   comment <- ledgercomment   restofline   parent <- getParentAccount-  return (RawTransaction account amount comment VirtualTransaction)+  return (RawTransaction status account amount comment VirtualTransaction)  balancedvirtualtransaction :: GenParser Char LedgerFileCtx RawTransaction balancedvirtualtransaction = do+  status <- ledgerstatus   char '['   account <- transactionaccountname   char ']'@@ -351,7 +398,7 @@   many spacenonewline   comment <- ledgercomment   restofline-  return (RawTransaction account amount comment BalancedVirtualTransaction)+  return (RawTransaction status account amount comment BalancedVirtualTransaction)  -- Qualify with the parent account from parsing context transactionaccountname :: GenParser Char LedgerFileCtx AccountName

@@ -106,6 +106,14 @@     RawLedger ms ps (map filtertxns es) tls hs f     where filtertxns e@Entry{etransactions=ts} = e{etransactions=filter isReal ts} +-- | Strip out any transactions to accounts deeper than the specified depth+-- (and any entries which have no transactions as a result).+filterRawLedgerTransactionsByDepth :: Int -> RawLedger -> RawLedger+filterRawLedgerTransactionsByDepth depth (RawLedger ms ps es tls hs f) =+    RawLedger ms ps (filter (not . null . etransactions) $ map filtertxns es) tls hs f+    where filtertxns e@Entry{etransactions=ts} = +              e{etransactions=filter ((<= depth) . accountNameLevel . taccount) ts}+ -- | Keep only entries which affect accounts matched by the account patterns. filterRawLedgerEntriesByAccount :: [String] -> RawLedger -> RawLedger filterRawLedgerEntriesByAccount apats (RawLedger ms ps es tls hs f) =@@ -120,7 +128,7 @@ canonicaliseAmounts costbasis l@(RawLedger ms ps es tls hs f) = RawLedger ms ps (map fixentry es) tls hs f     where        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+      fixrawtransaction (RawTransaction s ac a c t) = RawTransaction s 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)@@ -147,9 +155,10 @@ 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+-- | Close any open timelog sessions using the provided current time.+rawLedgerConvertTimeLog :: LocalTime -> RawLedger -> RawLedger+rawLedgerConvertTimeLog t l0 = l0 { entries = convertedTimeLog ++ entries l0+                                  , open_timelog_entries = []+                                  }+    where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0 

@@ -15,10 +15,10 @@  instance Show RawTransaction where show = showRawTransaction -nullrawtxn = RawTransaction "" nullmixedamt "" RegularTransaction+nullrawtxn = RawTransaction False "" nullmixedamt "" RegularTransaction  showRawTransaction :: RawTransaction -> String-showRawTransaction (RawTransaction a amt _ ttype) = +showRawTransaction (RawTransaction s a amt _ ttype) =      concatTopPadded [showaccountname a ++ " ", showamount amt]     where       showaccountname = printf "%-22s" . bracket . elideAccountName width

@@ -21,43 +21,58 @@ instance Show TimeLog where     show tl = printf "TimeLog with %d entries" $ length $ timelog_entries tl --- | Convert time log entries to ledger entries.-entriesFromTimeLogEntries :: [TimeLogEntry] -> [Entry]-entriesFromTimeLogEntries [] = []-entriesFromTimeLogEntries [i] = entriesFromTimeLogEntries [i, clockoutFor i]-entriesFromTimeLogEntries (i:o:rest) = [entryFromTimeLogInOut i o] ++ entriesFromTimeLogEntries rest---- | When there is a trailing clockin entry, provide the missing clockout.--- An entry for now is what we want but this requires IO so for now use--- the clockin time, ie don't count the current clocked-in period.-clockoutFor :: TimeLogEntry -> TimeLogEntry-clockoutFor (TimeLogEntry _ t _) = TimeLogEntry 'o' t ""+-- | Convert time log entries to ledger entries. When there is no+-- clockout, add one with the provided current time. Sessions crossing+-- midnight are split into days to give accurate per-day totals.+entriesFromTimeLogEntries :: LocalTime -> [TimeLogEntry] -> [Entry]+entriesFromTimeLogEntries _ [] = []+entriesFromTimeLogEntries now [i]+    | odate > idate = [entryFromTimeLogInOut i o'] ++ entriesFromTimeLogEntries now [i',o]+    | otherwise = [entryFromTimeLogInOut i o]+    where+      o = TimeLogEntry 'o' end ""+      end = if itime > now then itime else now+      (itime,otime) = (tldatetime i,tldatetime o)+      (idate,odate) = (localDay itime,localDay otime)+      o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}+      i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}+entriesFromTimeLogEntries now (i:o:rest)+    | odate > idate = [entryFromTimeLogInOut i o'] ++ entriesFromTimeLogEntries now (i':o:rest)+    | otherwise = [entryFromTimeLogInOut i o] ++ entriesFromTimeLogEntries now rest+    where+      (itime,otime) = (tldatetime i,tldatetime o)+      (idate,odate) = (localDay itime,localDay otime)+      o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}+      i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}  -- | Convert a timelog clockin and clockout entry to an equivalent ledger -- entry, representing the time expenditure. Note this entry is  not balanced, -- since we omit the \"assets:time\" transaction for simpler output. entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Entry entryFromTimeLogInOut i o-    | outtime >= intime = e+    | otime >= itime = e     | otherwise =          error $ "clock-out time less than clock-in time in:\n" ++ showEntry e     where       e = Entry {-            edate         = outdate, -- like ledger+            edate         = idate,             estatus       = True,             ecode         = "",-            edescription  = showtime intime ++ " - " ++ showtime outtime,+            edescription  = showtime itod ++ "-" ++ showtime otod,             ecomment      = "",             etransactions = txns,             epreceding_comment_lines=""           }-      showtime = show . timeToTimeOfDay . utctDayTime+      showtime = take 5 . show       acctname = tlcomment i-      indate   = utctDay intime-      outdate  = utctDay outtime-      intime   = tldatetime i-      outtime  = tldatetime o-      amount   = Mixed [hours $ elapsedSeconds outtime intime / 3600]-      txns     = [RawTransaction acctname amount "" RegularTransaction+      itime    = tldatetime i+      otime    = tldatetime o+      itod     = localTimeOfDay itime+      otod     = localTimeOfDay otime+      idate    = localDay itime+      odate    = localDay otime+      hrs      = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc+      amount   = Mixed [hours hrs]+      txns     = [RawTransaction False acctname amount "" RegularTransaction                  --,RawTransaction "assets:time" (-amount) "" RegularTransaction                  ]

@@ -18,14 +18,16 @@ instance Show Transaction where show=showTransaction  showTransaction :: Transaction -> String-showTransaction (Transaction eno d desc a amt ttype) = unwords [showDate d,desc,a,show amt,show ttype]+showTransaction (Transaction eno stat d desc a amt ttype) = +    s ++ unwords [showDate d,desc,a,show amt,show ttype]+    where s = if stat then " *" else ""  -- | Convert a 'Entry' to two or more 'Transaction's. An id number -- is attached to the transactions to preserve their grouping - it should -- be unique per entry. flattenEntry :: (Entry, Int) -> [Transaction]-flattenEntry (Entry d _ _ desc _ ts _, e) = -    [Transaction e d desc (taccount t) (tamount t) (rttype t) | t <- ts]+flattenEntry (Entry d s _ desc _ ts _, e) = +    [Transaction e s d desc (taccount t) (tamount t) (rttype t) | t <- ts]  accountNamesFromTransactions :: [Transaction] -> [AccountName] accountNamesFromTransactions ts = nub $ map account ts@@ -33,4 +35,4 @@ sumTransactions :: [Transaction] -> MixedAmount sumTransactions = sum . map amount -nulltxn = Transaction 0  (parsedate "1900/1/1") "" "" nullmixedamt RegularTransaction+nulltxn = Transaction 0 False (parsedate "1900/1/1") "" "" nullmixedamt RegularTransaction

@@ -45,6 +45,7 @@                        deriving (Eq,Show)  data RawTransaction = RawTransaction {+      tstatus :: Bool,       taccount :: AccountName,       tamount :: MixedAmount,       tcomment :: String,@@ -91,7 +92,7 @@  data TimeLogEntry = TimeLogEntry {       tlcode :: Char,-      tldatetime :: UTCTime,+      tldatetime :: LocalTime,       tlcomment :: String     } deriving (Eq,Ord) @@ -101,6 +102,7 @@  data Transaction = Transaction {       entryno :: Int,+      status :: Bool,       date :: Day,       description :: String,       account :: AccountName,

@@ -21,7 +21,6 @@ module Ledger.Utils, module Text.Printf, module Text.Regex,-module Text.RegexPR, module Test.HUnit, ) where@@ -39,7 +38,6 @@ import Test.HUnit import Text.Printf import Text.Regex-import Text.RegexPR import Text.ParserCombinators.Parsec  @@ -48,8 +46,7 @@ lowercase = map toLower uppercase = map toUpper -strip = dropspaces . reverse . dropspaces . reverse-    where dropspaces = dropWhile (`elem` " \t")+strip = dropws . reverse . dropws . reverse where dropws = dropWhile (`elem` " \t")  elideLeft width s =     case length s > width of@@ -215,12 +212,9 @@ strace :: Show a => a -> a strace a = trace (show a) a -p = putStr---- testing--assertequal e a = assertEqual "" e a-assertnotequal e a = assertBool "expected inequality, got equality" (e /= a)+-- | labelled trace - like strace, with a newline and a label prepended+ltrace :: Show a => String -> a -> a+ltrace l a = trace (l ++ ": " ++ show a) a  -- parsing @@ -238,4 +232,21 @@  restofline :: GenParser Char st String restofline = anyChar `manyTill` newline++-- time++getCurrentLocalTime :: IO LocalTime+getCurrentLocalTime = do+  t <- getCurrentTime+  tz <- getCurrentTimeZone+  return $ utcToLocalTime tz t++++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _        = False++isRight :: Either a b -> Bool+isRight = not . isLeft 

@@ -1,36 +1,56 @@+{-# OPTIONS_GHC -cpp #-} module Options  where import System import System.Console.GetOpt import System.Directory+import System.Environment import Text.Printf+import Text.RegexPR (gsubRegexPRBy)+import Data.Char (toLower) import Ledger.Parse import Ledger.Utils import Ledger.Types import Ledger.Dates +progname      = "hledger"+ledgerpath    = "~/.ledger"+ledgerenvvar  = "LEDGER"+timeprogname  = "hours"+timelogpath   = "~/.timelog"+timelogenvvar = "TIMELOG" -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 (can be abbreviated):\n" ++-              "  balance  - show account balances\n" ++-              "  print    - show formatted ledger entries\n" ++-              "  register - show register transactions\n" ++-              "\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 [TESTPATTERNS] to run self-tests.\n" ++-              "\n"+usagehdr = printf (+  "Usage: one of\n" +++  "  %s [OPTIONS] COMMAND [PATTERNS]\n" +++  "  %s [OPTIONS] [PERIOD [COMMAND [PATTERNS]]]\n" +++  "\n" +++  "COMMAND is one of (may be abbreviated):\n" +++  "  balance  - show account balances\n" +++  "  print    - show formatted ledger entries\n" +++  "  register - show register transactions\n" +++#ifdef VTY+  "  ui       - run a simple curses-based text ui\n" +++#endif+#ifdef HAPPS+  "  web      - run a simple web ui\n" +++#endif+  "  test     - run self-tests\n" +++  "\n" +++  "PATTERNS are regular expressions which filter by account name.\n" +++  "Or, prefix with desc: to filter by entry description.\n" +++  "Or, prefix with not: to negate a pattern. (When using both, not: comes last.)\n" +++  "\n" +++  "Dates can be y/m/d or ledger-style smart dates like \"last month\".\n" +++  "\n" +++  "Options:"+  ) progname timeprogname+  ++usageftr = printf (+  "\n"+  )+ usage = usageInfo usagehdr options ++ usageftr  -- | Command-line options we accept.@@ -42,26 +62,28 @@  ,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" +++ ,Option ['B'] ["cost","basis"] (NoArg  CostBasis)     "report cost of commodities"+ ,Option []    ["depth"]        (ReqArg Depth "N")     "hide accounts/transactions deeper than this"+ ,Option ['d'] ["display"]      (ReqArg Display "EXPR") ("show 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 ['E'] ["empty"]        (NoArg  Empty)         "show empty/zero things which are normally elided"  ,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 []    ["no-total"]     (NoArg  NoTotal)       "balance report: hide the final 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)"+ ,Option ['V'] ["version"]      (NoArg  Version)       "show version information"+ ,Option ['v'] ["verbose"]      (NoArg  Verbose)       "show verbose test output"+ ,Option []    ["debug"]        (NoArg  Debug)         "show some debug output"+ ,Option []    ["debug-no-ui"]  (NoArg  DebugNoUI)     "run ui commands with no output"  ]     where -      filehelp = printf "ledger file; - means use standard input. Defaults\nto the %s environment variable or %s"-                 fileenvvar defaultfile+      filehelp = printf (intercalate "\n"+                         ["ledger file; default is the %s env. variable's"+                         ,"value, or %s. - means use standard input."+                         ]) ledgerenvvar ledgerpath  -- | An option value from a command-line flag. data Opt = @@ -75,8 +97,7 @@     Display {value::String} |      Empty |      Real | -    OptionsAnywhere | -    Collapse |+    NoTotal |     SubTotal |     WeeklyOpt |     MonthlyOpt |@@ -84,6 +105,7 @@     Help |     Verbose |     Version+    | Debug     | DebugNoUI     deriving (Show,Eq) @@ -97,31 +119,43 @@ 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. 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.+-- | Parse the command-line arguments into options, command name, and+-- command arguments. 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. Arguments are parsed differently if the program was invoked as+-- \"hours\". parseArguments :: IO ([Opt], String, [String]) parseArguments = do   args <- getArgs-  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))+  istimequery <- usingTimeProgramName+  let (os,as,es) = getOpt Permute options args+  os' <- fixOptDates os+  case istimequery of+    False ->+        case (os,as,es) of+          (opts,cmd:args,[])   -> return (os',cmd,args)+          (opts,[],[])         -> return (os',"",[])+          (opts,_,errs)        -> ioError (userError (concat errs ++ usage))+    True -> +        case (os,as,es) of+          (opts,p:cmd:args,[]) -> return (os' ++ [Period p],cmd,args)+          (opts,p:args,[])     -> return ([Period p,SubTotal] ++ os',"balance",args)+          (opts,[],[])         -> return ([Period "today",SubTotal] ++ os',"balance",[])+          (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+  d <- getCurrentDay+  return $ map (fixopt d) opts   where-    fixopt t (Begin s)   = Begin $ fixSmartDateStr t s-    fixopt t (End s)     = End $ fixSmartDateStr t s-    fixopt t (Display s) = -- hacky+    fixopt d (Begin s)   = Begin $ fixSmartDateStr d s+    fixopt d (End s)     = End $ fixSmartDateStr d s+    fixopt d (Display s) = -- hacky         Display $ gsubRegexPRBy "\\[.+?\\]" fixbracketeddatestr s-        where fixbracketeddatestr s = "[" ++ (fixSmartDateStr t $ init $ tail s) ++ "]"+        where fixbracketeddatestr s = "[" ++ (fixSmartDateStr d $ init $ tail s) ++ "]"     fixopt _ o            = o  -- | Figure out the overall date span we should report on, based on any@@ -156,9 +190,9 @@       -- 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+-- | Get the value of the (last) depth option, if any, otherwise a large number.+depthFromOpts :: [Opt] -> Int+depthFromOpts opts = fromMaybe 9999 $ listtomaybeint $ optValuesForConstructor Depth opts     where       listtomaybeint [] = Nothing       listtomaybeint vs = Just $ read $ last vs@@ -170,10 +204,20 @@       listtomaybe [] = Nothing       listtomaybe vs = Just $ last vs +-- | Was the program invoked via the \"hours\" alias ?+usingTimeProgramName :: IO Bool+usingTimeProgramName = do+  progname <- getProgName+  return $ map toLower progname == timeprogname+ -- | 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+  istimequery <- usingTimeProgramName+  let (e,d) = if istimequery+              then (timelogenvvar,timelogpath)+              else (ledgerenvvar,ledgerpath)+  envordefault <- getEnv e `catch` \_ -> return d   paths <- mapM tildeExpand $ [envordefault] ++ optValuesForConstructor File opts   return $ last paths @@ -188,16 +232,16 @@ --                                return (homeDirectory pw ++ path) tildeExpand xs           =  return xs --- | Gather any ledger-style account/description pattern arguments into--- two lists.  These are 0 or more account patterns optionally followed by--- 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.+-- | Gather any pattern arguments into a list of account patterns and a+-- list of description patterns. For now we interpret pattern arguments as+-- follows: those prefixed with "desc:" are description patterns, all+-- others are account patterns. Also patterns prefixed with "not:" are+-- negated. not: should come after desc: if both are used.+-- This is different from ledger 2 and 3. 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 = '-'+    where+      descprefix = "desc:"+      (ds, as) = partition (descprefix `isPrefixOf`) args+      ds' = map (drop (length descprefix)) ds+

@@ -17,5 +17,9 @@ showEntries :: [Opt] -> [String] -> Ledger -> String showEntries opts args l = concatMap showEntry $ filteredentries     where -      filteredentries = entries $ filterRawLedgerEntriesByAccount apats $ rawledger l+      filteredentries = entries $ +                        filterRawLedgerTransactionsByDepth depth $ +                        filterRawLedgerEntriesByAccount apats $ +                        rawledger l+      depth = depthFromOpts opts       (apats,_) = parseAccountDescriptionArgs opts args

@@ -1,13 +1,12 @@-hledger - a ledger-compatible text-based accounting tool-========================================================  Welcome to 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+hledger is a partial haskell clone of John Wiegley's text-based accounting+tool, ledger (http://wiki.github.com/jwiegley/ledger). hledger generates+ledger-compatible register & balance reports from a plain text journal,+allows precise batch-mode or interactive querying, and demonstrates a pure+functional implementation of ledger.  For more information, see+http://hledger.org .  Copyright (c) 2007-2009 Simon Michael <simon@joyful.com> Released under GPL version 3 or later.@@ -15,100 +14,133 @@  Installation -------------hledger requires GHC. It is known to build with 6.8 and 6.10.-If you have cabal-install, do:: - cabal update- cabal install hledger+Building hledger requires GHC (http://haskell.org/ghc); it is known to+build with GHC 6.8 and up. hledger should work on any platform which GHC+supports.   -Otherwise, unpack the latest tarball from-http://hackage.haskell.org/cgi-bin/hackage-scripts/package/hledger and do::+Also, installing hledger easily requires the "cabal" command-line tool,+version 0.6.0 and up (http://www.haskell.org/cabal/download.html). (You+can manually download and install each dependency mentioned in+hledger.cabal from hackage.org, but installing cabal is much quicker.) - runhaskell Setup.hs configure- runhaskell Setup.hs build- sudo runhaskell Setup.hs install +Here's how to download and install the latest hledger release:: -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.)+ cabal update+ cabal install hledger (add -f happs to include the web ui) -To get the latest development code do::+Or, to get the latest development code::   darcs get http://joyful.com/repos/hledger  -Examples---------+Usage+-----++hledger looks for your ledger file at ~/.ledger by default. To use a+different file, specify it with the LEDGER environment variable or -f+option (which may be - for standard input). Basic usage is::++ hledger [OPTIONS] COMMAND [PATTERNS]++where COMMAND is one of balance, print, register, ui, web, test; and+PATTERNS are zero or more regular expressions used to narrow the results. Here are some commands to try::   hledger --help- hledger -f sample.ledger balance  export LEDGER=sample.ledger- hledger -s balance+ hledger balance+ hledger bal --depth 1  hledger register- hledger reg cash- hledger reg -- shop+ hledger reg income+ hledger reg desc:shop  hledger ui+ hledger web # if you installed with -f happs -hledger looks for your ledger file at ~/.ledger by default. To use a different file,-specify it with -f or the LEDGER environment variable. +Time reporting+--------------+hledger will also read timeclock.el-format timelog entries.  As a+convenience, if you invoke the hledger executable via a link or copy named+"hours", it looks for your timelog file (~/.timelog, or the file specified+by $TIMELOG or -f), and parses arguments slightly differently:: + hours [OPTIONS] [PERIOD [COMMAND [PATTERNS]]]++where PERIOD is a ledger-style period expression, defaulting to "today",+and COMMAND is one of the commands above. Timelog entries look like this::++ i 2009/03/31 22:21:45 some:project+ o 2009/04/01 02:00:34++The clock-in project is treated as an account. Here are some time queries to try::++ export TIMELOG=/my/timelog            # if it's not ~/.timelog+ hours                                 # today's balances+ hours today                           # the same+ hours 'this week'                     # so far this week+ hours lastmonth                       # the space is optional+ hours 'from 1/15' register            # sessions since last january 15+ hours 'monthly in 2009' reg --depth 1 # monthly time summary, top level only+ Features -------- -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::+This version of hledger mimics a subset of ledger 3.x, and adds some+features of its own. We currently support regular ledger entries, timelog+entries, multiple commodities, virtual transactions, account and+description patterns, the LEDGER environment variable, and these commands+and options:: +   Commands:+   balance  [REGEXP]...   show balance totals for matching accounts+   register [REGEXP]...   show register of matching transactions+   print    [REGEXP]...   print all matching entries+    Basic options:-   -h, --help             display summarized help text-   -v, --version          show version information+   -h, --help             show summarized help    -f, --file FILE        read ledger data from FILE      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+   -b, --begin DATE       report on entries on or after this date+   -e, --end DATE         report on entries prior to this date+   -p, --period EXPR      report on entries during the specified period+                          and/or with the specified reporting interval+   -C, --cleared          report only on cleared entries+   -R, --real             report only on real (non-virtual) transactions      Output customization:-   -n, --collapse         balance report: no grand total+   -B, --basis, --cost    report cost of commodities    -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+   -E, --empty            show empty/zero things which are normally elided+   --no-total             balance report: hide the final total+   -W, --weekly           register report: show weekly summary+   -M, --monthly          register report: show monthly summary+   -Y, --yearly           register report: show yearly summary -   Commands:-   balance  [REGEXP]...   show balance totals for matching accounts-   register [REGEXP]...   show register of matching transactions-   print    [REGEXP]...   print all matching entries+   Misc:+   -V, --version          show version information+   -v, --verbose          show verbose test output+   --debug                show some debug output +   --debug-no-ui          run ui commands with no output -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::+We handle (almost) the full period expression syntax, and very limited+display expressions consisting of a simple date predicate. Also the+following new commands are supported:: -   ui                     interactive text ui-   --depth=N              balance report: maximum account depth to show-   --options-anywhere     allow options anywhere, use ^ for negative patterns+   ui                     a simple interactive text ui (only on unix platforms)+   web                    a simple web ui+   test                   run self-tests  ledger features not supported ............................. -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::+ledger features not currently supported include: modifier and periodic+entries, and options such as these::     Basic options:    -o, --output FILE      write output to FILE    -i, --init-file FILE   initialize ledger using FILE (default: ~/.ledgerrc)-       --cache FILE       use FILE as a binary cache when --file is not used-       --no-cache         don't use a cache, even if it would be appropriate    -a, --account NAME     use NAME for the default account (useful with QIF)      Report filtering:@@ -126,13 +158,10 @@    -T, --total EXPR       use EXPR to calculate the displayed total      Output customization:-   -n, --collapse         register: collapse entries+   -n, --collapse         Only show totals in the top-most accounts.    -s, --subtotal         other: show subtotals    -P, --by-payee         show summarized totals by payee    -x, --comm-as-payee    set commodity name as the payee, for reporting-   -W, --weekly           show weekly sub-totals-   -M, --monthly          show monthly sub-totals-   -Y, --yearly           show yearly sub-totals        --dow              show a days-of-the-week report    -S, --sort EXPR        sort report according to the value expression EXPR    -w, --wide             for the default register report, use 132 columns@@ -169,12 +198,14 @@ Other differences ................. -* 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 calls the "note" field "description"+* hledger recognises description and negative patterns by  "desc:" and "not:" prefixes,+  unlike ledger 3's free-form parser+* hledger keeps differently-priced amounts of the same commodity separate+* hledger doesn't require a space before command-line option values, eg: -f-+* hledger's weekly reporting intervals always start on mondays+* hledger shows start and end dates of the intervals requested, 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+* hledger splits multi-day timelog sessions at midnight+* hledger register report always sorts transactions by date

@@ -33,7 +33,13 @@     | otherwise = showtxns summaryts nulltxn startbal     where       interval = intervalFromOpts opts-      ts = filter (not . isZeroMixedAmount . amount) $ filter matchapats $ ledgerTransactions l+      ts = sort $ filterempties $ filter matchapats $ filterdepth $ ledgerTransactions l+           where sort = sortBy (\a b -> compare (date a) (date b))+      filterdepth | interval == NoInterval = filter (\t -> (accountNameLevel $ account t) <= depth)+                  | otherwise = id+      filterempties+          | Empty `elem` opts = id+          | otherwise = filter (not . isZeroMixedAmount . amount)       (precedingts, ts') = break (matchdisplayopt dopt) ts       (displayedts, _) = span (matchdisplayopt dopt) ts'       startbal = sumTransactions precedingts@@ -64,7 +70,7 @@ --  -- 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 -> Int -> Int -> Bool -> [Transaction] -> [Transaction] summariseTransactionsInDateSpan (DateSpan b e) entryno depth showempty ts     | null ts && showempty = [txn]     | null ts = []@@ -80,14 +86,13 @@       -- 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+      isclipped a = accountNameLevel a >= 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] -clipAccountNames :: Maybe Int -> [AccountName] -> [AccountName]-clipAccountNames Nothing as = as-clipAccountNames (Just d) as = nub $ map (clip d) as +clipAccountNames :: Int -> [AccountName] -> [AccountName]+clipAccountNames d as = nub $ map (clip d) as      where clip d = accountNameFromComponents . take d . accountNameComponents  -- | Does the given transaction fall within the given date span ?@@ -113,7 +118,7 @@       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+      txn = showRawTransaction $ RawTransaction s a amt "" tt       bal = padleft 12 (showMixedAmountOrZero b)-      Transaction{date=da,description=de,account=a,amount=amt,ttype=tt} = t+      Transaction{status=s,date=da,description=de,account=a,amount=amt,ttype=tt} = t 

@@ -1,937 +1,1137 @@-module Tests-where-import qualified Data.Map as Map-import Text.ParserCombinators.Parsec-import Test.HUnit-import Ledger-import Utils-import Options-import BalanceCommand-import PrintCommand-import RegisterCommand---runtests opts args = do-  when (Verbose `elem` opts)-       (do-         putStrLn $ printf "Running %d tests%s:" n s-         sequence $ map (putStrLn . tname) $ tflatten flattests; putStrLn "Results:")-  runTestTT flattests-      where-        deeptests = tfilter matchname $ TestList tests-        flattests = TestList $ filter matchname $ concatMap tflatten tests-        matchname = matchpats args . tname-        n = length ts where (TestList ts) = flattests-        s | null args = ""-          | otherwise = printf " matching %s " -                        (intercalate ", " $ map (printf "\"%s\"") args)----------------------------------------------------------------------------------- tests--tests = [TestList []-        ,misc_tests-        ,newparse_tests-        ,balancereportacctnames_tests-        ,balancecommand_tests-        ,printcommand_tests-        ,registercommand_tests-        ]--misc_tests = TestList [-  "show dollars" ~: show (dollars 1) ~?= "$1.00"-  ,-  "show hours" ~: show (hours 1) ~?= "1.0h"-  ,-  "amount arithmetic"   ~: do-    let a1 = dollars 1.23-    let a2 = Amount (comm "$") (-1.23) Nothing-    let a3 = Amount (comm "$") (-1.23) Nothing-    assertequal (Amount (comm "$") 0 Nothing) (a1 + a2)-    assertequal (Amount (comm "$") 0 Nothing) (a1 + a3)-    assertequal (Amount (comm "$") (-2.46) Nothing) (a2 + a3)-    assertequal (Amount (comm "$") (-2.46) Nothing) (a3 + a3)-    assertequal (Amount (comm "$") (-2.46) Nothing) (sum [a2,a3])-    assertequal (Amount (comm "$") (-2.46) Nothing) (sum [a3,a3])-    assertequal (Amount (comm "$") 0 Nothing) (sum [a1,a2,a3,-a3])-  ,-  "ledgertransaction"  ~: do-    assertparseequal rawtransaction1 (parseWithCtx ledgertransaction rawtransaction1_str)-  ,                  -  "ledgerentry"        ~: do-    assertparseequal entry1 (parseWithCtx ledgerEntry entry1_str)-  ,-  "balanceEntry"      ~: do-    assertequal-      (Mixed [dollars (-47.18)])-      (tamount $ last $ etransactions $ balanceEntry entry1)-  ,-  "punctuatethousands"      ~: punctuatethousands "" @?= ""-  ,-  "punctuatethousands"      ~: punctuatethousands "1234567.8901" @?= "1,234,567.8901"-  ,-  "punctuatethousands"      ~: punctuatethousands "-100" @?= "-100"-  ,-  "expandAccountNames" ~: do-    assertequal-      ["assets","assets:cash","assets:checking","expenses","expenses:vacation"]-      (expandAccountNames ["assets:cash","assets:checking","expenses:vacation"])-  ,-  "accountnames" ~: do-    assertequal-      ["assets","assets:cash","assets:checking","assets:saving","equity","equity:opening balances",-       "expenses","expenses:food","expenses:food:dining","expenses:phone","expenses:vacation",-       "liabilities","liabilities:credit cards","liabilities:credit cards:discover"]-      (accountnames ledger7)-  ,-  "cacheLedger"        ~: do-    assertequal 15 (length $ Map.keys $ accountmap $ cacheLedger [] rawledger7)-  ,-  "transactionamount"       ~: do-    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 (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")-  ,                  -  "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: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"]-  ,"balancereportacctnames2" ~: ("",  ["assets"])      `gives` ["assets"]-  ,"balancereportacctnames3" ~: ("",  ["as"])          `gives` ["assets","assets:cash"]-  ,"balancereportacctnames4" ~: ("",  ["assets:cash"]) `gives` ["assets:cash"]-  ,"balancereportacctnames5" ~: ("",  ["-assets"])     `gives` ["expenses","income","liabilities"]-  ,"balancereportacctnames6" ~: ("",  ["-e"])          `gives` []-  ,"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 <- sampleledger-      let t = pruneZeroBalanceLeaves $ ledgerAccountTree 999 l-      assertequal e (balancereportacctnames l (opt=="-s") pats t)--balancecommand_tests = TestList [-  "simple balance report" ~:-  ([], []) `gives`-  ("                 $-1  assets\n" ++-   "                  $2  expenses\n" ++-   "                 $-2  income\n" ++-   "                  $1  liabilities\n" ++-   "")- ,-  "balance report with -s" ~:-  ([SubTotal], []) `gives`-  ("                 $-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" ++-   "")- ,-  "balance report --depth limits -s" ~:-  ([SubTotal,Depth "1"], []) `gives`-  ("                 $-1  assets\n" ++-   "                  $2  expenses\n" ++-   "                 $-2  income\n" ++-   "                  $1  liabilities\n" ++-   "")- ,-  "balance report --depth activates -s" ~:-  ([Depth "2"], []) `gives`-  ("                 $-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" ++-   "")- ,-  "balance report with account pattern o" ~:-  ([], ["o"]) `gives`-  ("                  $1  expenses:food\n" ++-   "                 $-2  income\n" ++-   "--------------------\n" ++-   "                 $-1\n" ++-   "")- ,-  "balance report with account pattern o and -s" ~:-  ([SubTotal], ["o"]) `gives`-  ("                  $1  expenses:food\n" ++-   "                 $-2  income\n" ++-   "                 $-1    gifts\n" ++-   "                 $-1    salary\n" ++-   "--------------------\n" ++-   "                 $-1\n" ++-   "")- ,-  "balance report with account pattern a" ~:-  ([], ["a"]) `gives`-  ("                 $-1  assets\n" ++-   "                  $1    bank:saving\n" ++-   "                 $-2    cash\n" ++-   "                 $-1  income:salary\n" ++-   "                  $1  liabilities\n" ++-   "--------------------\n" ++-   "                 $-1\n" ++-   "")- ,-  "balance report with account pattern e" ~:-  ([], ["e"]) `gives`-  ("                 $-1  assets\n" ++-   "                  $2  expenses\n" ++-   "                  $1    supplies\n" ++-   "                 $-2  income\n" ++-   "                  $1  liabilities:debts\n" ++-   "")- ,-  "balance report with unmatched parent of two matched subaccounts" ~: -  ([], ["cash","saving"]) `gives`-  ("                  $1  assets:bank:saving\n" ++-   "                 $-2  assets:cash\n" ++-   "--------------------\n" ++-   "                 $-1\n" ++-   "")- ,-  "balance report with multi-part account name" ~: -  ([], ["expenses:food"]) `gives`-  ("                  $1  expenses:food\n" ++-   "--------------------\n" ++-   "                  $1\n" ++-   "")- ,-  "balance report with negative account pattern" ~:-  ([], ["-assets"]) `gives`-  ("                  $2  expenses\n" ++-   "                 $-2  income\n" ++-   "                  $1  liabilities\n" ++-   "--------------------\n" ++-   "                  $1\n" ++-   "")- ,-  "balance report negative account pattern always matches full name" ~: -  ([], ["-e"]) `gives` ""- ,-  "balance report negative patterns affect totals" ~: -  ([], ["expenses","-food"]) `gives`-  ("                  $1  expenses\n" ++-   "--------------------\n" ++-   "                  $1\n" ++-   "")- ,-  "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" ++-   "--------------------\n" ++-   "                 $-1\n" ++-   "")- ,-  "balance report with -n omits the total" ~:-  ([Collapse], ["cash"]) `gives`-  ("                 $-2  assets:cash\n" ++-   "")- ,-  "balance report with cost basis" ~: do-    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,args) e = do -      l <- sampleledgerwithopts [] args-      assertequal e (showBalanceReport opts args l)--printcommand_tests = TestList [-  "print with account patterns" ~:-  do -    let args = ["expenses"]-    l <- sampleledgerwithopts [] args-    assertequal (-     "2008/06/03 * eat & shop\n" ++-     "    expenses:food                                 $1\n" ++-     "    expenses:supplies                             $1\n" ++-     "    assets:cash                                  $-2\n" ++-     "\n")-     $ showEntries [] args l-  ]--registercommand_tests = TestList [-  "register report" ~:-  do -    l <- sampleledger-    assertequal (-     "2008/01/01 income               assets:bank:checking             $1           $1\n" ++-     "                                income:salary                   $-1            0\n" ++-     "2008/06/01 gift                 assets:bank:checking             $1           $1\n" ++-     "                                income:gifts                    $-1            0\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/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--entry1_str = "" ++- "2007/01/28 coopportunity\n" ++- "  expenses:food:groceries                 $47.18\n" ++- "  assets:checking\n" ++- "\n"--entry1 =-    (Entry (parsedate "2007/01/28") False "" "coopportunity" ""-     [RawTransaction "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularTransaction, -      RawTransaction "assets:checking" (Mixed [dollars (-47.18)]) "" RegularTransaction] "")---entry2_str = "" ++- "2007/01/27 * joes diner\n" ++- "  expenses:food:dining                    $10.00\n" ++- "  expenses:gifts                          $10.00\n" ++- "  assets:checking                        $-20.00\n" ++- "\n"--entry3_str = "" ++- "2007/01/01 * opening balance\n" ++- "    assets:cash                                $4.82\n" ++- "    equity:opening balances\n" ++- "\n" ++- "2007/01/01 * opening balance\n" ++- "    assets:cash                                $4.82\n" ++- "    equity:opening balances\n" ++- "\n" ++- "2007/01/28 coopportunity\n" ++- "  expenses:food:groceries                 $47.18\n" ++- "  assets:checking\n" ++- "\n"--periodic_entry1_str = "" ++- "~ monthly from 2007/2/2\n" ++- "  assets:saving            $200.00\n" ++- "  assets:checking\n" ++- "\n"--periodic_entry2_str = "" ++- "~ monthly from 2007/2/2\n" ++- "  assets:saving            $200.00         ;auto savings\n" ++- "  assets:checking\n" ++- "\n"--periodic_entry3_str = "" ++- "~ monthly from 2007/01/01\n" ++- "    assets:cash                                $4.82\n" ++- "    equity:opening balances\n" ++- "\n" ++- "~ monthly from 2007/01/01\n" ++- "    assets:cash                                $4.82\n" ++- "    equity:opening balances\n" ++- "\n"--ledger1_str = "" ++- "\n" ++- "2007/01/27 * joes diner\n" ++- "  expenses:food:dining                    $10.00\n" ++- "  expenses:gifts                          $10.00\n" ++- "  assets:checking                        $-20.00\n" ++- "\n" ++- "\n" ++- "2007/01/28 coopportunity\n" ++- "  expenses:food:groceries                 $47.18\n" ++- "  assets:checking                        $-47.18\n" ++- "\n" ++- ""--ledger2_str = "" ++- ";comment\n" ++- "2007/01/27 * joes diner\n" ++- "  expenses:food:dining                    $10.00\n" ++- "  assets:checking                        $-47.18\n" ++- "\n"--ledger3_str = "" ++- "2007/01/27 * joes diner\n" ++- "  expenses:food:dining                    $10.00\n" ++- ";intra-entry comment\n" ++- "  assets:checking                        $-47.18\n" ++- "\n"--ledger4_str = "" ++- "!include \"somefile\"\n" ++- "2007/01/27 * joes diner\n" ++- "  expenses:food:dining                    $10.00\n" ++- "  assets:checking                        $-47.18\n" ++- "\n"--ledger5_str = ""--ledger6_str = "" ++- "~ monthly from 2007/1/21\n" ++- "    expenses:entertainment  $16.23        ;netflix\n" ++- "    assets:checking\n" ++- "\n" ++- "; 2007/01/01 * opening balance\n" ++- ";     assets:saving                            $200.04\n" ++- ";     equity:opening balances                         \n" ++- "\n"--ledger7_str = "" ++- "2007/01/01 * opening balance\n" ++- "    assets:cash                                $4.82\n" ++- "    equity:opening balances                         \n" ++- "\n" ++- "2007/01/01 * opening balance\n" ++- "    income:interest                                $-4.82\n" ++- "    equity:opening balances                         \n" ++- "\n" ++- "2007/01/02 * ayres suites\n" ++- "    expenses:vacation                        $179.92\n" ++- "    assets:checking                                 \n" ++- "\n" ++- "2007/01/02 * auto transfer to savings\n" ++- "    assets:saving                            $200.00\n" ++- "    assets:checking                                 \n" ++- "\n" ++- "2007/01/03 * poquito mas\n" ++- "    expenses:food:dining                       $4.82\n" ++- "    assets:cash                                     \n" ++- "\n" ++- "2007/01/03 * verizon\n" ++- "    expenses:phone                            $95.11\n" ++- "    assets:checking                                 \n" ++- "\n" ++- "2007/01/03 * discover\n" ++- "    liabilities:credit cards:discover         $80.00\n" ++- "    assets:checking                                 \n" ++- "\n" ++- "2007/01/04 * blue cross\n" ++- "    expenses:health:insurance                 $90.00\n" ++- "    assets:checking                                 \n" ++- "\n" ++- "2007/01/05 * village market liquor\n" ++- "    expenses:food:dining                       $6.48\n" ++- "    assets:checking                                 \n" ++- "\n"--rawledger7 = RawLedger-          [] -          [] -          [-           Entry {-             edate= parsedate "2007/01/01", -             estatus=False, -             ecode="*", -             edescription="opening balance", -             ecomment="",-             etransactions=[-              RawTransaction {-                taccount="assets:cash", -                tamount=(Mixed [dollars 4.82]),-                tcomment="",-                rttype=RegularTransaction-              },-              RawTransaction {-                taccount="equity:opening balances", -                tamount=(Mixed [dollars (-4.82)]),-                tcomment="",-                rttype=RegularTransaction-              }-             ],-             epreceding_comment_lines=""-           }-          ,-           Entry {-             edate= parsedate "2007/02/01", -             estatus=False, -             ecode="*", -             edescription="ayres suites", -             ecomment="",-             etransactions=[-              RawTransaction {-                taccount="expenses:vacation", -                tamount=(Mixed [dollars 179.92]),-                tcomment="",-                rttype=RegularTransaction-              },-              RawTransaction {-                taccount="assets:checking", -                tamount=(Mixed [dollars (-179.92)]),-                tcomment="",-                rttype=RegularTransaction-              }-             ],-             epreceding_comment_lines=""-           }-          ,-           Entry {-             edate=parsedate "2007/01/02", -             estatus=False, -             ecode="*", -             edescription="auto transfer to savings", -             ecomment="",-             etransactions=[-              RawTransaction {-                taccount="assets:saving", -                tamount=(Mixed [dollars 200]),-                tcomment="",-                rttype=RegularTransaction-              },-              RawTransaction {-                taccount="assets:checking", -                tamount=(Mixed [dollars (-200)]),-                tcomment="",-                rttype=RegularTransaction-              }-             ],-             epreceding_comment_lines=""-           }-          ,-           Entry {-             edate=parsedate "2007/01/03", -             estatus=False, -             ecode="*", -             edescription="poquito mas", -             ecomment="",-             etransactions=[-              RawTransaction {-                taccount="expenses:food:dining", -                tamount=(Mixed [dollars 4.82]),-                tcomment="",-                rttype=RegularTransaction-              },-              RawTransaction {-                taccount="assets:cash", -                tamount=(Mixed [dollars (-4.82)]),-                tcomment="",-                rttype=RegularTransaction-              }-             ],-             epreceding_comment_lines=""-           }-          ,-           Entry {-             edate=parsedate "2007/01/03", -             estatus=False, -             ecode="*", -             edescription="verizon", -             ecomment="",-             etransactions=[-              RawTransaction {-                taccount="expenses:phone", -                tamount=(Mixed [dollars 95.11]),-                tcomment="",-                rttype=RegularTransaction-              },-              RawTransaction {-                taccount="assets:checking", -                tamount=(Mixed [dollars (-95.11)]),-                tcomment="",-                rttype=RegularTransaction-              }-             ],-             epreceding_comment_lines=""-           }-          ,-           Entry {-             edate=parsedate "2007/01/03", -             estatus=False, -             ecode="*", -             edescription="discover", -             ecomment="",-             etransactions=[-              RawTransaction {-                taccount="liabilities:credit cards:discover", -                tamount=(Mixed [dollars 80]),-                tcomment="",-                rttype=RegularTransaction-              },-              RawTransaction {-                taccount="assets:checking", -                tamount=(Mixed [dollars (-80)]),-                tcomment="",-                rttype=RegularTransaction-              }-             ],-             epreceding_comment_lines=""-           }-          ] -          []-          []-          ""--ledger7 = cacheLedger [] rawledger7 --ledger8_str = "" ++- "2008/1/1 test           \n" ++- "  a:b          10h @ $40\n" ++- "  c:d                   \n" ++- "\n"--timelogentry1_str  = "i 2007/03/11 16:19:00 hledger\n"-timelogentry1 = TimeLogEntry 'i' (parsedatetime "2007/03/11 16:19:00") "hledger"--timelogentry2_str  = "o 2007/03/11 16:30:00\n"-timelogentry2 = TimeLogEntry 'o' (parsedatetime "2007/03/11 16:30:00") ""--timelog1_str = concat [-                timelogentry1_str,-                timelogentry2_str-               ]-timelog1 = TimeLog [-            timelogentry1,-            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)----------------------------------------------------------------------------------- test utils---- | Get a Test's label, or the empty string.-tname :: Test -> String-tname (TestLabel n _) = n-tname _ = ""---- | Flatten a Test containing TestLists into a list of single tests.-tflatten :: Test -> [Test]-tflatten (TestLabel _ t@(TestList _)) = tflatten t-tflatten (TestList ts) = concatMap tflatten ts-tflatten t = [t]---- | Filter TestLists in a Test, recursively, preserving the structure.-tfilter :: (Test -> Bool) -> Test -> Test-tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts)-tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts-tfilter _ t = t---- | Combine a list of TestLists into one.-tlistconcat :: [Test] -> Test-tlistconcat = foldr (\(TestList as) (TestList bs) -> TestList (as ++ bs)) (TestList []) ---- | Assert a parsed thing equals some expected thing, or print a parse error.-assertparseequal :: (Show a, Eq a) => a -> (Either ParseError a) -> Assertion-assertparseequal expected parsed = either printParseError (assertequal expected) parsed--rawLedgerWithAmounts as = -        RawLedger -        [] -        [] -        [nullentry{edescription=a,etransactions=[nullrawtxn{tamount=parse a}]} | a <- as]-        []-        []-        ""-            where parse = fromparse . parseWithCtx transactionamount . (" "++)+{- |+hledger's test suite. Most tests are HUnit-based, and defined in the+@tests@ list below. These tests are built in to hledger and can be run at+any time with @hledger test@.++In addition, we have tests in doctest format, which can be run with @make+doctest@ in the hledger source tree. These have some advantages:++- easier to read and write than hunit, for functional/shell tests++- easier to read multi-line output from failing tests++- can also appear in, and test, docs++and disadvantages:++- not included in hledger's built-in tests++- not platform independent++All doctests are included below. Some of these may also appear in other+modules as examples within the api docs.++Run a few with c++ ledger first:++@+$ ledger -f sample.ledger balance+                 $-1  assets+                  $1    bank:saving+                 $-2    cash+                  $2  expenses+                  $1    food+                  $1    supplies+                 $-2  income+                 $-1    gifts+                 $-1    salary+                  $1  liabilities:debts+@++@+$ ledger -f sample.ledger balance o+                  $1  expenses:food+                 $-2  income+                 $-1    gifts+                 $-1    salary+--------------------+                 $-1+@++Then hledger:++@+$ hledger -f sample.ledger balance+                 $-1  assets+                  $1    bank:saving+                 $-2    cash+                  $2  expenses+                  $1    food+                  $1    supplies+                 $-2  income+                 $-1    gifts+                 $-1    salary+                  $1  liabilities:debts+@++@+$ hledger -f sample.ledger balance o+                  $1  expenses:food+                 $-2  income+                 $-1    gifts+                 $-1    salary+--------------------+                 $-1+@++@+$ hledger -f sample.ledger balance --depth 1+                 $-1  assets+                  $2  expenses+                 $-2  income+                  $1  liabilities+@++-}+-- other test tools:+-- http://hackage.haskell.org/cgi-bin/hackage-scripts/package/test-framework+-- http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HTF++module Tests+where+import qualified Data.Map as Map+import Data.Time.Format+import System.Locale (defaultTimeLocale)+import Text.ParserCombinators.Parsec+import Test.HUnit+import Test.HUnit.Tools (assertRaises, runVerboseTests)+import Ledger+import Utils+import Options+import BalanceCommand+import PrintCommand+import RegisterCommand+++runtests opts args = runner flattests+    where+      runner | (Verbose `elem` opts) = runVerboseTests+             | otherwise = \t -> runTestTT t >>= return . (flip (,) 0)+      flattests = TestList $ filter matchname $ concatMap tflatten tests+      deeptests = tfilter matchname $ TestList tests+      matchname = matchpats args . tname++-- | Get a Test's label, or the empty string.+tname :: Test -> String+tname (TestLabel n _) = n+tname _ = ""++-- | Flatten a Test containing TestLists into a list of single tests.+tflatten :: Test -> [Test]+tflatten (TestLabel _ t@(TestList _)) = tflatten t+tflatten (TestList ts) = concatMap tflatten ts+tflatten t = [t]++-- | Filter TestLists in a Test, recursively, preserving the structure.+tfilter :: (Test -> Bool) -> Test -> Test+tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts)+tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts+tfilter _ t = t++-- | Simple way to assert something is some expected value, with no label.+is :: (Eq a, Show a) => a -> a -> Assertion+a `is` e = assertEqual "" a e++-- | Assert a parse result is some expected value, or print a parse error.+parseis :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion+parse `parseis` expected = either printParseError (`is` expected) parse++------------------------------------------------------------------------------+-- | Tests for any function or topic. Mostly ordered by test name.+tests :: [Test]+tests = [++   "account directive" ~: +   let sameParse str1 str2 = do l1 <- rawledgerfromstring str1+                                l2 <- rawledgerfromstring str2+                                l1 `is` l2+   in TestList+   [+    "account directive 1" ~: sameParse +                          "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"++   ,"account directive 2" ~: sameParse +                           "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"++   ,"account directive 3" ~: sameParse +                           "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"++   ,"account directive 4" ~: sameParse +                           ("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"+                           )+   ]++  ,"accountnames" ~: do+    accountnames ledger7 `is`+     ["assets","assets:cash","assets:checking","assets:saving","equity","equity:opening balances",+      "expenses","expenses:food","expenses:food:dining","expenses:phone","expenses:vacation",+      "liabilities","liabilities:credit cards","liabilities:credit cards:discover"]++  ,"accountNameTreeFrom" ~: do+    accountNameTreeFrom ["a"]       `is` Node "top" [Node "a" []]+    accountNameTreeFrom ["a","b"]   `is` Node "top" [Node "a" [], Node "b" []]+    accountNameTreeFrom ["a","a:b"] `is` Node "top" [Node "a" [Node "a:b" []]]+    accountNameTreeFrom ["a:b:c"]   `is` Node "top" [Node "a" [Node "a:b" [Node "a:b:c" []]]]++  ,"amount arithmetic" ~: do+    let a1 = dollars 1.23+    let a2 = Amount (comm "$") (-1.23) Nothing+    let a3 = Amount (comm "$") (-1.23) Nothing+    (a1 + a2) `is` Amount (comm "$") 0 Nothing+    (a1 + a3) `is` Amount (comm "$") 0 Nothing+    (a2 + a3) `is` Amount (comm "$") (-2.46) Nothing+    (a3 + a3) `is` Amount (comm "$") (-2.46) Nothing+    (sum [a2,a3]) `is` Amount (comm "$") (-2.46) Nothing+    (sum [a3,a3]) `is` Amount (comm "$") (-2.46) Nothing+    (sum [a1,a2,a3,-a3]) `is` Amount (comm "$") 0 Nothing++  ,"balance report tests" ~:+   let (opts,args) `gives` es = do +        l <- sampleledgerwithopts opts args+        showBalanceReport opts args l `is` unlines es+   in TestList+   [++    "balance report with no args" ~:+    ([], []) `gives`+    ["                 $-1  assets"+    ,"                  $1    bank:saving"+    ,"                 $-2    cash"+    ,"                  $2  expenses"+    ,"                  $1    food"+    ,"                  $1    supplies"+    ,"                 $-2  income"+    ,"                 $-1    gifts"+    ,"                 $-1    salary"+    ,"                  $1  liabilities:debts"+    ]++   ,"balance report can be limited with --depth" ~:+    ([Depth "1"], []) `gives`+    ["                 $-1  assets"+    ,"                  $2  expenses"+    ,"                 $-2  income"+    ,"                  $1  liabilities"+    ]+    +   ,"balance report with account pattern o" ~:+    ([SubTotal], ["o"]) `gives`+    ["                  $1  expenses:food"+    ,"                 $-2  income"+    ,"                 $-1    gifts"+    ,"                 $-1    salary"+    ,"--------------------"+    ,"                 $-1"+    ]++   ,"balance report with account pattern o and --depth 1" ~:+    ([Depth "1"], ["o"]) `gives`+    ["                  $1  expenses"+    ,"                 $-2  income"+    ,"--------------------"+    ,"                 $-1"+    ]++   ,"balance report with account pattern a" ~:+    ([], ["a"]) `gives`+    ["                 $-1  assets"+    ,"                  $1    bank:saving"+    ,"                 $-2    cash"+    ,"                 $-1  income:salary"+    ,"                  $1  liabilities:debts"+    ,"--------------------"+    ,"                 $-1"+    ]++   ,"balance report with account pattern e" ~:+    ([], ["e"]) `gives`+    ["                 $-1  assets"+    ,"                  $1    bank:saving"+    ,"                 $-2    cash"+    ,"                  $2  expenses"+    ,"                  $1    food"+    ,"                  $1    supplies"+    ,"                 $-2  income"+    ,"                 $-1    gifts"+    ,"                 $-1    salary"+    ,"                  $1  liabilities:debts"+    ]++   ,"balance report with unmatched parent of two matched subaccounts" ~: +    ([], ["cash","saving"]) `gives`+    ["                 $-1  assets"+    ,"                  $1    bank:saving"+    ,"                 $-2    cash"+    ,"--------------------"+    ,"                 $-1"+    ]++   ,"balance report with multi-part account name" ~: +    ([], ["expenses:food"]) `gives`+    ["                  $1  expenses:food"+    ,"--------------------"+    ,"                  $1"+    ]++   ,"balance report with negative account pattern" ~:+    ([], ["not:assets"]) `gives`+    ["                  $2  expenses"+    ,"                  $1    food"+    ,"                  $1    supplies"+    ,"                 $-2  income"+    ,"                 $-1    gifts"+    ,"                 $-1    salary"+    ,"                  $1  liabilities:debts"+    ,"--------------------"+    ,"                  $1"+    ]++   ,"balance report negative account pattern always matches full name" ~: +    ([], ["not:e"]) `gives` []++   ,"balance report negative patterns affect totals" ~: +    ([], ["expenses","not:food"]) `gives`+    ["                  $1  expenses:supplies"+    ,"--------------------"+    ,"                  $1"+    ]++   ,"balance report with -E shows zero-balance accounts" ~:+    ([SubTotal,Empty], ["assets"]) `gives`+    ["                 $-1  assets"+    ,"                  $1    bank"+    ,"                  $0      checking"+    ,"                  $1      saving"+    ,"                 $-2    cash"+    ,"--------------------"+    ,"                 $-1"+    ]++   ,"balance report with cost basis" ~: do+      rl <- rawledgerfromstring $ unlines+             [""+             ,"2008/1/1 test           "+             ,"  a:b          10h @ $50"+             ,"  c:d                   "+             ,""+             ]+      let l = cacheLedger [] $ +              filterRawLedger (DateSpan Nothing Nothing) [] False False $ +              canonicaliseAmounts True rl -- enable cost basis adjustment            +      showBalanceReport [] [] l `is` +       unlines+        ["                $500  a:b"+        ,"               $-500  c:d"+        ]++   ,"balance report elides zero-balance root account(s)" ~: do+      l <- ledgerfromstringwithopts [] [] sampletime+             (unlines+              ["2008/1/1 one"+              ,"  test:a  1"+              ,"  test:b"+              ])+      showBalanceReport [] [] l `is`+       unlines+        ["                   1  test:a"+        ,"                  -1  test:b"+        ]++   ]++  ,"balanceEntry" ~: do+     assertBool "detect unbalanced entry, sign error"+                    (isLeft $ balanceEntry+                           (Entry (parsedate "2007/01/28") False "" "test" ""+                            [RawTransaction False "a" (Mixed [dollars 1]) "" RegularTransaction, +                             RawTransaction False "b" (Mixed [dollars 1]) "" RegularTransaction+                            ] ""))+     assertBool "detect unbalanced entry, multiple missing amounts"+                    (isLeft $ balanceEntry+                           (Entry (parsedate "2007/01/28") False "" "test" ""+                            [RawTransaction False "a" missingamt "" RegularTransaction, +                             RawTransaction False "b" missingamt "" RegularTransaction+                            ] ""))+     let e = balanceEntry (Entry (parsedate "2007/01/28") False "" "test" ""+                           [RawTransaction False "a" (Mixed [dollars 1]) "" RegularTransaction, +                            RawTransaction False "b" missingamt "" RegularTransaction+                           ] "")+     assertBool "one missing amount should be ok" (isRight e)+     assertEqual "balancing amount is added" +                     (Mixed [dollars (-1)])+                     (case e of+                        Right e' -> (tamount $ last $ etransactions e')+                        Left _ -> error "should not happen")++  ,"cacheLedger" ~: do+    (length $ Map.keys $ accountmap $ cacheLedger [] rawledger7) `is` 15++  ,"canonicaliseAmounts" ~:+   "use the greatest precision" ~: do+    (rawLedgerPrecisions $ canonicaliseAmounts False $ rawLedgerWithAmounts ["1","2.00"]) `is` [2,2]++  ,"dateSpanFromOpts" ~: do+    let todaysdate = parsedate "2008/11/26"+    let opts `gives` spans = show (dateSpanFromOpts todaysdate opts) `is` spans+    [] `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)"++  ,"entriesFromTimeLogEntries" ~: do+     today <- getCurrentDay+     now' <- getCurrentTime+     tz <- getCurrentTimeZone+     let now = utcToLocalTime tz now'+         nowstr = showtime now+         yesterday = prevday today+         clockin t a = TimeLogEntry 'i' t a+         clockout t = TimeLogEntry 'o' t ""+         mktime d s = LocalTime d $ fromMaybe midnight $ parseTime defaultTimeLocale "%H:%M:%S" s+         showtime t = formatTime defaultTimeLocale "%H:%M" t+         assertEntriesGiveStrings name es ss = assertEqual name ss (map edescription $ entriesFromTimeLogEntries now es)++     assertEntriesGiveStrings "started yesterday, split session at midnight"+                                  [clockin (mktime yesterday "23:00:00") ""]+                                  ["23:00-23:59","00:00-"++nowstr]+     assertEntriesGiveStrings "split multi-day sessions at each midnight"+                                  [clockin (mktime (addDays (-2) today) "23:00:00") ""]+                                  ["23:00-23:59","00:00-23:59","00:00-"++nowstr]+     assertEntriesGiveStrings "auto-clock-out if needed" +                                  [clockin (mktime today "00:00:00") ""] +                                  ["00:00-"++nowstr]+     let future = utcToLocalTime tz $ addUTCTime 100 now'+         futurestr = showtime future+     assertEntriesGiveStrings "use the clockin time for auto-clockout if it's in the future"+                                  [clockin future ""]+                                  [printf "%s-%s" futurestr futurestr]++  ,"expandAccountNames" ~: do+    expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] `is`+     ["assets","assets:cash","assets:checking","expenses","expenses:vacation"]++  ,"intervalFromOpts" ~: do+    let opts `gives` interval = intervalFromOpts opts `is` interval+    [] `gives` NoInterval+    [WeeklyOpt] `gives` Weekly+    [MonthlyOpt] `gives` Monthly+    [YearlyOpt] `gives` Yearly+    [Period "weekly"] `gives` Weekly+    [Period "monthly"] `gives` Monthly+    [WeeklyOpt, Period "yearly"] `gives` Yearly++  ,"isAccountNamePrefixOf" ~: do+    "assets" `isAccountNamePrefixOf` "assets" `is` False+    "assets" `isAccountNamePrefixOf` "assets:bank" `is` True+    "assets" `isAccountNamePrefixOf` "assets:bank:checking" `is` True+    "my assets" `isAccountNamePrefixOf` "assets:bank" `is` False++  ,"isSubAccountNameOf" ~: do+    "assets" `isSubAccountNameOf` "assets" `is` False+    "assets:bank" `isSubAccountNameOf` "assets" `is` True+    "assets:bank:checking" `isSubAccountNameOf` "assets" `is` False+    "assets:bank" `isSubAccountNameOf` "my assets" `is` False++  ,"default year" ~: do+    rl <- rawledgerfromstring defaultyear_ledger_str+    (edate $ head $ entries rl) `is` fromGregorian 2009 1 1+    return ()++  ,"ledgerEntry" ~: do+    parseWithCtx ledgerEntry entry1_str `parseis` entry1++  ,"ledgerHistoricalPrice" ~: do+    parseWithCtx ledgerHistoricalPrice price1_str `parseis` price1++  ,"ledgertransaction" ~: do+    parseWithCtx ledgertransaction rawtransaction1_str `parseis` rawtransaction1++  ,"parsedate" ~: do+    parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" sampledate+    parsedate "2008-02-03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" sampledate++  ,"period expressions" ~: do+    let todaysdate = parsedate "2008/11/26"+    let str `gives` result = (show $ parsewith (periodexpr todaysdate) str) `is` ("Right "++result)+    "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))"++  ,"print report tests" ~: TestList+  [++   "print expenses" ~:+   do +    let args = ["expenses"]+    l <- sampleledgerwithopts [] args+    showEntries [] args l `is` unlines +     ["2008/06/03 * eat & shop"+     ,"    expenses:food                                 $1"+     ,"    expenses:supplies                             $1"+     ,"    assets:cash                                  $-2"+     ,""+     ]++  , "print report with depth arg" ~:+   do +    l <- sampleledger+    showEntries [Depth "2"] [] l `is` unlines+      ["2008/01/01 income"+      ,"    income:salary                                $-1"+      ,""+      ,"2008/06/01 gift"+      ,"    income:gifts                                 $-1"+      ,""+      ,"2008/06/03 * eat & shop"+      ,"    expenses:food                                 $1"+      ,"    expenses:supplies                             $1"+      ,"    assets:cash                                  $-2"+      ,""+      ,"2008/12/31 * pay off"+      ,"    liabilities:debts                             $1"+      ,""+      ]++  ]++  ,"punctuatethousands 1" ~: punctuatethousands "" `is` ""++  ,"punctuatethousands 2" ~: punctuatethousands "1234567.8901" `is` "1,234,567.8901"++  ,"punctuatethousands 3" ~: punctuatethousands "-100" `is` "-100"++  ,"register report tests" ~:+  let registerdates = filter (not . null) .  map (strip . take 10) . lines+  in+  TestList+  [++   "register report with no args" ~:+   do +    l <- sampleledger+    showRegisterReport [] [] l `is` unlines+     ["2008/01/01 income               assets:bank:checking             $1           $1"+     ,"                                income:salary                   $-1            0"+     ,"2008/06/01 gift                 assets:bank:checking             $1           $1"+     ,"                                income:gifts                    $-1            0"+     ,"2008/06/02 save                 assets:bank:saving               $1           $1"+     ,"                                assets:bank:checking            $-1            0"+     ,"2008/06/03 eat & shop           expenses:food                    $1           $1"+     ,"                                expenses:supplies                $1           $2"+     ,"                                assets:cash                     $-2            0"+     ,"2008/12/31 pay off              liabilities:debts                $1           $1"+     ,"                                assets:bank:checking            $-1            0"+     ]++  ,"register report sorts by date" ~:+   do +    l <- ledgerfromstringwithopts [] [] sampletime $ unlines+        ["2008/02/02 a"+        ,"  b  1"+        ,"  c"+        ,""+        ,"2008/01/01 d"+        ,"  e  1"+        ,"  f"+        ]+    registerdates (showRegisterReport [] [] l) `is` ["2008/01/01","2008/02/02"]++  ,"register report with account pattern" ~:+   do+    l <- sampleledger+    showRegisterReport [] ["cash"] l `is` unlines+     ["2008/06/03 eat & shop           assets:cash                     $-2          $-2"+     ]++  ,"register report with account pattern, case insensitive" ~:+   do +    l <- sampleledger+    showRegisterReport [] ["cAsH"] l `is` unlines+     ["2008/06/03 eat & shop           assets:cash                     $-2          $-2"+     ]++  ,"register report with display expression" ~:+   do +    l <- sampleledger+    let displayexpr `gives` dates = +            registerdates (showRegisterReport [Display displayexpr] [] l) `is` dates+    "d<[2008/6/2]"  `gives` ["2008/01/01","2008/06/01"]+    "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"]+    "d=[2008/6/2]"  `gives` ["2008/06/02"]+    "d>=[2008/6/2]" `gives` ["2008/06/02","2008/06/03","2008/12/31"]+    "d>[2008/6/2]"  `gives` ["2008/06/03","2008/12/31"]++  ,"register report with period expression" ~:+   do +    l <- sampleledger    +    let periodexpr `gives` dates = do+          lopts <- sampleledgerwithopts [Period periodexpr] []+          registerdates (showRegisterReport [Period periodexpr] [] lopts) `is` dates+    ""     `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]+    "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]+    "2007" `gives` []+    "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"]+    "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"]+    showRegisterReport [Period "yearly"] [] l `is` unlines+     ["2008/01/01 - 2008/12/31         assets:bank:saving               $1           $1"+     ,"                                assets:cash                     $-2          $-1"+     ,"                                expenses:food                    $1            0"+     ,"                                expenses:supplies                $1           $1"+     ,"                                income:gifts                    $-1            0"+     ,"                                income:salary                   $-1          $-1"+     ,"                                liabilities:debts                $1            0"+     ]+    registerdates (showRegisterReport [Period "quarterly"] [] l) `is` ["2008/01/01","2008/04/01","2008/10/01"]+    registerdates (showRegisterReport [Period "quarterly",Empty] [] l) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]++  ]++  , "register report with depth arg" ~:+   do +    l <- sampleledger+    showRegisterReport [Depth "2"] [] l `is` unlines+     ["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"+     ,"                                assets:cash                     $-2          $-2"+     ,"2008/12/31 pay off              liabilities:debts                $1          $-1"+     ]++  ,"show dollars" ~: show (dollars 1) ~?= "$1.00"++  ,"show hours" ~: show (hours 1) ~?= "1.0h"++  ,"smart dates" ~: do+    let str `gives` datestr = fixSmartDateStr (parsedate "2008/11/26") str `is` datestr+    "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"++  ,"splitSpan" ~: do+    let (interval,span) `gives` spans = splitSpan interval span `is` spans+    (NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives`+     [mkdatespan "2008/01/01" "2009/01/01"]+    (Quarterly,mkdatespan "2008/01/01" "2009/01/01") `gives`+     [mkdatespan "2008/01/01" "2008/04/01"+     ,mkdatespan "2008/04/01" "2008/07/01"+     ,mkdatespan "2008/07/01" "2008/10/01"+     ,mkdatespan "2008/10/01" "2009/01/01"+     ]+    (Quarterly,nulldatespan) `gives`+     [nulldatespan]+    (Daily,mkdatespan "2008/01/01" "2008/01/01") `gives`+     [mkdatespan "2008/01/01" "2008/01/01"]+    (Quarterly,mkdatespan "2008/01/01" "2008/01/01") `gives`+     [mkdatespan "2008/01/01" "2008/01/01"]++  ,"subAccounts" ~: do+    l <- sampleledger+    let a = ledgerAccount l "assets"+    (map aname $ subAccounts l a) `is` ["assets:bank","assets:cash"]++  ,"summariseTransactionsInDateSpan" ~: do+    let (b,e,entryno,depth,showempty,ts) `gives` summaryts = +            summariseTransactionsInDateSpan (mkdatespan b e) entryno depth showempty ts `is` summaryts+    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,9999,False,[]) `gives` +     []+    ("2008/01/01","2009/01/01",0,9999,True,[]) `gives` +     [+      nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31"}+     ]+    ("2008/01/01","2009/01/01",0,9999,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,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,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,0,False,ts) `gives` +     [+      nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="",amount=Mixed [dollars 15]}+     ]++  ,"timelog" ~: do+    parseWithCtx timelog timelog1_str `parseis` timelog1++  ,"transactionamount" ~: do+    parseWithCtx transactionamount " $47.18" `parseis` Mixed [dollars 47.18]+    parseWithCtx transactionamount " $1." `parseis` +     Mixed [Amount (Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0}) 1 Nothing]++  ]++  +------------------------------------------------------------------------------+-- test data++sampledate = parsedate "2008/11/26"+sampletime = LocalTime sampledate midday+sampleledger = ledgerfromstringwithopts [] [] sampletime sample_ledger_str+sampleledgerwithopts opts args = ledgerfromstringwithopts opts args sampletime sample_ledger_str++sample_ledger_str = unlines+ ["; A sample ledger file."+ ,";"+ ,"; Sets up this account tree:"+ ,"; assets"+ ,";   bank"+ ,";     checking"+ ,";     saving"+ ,";   cash"+ ,"; expenses"+ ,";   food"+ ,";   supplies"+ ,"; income"+ ,";   gifts"+ ,";   salary"+ ,"; liabilities"+ ,";   debts"+ ,""+ ,"2008/01/01 income"+ ,"    assets:bank:checking  $1"+ ,"    income:salary"+ ,""+ ,"2008/06/01 gift"+ ,"    assets:bank:checking  $1"+ ,"    income:gifts"+ ,""+ ,"2008/06/02 save"+ ,"    assets:bank:saving  $1"+ ,"    assets:bank:checking"+ ,""+ ,"2008/06/03 * eat & shop"+ ,"    expenses:food      $1"+ ,"    expenses:supplies  $1"+ ,"    assets:cash"+ ,""+ ,"2008/12/31 * pay off"+ ,"    liabilities:debts  $1"+ ,"    assets:bank:checking"+ ,""+ ,""+ ,";final comment"+ ]++defaultyear_ledger_str = unlines+ ["Y2009"+ ,""+ ,"01/01 A"+ ,"    a  $1"+ ,"    b"+ ]++write_sample_ledger = writeFile "sample.ledger" sample_ledger_str++rawtransaction1_str  = "  expenses:food:dining  $10.00\n"++rawtransaction1 = RawTransaction False "expenses:food:dining" (Mixed [dollars 10]) "" RegularTransaction++entry1_str = unlines+ ["2007/01/28 coopportunity"+ ,"  expenses:food:groceries                 $47.18"+ ,"  assets:checking"+ ,""+ ]++entry1 =+    (Entry (parsedate "2007/01/28") False "" "coopportunity" ""+     [RawTransaction False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularTransaction, +      RawTransaction False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularTransaction] "")+++entry2_str = unlines+ ["2007/01/27 * joes diner"+ ,"  expenses:food:dining                    $10.00"+ ,"  expenses:gifts                          $10.00"+ ,"  assets:checking                        $-20.00"+ ,""+ ]++entry3_str = unlines+ ["2007/01/01 * opening balance"+ ,"    assets:cash                                $4.82"+ ,"    equity:opening balances"+ ,""+ ,"2007/01/01 * opening balance"+ ,"    assets:cash                                $4.82"+ ,"    equity:opening balances"+ ,""+ ,"2007/01/28 coopportunity"+ ,"  expenses:food:groceries                 $47.18"+ ,"  assets:checking"+ ,""+ ]++periodic_entry1_str = unlines+ ["~ monthly from 2007/2/2"+ ,"  assets:saving            $200.00"+ ,"  assets:checking"+ ,""+ ]++periodic_entry2_str = unlines+ ["~ monthly from 2007/2/2"+ ,"  assets:saving            $200.00         ;auto savings"+ ,"  assets:checking"+ ,""+ ]++periodic_entry3_str = unlines+ ["~ monthly from 2007/01/01"+ ,"    assets:cash                                $4.82"+ ,"    equity:opening balances"+ ,""+ ,"~ monthly from 2007/01/01"+ ,"    assets:cash                                $4.82"+ ,"    equity:opening balances"+ ,""+ ]++ledger1_str = unlines+ [""+ ,"2007/01/27 * joes diner"+ ,"  expenses:food:dining                    $10.00"+ ,"  expenses:gifts                          $10.00"+ ,"  assets:checking                        $-20.00"+ ,""+ ,""+ ,"2007/01/28 coopportunity"+ ,"  expenses:food:groceries                 $47.18"+ ,"  assets:checking                        $-47.18"+ ,""+ ,""+ ]++ledger2_str = unlines+ [";comment"+ ,"2007/01/27 * joes diner"+ ,"  expenses:food:dining                    $10.00"+ ,"  assets:checking                        $-47.18"+ ,""+ ]++ledger3_str = unlines+ ["2007/01/27 * joes diner"+ ,"  expenses:food:dining                    $10.00"+ ,";intra-entry comment"+ ,"  assets:checking                        $-47.18"+ ,""+ ]++ledger4_str = unlines+ ["!include \"somefile\""+ ,"2007/01/27 * joes diner"+ ,"  expenses:food:dining                    $10.00"+ ,"  assets:checking                        $-47.18"+ ,""+ ]++ledger5_str = ""++ledger6_str = unlines+ ["~ monthly from 2007/1/21"+ ,"    expenses:entertainment  $16.23        ;netflix"+ ,"    assets:checking"+ ,""+ ,"; 2007/01/01 * opening balance"+ ,";     assets:saving                            $200.04"+ ,";     equity:opening balances                         "+ ,""+ ]++ledger7_str = unlines+ ["2007/01/01 * opening balance"+ ,"    assets:cash                                $4.82"+ ,"    equity:opening balances                         "+ ,""+ ,"2007/01/01 * opening balance"+ ,"    income:interest                                $-4.82"+ ,"    equity:opening balances                         "+ ,""+ ,"2007/01/02 * ayres suites"+ ,"    expenses:vacation                        $179.92"+ ,"    assets:checking                                 "+ ,""+ ,"2007/01/02 * auto transfer to savings"+ ,"    assets:saving                            $200.00"+ ,"    assets:checking                                 "+ ,""+ ,"2007/01/03 * poquito mas"+ ,"    expenses:food:dining                       $4.82"+ ,"    assets:cash                                     "+ ,""+ ,"2007/01/03 * verizon"+ ,"    expenses:phone                            $95.11"+ ,"    assets:checking                                 "+ ,""+ ,"2007/01/03 * discover"+ ,"    liabilities:credit cards:discover         $80.00"+ ,"    assets:checking                                 "+ ,""+ ,"2007/01/04 * blue cross"+ ,"    expenses:health:insurance                 $90.00"+ ,"    assets:checking                                 "+ ,""+ ,"2007/01/05 * village market liquor"+ ,"    expenses:food:dining                       $6.48"+ ,"    assets:checking                                 "+ ,""+ ]++rawledger7 = RawLedger+          [] +          [] +          [+           Entry {+             edate= parsedate "2007/01/01", +             estatus=False, +             ecode="*", +             edescription="opening balance", +             ecomment="",+             etransactions=[+              RawTransaction {+                tstatus=False,+                taccount="assets:cash", +                tamount=(Mixed [dollars 4.82]),+                tcomment="",+                rttype=RegularTransaction+              },+              RawTransaction {+                tstatus=False,+                taccount="equity:opening balances", +                tamount=(Mixed [dollars (-4.82)]),+                tcomment="",+                rttype=RegularTransaction+              }+             ],+             epreceding_comment_lines=""+           }+          ,+           Entry {+             edate= parsedate "2007/02/01", +             estatus=False, +             ecode="*", +             edescription="ayres suites", +             ecomment="",+             etransactions=[+              RawTransaction {+                tstatus=False,+                taccount="expenses:vacation", +                tamount=(Mixed [dollars 179.92]),+                tcomment="",+                rttype=RegularTransaction+              },+              RawTransaction {+                tstatus=False,+                taccount="assets:checking", +                tamount=(Mixed [dollars (-179.92)]),+                tcomment="",+                rttype=RegularTransaction+              }+             ],+             epreceding_comment_lines=""+           }+          ,+           Entry {+             edate=parsedate "2007/01/02", +             estatus=False, +             ecode="*", +             edescription="auto transfer to savings", +             ecomment="",+             etransactions=[+              RawTransaction {+                tstatus=False,+                taccount="assets:saving", +                tamount=(Mixed [dollars 200]),+                tcomment="",+                rttype=RegularTransaction+              },+              RawTransaction {+                tstatus=False,+                taccount="assets:checking", +                tamount=(Mixed [dollars (-200)]),+                tcomment="",+                rttype=RegularTransaction+              }+             ],+             epreceding_comment_lines=""+           }+          ,+           Entry {+             edate=parsedate "2007/01/03", +             estatus=False, +             ecode="*", +             edescription="poquito mas", +             ecomment="",+             etransactions=[+              RawTransaction {+                tstatus=False,+                taccount="expenses:food:dining", +                tamount=(Mixed [dollars 4.82]),+                tcomment="",+                rttype=RegularTransaction+              },+              RawTransaction {+                tstatus=False,+                taccount="assets:cash", +                tamount=(Mixed [dollars (-4.82)]),+                tcomment="",+                rttype=RegularTransaction+              }+             ],+             epreceding_comment_lines=""+           }+          ,+           Entry {+             edate=parsedate "2007/01/03", +             estatus=False, +             ecode="*", +             edescription="verizon", +             ecomment="",+             etransactions=[+              RawTransaction {+                tstatus=False,+                taccount="expenses:phone", +                tamount=(Mixed [dollars 95.11]),+                tcomment="",+                rttype=RegularTransaction+              },+              RawTransaction {+                tstatus=False,+                taccount="assets:checking", +                tamount=(Mixed [dollars (-95.11)]),+                tcomment="",+                rttype=RegularTransaction+              }+             ],+             epreceding_comment_lines=""+           }+          ,+           Entry {+             edate=parsedate "2007/01/03", +             estatus=False, +             ecode="*", +             edescription="discover", +             ecomment="",+             etransactions=[+              RawTransaction {+                tstatus=False,+                taccount="liabilities:credit cards:discover", +                tamount=(Mixed [dollars 80]),+                tcomment="",+                rttype=RegularTransaction+              },+              RawTransaction {+                tstatus=False,+                taccount="assets:checking", +                tamount=(Mixed [dollars (-80)]),+                tcomment="",+                rttype=RegularTransaction+              }+             ],+             epreceding_comment_lines=""+           }+          ] +          []+          []+          ""++ledger7 = cacheLedger [] rawledger7 ++ledger8_str = unlines+ ["2008/1/1 test           "+ ,"  a:b          10h @ $40"+ ,"  c:d                   "+ ,""+ ]++timelogentry1_str  = "i 2007/03/11 16:19:00 hledger\n"+timelogentry1 = TimeLogEntry 'i' (parsedatetime "2007/03/11 16:19:00") "hledger"++timelogentry2_str  = "o 2007/03/11 16:30:00\n"+timelogentry2 = TimeLogEntry 'o' (parsedatetime "2007/03/11 16:30:00") ""++timelog1_str = concat [+                timelogentry1_str,+                timelogentry2_str+               ]+timelog1 = TimeLog [+            timelogentry1,+            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)++rawLedgerWithAmounts as = +        RawLedger +        [] +        [] +        [nullentry{edescription=a,etransactions=[nullrawtxn{tamount=parse a}]} | a <- as]+        []+        []+        ""+    where parse = fromparse . parseWithCtx transactionamount . (" "++) 

@@ -1,6 +1,6 @@ {-|  -A simple text UI for hledger.+A simple text UI for hledger, based on the vty library.  -} @@ -17,7 +17,7 @@ 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"+helpmsg = "(b)alance, (r)egister, (p)rint, (right) to drill down, (left) to back up, (q)uit"  instance Show Vty where show v = "a Vty" @@ -80,7 +80,7 @@     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 (KASCII 'l') []       -> go $ resetTrailAndEnter LedgerScreen a     EvKey KRight []             -> go $ drilldown a     EvKey KEnter []             -> go $ drilldown a     EvKey KLeft  []             -> go $ backout a@@ -234,8 +234,9 @@ 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+    | screen a == 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

@@ -8,6 +8,7 @@ where import Control.Monad.Error import qualified Data.Map as Map (lookup)+import Data.Time.Clock import Text.ParserCombinators.Parsec import System.IO import Options@@ -15,33 +16,37 @@   -- | 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}+-- based on the command-line options/arguments and the current date/time.+prepareLedger ::  [Opt] -> [String] -> LocalTime -> String -> RawLedger -> Ledger+prepareLedger opts args reftime 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+      span = dateSpanFromOpts (localDay reftime) opts       c = Cleared `elem` opts       r = Real `elem` opts       cb = CostBasis `elem` opts  -- | Get a RawLedger from the given string, or raise an error.+-- This uses the current local time as the reference time (for closing+-- open timelog entries). rawledgerfromstring :: String -> IO RawLedger-rawledgerfromstring = liftM (either error id) . runErrorT . parseLedger "(string)"+rawledgerfromstring s = do+  t <- getCurrentLocalTime+  liftM (either error id) $ runErrorT $ parseLedger t "(string)" s  -- | 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+ledgerfromstringwithopts :: [Opt] -> [String] -> LocalTime -> String -> IO Ledger+ledgerfromstringwithopts opts args reftime s =+    liftM (prepareLedger opts args reftime s) $ rawledgerfromstring s  -- | 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+  reftime <- getCurrentLocalTime+  return $ prepareLedger opts args reftime s rl             -- | Get a Ledger from your default ledger file, or raise an error. -- Assumes no options.

@@ -0,0 +1,46 @@+{-# OPTIONS_GHC -cpp #-}+module Version+where+import Ledger.Utils+import Options (progname)++-- updated by build process from VERSION+version       = "0.4.0"+#ifdef PATCHES+-- a "make" development build defines PATCHES from the repo state+patchlevel = "." ++ show PATCHES -- must be numeric !+#else+patchlevel = ""+#endif+buildversion  = version ++ patchlevel++versionstr    = prettify $ splitAtElement '.' buildversion+                where+                  prettify (major:minor:bugfix:patches:[]) =+                      printf "%s.%s%s%s%s" major minor bugfix' patches' desc+                          where+                            bugfix'+                                | bugfix `elem` ["0"{-,"98","99"-}] = ""+                                | otherwise = "."++bugfix+                            patches'+                                | patches/="0" = " + "++patches++" patches"+                                | otherwise = ""+                            desc+--                                 | bugfix=="98" = " (alpha)"+--                                 | bugfix=="99" = " (beta)"+                                | otherwise = ""+                  prettify s = intercalate "." s++versionmsg    = progname ++ " " ++ versionstr ++ configmsg ++ "\n"+    where configmsg+              | null configflags = ""+              | otherwise = ", built with " ++ intercalate ", " configflags++configflags   = tail [""+#ifdef VTY+  ,"vty"+#endif+#ifdef HAPPS+  ,"happs"+#endif+ ]

@@ -0,0 +1,117 @@+{-| +A happs-based web UI for hledger.+-}++module WebCommand+where+import Control.Monad.Trans (liftIO)+import Data.ByteString.Lazy.UTF8 (toString)+import qualified Data.Map as M+import Data.Map ((!))+import Data.Time.Clock+import Data.Time.Format+import System.Locale+import Control.Concurrent+import qualified Data.ByteString.Lazy.Char8 as B+import Happstack.Data (defaultValue)+import Happstack.Server+import Happstack.Server.HTTP.FileServe (fileServe)+import Happstack.State.Control (waitForTermination)+import System.Cmd (system)+import System.Info (os)+import System.Exit++import Ledger+import Options+import BalanceCommand+import RegisterCommand+import PrintCommand+++tcpport = 5000++web :: [Opt] -> [String] -> Ledger -> IO ()+web opts args l =+  if Debug `elem` opts+     then do+       putStrLn $ printf "starting web server on port %d in debug mode" tcpport+       simpleHTTP nullConf{port=tcpport} handlers+     else do+       putStrLn $ printf "starting web server on port %d" tcpport+       tid <- forkIO $ simpleHTTP nullConf{port=tcpport} handlers+       putStrLn "starting web browser"+       openBrowserOn $ printf "http://localhost:%s/balance" (show tcpport)+       waitForTermination+       putStrLn "shutting down web server..."+       killThread tid+       putStrLn "shutdown complete"++    where+      handlers :: ServerPartT IO Response+      handlers = msum+       [dir "print" $ withDataFn (look "a") $ \a -> templatise $ printreport [a]+       ,dir "print" $ templatise $ printreport []+       ,dir "register" $ withDataFn (look "a") $ \a -> templatise $ registerreport [a]+       ,dir "register" $ templatise $ registerreport []+       ,dir "balance" $ withDataFn (look "a") $ \a -> templatise $ balancereport [a]+       ,dir "balance" $ templatise $ balancereport []+       ]+      printreport apats    = showEntries opts (apats ++ args) l+      registerreport apats = showRegisterReport opts (apats ++ args) l+      balancereport []  = showBalanceReport opts args l+      balancereport apats  = showBalanceReport opts (apats ++ args) l'+          where l' = cacheLedger apats (rawledger l) -- re-filter by account pattern each time++templatise :: String -> ServerPartT IO Response+templatise s = do+  r <- askRq+  return $ setHeader "Content-Type" "text/html" $ toResponse $ maintemplate r s++maintemplate :: Request -> String -> String+maintemplate r = printf (unlines+  ["<div style=float:right>"+  ,"<form action=%s>search:&nbsp;<input name=a value=%s></form>"+  ,"</div>"+  ,"<div align=center style=width:100%%>"+  ," <a href=balance>balance</a>"+  ,"|"+  ," <a href=register>register</a>"+  ,"|"+  ," <a href=print>print</a>"+  ,"</div>"+  ,"<pre>%s</pre>"+  ])+  (dropWhile (=='/') $ rqUri r)+  (fromMaybe "" $ queryValue "a" r)++queryValues :: String -> Request -> [String]+queryValues q r = map (B.unpack . inputValue . snd) $ filter ((==q).fst) $ rqInputs r++queryValue :: String -> Request -> Maybe String+queryValue q r = case filter ((==q).fst) $ rqInputs r of+                   [] -> Nothing+                   is -> Just $ B.unpack $ inputValue $ snd $ head is++-- | Attempt to open a web browser on the given url, all platforms.+openBrowserOn :: String -> IO ExitCode+openBrowserOn u = trybrowsers browsers u+    where+      trybrowsers (b:bs) u = do+        e <- system $ printf "%s %s" b u+        case e of+          ExitSuccess -> return ExitSuccess+          ExitFailure _ -> trybrowsers bs u+      trybrowsers [] u = do+        putStrLn $ printf "Sorry, I could not start a browser (tried: %s)" $ intercalate ", " browsers+        putStrLn $ printf "Please open your browser and visit %s" u+        return $ ExitFailure 127+      browsers | os=="darwin"  = ["open"]+               | os=="mingw32" = ["firefox","safari","opera","iexplore"]+               | otherwise     = ["sensible-browser","firefox"]+    -- jeffz: write a ffi binding for it using the Win32 package as a basis+    -- start by adding System/Win32/Shell.hsc and follow the style of any+    -- other module in that directory for types, headers, error handling and+    -- what not.+    -- ::ShellExecute(NULL, "open", "www.somepage.com", NULL, NULL, SW_SHOWNORMAL);+    -- ::ShellExecute(NULL, "open", "firefox.exe", "www.somepage.com" NULL, SW_SHOWNORMAL);+

@@ -1,16 +1,16 @@ Name:           hledger-Version:        0.3+-- updated by build process from VERSION+Version:        0.4 Category:       Finance Synopsis:       A ledger-compatible text-based accounting tool.-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.+Description:    hledger is a partial haskell clone of John Wiegley's "ledger" text-based+                accounting tool. It generates ledger-compatible register & balance reports+                from a plain text journal, and demonstrates a functional implementation of ledger. License:        GPL Stability:      beta Author:         Simon Michael <simon@joyful.com> Maintainer:     Simon Michael <simon@joyful.com>-Homepage:       http://joyful.com/hledger+Homepage:       http://hledger.org Tested-With:    GHC Build-Type:     Simple License-File:   LICENSE@@ -18,32 +18,19 @@ Extra-Tmp-Files:  Cabal-Version:  >= 1.2 -Executable hledger-  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-                  PrintCommand-                  RegisterCommand-                  Setup-                  Tests-                  UICommand-                  Utils-                  Ledger+Flag vty+  description: enable the curses ui+  default:     True++Flag happs+  description: enable the web ui+  default:     False++Library+  Build-Depends:  base, containers, haskell98, directory, parsec, regex-compat,+                  old-locale, time, HUnit, filepath++  Exposed-modules:Ledger                   Ledger.Account                   Ledger.AccountName                   Ledger.Amount@@ -59,10 +46,22 @@                   Ledger.Types                   Ledger.Utils -library-  Build-Depends:  base, containers, haskell98, directory, parsec, regex-compat,-                  old-locale, time, HUnit-  Exposed-modules:+Executable hledger+  Main-Is:        hledger.hs++  Build-Depends:  base, containers, haskell98, directory, parsec,+                  regex-compat, regexpr>=0.5.1, old-locale, time,+                  HUnit, mtl, bytestring, filepath, process, testpack++  Other-Modules:  +                  BalanceCommand+                  Options+                  PrintCommand+                  RegisterCommand+                  Setup+                  Tests+                  Utils+                  Version                   Ledger                   Ledger.Account                   Ledger.AccountName@@ -70,11 +69,29 @@                   Ledger.Commodity                   Ledger.Dates                   Ledger.Entry-                  Ledger.RawLedger                   Ledger.Ledger-                  Ledger.RawTransaction                   Ledger.Parse+                  Ledger.RawLedger+                  Ledger.RawTransaction                   Ledger.TimeLog                   Ledger.Transaction                   Ledger.Types                   Ledger.Utils++  -- how to set patchlevel in cabal builds ?+  cpp-options:    -DPATCHES=0++  if flag(vty)+    cpp-options: -DVTY+    Build-Depends:vty >= 3.1.8.2 && < 3.2+    Other-Modules:UICommand++  if flag(happs)+    cpp-options: -DHAPPS+    Build-Depends:happstack >= 0.2 && < 0.3+                  ,happstack-data >= 0.2 && < 0.3+                  ,happstack-server >= 0.2 && < 0.3+                  ,happstack-state >= 0.2 && < 0.3+                  ,utf8-string >= 0.3 && < 0.4+    Other-Modules:WebCommand+

@@ -1,15 +1,15 @@-#!/usr/bin/env runhaskell+-- sp doesn't like.. #!/usr/bin/env runhaskell+{-# OPTIONS_GHC -cpp #-} {-| hledger - a ledger-compatible text-based accounting tool.  Copyright (c) 2007-2009 Simon Michael <simon@joyful.com> Released under GPL version 3 or later. -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+hledger is a partial haskell clone of John Wiegley's "ledger" text-based+accounting tool.  It generates ledger-compatible register & balance+reports from a plain text journal, and demonstrates a functional+implementation of ledger.  For more information, see ledger.org .  You can use the command line: @@ -33,27 +33,36 @@ -}  module Main (+             -- for easy ghci access              module Main,              module Utils,              module Options,              module BalanceCommand,              module PrintCommand,              module RegisterCommand,-             module UICommand,+#ifdef HAPPS+             module WebCommand,+#endif ) where import Control.Monad.Error import qualified Data.Map as Map (lookup) import System.IO +import Version (versionmsg) import Ledger import Utils import Options+import Tests import BalanceCommand import PrintCommand import RegisterCommand+#ifdef VTY import UICommand-import Tests+#endif+#ifdef HAPPS+import WebCommand+#endif   main :: IO ()@@ -63,11 +72,16 @@     where        run cmd opts args        | Help `elem` opts            = putStr $ usage-       | Version `elem` opts         = putStr version+       | Version `elem` opts         = putStr versionmsg        | cmd `isPrefixOf` "balance"  = parseLedgerAndDo opts args balance        | cmd `isPrefixOf` "print"    = parseLedgerAndDo opts args print'        | cmd `isPrefixOf` "register" = parseLedgerAndDo opts args register+#ifdef VTY        | cmd `isPrefixOf` "ui"       = parseLedgerAndDo opts args ui+#endif+#ifdef HAPPS+       | cmd `isPrefixOf` "web"      = parseLedgerAndDo opts args web+#endif        | cmd `isPrefixOf` "test"     = runtests opts args >> return ()        | otherwise                   = putStr $ usage @@ -75,11 +89,11 @@ -- (or report a parse error). This function makes the whole thing go. parseLedgerAndDo :: [Opt] -> [String] -> ([Opt] -> [String] -> Ledger -> IO ()) -> IO () 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+  t <- getCurrentLocalTime+  let runcmd = cmd opts args . prepareLedger opts args t rawtext+  return f >>= runErrorT . parseLedgerFile t >>= either (hPutStrLn stderr) runcmd