Skip to content

Commit a89bd88

Browse files
drlkfdrlkf
committed
feat: add duration parsers
1 parent 84857eb commit a89bd88

File tree

2 files changed

+119
-16
lines changed

2 files changed

+119
-16
lines changed

‎src/Text/Megaparsec/Time.hs

Lines changed: 38 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2,16 +2,25 @@
22

33
module Text.Megaparsec.Time
44
( dayParser
5+
, durationParser
6+
, hoursParser
7+
, minutesParser
8+
, secondsParser
59
, timeParser
610
) where
711

12+
import Control.Applicative (optional, (<|>))
813
import Control.Monad (replicateM, void)
914
import Control.Monad.Combinators (choice, some)
1015
import Data.Functor (($>))
11-
import Data.Time (DayOfWeek (..), TimeOfDay (..))
16+
import Data.Maybe (fromMaybe)
17+
import Data.Time (DayOfWeek (..), NominalDiffTime,
18+
TimeOfDay (..),
19+
secondsToNominalDiffTime)
1220
import Data.Void (Void)
1321
import Text.Megaparsec (Parsec, try)
14-
import Text.Megaparsec.Char (char, digitChar, string')
22+
import Text.Megaparsec.Char (char, digitChar, space, string')
23+
import Text.Megaparsec.Utils (posNumParser)
1524

1625
dayParser :: Parsec Void String (Either Int DayOfWeek)
1726
dayParser = choice
@@ -28,10 +37,37 @@ dayParser = choice
2837
absoluteDay = toEnum . read <$> try (some digitChar)
2938
relativeDay = char '+' >> read <$> try (some digitChar)
3039

40+
durationParser :: Parsec Void String NominalDiffTime
41+
durationParser = try hours <|> try minutes <|> secondsParser
42+
where hours = do
43+
h <- hoursParser <* space
44+
m <- fromMaybe zero <$> optional (try minutes)
45+
s <- fromMaybe zero <$> optional secondsParser
46+
47+
return $ h + m + s
48+
49+
minutes = do
50+
m <- minutesParser <* space
51+
s <- fromMaybe zero <$> optional secondsParser
52+
53+
return $ m + s
54+
55+
hoursParser :: Parsec Void String NominalDiffTime
56+
hoursParser = secondsToNominalDiffTime . (* 3600) <$> posNumParser <* char 'h'
57+
58+
minutesParser :: Parsec Void String NominalDiffTime
59+
minutesParser = secondsToNominalDiffTime . (* 60) <$> posNumParser <* char 'm'
60+
61+
secondsParser :: Parsec Void String NominalDiffTime
62+
secondsParser = secondsToNominalDiffTime <$> posNumParser <* optional (char 's')
63+
3164
timeParser :: Parsec Void String TimeOfDay
3265
timeParser = do
3366
h <- read <$> replicateM 2 digitChar
3467
void $ char ':'
3568
m <- read <$> replicateM 2 digitChar
3669

3770
return $ TimeOfDay h m 0
71+
72+
zero :: NominalDiffTime
73+
zero = secondsToNominalDiffTime 0

‎test/Text/Megaparsec/TimeSpec.hs

Lines changed: 81 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -5,27 +5,44 @@ module Text.Megaparsec.TimeSpec
55
) where
66

77
import Control.Monad (forM_)
8+
import Data.Bifunctor (Bifunctor (first))
89
import Data.Either (isLeft)
910
import Data.List.Extra (lower)
1011
import Data.Time (DayOfWeek (..), TimeOfDay (..),
11-
defaultTimeLocale, formatTime)
12+
defaultTimeLocale, formatTime,
13+
secondsToNominalDiffTime)
14+
import Data.Void (Void)
1215
import Test.Hspec (Spec, context, describe, it, shouldBe,
1316
shouldSatisfy)
14-
import Test.QuickCheck (Arbitrary (..), elements, forAll,
17+
import Test.QuickCheck (Arbitrary (..), Gen, elements, forAll,
1518
property, suchThat)
16-
import Text.Megaparsec (runParser)
17-
import Text.Megaparsec.Time (dayParser, timeParser)
19+
import Text.Megaparsec (Parsec, errorBundlePretty, runParser)
20+
import Text.Megaparsec.Time (dayParser, durationParser, hoursParser,
21+
minutesParser, secondsParser, timeParser)
1822
import Text.Printf (printf)
1923

2024
instance Arbitrary TimeOfDay where
21-
arbitrary = TimeOfDay
22-
<$> ((`mod` 24) . abs <$> arbitrary)
25+
arbitrary =
26+
(TimeOfDay . (`mod` 24) . abs
27+
<$> arbitrary)
2328
<*> ((`mod` 60) . abs <$> arbitrary)
2429
<*> pure 0
2530

2631
instance Arbitrary DayOfWeek where
2732
arbitrary = elements [Monday .. Sunday]
2833

34+
positive
35+
:: Num a
36+
=> Arbitrary a
37+
=> Gen a
38+
positive = abs <$> arbitrary
39+
40+
parseOrPrettyError
41+
:: Parsec Void String a
42+
-> String
43+
-> Either String a
44+
parseOrPrettyError p = first errorBundlePretty . runParser p "test"
45+
2946
spec :: Spec
3047
spec = do
3148
describe "day" $ do
@@ -37,31 +54,81 @@ spec = do
3754
] $ \(title, format) ->
3855
context title $ do
3956
it "nominal" . forAll (arbitrary `suchThat` weekday) $ \d ->
40-
runParser dayParser "day" (formatTime defaultTimeLocale format d) `shouldBe`
57+
parseOrPrettyError dayParser (formatTime defaultTimeLocale format d) `shouldBe`
4158
Right (Right d)
4259

4360
it "lowercase" . forAll (arbitrary `suchThat` weekday) $ \d ->
44-
runParser dayParser "day" (lower (formatTime defaultTimeLocale format d)) `shouldBe`
61+
parseOrPrettyError dayParser (lower (formatTime defaultTimeLocale format d)) `shouldBe`
4562
Right (Right d)
4663

4764
it "weekend" . forAll (arbitrary `suchThat` (not . weekday)) $ \d ->
48-
runParser dayParser "day" (formatTime defaultTimeLocale format d) `shouldSatisfy`
65+
parseOrPrettyError dayParser (formatTime defaultTimeLocale format d) `shouldSatisfy`
4966
isLeft
5067

5168
context "tomorrow" $ do
5269
it "capitalized" $
53-
runParser dayParser "day" "Tomorrow "`shouldBe` Right (Left 1)
70+
parseOrPrettyError dayParser "Tomorrow "`shouldBe` Right (Left 1)
5471

5572
it "lowercase" $
56-
runParser dayParser "day" "tomorrow "`shouldBe` Right (Left 1)
73+
parseOrPrettyError dayParser "tomorrow "`shouldBe` Right (Left 1)
5774

5875
it "future day" . forAll (abs <$> arbitrary) $ \x ->
59-
runParser dayParser "day" (printf "+%d" x) `shouldBe` Right (Left x)
76+
parseOrPrettyError dayParser (printf "+%d" x) `shouldBe` Right (Left x)
6077

6178
it "invalid" . forAll (negate . (+1) . abs <$> arbitrary) $ \x ->
62-
runParser dayParser "day" (printf "+%d" (x :: Int)) `shouldSatisfy` isLeft
79+
parseOrPrettyError dayParser (printf "+%d" (x :: Int)) `shouldSatisfy` isLeft
80+
81+
describe "duration" $ do
82+
it "hours" . forAll positive $ \h ->
83+
parseOrPrettyError hoursParser (printf "%dh" h) `shouldBe`
84+
Right (secondsToNominalDiffTime (fromInteger h * 3600))
85+
86+
it "minutes" . forAll positive $ \m ->
87+
parseOrPrettyError minutesParser (printf "%dm" m) `shouldBe`
88+
Right (secondsToNominalDiffTime (fromInteger m * 60))
89+
90+
context "seconds" $ do
91+
it "raw" . forAll positive $ \s ->
92+
parseOrPrettyError secondsParser (printf "%d" s) `shouldBe`
93+
Right (secondsToNominalDiffTime (fromInteger s))
94+
95+
it "with suffix" . forAll positive $ \s ->
96+
parseOrPrettyError secondsParser (printf "%ds" s) `shouldBe`
97+
Right (secondsToNominalDiffTime (fromInteger s))
98+
99+
context "duration" $ do
100+
context "hours" $ do
101+
it "hms" . forAll ((,,) <$> positive <*> positive <*> positive) $ \(h, m, s) ->
102+
parseOrPrettyError durationParser (printf "%dh %dm %ds" h m s) `shouldBe`
103+
Right (secondsToNominalDiffTime (fromInteger (((h * 60 + m) * 60) + s)))
104+
105+
it "hm" . forAll ((,) <$> positive <*> positive) $ \(h, m) ->
106+
parseOrPrettyError durationParser (printf "%dh %dm" h m) `shouldBe`
107+
Right (secondsToNominalDiffTime (fromInteger ((h * 60 + m) * 60)))
108+
109+
it "hs" . forAll ((,) <$> positive <*> positive) $ \(h, s) ->
110+
parseOrPrettyError durationParser (printf "%dh %ds" h s) `shouldBe`
111+
Right (secondsToNominalDiffTime (fromInteger (h * 3600 + s)))
112+
113+
context "minutes" $ do
114+
it "ms" . forAll ((,) <$> positive <*> positive) $ \(m, s) ->
115+
parseOrPrettyError durationParser (printf "%dm%ds" m s) `shouldBe`
116+
Right (secondsToNominalDiffTime (fromInteger (m * 60 + s)))
117+
118+
it "m" . forAll positive $ \m ->
119+
parseOrPrettyError durationParser (printf "%dm" m) `shouldBe`
120+
Right (secondsToNominalDiffTime (fromInteger (m * 60)))
121+
122+
context "seconds" $ do
123+
it "s" . forAll positive $ \s ->
124+
parseOrPrettyError durationParser (printf "%ds" s) `shouldBe`
125+
Right (secondsToNominalDiffTime (fromInteger s))
126+
127+
it "no suffix" . forAll positive $ \s ->
128+
parseOrPrettyError durationParser (show s) `shouldBe`
129+
Right (secondsToNominalDiffTime (fromInteger s))
63130

64131
describe "time" $ do
65132
it "valid" . property $ \t ->
66-
runParser timeParser "time" (formatTime defaultTimeLocale "%R" t) `shouldBe`
133+
parseOrPrettyError timeParser (formatTime defaultTimeLocale "%R" t) `shouldBe`
67134
Right t

0 commit comments

Comments
 (0)