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

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
+> 21
-> oct
+> october, oct
-> this week  # or day, month, quarter, year
+> this/next/last week/day/month/quarter/year
-> next week
+> yesterday, today, tomorrow
-> last week
+
+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 ym 
-             <|> try md
+             ,try md
-             <|> try y
+             ,try y
-             <|> try d
+             ,try d
---              <|> try month
+             ,try month
---              <|> try mon
+             ,try mon
---              <|> try today
+--              ,try today
---              <|> try yesterday
+--              ,try yesterday
---              <|> try tomorrow
+--              ,try tomorrow
---              <|> try thiswhatever
+--              ,try thiswhatever
---              <|> try nextwhatever
+--              ,try nextwhatever
---              <|> try lastwhatever
+--              ,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
+months = ["january","february","march","april","may","june",
--- time, or raise an error.
+          "july","august","september","october","november","december"]
-smartparsedate :: String -> IO Date
+
-smartparsedate s = do
+mons = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"]
-  let (y,m,d) = fromparse $ parsewith smartdate s
+
-  (thisy,thism,_) <- today >>= return . dateComponents
+month :: Parser (String,String,String)
-  let (y',m',d') = case (y,m,d) of
+month = do
-                     ("","",d) -> (show thisy,show thism,d)
+  m <- choice $ map string months
-                     ("",m,d)  -> (show thisy,m,d)
+  let i = maybe 0 (+1) $ (map toLower m) `elemIndex` months
-                     otherwise -> (y,m,d)
+  return ("",show i,"1")
-  return $ parsedate $ printf "%04s/%02s/%02s" y' m' d'
+
+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
 

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,cmd:args,[]) -> do {opts' <- fixDates opts; return (opts',cmd,args)}
-    (opts,[],[])       -> return (opts, [], [])
+    (opts,[],[])       -> do {opts' <- fixDates opts; return (opts',[],[])}
-    (opts,_,errs)         -> ioError (userError (concat errs ++ usage 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
+    if null beginopts 
-      (x:_) -> smartparsedate (last beginopts) >>= return . Just
+    then Nothing
-      _ -> return 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 :: [Opt] -> Maybe Date
-endDateFromOpts opts = do
+endDateFromOpts opts =
-    case endopts of
+    if null endopts 
-      (x:_) -> smartparsedate (last endopts) >>= return . Just
+    then Nothing
-      _ -> return 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
 

Tests.hs

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

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