um.. refactor option handling, filtering, and support -b/-e date filtering options

Ledger/Ledger.hs

@@ -2,15 +2,14 @@
 
 A 'Ledger' stores, for efficiency, a 'RawLedger' plus its tree of account
 names, a map from account names to 'Account's, and the display precision.
-Also, the Account 'Transaction's are filtered according to the provided
-account name/description patterns.
+Typically it has also has had the uninteresting 'Entry's and
+'Transaction's filtered out.
 
 -}
 
 module Ledger.Ledger (
 cacheLedger,
-filterLedgerEntries,
-filterLedgerTransactions,
+filterLedger,
 accountnames,
 ledgerAccount,
 ledgerTransactions,
@@ -44,16 +43,14 @@ instance Show Ledger where
               (length $ periodic_entries $ rawledger l))
              (length $ accountnames l)
 
--- | Convert a raw ledger to a more efficient filtered and cached type, described above.
-cacheLedger :: RawLedger -> (Regex,Regex) -> Ledger
-cacheLedger l pats = 
+-- | Convert a raw ledger to a more efficient cached type, described above.  
+cacheLedger :: RawLedger -> Ledger
+cacheLedger l = 
     let 
         lprecision = maximum $ map (precision . amount) $ rawLedgerTransactions l
-        l' = filterLedgerEntries pats l
-        l'' = filterLedgerTransactions pats l'
-        ant = rawLedgerAccountNameTree l''
+        ant = rawLedgerAccountNameTree l
         ans = flatten ant
-        ts = rawLedgerTransactions l''
+        ts = rawLedgerTransactions l
         sortedts = sortBy (comparing account) ts
         groupedts = groupBy (\t1 t2 -> account t1 == account t2) sortedts
         tmap = Map.union 
@@ -67,30 +64,52 @@ cacheLedger l pats =
                (Map.fromList [(a,nullamt) | a <- ans])
         amap = Map.fromList [(a, Account a (tmap ! a) (bmap ! a)) | a <- ans]
     in
-      Ledger l'' ant amap lprecision
+      Ledger l ant amap lprecision
 
--- | keep only entries whose description matches one of the description
--- patterns, and which have at least one transaction matching one of the
--- account patterns. (One or both patterns may be the wildcard.)
-filterLedgerEntries :: (Regex,Regex) -> RawLedger -> RawLedger
-filterLedgerEntries (acctpat,descpat) (RawLedger ms ps es f) = 
-    RawLedger ms ps filteredentries f
+-- | Remove ledger entries and transactions we are not interested in - 
+-- keep only those which fall between the begin and end dates and match the
+-- account and description patterns.
+filterLedger :: String -> String -> Regex -> Regex -> RawLedger -> RawLedger
+filterLedger begin end acctpat descpat = 
+    filterEmptyLedgerEntries .
+    filterLedgerTransactions acctpat .
+    filterLedgerEntriesByDate begin end .
+    filterLedgerEntriesByDescription descpat
+
+-- | Keep only entries whose description matches the description pattern.
+filterLedgerEntriesByDescription :: Regex -> RawLedger -> RawLedger
+filterLedgerEntriesByDescription descpat (RawLedger ms ps es f) = 
+    RawLedger ms ps (filter matchdesc es) f
     where
-      filteredentries :: [Entry]
-      filteredentries = (filter matchdesc $ filter (any matchtxn . etransactions) es)
-      matchtxn :: RawTransaction -> Bool
-      matchtxn t = case matchRegex acctpat (taccount t) of
-                     Nothing -> False
-                     otherwise -> True
       matchdesc :: Entry -> Bool
       matchdesc e = case matchRegex descpat (edescription e) of
                       Nothing -> False
                       otherwise -> True
 
--- | in each ledger entry, filter out transactions which do not match the
--- filter patterns.  (The entries are no longer balanced after this.)
-filterLedgerTransactions :: (Regex,Regex) -> RawLedger -> RawLedger
-filterLedgerTransactions (acctpat,descpat) (RawLedger ms ps es f) = 
+-- | Keep only entries which fall between begin and end dates. 
+-- We include entries on the begin date and exclude entries on the end
+-- date, like ledger.  An empty date string means no restriction.
+filterLedgerEntriesByDate :: String -> String -> RawLedger -> RawLedger
+filterLedgerEntriesByDate begin end (RawLedger ms ps es f) = 
+    RawLedger ms ps (filter matchdate es) f
+    where
+      matchdate :: Entry -> Bool
+      matchdate e = (begin == "" || entrydate >= begindate) && 
+                    (end == "" || entrydate < enddate)
+                    where 
+                      begindate = parsedate begin :: UTCTime
+                      enddate   = parsedate end
+                      entrydate = parsedate $ edate e
+
+-- | Remove entries which have no transactions.
+filterEmptyLedgerEntries :: RawLedger -> RawLedger
+filterEmptyLedgerEntries (RawLedger ms ps es f) =
+    RawLedger ms ps (filter ((> 0) . length . etransactions) es) f
+
+-- | In each ledger entry, filter out transactions which do not match the
+-- account pattern. Entries are no longer balanced after this.
+filterLedgerTransactions :: Regex -> RawLedger -> RawLedger
+filterLedgerTransactions acctpat (RawLedger ms ps es f) = 
     RawLedger ms ps (map filterentrytxns es) f
     where
       filterentrytxns l@(Entry _ _ _ _ _ ts _) = l{etransactions=filter matchtxn ts}

Ledger/TimeLog.hs

@@ -8,9 +8,6 @@ containing zero or more 'TimeLogEntry's. It can be converted to a
 
 module Ledger.TimeLog
 where
-import System.Locale (defaultTimeLocale)
-import Data.Time.Clock (UTCTime, diffUTCTime)
-import Data.Time.Format (parseTime, formatTime)
 
 import Ledger.Utils
 import Ledger.Types
@@ -26,14 +23,19 @@ instance Show TimeLogEntry where
 instance Show TimeLog where
     show tl = printf "TimeLog with %d entries" $ length $ timelog_entries tl
 
+-- | Convert a time log to a ledger.
 ledgerFromTimeLog :: TimeLog -> RawLedger
 ledgerFromTimeLog tl = 
     RawLedger [] [] (entriesFromTimeLogEntries $ timelog_entries tl) ""
 
+-- | Convert time log entries to ledger entries.
 entriesFromTimeLogEntries :: [TimeLogEntry] -> [Entry]
 
-entriesFromTimeLogEntries [clockin] = 
-    entriesFromTimeLogEntries [clockin, clockoutNowEntry]
+-- | When there is a trailing clockin entry, provide the missing clockout.
+-- "Now" would be ideal but requires IO, for now we make it the same as
+-- clockin time.
+entriesFromTimeLogEntries [clockin@(TimeLogEntry _ t _)] = 
+    entriesFromTimeLogEntries [clockin, (TimeLogEntry 'o' t "")]
 
 entriesFromTimeLogEntries [clockin,clockout] =
     [
@@ -52,8 +54,8 @@ entriesFromTimeLogEntries [clockin,clockout] =
     where
       accountname = tlcomment clockin
       indate      = showDateFrom intime
-      intime      = parseDateTime $ tldatetime clockin
-      outtime     = parseDateTime $ tldatetime clockout
+      intime      = parsedatetime $ tldatetime clockin
+      outtime     = parsedatetime $ tldatetime clockout
       hours       = fromRational (toRational (diffUTCTime outtime intime) / 3600) -- whatever
       amount      = Amount (getcurrency "h") hours 1
 
@@ -61,13 +63,5 @@ entriesFromTimeLogEntries many =
     (entriesFromTimeLogEntries $ take 2 many) ++
     (entriesFromTimeLogEntries $ drop 2 many)
 
-clockoutNowEntry = TimeLogEntry ' ' "" ""
-
-parseDateTime :: String -> UTCTime
-parseDateTime s = fromMaybe err parsed
-    where
-      err    = error $ printf "could not parse timestamp \"%s\"" s
-      parsed = parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s
-
 showDateFrom :: UTCTime -> String
 showDateFrom = formatTime defaultTimeLocale "%Y/%m/%d"

Ledger/Utils.hs

@@ -5,19 +5,19 @@ Standard always-available imports and utilities.
 -}
 
 module Ledger.Utils (
-              module Ledger.Utils,
-              module Char,
-              module Data.List,
-              module Data.Tree,
-              -- module Data.Map,
-              module Data.Ord,
-              module Data.Maybe,
-              module Text.Printf,
-              module Text.Regex,
-              module Debug.Trace,
-              module Test.QuickCheck,
-              module Test.HUnit
-             )
+module Ledger.Utils,
+module Char,
+module Data.List,
+module Data.Tree,
+module Data.Ord,
+module Data.Maybe,
+module Text.Printf,
+module Text.Regex,
+module Debug.Trace,
+module Test.QuickCheck,
+module Test.HUnit,
+defaultTimeLocale, UTCTime, diffUTCTime, parseTime, formatTime,
+)
 where
 import Char
 import Data.List
@@ -30,8 +30,30 @@ import Text.Regex
 import Debug.Trace
 import Test.QuickCheck hiding (test, Testable)
 import Test.HUnit
+import System.Locale (defaultTimeLocale)
+import Data.Time.Clock (UTCTime, diffUTCTime)
+import Data.Time.Format (ParseTime, parseTime, formatTime)
 
 
+-- time
+
+-- | Parse a date-time string to a time type, or raise an error.
+parsedatetime :: ParseTime t => String -> t
+parsedatetime s =
+    parsetimewith "%Y/%m/%d %H:%M:%S" s $
+    error $ printf "could not parse timestamp \"%s\"" s
+
+-- | Parse a date string to a time type, or raise an error.
+parsedate :: ParseTime t => String -> t
+parsedate s = 
+    parsetimewith "%Y/%m/%d" s $
+    error $ printf "could not parse date \"%s\"" s
+
+-- | Parse a time string to a time type using the provided pattern, or
+-- return the default.
+parsetimewith :: ParseTime t => String -> String -> t -> t
+parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s
+
 -- lists
 
 splitAtElement :: Eq a => a -> [a] -> [[a]]

Options.hs

@@ -1,5 +1,17 @@
-module Options (parseOptions, parsePatternArgs, regexFor, nullpats, wildcard, Flag(..), usage, ledgerFilePath)
+module Options (
+Flag(..), 
+usage, 
+parseArguments, 
+ledgerFilePathFromOpts,
+beginDateFromOpts,
+endDateFromOpts,
+parsePatternArgs, 
+regexFor, 
+nullpats, 
+wildcard, 
+)
 where
+import System
 import System.Console.GetOpt
 import System.Directory
 import System.Environment (getEnv)
@@ -11,68 +23,87 @@ import Ledger.Parse (parseLedgerFile, parseError)
 import Ledger.Ledger (cacheLedger)
 
 
-usagehdr       = "Usage: hledger [OPTIONS] "++commands++" [ACCTPATTERNS] [-- DESCPATTERNS]\nOptions:"
-commands       = "register|balance|print"
-defaultcmd     = "register"
+usagehdr    = "Usage: hledger [OPTIONS] "++commands++" [ACCTPATTERNS] [-- DESCPATTERNS]\nOptions:"
+commands    = "register|balance|print"
+defaultcmd  = "register"
+defaultfile = "~/.ledger"
+fileenvvar  = "LEDGER"
 
-options :: [OptDescr Flag]
-options = [
- Option ['f'] ["file"]     (ReqArg File "FILE") "ledger file; - means use standard input",
- Option ['s'] ["showsubs"] (NoArg ShowSubs)     "balance report: show subaccounts", -- register: show subtotals
- Option ['h'] ["help"]     (NoArg Help)         "show this help"
- --Option ['V'] ["version"]  (NoArg Version)      "show version"
- ]
+usage = usageInfo usagehdr options
 
 data Flag = 
     File String | 
+    Begin String | 
+    End String | 
     ShowSubs |
     Help |
     Version
     deriving (Show,Eq)
 
-parseOptions :: [String] -> IO ([Flag], [String])
-parseOptions argv =
-    case getOpt RequireOrder options argv of
-      (opts,[],[])   -> return (opts, [defaultcmd])
-      (opts,args,[]) -> return (opts, args)
-      (_,_,errs)     -> ioError (userError (concat errs ++ usage))
+options :: [OptDescr Flag]
+options = [
+ Option ['f'] ["file"]      (ReqArg File "FILE")       "ledger file; - means use standard input",
+ Option ['b'] []            (ReqArg Begin "BEGINDATE") "begin reports from this date (inclusive)",
+ Option ['e'] []            (ReqArg End "ENDDATE")     "end reports on this date (exclusive)",
+ Option ['s'] ["showsubs"]  (NoArg ShowSubs)           "balance report: show subaccounts",
+ Option ['h'] ["help"]      (NoArg Help)               "show this help"
+ --Option ['V'] ["version"] (NoArg Version)            "show version"
+ ]
 
--- testoptions RequireOrder ["foo","-v"]
--- testoptions Permute ["foo","-v"]
--- testoptions (ReturnInOrder Arg) ["foo","-v"]
--- testoptions Permute ["foo","--","-v"]
--- testoptions Permute ["-?o","--name","bar","--na=baz"]
--- testoptions Permute ["--ver","foo"]
-testoptions order cmdline = putStr $ 
-    case getOpt order options cmdline of
-      (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n
-      (_,_,errs) -> concat errs ++ usage
+-- | Parse the command-line arguments into ledger options, ledger command
+-- name, and ledger command arguments
+parseArguments :: IO ([Flag], String, [String])
+parseArguments = do
+  args <- getArgs
+  case (getOpt RequireOrder options args) of
+    (opts,[],[])       -> return (opts, defaultcmd, [])
+    (opts,cmd:args,[]) -> return (opts, cmd, args)
+    (_,_,errs)         -> ioError (userError (concat errs ++ usage))
 
-usage = usageInfo usagehdr options
-
-ledgerFilePath :: [Flag] -> IO String
-ledgerFilePath = findFileFromOpts "~/ledger.dat" "LEDGER"
-
--- | find a file path from options, an env var or a default value
-findFileFromOpts :: FilePath -> String -> [Flag] -> IO String
-findFileFromOpts defaultpath envvar opts = do
-  envordefault <- getEnv envvar `catch` \_ -> return defaultpath
+-- | Get the ledger file path from options, an environment variable, or a default
+ledgerFilePathFromOpts :: [Flag] -> IO String
+ledgerFilePathFromOpts opts = do
+  envordefault <- getEnv fileenvvar `catch` \_ -> return defaultfile
   paths <- mapM tildeExpand $ [envordefault] ++ (concatMap getfile opts)
   return $ last paths
     where
       getfile (File s) = [s]
       getfile _ = []
 
-tildeExpand              :: FilePath -> IO FilePath
-tildeExpand ('~':[])     =  getHomeDirectory
-tildeExpand ('~':'/':xs) =  getHomeDirectory >>= return . (++ ('/':xs))
--- -- ~name, requires -fvia-C or ghc 6.8
--- --import System.Posix.User
--- -- tildeExpand ('~':xs)     =  do let (user, path) = span (/= '/') xs
--- --                                pw <- getUserEntryForName user
--- --                                return (homeDirectory pw ++ path)
+-- | Expand ~ in a file path (does not handle ~name).
+tildeExpand :: FilePath -> IO FilePath
+tildeExpand ('~':[])     = getHomeDirectory
+tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs))
+--handle ~name, requires -fvia-C or ghc 6.8:
+--import System.Posix.User
+-- tildeExpand ('~':xs)     =  do let (user, path) = span (/= '/') xs
+--                                pw <- getUserEntryForName user
+--                                return (homeDirectory pw ++ path)
 tildeExpand xs           =  return xs
--- -- courtesy of allberry_b
+
+-- | get the value of the begin date option, or a default
+beginDateFromOpts :: [Flag] -> String
+beginDateFromOpts opts = 
+    case beginopts of
+      (x:_) -> last beginopts
+      _      -> defaultdate
+    where
+      beginopts = concatMap getbegindate opts
+      getbegindate (Begin s) = [s]
+      getbegindate _ = []
+      defaultdate = ""
+
+-- | get the value of the end date option, or a default
+endDateFromOpts :: [Flag] -> String
+endDateFromOpts opts = 
+    case endopts of
+      (x:_) -> last endopts
+      _      -> defaultdate
+    where
+      endopts = concatMap getenddate opts
+      getenddate (End s) = [s]
+      getenddate _ = []
+      defaultdate = ""
 
 -- | ledger pattern arguments are: 0 or more account patterns
 -- optionally followed by -- and 0 or more description patterns.
@@ -93,3 +124,15 @@ wildcard :: Regex
 wildcard = mkRegex ".*"
 
 nullpats = (wildcard,wildcard)
+
+-- testoptions RequireOrder ["foo","-v"]
+-- testoptions Permute ["foo","-v"]
+-- testoptions (ReturnInOrder Arg) ["foo","-v"]
+-- testoptions Permute ["foo","--","-v"]
+-- testoptions Permute ["-?o","--name","bar","--na=baz"]
+-- testoptions Permute ["--ver","foo"]
+testoptions order cmdline = putStr $ 
+    case getOpt order options cmdline of
+      (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n
+      (_,_,errs) -> concat errs ++ usage
+

Tests.hs

@@ -284,7 +284,7 @@ ledger7 = RawLedger
           ]
           ""
 
-l7 = cacheLedger ledger7 nullpats
+l7 = cacheLedger ledger7
 
 timelogentry1_str  = "i 2007/03/11 16:19:00 hledger\n"
 timelogentry1 = TimeLogEntry 'i' "2007/03/11 16:19:00" "hledger"
@@ -375,7 +375,7 @@ test_ledgerAccountNames =
     (accountnames l7)
 
 test_cacheLedger =
-    assertEqual' 15 (length $ Map.keys $ accounts $ cacheLedger ledger7 nullpats)
+    assertEqual' 15 (length $ Map.keys $ accounts $ cacheLedger ledger7)
 
 test_showLedgerAccounts = 
     assertEqual' 4 (length $ lines $ showLedgerAccountBalances l7 1)

hledger.hs

@@ -44,38 +44,38 @@ import Ledger hiding (rawledger)
 
 main :: IO ()
 main = do
-  (opts, (cmd:args)) <- getArgs >>= parseOptions
-  let pats = parsePatternArgs args
-  run cmd opts pats
-    where run cmd opts pats
+  (opts, cmd, args) <- parseArguments
+  run cmd opts args
+    where run cmd opts args
               | Help `elem` opts            = putStr usage
-              | cmd `isPrefixOf` "selftest" = selftest opts pats
-              | cmd `isPrefixOf` "print"    = print_   opts pats
-              | cmd `isPrefixOf` "register" = register opts pats
-              | cmd `isPrefixOf` "balance"  = balance  opts pats
+              | cmd `isPrefixOf` "selftest" = selftest opts args
+              | cmd `isPrefixOf` "print"    = print_   opts args
+              | cmd `isPrefixOf` "register" = register opts args
+              | cmd `isPrefixOf` "balance"  = balance  opts args
               | otherwise                   = putStr usage
 
-type Command = [Flag] -> ([String],[String]) -> IO ()
+type Command = [Flag] -> [String] -> IO ()
 
 selftest :: Command
-selftest opts pats = do 
+selftest _ _ = do 
   hunit
   quickcheck
   return ()
 
 print_ :: Command
-print_ opts pats = parseLedgerAndDo opts pats printentries
+print_ opts args = parseLedgerAndDo opts args printentries
 
 register :: Command
-register opts pats = parseLedgerAndDo opts pats printregister
+register opts args = parseLedgerAndDo opts args printregister
 
 balance :: Command
-balance opts pats = parseLedgerAndDo opts pats printbalance
+balance opts args = parseLedgerAndDo opts args printbalance
     where
       printbalance :: Ledger -> IO ()
       printbalance l = putStr $ showLedgerAccountBalances l depth
           where 
             showsubs = (ShowSubs `elem` opts)
+            pats = parsePatternArgs args
             depth = case (pats, showsubs) of
                       -- when there is no -s or pattern args, show with depth 1
                       (([],[]), False) -> 1
@@ -83,12 +83,17 @@ balance opts pats = parseLedgerAndDo opts pats printbalance
 
 -- | parse the user's specified ledger file and do some action with it
 -- (or report a parse error). This function makes the whole thing go.
-parseLedgerAndDo :: [Flag] -> ([String],[String]) -> (Ledger -> IO ()) -> IO ()
-parseLedgerAndDo opts (apats,dpats) cmd = do
-    path <- ledgerFilePath opts
-    parsed <- parseLedgerFile path
-    case parsed of Left err -> parseError err
-                   Right l -> cmd $ cacheLedger l (regexFor apats, regexFor dpats)
+parseLedgerAndDo :: [Flag] -> [String] -> (Ledger -> IO ()) -> IO ()
+parseLedgerAndDo opts args cmd = do
+  parsed <- ledgerFilePathFromOpts opts >>= parseLedgerFile
+  case parsed of Left err -> parseError err
+                 Right l -> cmd $ cacheLedger $ filterLedger begin end aregex dregex l
+  where
+    (apats,dpats) = parsePatternArgs args
+    aregex = regexFor apats
+    dregex = regexFor dpats
+    begin = beginDateFromOpts opts
+    end = endDateFromOpts opts
 
 -- ghci helpers
 
@@ -96,19 +101,19 @@ parseLedgerAndDo opts (apats,dpats) cmd = do
 -- or (WARNING) an empty one if there was a problem.
 rawledger :: IO RawLedger
 rawledger = do
-  parsed <- ledgerFilePath [] >>= parseLedgerFile
+  parsed <- ledgerFilePathFromOpts [] >>= parseLedgerFile
   return $ either (\_ -> RawLedger [] [] [] "") id parsed
 
 -- | as above, and convert it to a cached Ledger
 ledger :: IO Ledger
 ledger = do
   l <- rawledger
-  return $ cacheLedger l nullpats
+  return $ cacheLedger $ filterLedger "" "" wildcard wildcard l
 
 -- | get a Ledger from the given file path
 rawledgerfromfile :: String -> IO RawLedger
 rawledgerfromfile f = do
-  parsed <- ledgerFilePath [File f] >>= parseLedgerFile
+  parsed <- ledgerFilePathFromOpts [File f] >>= parseLedgerFile
   return $ either (\_ -> RawLedger [] [] [] "") id parsed
 
 -- | get a named account from your ledger file