parsing: tighten up dates, error messages, tests

Ledger/Dates.hs

@@ -259,20 +259,21 @@ ymd :: GenParser Char st SmartDate
 ymd = do
   y <- many1 digit
   datesepchar
-  m <- many1 digit
-  guard (read m <= 12)
+  m <- try (count 2 digit) <|> count 1 digit
+  guard (read m >= 1 && (read m <= 12))
+  -- when (read m < 1 || (read m > 12)) $ fail "bad month number specified"
   datesepchar
-  d <- many1 digit
-  guard (read d <= 31)
-  return (y,m,d)
+  d <- try (count 2 digit) <|> count 1 digit
+  when (read d < 1 || (read d > 31)) $ fail "bad day number specified"
+  return $ (y,m,d)
 
 ym :: GenParser Char st SmartDate
 ym = do
   y <- many1 digit
   guard (read y > 12)
   datesepchar
-  m <- many1 digit
-  guard (read m <= 12)
+  m <- try (count 2 digit) <|> count 1 digit
+  guard (read m >= 1 && (read m <= 12))
   return (y,m,"")
 
 y :: GenParser Char st SmartDate
@@ -289,11 +290,11 @@ d = do
 
 md :: GenParser Char st SmartDate
 md = do
-  m <- many1 digit
-  guard (read m <= 12)
+  m <- try (count 2 digit) <|> count 1 digit
+  guard (read m >= 1 && (read m <= 12))
   datesepchar
-  d <- many1 digit
-  guard (read d <= 31)
+  d <- try (count 2 digit) <|> count 1 digit
+  when (read d < 1 || (read d > 31)) $ fail "bad day number specified"
   return ("",m,d)
 
 months         = ["january","february","march","april","may","june",

Ledger/Parse.hs

@@ -290,7 +290,7 @@ ledgerHistoricalPrice = do
   char 'P' <?> "historical price"
   many spacenonewline
   date <- ledgerdate
-  many spacenonewline
+  many1 spacenonewline
   symbol1 <- commoditysymbol
   many spacenonewline
   (Mixed [Amount c q _]) <- someamount
@@ -313,11 +313,10 @@ ledgerDefaultYear = do
 ledgerTransaction :: GenParser Char LedgerFileCtx LedgerTransaction
 ledgerTransaction = do
   date <- ledgerdate <?> "transaction"
-  edate <- ledgereffectivedate
-  many1 spacenonewline
+  edate <- try (ledgereffectivedate <?> "effective date") <|> return Nothing
   status <- ledgerstatus
   code <- ledgercode
-  description <- liftM rstrip (many1 (noneOf ";\n") <?> "description")
+  description <- many1 spacenonewline >> liftM rstrip (many1 (noneOf ";\n") <?> "description")
   comment <- ledgercomment
   restofline
   postings <- ledgerpostings
@@ -326,22 +325,12 @@ ledgerTransaction = do
     Right t' -> return t'
     Left err -> fail err
 
-ledgereffectivedate :: GenParser Char LedgerFileCtx (Maybe Day)
-ledgereffectivedate = 
-    try (do
-          string "[="
-          edate <- ledgerdate
-          char ']'
-          return $ Just edate)
-    <|> return Nothing
-
 ledgerdate :: GenParser Char LedgerFileCtx Day
-ledgerdate = try ledgerfulldate <|> ledgerpartialdate
+ledgerdate = (try ledgerfulldate <|> ledgerpartialdate) <?> "full or partial date"
 
 ledgerfulldate :: GenParser Char LedgerFileCtx Day
 ledgerfulldate = do
   (y,m,d) <- ymd
-  many spacenonewline
   return $ fromGregorian (read y) (read m) (read d)
 
 -- | Match a partial M/D date in a ledger. Warning, this terminates the
@@ -349,7 +338,6 @@ ledgerfulldate = do
 ledgerpartialdate :: GenParser Char LedgerFileCtx Day
 ledgerpartialdate = do
   (_,m,d) <- md
-  many spacenonewline
   y <- getYear
   when (y==Nothing) $ fail "partial date found, but no default year specified"
   return $ fromGregorian (fromJust y) (read m) (read d)
@@ -363,15 +351,21 @@ ledgerdatetime = do
   s <- optionMaybe $ do
       char ':'
       many1 digit
-  many spacenonewline
   let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)
   return $ LocalTime day tod
 
+ledgereffectivedate :: GenParser Char LedgerFileCtx (Maybe Day)
+ledgereffectivedate = do
+  string "[="
+  edate <- ledgerdate
+  char ']'
+  return $ Just edate
+
 ledgerstatus :: GenParser Char st Bool
-ledgerstatus = try (do { char '*' <?> "status"; many1 spacenonewline; return True } ) <|> return False
+ledgerstatus = try (do { many1 spacenonewline; char '*' <?> "status"; return True } ) <|> return False
 
 ledgercode :: GenParser Char st String
-ledgercode = try (do { char '(' <?> "code"; code <- anyChar `manyTill` char ')'; many1 spacenonewline; return code } ) <|> return ""
+ledgercode = try (do { many1 spacenonewline; char '(' <?> "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
 
 -- Complicated to handle intermixed comment lines.. please make me better.
 ledgerpostings :: GenParser Char LedgerFileCtx [Posting]
@@ -560,6 +554,7 @@ timelogentry = do
   code <- oneOf "bhioO"
   many1 spacenonewline
   datetime <- ledgerdatetime
+  many1 spacenonewline
   comment <- liftM2 (++) getParentAccount restofline
   return $ TimeLogEntry (read [code]) datetime comment
 

tests/add-bad-date-fails.test

@@ -1,3 +1,4 @@
+# add should prompt again when it gets a bad date
 add
 <<<
 2009/1/32

tests/effective-day.test

@@ -0,0 +1,13 @@
+# 
+-f - print --effective
+<<<
+Y 2009
+
+2009/1/1[=1/2] x
+  a  1
+  b
+>>>
+2009/01/02 x
+    a             1
+    b            -1
+

tests/effective-print.test

@@ -4,7 +4,7 @@
   a  1
   b
 >>>
-2010/01/01  x
+2010/01/01 x
     a                                              1
     b
 

tests/effective-register.test

@@ -4,5 +4,5 @@
   a  1
   b
 >>>
-2010/01/01  x                   a                                 1            1
+2010/01/01 x                    a                                 1            1
                                 b                                -1            0

tests/print-long-account.test

@@ -0,0 +1,10 @@
+-f - print
+<<<
+2009/1/1 x
+ aaaaabbbbbcccccdddddeeeeefffffggggghhhhh   1
+ b
+>>>
+2009/01/01 x
+    aaaaabbbbbcccccdddddeeeeefffffggggghhhhh             1
+    b                                                   -1
+