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

do IO date parsing up front, and support (english) month names

Browse Source
This commit is contained in:
Simon Michael 2008-11-26 04:04:05 +00:00
parent 1c60514973
commit 6c88197c6a
4 changed files with 110 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
Ledger/Parse.hs
View File

@ -483,92 +483,99 @@ ledgerfromtimelog = do
-- misc parsing
{-|
Parse a date in any of the formats allowed in ledger's period expressions:
Parse a date in any of the formats allowed in ledger's period expressions,
and maybe some others:
> 2004
> 2004/10
> 2004/10/1
> 10/1
> october
> oct
> this week # or day, month, quarter, year
> next week
> last week
> 21
> october, oct
> this/next/last week/day/month/quarter/year
> yesterday, today, tomorrow
Note: only recognises month names in lowercase.
-}
smartdate :: Parser (String,String,String)
smartdate = do
(y,m,d) <- (
(y,m,d) <- choice [
try ymd
<|> try ym
<|> try md
<|> try y
<|> try d
-- <|> try month
-- <|> try mon
-- <|> try today
-- <|> try yesterday
-- <|> try tomorrow
-- <|> try thiswhatever
-- <|> try nextwhatever
-- <|> try lastwhatever
)
,try ym
,try md
,try y
,try d
,try month
,try mon
-- ,try today
-- ,try yesterday
-- ,try tomorrow
-- ,try thiswhatever
-- ,try nextwhatever
-- ,try lastwhatever
]
return $ (y,m,d)
datesep = oneOf "/-."
ymd :: Parser (String,String,String)
ymd = do
y <- many digit
y <- many1 digit
datesep
m <- many digit
m <- many1 digit
guard (read m <= 12)
datesep
d <- many digit
d <- many1 digit
guard (read d <= 31)
return (y,m,d)
ym :: Parser (String,String,String)
ym = do
y <- many digit
y <- many1 digit
guard (read y > 12)
datesep
m <- many digit
m <- many1 digit
guard (read m <= 12)
return (y,m,"1")
y :: Parser (String,String,String)
y = do
y <- many digit
y <- many1 digit
guard (read y >= 1000)
return (y,"1","1")
d :: Parser (String,String,String)
d = do
d <- many digit
d <- many1 digit
guard (read d <= 31)
return ("","",d)
-- | Parse a M/D string as ("",M,D), year will be filled in later
md :: Parser (String,String,String)
md = do
m <- many digit
m <- many1 digit
guard (read m <= 12)
datesep
d <- many digit
d <- many1 digit
guard (read d <= 31)
return ("",m,d)
-- | Parse a flexible date string to a Date with awareness of the current
-- time, or raise an error.
smartparsedate :: String -> IO Date
smartparsedate s = do
let (y,m,d) = fromparse $ parsewith smartdate s
(thisy,thism,_) <- today >>= return . dateComponents
let (y',m',d') = case (y,m,d) of
("","",d) -> (show thisy,show thism,d)
("",m,d) -> (show thisy,m,d)
otherwise -> (y,m,d)
return $ parsedate $ printf "%04s/%02s/%02s" y' m' d'
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"]
month :: Parser (String,String,String)
month = do
m <- choice $ map string months
let i = maybe 0 (+1) $ (map toLower m) `elemIndex` months
return ("",show i,"1")
mon :: Parser (String,String,String)
mon = do
m <- choice $ map string mons
let i = maybe 0 (+1) $ (map toLower m) `elemIndex` mons
return ("",show i,"1")
type TransactionMatcher = Transaction -> Bool

61
Options.hs
View File

@ -4,12 +4,12 @@ import System
import System.Console.GetOpt
import System.Directory
import Text.Printf
import Ledger.Parse (smartparsedate)
import Ledger.Parse
import Ledger.Dates
import Ledger.Utils
usage opts = usageInfo usagehdr options ++ usageftr
usage = usageInfo usagehdr options ++ usageftr
negativePatternChar opts
| OptionsAnywhere `elem` opts = '^'
@ -81,15 +81,42 @@ versionno = "0.3pre"
version = printf "hledger version %s \n" versionno :: String
-- | Parse the command-line arguments into ledger options, ledger command
-- name, and ledger command arguments
-- 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.
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,[]) -> return (opts, cmd, args)
(opts,[],[]) -> return (opts, [], [])
(opts,_,errs) -> ioError (userError (concat errs ++ usage opts))
(opts,cmd:args,[]) -> do {opts' <- fixDates opts; return (opts',cmd,args)}
(opts,[],[]) -> do {opts' <- fixDates opts; return (opts',[],[])}
(opts,_,errs) -> ioError (userError (concat errs ++ usage))
-- | Convert any fuzzy/relative dates within these option values to
-- explicit ones, based on today's date.
fixDates :: [Opt] -> IO [Opt]
fixDates opts = do
ds <- today >>= return . dateComponents
return $ map (fixopt ds) opts
where
fixopt ds (Begin s) = Begin $ fixdate ds s
fixopt ds (End s) = End $ fixdate ds s
fixopt ds (Display s) = -- hacky
Display $ gsubRegexPRBy "\\[.+?\\]" fixbracketeddate s
where fixbracketeddate s = "[" ++ (fixdate ds $ init $ tail s) ++ "]"
fixopt _ o = o
-- | Convert a fuzzy date string to an explicit yyyy/mm/dd date, using the
-- provided today's date for defaults.
fixdate :: (Integer,Int,Int) -> String -> String
fixdate (thisy,thism,thisd) s = printf "%04s/%02s/%02s" y' m' d'
where
(y,m,d) = fromparse $ parsewith smartdate $ map toLower s
(y',m',d') = case (y,m,d) of
("","",d) -> (show thisy,show thism,d)
("",m,d) -> (show thisy,m,d)
otherwise -> (y,m,d)
-- | Get the ledger file path from options, an environment variable, or a default
ledgerFilePathFromOpts :: [Opt] -> IO String
@ -113,28 +140,30 @@ tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs))
tildeExpand xs = return xs
-- | Get the value of the begin date option, if any.
beginDateFromOpts :: [Opt] -> IO (Maybe Date)
beginDateFromOpts :: [Opt] -> Maybe Date
beginDateFromOpts opts =
case beginopts of
(x:_) -> smartparsedate (last beginopts) >>= return . Just
_ -> return Nothing
if null beginopts
then Nothing
else Just $ parsedate $ printf "%04s/%02s/%02s" y m d
where
beginopts = concatMap getbegindate opts
getbegindate (Begin s) = [s]
getbegindate _ = []
defaultdate = ""
(y,m,d) = fromparse $ parsewith smartdate $ last beginopts
-- | Get the value of the end date option, if any.
endDateFromOpts :: [Opt] -> IO (Maybe Date)
endDateFromOpts opts = do
case endopts of
(x:_) -> smartparsedate (last endopts) >>= return . Just
_ -> return Nothing
endDateFromOpts :: [Opt] -> Maybe Date
endDateFromOpts opts =
if null endopts
then Nothing
else Just $ parsedate $ printf "%04s/%02s/%02s" y m d
where
endopts = concatMap getenddate opts
getenddate (End s) = [s]
getenddate _ = []
defaultdate = ""
(y,m,d) = fromparse $ parsewith smartdate $ last endopts
-- | Get the value of the depth option, if any.
depthFromOpts :: [Opt] -> Maybe Int
@ -179,5 +208,5 @@ parseAccountDescriptionArgs opts args = (as, ds')
testoptions order cmdline = putStr $
case getOpt order options cmdline of
(o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n
(o,_,errs) -> concat errs ++ usage o
(o,_,errs) -> concat errs ++ usage

21
Tests.hs
View File

@ -98,15 +98,18 @@ misc_tests = TestList [
assertparseequal timelog1 (parsewith timelog timelog1_str)
,
"smartparsedate" ~: do
(thisyear,thismonth,thisday) <- today >>= return . dateComponents
d <- smartparsedate "1999-12-02"; assertequal (1999,12,2) (dateComponents d)
d <- smartparsedate "1999.12.02"; assertequal (1999,12,2) (dateComponents d)
d <- smartparsedate "1999/3/2"; assertequal (1999,3,2) (dateComponents d)
d <- smartparsedate "2008/2"; assertequal (2008,2,1) (dateComponents d)
d <- smartparsedate "20/2"; assertequal (20,2,1) (dateComponents d)
d <- smartparsedate "4/2"; assertequal (thisyear,4,2) (dateComponents d)
d <- smartparsedate "1000"; assertequal (1000,1,1) (dateComponents d)
d <- smartparsedate "2"; assertequal (thisyear,thismonth,2) (dateComponents d)
ds@(y,m,d) <- today >>= return . dateComponents
let str `gives` datestr = assertequal datestr (fixdate ds str)
"1999-12-02" `gives` "1999/12/02"
"1999.12.02" `gives` "1999/12/02"
"1999/3/2" `gives` "1999/03/02"
"2008/2" `gives` "2008/02/01"
"20/2" `gives` "0020/02/01"
"1000" `gives` "1000/01/01"
"4/2" `gives` (printf "%04d/04/02" y)
"2" `gives` (printf "%04d/%02d/02" y m)
"January" `gives` (printf "%04d/01/01" y)
"feb" `gives` (printf "%04d/02/01" y)
]
balancereportacctnames_tests = TestList

10
hledger.hs
View File

@ -57,24 +57,24 @@ main = do
run cmd opts args
where
run cmd opts args
| Help `elem` opts = putStr $ usage opts
| Help `elem` opts = putStr $ usage
| Version `elem` opts = putStr version
| cmd `isPrefixOf` "balance" = parseLedgerAndDo opts args balance
| cmd `isPrefixOf` "print" = parseLedgerAndDo opts args print'
| cmd `isPrefixOf` "register" = parseLedgerAndDo opts args register
| cmd `isPrefixOf` "test" = runtests opts args >> return ()
| otherwise = putStr $ usage opts
| otherwise = putStr $ usage
-- | 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 :: [Opt] -> [String] -> ([Opt] -> [String] -> Ledger -> IO ()) -> IO ()
parseLedgerAndDo opts args cmd = do
b <- beginDateFromOpts opts
e <- endDateFromOpts opts
let runcmd = cmd opts args . cacheLedger apats . filterRawLedger b e dpats c r . canonicaliseAmounts costbasis
ledgerFilePathFromOpts opts >>= parseLedgerFile >>= either printParseError runcmd
where
runcmd = cmd opts args . cacheLedger apats . filterRawLedger b e dpats c r . canonicaliseAmounts costbasis
(apats,dpats) = parseAccountDescriptionArgs opts args
b = beginDateFromOpts opts
e = endDateFromOpts opts
c = Cleared `elem` opts
r = Real `elem` opts
costbasis = CostBasis `elem` opts