diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs index ccdce4469..fd7f816da 100644 --- a/Ledger/Parse.hs +++ b/Ledger/Parse.hs @@ -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) <- ( - 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 - ) + (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 + ] 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 diff --git a/Options.hs b/Options.hs index ef193c7d1..9b8ea51de 100644 --- a/Options.hs +++ b/Options.hs @@ -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 diff --git a/Tests.hs b/Tests.hs index 4f5b752c6..130f2b4f9 100644 --- a/Tests.hs +++ b/Tests.hs @@ -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 diff --git a/hledger.hs b/hledger.hs index 393fec349..740c53df5 100644 --- a/hledger.hs +++ b/hledger.hs @@ -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