lib: refactor date parser

hledger-lib/Hledger/Read/Common.hs

@@ -105,7 +105,6 @@ import Data.Default
 import Data.Functor.Identity
 import Data.List.Compat
 import Data.List.NonEmpty (NonEmpty(..))
-import Data.List.Split (wordsBy)
 import Data.Maybe
 import qualified Data.Map as M
 import Data.Text (Text)
@@ -116,6 +115,7 @@ import Data.Void (Void)
 import System.Time (getClockTime)
 import Text.Megaparsec
 import Text.Megaparsec.Char
+import Text.Megaparsec.Char.Lexer (decimal)
 
 import Hledger.Data
 import Hledger.Utils
@@ -366,28 +366,39 @@ datep = do
   lift $ datep' myear
 
 datep' :: Maybe Year -> TextParser m Day
-datep' myear = do
+datep' mYear = do
-  -- hacky: try to ensure precise errors for invalid dates
+  d1 <- decimal <?> "year or month"
-  -- XXX reported error position is not too good
+  sep <- satisfy isDateSepChar <?> "date separator"
-  -- pos <- genericSourcePos <$> getPosition
+  d2 <- decimal <?> "month or day"
-  datestr <- do
+  fullDate d1 sep d2 <|> partialDate mYear d1 sep d2
-    c <- digitChar
-    cs <- many $ choice' [digitChar, datesepchar]
-    return $ c:cs
-  let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr
-  when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr
-  let dateparts = wordsBy (`elem` datesepchars) datestr
-  [y,m,d] <- case (dateparts, myear) of
-              ([m,d],Just y)  -> return [show y,m,d]
-              ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"
-              ([y,m,d],_)     -> return [y,m,d]
-              _               -> fail $ "bad date: " ++ datestr
-  let maybedate = fromGregorianValid (read y) (read m) (read d)
-  case maybedate of
-    Nothing   -> fail $ "bad date: " ++ datestr
-    Just date -> return date
   <?> "full or partial date"
 
+  where
+
+  fullDate :: Integer -> Char -> Integer -> TextParser m Day
+  fullDate year sep1 month = do
+    sep2 <- satisfy isDateSepChar <?> "date separator"
+    day <- decimal <?> "day"
+    let dateStr = show year ++ [sep1] ++ show month ++ [sep2] ++ show day
+
+    when (sep1 /= sep2) $ fail $
+      "invalid date (mixing date separators is not allowed): " ++ dateStr
+
+    case fromGregorianValid year (fromIntegral month) day of
+      Nothing -> fail $ "well-formed but invalid date: " ++ dateStr
+      Just date -> pure date
+
+  partialDate :: Maybe Year -> Integer -> Char -> Integer -> TextParser m Day
+  partialDate mYear month sep day = case mYear of
+    Just year ->
+      case fromGregorianValid year (fromIntegral month) (fromIntegral day) of
+        Nothing -> fail $ "well-formed but invalid date: " ++ dateStr
+        Just date -> pure date
+      where dateStr = show year ++ [sep] ++ show month ++ [sep] ++ show day
+    Nothing -> fail $
+      "partial date "++dateStr++" found, but the current year is unknown"
+      where dateStr = show month ++ [sep] ++ show day
+
 -- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format.
 -- Hyphen (-) and period (.) are also allowed as date separators.
 -- The year may be omitted if a default year has been set.
@@ -1040,13 +1051,13 @@ bracketedpostingdatesp mdefdate = do
 -- Left ...not a bracketed date...
 --
 -- >>> first parseErrorPretty $ rtp (bracketeddatetagsp Nothing) "[2016/1/32]"
--- Left ...1:11:...bad date: 2016/1/32...
+-- Left ...1:11:...well-formed but invalid date: 2016/1/32...
 --
 -- >>> first parseErrorPretty $ rtp (bracketeddatetagsp Nothing) "[1/31]"
 -- Left ...1:6:...partial date 1/31 found, but the current year is unknown...
 --
 -- >>> first parseErrorPretty $ rtp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"
--- Left ...1:15:...bad date, different separators...
+-- Left ...1:13:...expecting month or day...
 --
 bracketeddatetagsp :: Maybe Day -> SimpleTextParser [(TagName, Day)]
 bracketeddatetagsp mdefdate = do

tests/journal/dates.test

@@ -5,7 +5,7 @@ hledger -f- print
 2010/31/12 x
    a  1
    b
->>>2 /bad date/
+>>>2 /invalid date/
 >>>= 1
 # 2. too-large day
 hledger -f- print
@@ -13,7 +13,7 @@ hledger -f- print
 2010/12/32 x
    a  1
    b
->>>2 /bad date/
+>>>2 /invalid date/
 >>>= 1
 # 3. 29th feb on leap year should be ok
 hledger -f- print
@@ -33,7 +33,7 @@ hledger -f- print
 2001/2/29 x
    a  1
    b
->>>2 /bad date/
+>>>2 /invalid date/
 >>>= 1
 # 5. dates must be followed by whitespace or newline
 hledger -f- print

tests/journal/posting-dates.test

@@ -50,5 +50,5 @@ end comment
 2000/1/2
    b  0   ; [1/1=1/2/3/4] bad second date, should error
 
->>>2 /9:25/
+>>>2 /9:23/
 >>>=1