feat: add time parsers

Author: drlkf

megaparsec-utils.cabal

@@ -19,6 +19,7 @@ extra-source-files:
 library
   exposed-modules:
       Lib
+      Text.Megaparsec.Time
       Text.Megaparsec.Utils
   other-modules:
       Paths_megaparsec_utils
@@ -27,15 +28,18 @@ library
   ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
   build-depends:
       base >=4.7 && <5
+    , extra
     , megaparsec
     , parser-combinators
+    , time
     , uuid
   default-language: Haskell2010
 
 test-suite megaparsec-utils-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      Text.Megaparsec.TimeSpec
       Text.Megaparsec.UtilsSpec
       Paths_megaparsec_utils
   hs-source-dirs:
@@ -44,9 +48,11 @@ test-suite megaparsec-utils-test
   build-depends:
       QuickCheck
     , base >=4.7 && <5
+    , extra
     , hspec
     , megaparsec
     , megaparsec-utils
     , parser-combinators
+    , time
     , uuid
   default-language: Haskell2010

package.yaml

@@ -13,8 +13,10 @@ description: Utilities for the Megaparsec library.
 
 dependencies:
   - base >= 4.7 && < 5
+  - extra
   - megaparsec
   - parser-combinators
+  - time
   - uuid
 
 ghc-options:

src/Text/Megaparsec/Time.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Text.Megaparsec.Time
+  ( dayParser
+  , timeParser
+  ) where
+
+import           Control.Monad             (replicateM, void)
+import           Control.Monad.Combinators (choice, some)
+import           Data.Functor              (($>))
+import           Data.Time                 (DayOfWeek (..), TimeOfDay (..))
+import           Data.Void                 (Void)
+import           Text.Megaparsec           (Parsec, try)
+import           Text.Megaparsec.Char      (char, digitChar, string')
+
+dayParser :: Parsec Void String (Either Int DayOfWeek)
+dayParser = choice
+  [ Right <$> shortDay
+  , Right <$> longDay
+  , Left <$> (try (string' "tomorrow") $> 1)
+  , Right <$> absoluteDay
+  , Left <$> relativeDay
+  ]
+  where shortDay = choice $ map (ciString (take 3 . show)) weekDays
+        longDay = choice $ map (ciString show) weekDays
+        ciString f d = try (string' (f d)) $> d
+        weekDays = [Monday .. Friday]
+        absoluteDay = toEnum . read <$> try (some digitChar)
+        relativeDay = char '+' >> read <$> try (some digitChar)
+
+timeParser :: Parsec Void String TimeOfDay
+timeParser = do
+  h <- read <$> replicateM 2 digitChar
+  void $ char ':'
+  m <- read <$> replicateM 2 digitChar
+
+  return $ TimeOfDay h m 0

test/Text/Megaparsec/TimeSpec.hs

@@ -0,0 +1,67 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Text.Megaparsec.TimeSpec
+  ( spec
+  ) where
+
+import           Control.Monad        (forM_)
+import           Data.Either          (isLeft)
+import           Data.List.Extra      (lower)
+import           Data.Time            (DayOfWeek (..), TimeOfDay (..),
+                                       defaultTimeLocale, formatTime)
+import           Test.Hspec           (Spec, context, describe, it, shouldBe,
+                                       shouldSatisfy)
+import           Test.QuickCheck      (Arbitrary (..), elements, forAll,
+                                       property, suchThat)
+import           Text.Megaparsec      (runParser)
+import           Text.Megaparsec.Time (dayParser, timeParser)
+import           Text.Printf          (printf)
+
+instance Arbitrary TimeOfDay where
+  arbitrary = TimeOfDay
+    <$> ((`mod` 24) . abs <$> arbitrary)
+    <*> ((`mod` 60) . abs <$> arbitrary)
+    <*> pure 0
+
+instance Arbitrary DayOfWeek where
+  arbitrary = elements [Monday .. Sunday]
+
+spec :: Spec
+spec = do
+  describe "day" $ do
+    let weekday d = d < Saturday
+
+    forM_
+      [ ("full", "%A")
+      , ("short", "%a")
+      ] $ \(title, format) ->
+      context title $ do
+      it "nominal" . forAll (arbitrary `suchThat` weekday) $ \d ->
+        runParser dayParser "day" (formatTime defaultTimeLocale format d) `shouldBe`
+        Right (Right d)
+
+      it "lowercase" . forAll (arbitrary `suchThat` weekday) $ \d ->
+        runParser dayParser "day" (lower (formatTime defaultTimeLocale format d)) `shouldBe`
+        Right (Right d)
+
+      it "weekend" . forAll (arbitrary `suchThat` (not . weekday)) $ \d ->
+        runParser dayParser "day" (formatTime defaultTimeLocale format d) `shouldSatisfy`
+        isLeft
+
+    context "tomorrow" $ do
+      it "capitalized" $
+        runParser dayParser "day" "Tomorrow "`shouldBe` Right (Left 1)
+
+      it "lowercase" $
+        runParser dayParser "day" "tomorrow "`shouldBe` Right (Left 1)
+
+    it "future day" . forAll (abs <$> arbitrary) $ \x ->
+      runParser dayParser "day" (printf "+%d" x) `shouldBe` Right (Left x)
+
+    it "invalid" . forAll (negate . (+1) . abs <$> arbitrary) $ \x ->
+      runParser dayParser "day" (printf "+%d" (x :: Int)) `shouldSatisfy` isLeft
+
+  describe "time" $ do
+    it "valid" . property $ \t ->
+      runParser timeParser "time" (formatTime defaultTimeLocale "%R" t) `shouldBe`
+      Right t