From 57c31f5ab0b3811b384c1bbd31e094bf511df069 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Thu, 27 Nov 2008 06:29:29 +0000 Subject: [PATCH] support basic --period expressions, containing a single smart date --- Ledger/Dates.hs | 60 ++++++++++++++++++++++++++++------ Ledger/Types.hs | 2 +- Options.hs | 87 ++++++++++++++++++++++++++++++++++--------------- Tests.hs | 26 +++++++++++---- hledger.hs | 5 +-- 5 files changed, 133 insertions(+), 47 deletions(-) diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs index 4d6e690db..c2fb3909e 100644 --- a/Ledger/Dates.hs +++ b/Ledger/Dates.hs @@ -53,7 +53,41 @@ elapsedSeconds t1 t2 = realToFrac $ diffUTCTime t1 t2 dayToUTC :: Day -> UTCTime dayToUTC d = localTimeToUTC utc (LocalTime d midnight) --- | Convert a fuzzy date string to an explicit yyyy/mm/dd string using +-- | Convert a smart date string to a date span using the provided date as +-- reference point. +spanFromSmartDateString :: Day -> String -> DateSpan +spanFromSmartDateString refdate s = DateSpan (Just b) (Just e) + where + sdate = fromparse $ parsewith smartdate s + (ry,rm,rd) = toGregorian refdate + (b,e) = span sdate + span :: SmartDate -> (Day,Day) + span ("","","today") = (refdate, nextday refdate) + span ("","this","day") = (refdate, nextday refdate) + span ("","","yesterday") = (prevday refdate, refdate) + span ("","last","day") = (prevday refdate, refdate) + span ("","","tomorrow") = (nextday refdate, addDays 2 refdate) + span ("","next","day") = (nextday refdate, addDays 2 refdate) + span ("","last","week") = (prevweek refdate, thisweek refdate) + span ("","this","week") = (thisweek refdate, nextweek refdate) + span ("","next","week") = (nextweek refdate, startofweek $ addDays 14 refdate) + span ("","last","month") = (prevmonth refdate, thismonth refdate) + span ("","this","month") = (thismonth refdate, nextmonth refdate) + span ("","next","month") = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate) + span ("","last","quarter") = (prevquarter refdate, thisquarter refdate) + span ("","this","quarter") = (thisquarter refdate, nextquarter refdate) + span ("","next","quarter") = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate) + span ("","last","year") = (prevyear refdate, thisyear refdate) + span ("","this","year") = (thisyear refdate, nextyear refdate) + span ("","next","year") = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate) + span ("","",d) = (day, nextday day) where day = fromGregorian ry rm (read d) + span ("",m,"") = (startofmonth day, nextmonth day) where day = fromGregorian ry (read m) 1 + span ("",m,d) = (day, nextday day) where day = fromGregorian ry (read m) (read d) + span (y,"","") = (startofyear day, nextyear day) where day = fromGregorian (read y) 1 1 + span (y,m,"") = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1 + span (y,m,d) = (day, nextday day) where day = fromGregorian (read y) (read m) (read d) + +-- | Convert a smart date string to an explicit yyyy/mm/dd string using -- the provided date as reference point. fixSmartDateStr :: Day -> String -> String fixSmartDateStr t s = printf "%04d/%02d/%02d" y m d @@ -86,7 +120,10 @@ fixSmartDate refdate sdate = fix sdate fix ("","this","year") = thisyear refdate fix ("","next","year") = nextyear refdate fix ("","",d) = fromGregorian ry rm (read d) + fix ("",m,"") = fromGregorian ry (read m) 1 fix ("",m,d) = fromGregorian ry (read m) (read d) + fix (y,"","") = fromGregorian (read y) 1 1 + fix (y,m,"") = fromGregorian (read y) (read m) 1 fix (y,m,d) = fromGregorian (read y) (read m) (read d) (ry,rm,rd) = toGregorian refdate @@ -184,13 +221,13 @@ ym = do datesepchar m <- many1 digit guard (read m <= 12) - return (y,m,"1") + return (y,m,"") y :: Parser SmartDate y = do y <- many1 digit guard (read y >= 1000) - return (y,"1","1") + return (y,"","") d :: Parser SmartDate d = do @@ -210,19 +247,22 @@ md = do months = ["january","february","march","april","may","june", "july","august","september","october","november","december"] -mons = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"] +mons = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"] + +monthIndex s = maybe 0 (+1) $ (map toLower s) `elemIndex` months +monIndex s = maybe 0 (+1) $ (map toLower s) `elemIndex` mons month :: Parser SmartDate month = do - m <- choice $ map string months - let i = maybe 0 (+1) $ (map toLower m) `elemIndex` months - return ("",show i,"1") + m <- choice $ map (try . string) months + let i = monthIndex m + return $ ("",show i,"") mon :: Parser SmartDate mon = do - m <- choice $ map string mons - let i = maybe 0 (+1) $ (map toLower m) `elemIndex` mons - return ("",show i,"1") + m <- choice $ map (try . string) mons + let i = monIndex m + return ("",show i,"") today',yesterday,tomorrow :: Parser SmartDate today' = string "today" >> return ("","","today") diff --git a/Ledger/Types.hs b/Ledger/Types.hs index a59edc541..f6d9ac040 100644 --- a/Ledger/Types.hs +++ b/Ledger/Types.hs @@ -14,7 +14,7 @@ import qualified Data.Map as Map type SmartDate = (String,String,String) -data DateSpan = DateSpan (Maybe Day) (Maybe Day) +data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord) type AccountName = String diff --git a/Options.hs b/Options.hs index 06592379c..da6ea6c9f 100644 --- a/Options.hs +++ b/Options.hs @@ -10,6 +10,8 @@ import Ledger.Types import Ledger.Dates +versionno = "0.3pre" +version = printf "hledger version %s \n" versionno :: String defaultfile = "~/.ledger" fileenvvar = "LEDGER" usagehdr = "Usage: hledger [OPTS] COMMAND [ACCTPATTERNS] [-- DESCPATTERNS]\n" ++ @@ -37,6 +39,7 @@ options = [ Option ['f'] ["file"] (ReqArg File "FILE") filehelp, Option ['b'] ["begin"] (ReqArg Begin "DATE") "report on entries on or after this date", Option ['e'] ["end"] (ReqArg End "DATE") "report on entries prior to this date", + Option ['p'] ["period"] (ReqArg Period "EXPR") "report on entries during this calendar period", 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", @@ -57,13 +60,14 @@ options = [ -- | An option value from a command-line flag. data Opt = - File String | - Begin String | - End String | + File {value::String} | + Begin {value::String} | + End {value::String} | + Period {value::String} | Cleared | CostBasis | - Depth String | - Display String | + Depth {value::String} | + Display {value::String} | Empty | Real | OptionsAnywhere | @@ -74,8 +78,9 @@ data Opt = Version deriving (Show,Eq) -versionno = "0.3pre" -version = printf "hledger version %s \n" versionno :: String +-- yow.. +optValuesForConstructor f opts = concatMap get opts + where get o = if f v == o 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 @@ -104,28 +109,24 @@ fixOptDates opts = do where fixbracketeddatestr s = "[" ++ (fixSmartDateStr t $ init $ tail s) ++ "]" fixopt _ o = o --- | Get the ledger file path from options, an environment variable, or a default -ledgerFilePathFromOpts :: [Opt] -> IO String -ledgerFilePathFromOpts opts = do - envordefault <- getEnv fileenvvar `catch` \_ -> return defaultfile - paths <- mapM tildeExpand $ [envordefault] ++ (concatMap getfile opts) - return $ last paths +-- | Figure out the date span we should report on, based on any +-- begin/end/period options provided. This could be really smart but I'm +-- just going to look for 1. the first Period or 2. the first Begin and +-- first End. +dateSpanFromOpts :: Day -> [Opt] -> DateSpan +dateSpanFromOpts refdate opts + | not $ null ps = spanFromPeriodExpr refdate $ head ps + | otherwise = DateSpan firstb firste where - getfile (File s) = [s] - getfile _ = [] + ps = optValuesForConstructor Period opts + firstb = listtomaybeday $ optValuesForConstructor Begin opts + firste = listtomaybeday $ optValuesForConstructor End opts + listtomaybeday [] = Nothing + listtomaybeday vs = Just $ parse $ head vs + parse s = parsedate $ printf "%04s/%02s/%02s" y m d + where (y,m,d) = fromparse $ parsewith smartdate $ s --- | 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 - -dateSpanFromOpts opts = DateSpan (beginDateFromOpts opts) (endDateFromOpts opts) +spanFromPeriodExpr refdate = spanFromSmartDateString refdate -- | Get the value of the begin date option, if any. beginDateFromOpts :: [Opt] -> Maybe Day @@ -153,6 +154,17 @@ endDateFromOpts opts = defaultdate = "" (y,m,d) = fromparse $ parsewith smartdate $ last endopts +-- | Get the value of the period option, if any. +periodFromOpts :: [Opt] -> Maybe String +periodFromOpts opts = + if null periodopts + then Nothing + else Just $ head periodopts + where + periodopts = concatMap getperiod opts + getperiod (Period s) = [s] + getperiod _ = [] + -- | Get the value of the depth option, if any. depthFromOpts :: [Opt] -> Maybe Int depthFromOpts opts = @@ -175,6 +187,27 @@ displayFromOpts opts = getdisplay (Display s) = [s] getdisplay _ = [] +-- | Get the ledger file path from options, an environment variable, or a default +ledgerFilePathFromOpts :: [Opt] -> IO String +ledgerFilePathFromOpts opts = do + envordefault <- getEnv fileenvvar `catch` \_ -> return defaultfile + paths <- mapM tildeExpand $ [envordefault] ++ (concatMap getfile opts) + return $ last paths + where + getfile (File s) = [s] + getfile _ = [] + +-- | 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 + -- | 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 diff --git a/Tests.hs b/Tests.hs index 668c78cff..c64f79aab 100644 --- a/Tests.hs +++ b/Tests.hs @@ -346,18 +346,30 @@ registercommand_tests = TestList [ , "register report with display expression" ~: do - "d<[2008/6/2]" `displayexprgivestxns` ["2008/01/01","2008/06/01"] - "d<=[2008/6/2]" `displayexprgivestxns` ["2008/01/01","2008/06/01","2008/06/02"] - "d=[2008/6/2]" `displayexprgivestxns` ["2008/06/02"] - "d>=[2008/6/2]" `displayexprgivestxns` ["2008/06/02","2008/06/03","2008/12/31"] - "d>[2008/6/2]" `displayexprgivestxns` ["2008/06/03","2008/12/31"] - ] + "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 + "" `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"] +-- need to get datespan into ledgerFromString, or preconvert period expressions +-- "2007" `periodexprgives` [] + ] where - expr `displayexprgivestxns` dates = + expr `displayexprgives` dates = assertequal dates (datesfromregister r) where r = showRegisterReport [Display expr] [] l l = ledgerfromstring [] sample_ledger_str + expr `periodexprgives` dates = + assertequal dates (datesfromregister r) + where + r = showRegisterReport [Period expr] [] l + l = ledgerfromstring [] sample_ledger_str datesfromregister = filter (not . null) . map (strip . take 10) . lines diff --git a/hledger.hs b/hledger.hs index abf144948..85fce23cc 100644 --- a/hledger.hs +++ b/hledger.hs @@ -69,11 +69,12 @@ main = do -- (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 + day <- today + let span = dateSpanFromOpts day opts + let runcmd = cmd opts args . cacheLedger apats . filterRawLedger span dpats c r . canonicaliseAmounts costbasis ledgerFilePathFromOpts opts >>= parseLedgerFile >>= either printParseError runcmd where - runcmd = cmd opts args . cacheLedger apats . filterRawLedger span dpats c r . canonicaliseAmounts costbasis (apats,dpats) = parseAccountDescriptionArgs opts args - span = dateSpanFromOpts opts c = Cleared `elem` opts r = Real `elem` opts costbasis = CostBasis `elem` opts