Skip to content

Commit 64f3229

Browse files
drlkfdrlkf
committed
fix: fix date parser with day short names
1 parent 7365b4e commit 64f3229

File tree

4 files changed

+55
-28
lines changed

4 files changed

+55
-28
lines changed

‎src/Text/Megaparsec/Time.hs

Lines changed: 13 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ import Control.Applicative (optional, (<|>))
1414
import Control.Monad (replicateM, void)
1515
import Control.Monad.Combinators (choice, some)
1616
import Data.Functor (($>))
17+
import Data.List.Extra (lower)
1718
import Data.Maybe (fromMaybe)
1819
import Data.Time (DayOfWeek (..), NominalDiffTime,
1920
TimeOfDay (..),
@@ -31,19 +32,19 @@ dateParser = (,) <$> optional (try (dayParser <* space1)) <*> timeParser
3132

3233
dayParser :: Parsec Void String DayResult
3334
dayParser = choice
34-
[ Right <$> shortDay
35-
, Right <$> longDay
36-
, Left <$> (try (string' "yesterday") $> -1)
37-
, Left <$> (try (string' "tomorrow") $> 1)
35+
[ Right <$> longDay
36+
, Right <$> shortDay
37+
, Left <$> (string' "yesterday" $> -1)
38+
, Left <$> (string' "tomorrow" $> 1)
3839
, Right <$> absoluteDay
39-
, Left <$> relativeDay
40-
]
41-
where shortDay = choice $ map (ciString (take 3 . show)) weekDays
42-
longDay = choice $ map (ciString show) weekDays
43-
ciString f d = try (string' (f d)) $> d
44-
weekDays = [Monday .. Friday]
45-
absoluteDay = toEnum . read <$> try (some digitChar)
46-
relativeDay = char '+' >> read <$> try (some digitChar)
40+
, Left <$> relativeDay
41+
] where shortDay = choice $ map (ciString (lower . take 3 . show)) weekDays
42+
longDay = choice $ map (ciString (lower . show)) weekDays
43+
ciString f d = try (string' (f d)) $> d
44+
weekDays = [Monday .. Friday]
45+
sign = (char '-' $> negate) <|> (char '+' $> id)
46+
absoluteDay = toEnum . read <$> some digitChar
47+
relativeDay = ($) <$> sign <*> (read <$> some digitChar)
4748

4849
durationParser :: Parsec Void String NominalDiffTime
4950
durationParser = try hours <|> try minutes <|> secondsParser

‎src/Text/Megaparsec/Utils.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -62,7 +62,7 @@ occurrence p = go
6262

6363
-- | Parse all occurrences of a given parser.
6464
occurrences :: Parsec Void String a -> Parsec Void String [a]
65-
occurrences = some . try . occurrence
65+
occurrences = some . try . occurrence . try
6666

6767
-- | Parse a positive number with decimals.
6868
posDecNumParser :: Parsec Void String Double

‎test/Text/Megaparsec/TimeSpec.hs

Lines changed: 19 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -51,7 +51,25 @@ spec = do
5151
parseOrPrettyError dateParser "11:03" `shouldBe`
5252
Right (Nothing, TimeOfDay 11 3 0)
5353

54-
it "with day" $
54+
context "with day" $ do
55+
it "short" $
56+
parseOrPrettyError dateParser "tue 11:03" `shouldBe`
57+
Right (Just (Right Tuesday), TimeOfDay 11 3 0)
58+
59+
it "long" $
60+
parseOrPrettyError dateParser "tuesday 11:03" `shouldBe`
61+
Right (Just (Right Tuesday), TimeOfDay 11 3 0)
62+
63+
context "with rel day" $ do
64+
it "positive" $
65+
parseOrPrettyError dateParser "+1 11:03" `shouldBe`
66+
Right (Just (Left 1), TimeOfDay 11 3 0)
67+
68+
it "negative" $
69+
parseOrPrettyError dateParser "-1 11:03" `shouldBe`
70+
Right (Just (Left (-1)), TimeOfDay 11 3 0)
71+
72+
it "with yesterday" $
5573
parseOrPrettyError dateParser "yesterday 11:03" `shouldBe`
5674
Right (Just (Left (-1)), TimeOfDay 11 3 0)
5775

‎test/Text/Megaparsec/UtilsSpec.hs

Lines changed: 22 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ module Text.Megaparsec.UtilsSpec
77
import Control.Applicative (some)
88
import Control.Applicative.Combinators (choice)
99
import Control.Monad (void)
10+
import Data.Bifunctor (first)
1011
import Data.Char (isAlphaNum, toUpper)
1112
import Data.Either (isLeft)
1213
import Data.List (intercalate)
@@ -19,7 +20,8 @@ import Test.Hspec (Expectation, Spec, SpecWith,
1920
import Test.QuickCheck (Arbitrary (..), Gen, elements,
2021
forAll, listOf, listOf1,
2122
property, suchThat)
22-
import Text.Megaparsec (Parsec, eof, parseMaybe,
23+
import Text.Megaparsec (Parsec, eof,
24+
errorBundlePretty, parseMaybe,
2325
runParser)
2426
import Text.Megaparsec.Char (alphaNumChar, char, digitChar,
2527
string)
@@ -101,6 +103,12 @@ exhaustive f = foldl1 (>>) $ mkIt <$> values
101103
instance Arbitrary a => Arbitrary (NonEmpty a) where
102104
arbitrary = (:|) <$> arbitrary <*> arbitrary
103105

106+
parseOrPrettyError
107+
:: Parsec Void String a
108+
-> String
109+
-> Either String a
110+
parseOrPrettyError p = first errorBundlePretty . runParser p "test"
111+
104112
spec :: Spec
105113
spec = do
106114
describe "parsers" $ do
@@ -146,57 +154,57 @@ spec = do
146154
describe "occurrence" $ do
147155
it "SomeData" . forAll input $ \(prefix, v, suffix) -> do
148156
let s = unwords [prefix, show (v :: SomeData), suffix]
149-
runParser (occurrence someDataParser) "test" s `shouldBe` Right v
157+
parseOrPrettyError (occurrence someDataParser) s `shouldBe` Right v
150158

151159
it "SomeEnum" . forAll input $ \(prefix, v, suffix) -> do
152160
let s = unwords [prefix, show (v :: SomeEnum), suffix]
153-
runParser (occurrence someEnumParser) "test" s `shouldBe` Right v
161+
parseOrPrettyError (occurrence someEnumParser) s `shouldBe` Right v
154162

155163
it "SomeADT" . forAll input $ \(prefix, v, suffix) -> do
156164
let s = unwords [prefix, show (v :: SomeADT), suffix]
157-
runParser (occurrence someADTParser) "test" s `shouldBe` Right v
165+
parseOrPrettyError (occurrence someADTParser) s `shouldBe` Right v
158166

159167
describe "occurrences" $ do
160168
it "SomeData" . forAll input $ \(prefix, v, suffix) -> do
161169
let s = unwords [prefix, show (v :: SomeData), suffix]
162-
runParser (occurrences someDataParser) "test" s `shouldBe` Right [v]
170+
parseOrPrettyError (occurrences someDataParser) s `shouldBe` Right [v]
163171

164172
context "SomeEnum" $ do
165173
it "words" . forAll input $ \(prefix, v, suffix) -> do
166174
let s = unwords [prefix, show (v :: SomeEnum), suffix]
167-
runParser (occurrences someEnumParser) "test" s `shouldBe` Right [v]
175+
parseOrPrettyError (occurrences someEnumParser) s `shouldBe` Right [v]
168176

169177
it "with partial" $
170-
runParser (occurrences someEnumParser) "test" "a [Some] SomeA yo" `shouldBe`
178+
parseOrPrettyError (occurrences someEnumParser) "a [Some] SomeA yo" `shouldBe`
171179
Right [SomeA]
172180

173181
it "SomeADT" . forAll input $ \(prefix, v, suffix) -> do
174182
let s = unwords [prefix, show (v :: SomeADT), suffix]
175-
runParser (occurrences someADTParser) "test" s `shouldBe` Right [v]
183+
parseOrPrettyError (occurrences someADTParser) s `shouldBe` Right [v]
176184

177185
describe "comma-separated" $ do
178186
context "valid" $ do
179187
it "single" . property $ \x -> do
180188
let y = abs x
181-
runParser (commaSeparated numParser) "test" (show y)
189+
parseOrPrettyError (commaSeparated numParser) (show y)
182190
`shouldBe` Right (y :| [])
183191

184192
it "multiple" . property $ \xs -> do
185193
let ys = fmap abs xs
186194
s = intercalate "," . map show $ N.toList ys
187-
runParser (commaSeparated numParser) "test" s
195+
parseOrPrettyError (commaSeparated numParser) s
188196
`shouldBe` Right ys
189197

190198
context "invalid" $ do
191199
it "empty" $
192-
runParser (commaSeparated numParser) "test" "" `shouldSatisfy` isLeft
200+
parseOrPrettyError (commaSeparated numParser) "" `shouldSatisfy` isLeft
193201

194202
it "first" $
195-
runParser (commaSeparated numParser) "test" "abc,42" `shouldSatisfy` isLeft
203+
parseOrPrettyError (commaSeparated numParser) "test" `shouldSatisfy` isLeft
196204

197205
it "first partially correct" $
198-
runParser (commaSeparated (numParser <* eof)) "test" "42abc,42"
206+
parseOrPrettyError (commaSeparated (numParser <* eof)) "test"
199207
`shouldSatisfy` isLeft
200208

201209
it "second" $
202-
runParser (commaSeparated numParser) "test" "42,abc" `shouldSatisfy` isLeft
210+
parseOrPrettyError (commaSeparated numParser) "test" `shouldSatisfy` isLeft

0 commit comments

Comments
 (0)