slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

support basic --period expressions, containing a single smart date

Browse Source
This commit is contained in:
Simon Michael 2008-11-27 06:29:29 +00:00
parent 1e7679176c
commit 57c31f5ab0
5 changed files with 133 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
Ledger/Dates.hs
View File

@ -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
@ -212,17 +249,20 @@ months = ["january","february","march","april","may","june",
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")

2
Ledger/Types.hs
View File

@ -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

87
Options.hs
View File

@ -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

24
Tests.hs
View File

@ -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

5
hledger.hs
View File

@ -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