tighten up date parsing, make it io-friendly and parse Y, M/D, D

Ledger/Parse.hs

@@ -500,10 +500,14 @@ smartdate = do
   (y,m,d) <- (
              try ymd 
              <|> try ym 
+             <|> try md
              <|> try y
---              <|> try md
+             <|> try d
 --              <|> try month
 --              <|> try mon
+--              <|> try today
+--              <|> try yesterday
+--              <|> try tomorrow
 --              <|> try thiswhatever
 --              <|> try nextwhatever
 --              <|> try lastwhatever
@@ -517,27 +521,54 @@ ymd = do
   y <- many digit
   datesep
   m <- many digit
+  guard (read m <= 12)
   datesep
   d <- many digit
+  guard (read d <= 31)
   return (y,m,d)
 
 ym :: Parser (String,String,String)
 ym = do
   y <- many digit
+  guard (read y > 12)
   datesep
   m <- many digit
+  guard (read m <= 12)
   return (y,m,"1")
 
 y :: Parser (String,String,String)
 y = do
   y <- many digit
+  guard (read y >= 1000)
   return (y,"1","1")
 
--- | Parse a flexible date string, with awareness of the current time,
--- and return a Date or raise an error.
-smartparsedate :: String -> Date
-smartparsedate s = parsedate $ printf "%04s/%02s/%02s" y m d
-    where (y,m,d) = fromparse $ parsewith smartdate s
+d :: Parser (String,String,String)
+d = do
+  d <- many 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
+  guard (read m <= 12)
+  datesep
+  d <- many 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'
 
 type TransactionMatcher = Transaction -> Bool
 

Options.hs

@@ -113,11 +113,11 @@ tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs))
 tildeExpand xs           =  return xs
 
 -- | Get the value of the begin date option, if any.
-beginDateFromOpts :: [Opt] -> Maybe Date
-beginDateFromOpts opts = 
+beginDateFromOpts :: [Opt] -> IO (Maybe Date)
+beginDateFromOpts opts =
     case beginopts of
-      (x:_) -> Just $ smartparsedate $ last beginopts
-      _     -> Nothing
+      (x:_) -> smartparsedate (last beginopts) >>= return . Just
+      _ -> return Nothing
     where
       beginopts = concatMap getbegindate opts
       getbegindate (Begin s) = [s]
@@ -125,11 +125,11 @@ beginDateFromOpts opts =
       defaultdate = ""
 
 -- | Get the value of the end date option, if any.
-endDateFromOpts :: [Opt] -> Maybe Date
-endDateFromOpts opts = 
+endDateFromOpts :: [Opt] -> IO (Maybe Date)
+endDateFromOpts opts = do
     case endopts of
-      (x:_) -> Just $ smartparsedate $ last endopts
-      _      -> Nothing
+      (x:_) -> smartparsedate (last endopts) >>= return . Just
+      _ -> return Nothing
     where
       endopts = concatMap getenddate opts
       getenddate (End s) = [s]

Tests.hs

@@ -98,9 +98,15 @@ misc_tests = TestList [
     assertparseequal timelog1 (parsewith timelog timelog1_str)
   ,                  
   "smartparsedate"     ~: do
-    assertequal (1999,12,13) (dateComponents $ smartparsedate "1999/12/13")
-    assertequal (2008,2,1)   (dateComponents $ smartparsedate "2008-2")
-    assertequal (2008,1,1)   (dateComponents $ smartparsedate "2008")
+    (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)
   ]
 
 balancereportacctnames_tests = TestList 

hledger.hs

@@ -68,12 +68,12 @@ main = do
 -- | 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 = 
-    ledgerFilePathFromOpts opts >>= parseLedgerFile >>= either printParseError runcmd
+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
-      b = beginDateFromOpts opts
-      e = endDateFromOpts opts
       (apats,dpats) = parseAccountDescriptionArgs opts args
       c = Cleared `elem` opts
       r = Real `elem` opts