feat: add gregorian day parser

Author: drlkf

src/Text/Megaparsec/Time.hs

@@ -4,6 +4,7 @@ module Text.Megaparsec.Time
   ( dateParser
   , dayParser
   , durationParser
+  , gregorianDayParser
   , hoursParser
   , minutesParser
   , secondsParser
@@ -16,11 +17,12 @@ import           Control.Monad.Combinators (choice, some)
 import           Data.Functor              (($>))
 import           Data.List.Extra           (lower)
 import           Data.Maybe                (fromMaybe)
-import           Data.Time                 (DayOfWeek (..), NominalDiffTime,
-                                            TimeOfDay (..),
+import           Data.Time                 (Day, DayOfWeek (..),
+                                            NominalDiffTime, TimeOfDay (..),
+                                            defaultTimeLocale, parseTimeM,
                                             secondsToNominalDiffTime)
 import           Data.Void                 (Void)
-import           Text.Megaparsec           (Parsec, try)
+import           Text.Megaparsec           (Parsec, takeRest, try)
 import           Text.Megaparsec.Char      (char, digitChar, space, space1,
                                             string')
 import           Text.Megaparsec.Utils     (posNumParser)
@@ -61,6 +63,12 @@ durationParser = try hours <|> try minutes <|> secondsParser
 
           return $ m + s
 
+gregorianDayParser :: Parsec Void String Day
+gregorianDayParser = do
+  s <- takeRest
+  parseTimeM False defaultTimeLocale "%F" s <|>
+    parseTimeM False defaultTimeLocale "%d/%m/%Y" s
+
 hoursParser :: Parsec Void String NominalDiffTime
 hoursParser = secondsToNominalDiffTime . (* 3600) <$> posNumParser <* char 'h'
 

test/Text/Megaparsec/TimeSpec.hs

@@ -8,18 +8,18 @@ import           Control.Monad        (forM_)
 import           Data.Bifunctor       (Bifunctor (first))
 import           Data.Either          (isLeft)
 import           Data.List.Extra      (lower)
-import           Data.Time            (DayOfWeek (..), TimeOfDay (..),
+import           Data.Time            (Day, DayOfWeek (..), TimeOfDay (..),
                                        defaultTimeLocale, formatTime,
-                                       secondsToNominalDiffTime)
+                                       fromGregorian, secondsToNominalDiffTime)
 import           Data.Void            (Void)
 import           Test.Hspec           (Spec, context, describe, it, shouldBe,
                                        shouldSatisfy)
 import           Test.QuickCheck      (Arbitrary (..), Gen, elements, forAll,
                                        property, suchThat)
 import           Text.Megaparsec      (Parsec, errorBundlePretty, runParser)
 import           Text.Megaparsec.Time (dateParser, dayParser, durationParser,
-                                       hoursParser, minutesParser,
-                                       secondsParser, timeParser)
+                                       gregorianDayParser, hoursParser,
+                                       minutesParser, secondsParser, timeParser)
 import           Text.Printf          (printf)
 
 instance Arbitrary TimeOfDay where
@@ -32,6 +32,12 @@ instance Arbitrary TimeOfDay where
 instance Arbitrary DayOfWeek where
   arbitrary = elements [Monday .. Sunday]
 
+instance Arbitrary Day where
+  arbitrary = fromGregorian
+    <$> elements [1970 .. 2100]
+    <*> elements [1 .. 12]
+    <*> arbitrary
+
 positive
   :: Num a
   => Arbitrary a
@@ -156,6 +162,12 @@ spec = do
           parseOrPrettyError durationParser (show s) `shouldBe`
           Right (secondsToNominalDiffTime (fromInteger s))
 
+  describe "gregorian day" $ do
+    forM_ ["%F", "%d/%m/%Y"] $ \format ->
+      it format . property $ \d ->
+        parseOrPrettyError gregorianDayParser (formatTime defaultTimeLocale format d) `shouldBe`
+        Right d
+
   describe "time" $ do
     it "valid" . property $ \t ->
       parseOrPrettyError timeParser (formatTime defaultTimeLocale "%R" t) `shouldBe`