parsing: date parsing overhaul, don't exit on bad dates

- get rid of undefined parse errors due to guard
- don't call error from date parsers; let add re-prompt on bad dates
- years now must always have at least four digits
- clearer date parse errors

Hledger/Cli/Tests.hs

@@ -597,7 +597,7 @@ tests = TestList [
     "1999/3/2"     `gives` "1999/03/02"
     "19990302"     `gives` "1999/03/02"
     "2008/2"       `gives` "2008/02/01"
-    "20/2"         `gives` "0020/02/01"
+    "0020/2"       `gives` "0020/02/01"
     "1000"         `gives` "1000/01/01"
     "4/2"          `gives` "2008/04/02"
     "2"            `gives` "2008/11/02"

hledger-lib/Hledger/Data/Dates.hs

@@ -23,6 +23,7 @@ where
 
 import Data.Time.Format
 import Data.Time.Calendar.OrdinalDate
+import Safe (readMay)
 import System.Locale (defaultTimeLocale)
 import Text.ParserCombinators.Parsec
 import Hledger.Data.Types
@@ -261,54 +262,65 @@ smartdateonly = do
 
 datesepchar = oneOf "/-."
 
+validYear, validMonth, validDay :: String -> Bool
+validYear s = length s >= 4 && isJust (readMay s :: Maybe Int)
+validMonth s = maybe False (\n -> n>=1 && n<=12) $ readMay s
+validDay s = maybe False (\n -> n>=1 && n<=31) $ readMay s
+
+-- failIfInvalidYear, failIfInvalidMonth, failIfInvalidDay :: a
+failIfInvalidYear s  = unless (validYear s)  $ fail $ "bad year number: " ++ s
+failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s
+failIfInvalidDay s   = unless (validDay s)   $ fail $ "bad day number: " ++ s
+
 yyyymmdd :: GenParser Char st SmartDate
 yyyymmdd = do
   y <- count 4 digit
   m <- count 2 digit
-  guard (read m <= 12)
+  failIfInvalidMonth m
   d <- count 2 digit
-  guard (read d <= 31)
+  failIfInvalidDay d
   return (y,m,d)
 
 ymd :: GenParser Char st SmartDate
 ymd = do
   y <- many1 digit
+  failIfInvalidYear y
   datesepchar
-  m <- try (count 2 digit) <|> count 1 digit
+  m <- many1 digit
-  when (read m < 1 || (read m > 12)) $ error $ "bad month number: " ++ m
+  failIfInvalidMonth m
   datesepchar
-  d <- try (count 2 digit) <|> count 1 digit
+  d <- many1 digit
-  when (read d < 1 || (read d > 31)) $ error $ "bad day number: " ++ d
+  failIfInvalidDay d
   return $ (y,m,d)
 
 ym :: GenParser Char st SmartDate
 ym = do
   y <- many1 digit
-  guard (read y > 12)
+  failIfInvalidYear y
   datesepchar
-  m <- try (count 2 digit) <|> count 1 digit
+  m <- many1 digit
-  guard (read m >= 1 && (read m <= 12))
+  failIfInvalidMonth m
   return (y,m,"")
 
 y :: GenParser Char st SmartDate
 y = do
   y <- many1 digit
-  guard (read y >= 1000)
+  failIfInvalidYear y
   return (y,"","")
 
 d :: GenParser Char st SmartDate
 d = do
   d <- many1 digit
-  guard (read d <= 31)
+  failIfInvalidDay d
   return ("","",d)
 
 md :: GenParser Char st SmartDate
 md = do
-  m <- try (count 2 digit) <|> count 1 digit
+  m <- many1 digit
-  guard (read m >= 1 && (read m <= 12))
+  failIfInvalidMonth m
   datesepchar
-  d <- try (count 2 digit) <|> count 1 digit
+  d <- many1 digit
-  when (read d < 1 || (read d > 31)) $ fail "bad day number specified"
+  failIfInvalidDay d
   return ("",m,d)
 
 months         = ["january","february","march","april","may","june",

hledger-lib/Hledger/Data/Parse.hs

@@ -380,7 +380,7 @@ ledgerDefaultYear = do
   many spacenonewline
   y <- many1 digit
   let y' = read y
-  guard (y' >= 1000)
+  failIfInvalidYear y
   setYear y'
   return $ return id
 
@@ -403,7 +403,7 @@ ledgerTransaction = do
     Left err -> fail err
 
 ledgerdate :: GenParser Char LedgerFileCtx Day
-ledgerdate = (try ledgerfulldate <|> ledgerpartialdate) <?> "full or partial date"
+ledgerdate = choice' [ledgerfulldate, ledgerpartialdate] <?> "full or partial date"
 
 ledgerfulldate :: GenParser Char LedgerFileCtx Day
 ledgerfulldate = do
@@ -416,7 +416,7 @@ ledgerpartialdate :: GenParser Char LedgerFileCtx Day
 ledgerpartialdate = do
   (_,m,d) <- md
   y <- getYear
-  when (y==Nothing) $ fail "partial date found, but no default year specified"
+  when (isNothing y) $ fail "partial date found, but no default year specified"
   return $ fromGregorian (fromJust y) (read m) (read d)
 
 ledgerdatetime :: GenParser Char LedgerFileCtx LocalTime
@@ -458,7 +458,7 @@ ledgerpostings = do
   let parses p = isRight . parseWithCtx ctx p
   ls <- many1 $ try linebeginningwithspaces
   let ls' = filter (not . (ledgercommentline `parses`)) ls
-  guard (not $ null ls')
+  when (null ls') $ fail "no postings"
   return $ map (fromparse . parseWithCtx ctx ledgerposting) ls'
   <?> "postings"