From 91802391a15fb2e9b472765067603358f873cbe5 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Wed, 8 Oct 2008 17:00:22 +0000 Subject: [PATCH] um.. refactor option handling, filtering, and support -b/-e date filtering options --- Ledger/Ledger.hs | 75 ++++++++++++++++---------- Ledger/TimeLog.hs | 24 ++++----- Ledger/Utils.hs | 48 ++++++++++++----- Options.hs | 133 ++++++++++++++++++++++++++++++---------------- Tests.hs | 4 +- hledger.hs | 49 +++++++++-------- 6 files changed, 208 insertions(+), 125 deletions(-) diff --git a/Ledger/Ledger.hs b/Ledger/Ledger.hs index 96dec7827..7bc972b1c 100644 --- a/Ledger/Ledger.hs +++ b/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} diff --git a/Ledger/TimeLog.hs b/Ledger/TimeLog.hs index 986cf6af1..fa769cb37 100644 --- a/Ledger/TimeLog.hs +++ b/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" diff --git a/Ledger/Utils.hs b/Ledger/Utils.hs index 9bb60f464..7d15f47b5 100644 --- a/Ledger/Utils.hs +++ b/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]] diff --git a/Options.hs b/Options.hs index 5f625e6cb..d24d33044 100644 --- a/Options.hs +++ b/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 + diff --git a/Tests.hs b/Tests.hs index 7bb162d33..5b6ee6761 100644 --- a/Tests.hs +++ b/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) diff --git a/hledger.hs b/hledger.hs index a7302645c..bbbb5ed03 100644 --- a/hledger.hs +++ b/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