on master help sign in
Merge pull request #698 from phadej/time-compat-and-monad-fail

Use time-compat and fix MonadFail breakages

commit6c5cc1d0f15117964a6a500300c498dcdf0c7822 authorAdam Bergmark <adam@bergmark.nl> dateSat 18 May 2019, 15:34 (7 years ago) parent2a3fd2218be733
12 files changed+179−35
Data/Aeson/Types/FromJSON.hs+40−4 Data/Aeson/Types/Internal.hs+7 Data/Aeson/Types/ToJSON.hs+49−3 aeson.cabal+5−4 benchmarks/aeson-benchmarks.cabal+1 stack-bench.yaml+8−1 stack-ffi-unescape.yaml+6−1 stack-lts12.yaml+5 stack-nightly.yaml+2 tests/PropertyRoundTrip.hs+7 tests/SerializationFormatSpec.hs+47−19 tests/UnitTests.hs+2−3
Data/Aeson/Types/FromJSON.hs+40−4
@@ -87,7 +87,7 @@ import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
8787import Data.Aeson.Types.Generic
8888import Data.Aeson.Types.Internal
8989import Data.Bits (unsafeShiftR)
90−import Data.Fixed (Fixed, HasResolution)
90+import Data.Fixed (Fixed, HasResolution (resolution), Nano)
9191import Data.Functor.Compose (Compose(..))
9292import Data.Functor.Identity (Identity(..))
9393import Data.Functor.Product (Product(..))
@@ -103,8 +103,10 @@ import Data.Scientific (Scientific, base10Exponent)
103103import Data.Tagged (Tagged(..))
104104import Data.Text (Text, pack, unpack)
105105import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
106−import Data.Time.Format (parseTime)
107−import Data.Time.Locale.Compat (defaultTimeLocale)
106+import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))
107+import Data.Time.LocalTime.Compat (CalendarDiffTime (..))
108+import Data.Time.Clock.System.Compat (SystemTime (..))
109+import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)
108110import Data.Traversable as Tr (sequence)
109111import Data.Vector (Vector)
110112import Data.Version (Version, parseVersion)
@@ -1914,7 +1916,7 @@ instance FromJSON DotNetTime where
19141916 parseJSON = withText "DotNetTime" $ \t ->
19151917 let (s,m) = T.splitAt (T.length t - 5) t
19161918 t' = T.concat [s,".",m]
1917− in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
1919+ in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
19181920 Just d -> pure (DotNetTime d)
19191921 _ -> fail "could not parse .NET time"
19201922 {-# INLINE parseJSON #-}
@@ -2008,6 +2010,40 @@ instance FromJSON DiffTime where
20082010 parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac
20092011 {-# INLINE parseJSON #-}
20102012
2013+instance FromJSON SystemTime where
2014+ parseJSON v = prependContext "SystemTime" $ do
2015+ n <- parseJSON v
2016+ let n' = floor (n * fromInteger (resolution n) :: Nano)
2017+ let (secs, nano) = n' `divMod` resolution n
2018+ return (MkSystemTime (fromInteger secs) (fromInteger nano))
2019+
2020+instance FromJSON CalendarDiffTime where
2021+ parseJSON = withObject "CalendarDiffTime" $ \obj -> CalendarDiffTime
2022+ <$> obj .: "months"
2023+ <*> obj .: "time"
2024+
2025+instance FromJSON CalendarDiffDays where
2026+ parseJSON = withObject "CalendarDiffDays" $ \obj -> CalendarDiffDays
2027+ <$> obj .: "months"
2028+ <*> obj .: "days"
2029+
2030+instance FromJSON DayOfWeek where
2031+ parseJSON = withText "DaysOfWeek" parseDayOfWeek
2032+
2033+parseDayOfWeek :: T.Text -> Parser DayOfWeek
2034+parseDayOfWeek t = case T.toLower t of
2035+ "monday" -> return Monday
2036+ "tuesday" -> return Tuesday
2037+ "wednesday" -> return Wednesday
2038+ "thursday" -> return Thursday
2039+ "friday" -> return Friday
2040+ "saturday" -> return Saturday
2041+ "sunday" -> return Sunday
2042+ _ -> fail "Invalid week day"
2043+
2044+instance FromJSONKey DayOfWeek where
2045+ fromJSONKey = FromJSONKeyTextParser parseDayOfWeek
2046+
20112047-------------------------------------------------------------------------------
20122048-- base Monoid/Semigroup
20132049-------------------------------------------------------------------------------
Data/Aeson/Types/Internal.hs+7
@@ -158,8 +158,10 @@ instance Monad IResult where
158158 IError path err >>= _ = IError path err
159159 {-# INLINE (>>=) #-}
160160
161+#if !(MIN_VERSION_base(4,13,0))
161162 fail = Fail.fail
162163 {-# INLINE fail #-}
164+#endif
163165
164166instance Fail.MonadFail IResult where
165167 fail err = IError [] err
@@ -173,8 +175,10 @@ instance Monad Result where
173175 Error err >>= _ = Error err
174176 {-# INLINE (>>=) #-}
175177
178+#if !(MIN_VERSION_base(4,13,0))
176179 fail = Fail.fail
177180 {-# INLINE fail #-}
181+#endif
178182
179183instance Fail.MonadFail Result where
180184 fail err = Error err
@@ -288,8 +292,11 @@ instance Monad Parser where
288292 {-# INLINE (>>=) #-}
289293 return = pure
290294 {-# INLINE return #-}
295+
296+#if !(MIN_VERSION_base(4,13,0))
291297 fail = Fail.fail
292298 {-# INLINE fail #-}
299+#endif
293300
294301instance Fail.MonadFail Parser where
295302 fail msg = Parser $ \path kf _ks -> kf (reverse path) msg
Data/Aeson/Types/ToJSON.hs+49−3
@@ -69,7 +69,7 @@ import Data.Aeson.Types.Internal
6969import Data.Attoparsec.Number (Number(..))
7070import Data.Bits (unsafeShiftR)
7171import Data.DList (DList)
72−import Data.Fixed (Fixed, HasResolution)
72+import Data.Fixed (Fixed, HasResolution, Nano)
7373import Data.Foldable (toList)
7474import Data.Functor.Compose (Compose(..))
7575import Data.Functor.Contravariant (Contravariant (..))
@@ -86,8 +86,10 @@ import Data.Scientific (Scientific)
8686import Data.Tagged (Tagged(..))
8787import Data.Text (Text, pack)
8888import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
89−import Data.Time.Format (FormatTime, formatTime)
90−import Data.Time.Locale.Compat (defaultTimeLocale)
89+import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))
90+import Data.Time.LocalTime.Compat (CalendarDiffTime (..))
91+import Data.Time.Clock.System.Compat (SystemTime (..))
92+import Data.Time.Format.Compat (FormatTime, formatTime, defaultTimeLocale)
9193import Data.Vector (Vector)
9294import Data.Version (Version, showVersion)
9395import Data.Void (Void, absurd)
@@ -2029,6 +2031,50 @@ instance ToJSON DiffTime where
20292031 toEncoding = E.scientific . realToFrac
20302032 {-# INLINE toEncoding #-}
20312033
2034+-- | Encoded as number
2035+instance ToJSON SystemTime where
2036+ toJSON (MkSystemTime secs nsecs) =
2037+ toJSON (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)
2038+ toEncoding (MkSystemTime secs nsecs) =
2039+ toEncoding (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)
2040+
2041+instance ToJSON CalendarDiffTime where
2042+ toJSON (CalendarDiffTime m nt) = object
2043+ [ "months" .= m
2044+ , "time" .= nt
2045+ ]
2046+ toEncoding (CalendarDiffTime m nt) = E.pairs
2047+ ("months" .= m <> "time" .= nt)
2048+
2049+instance ToJSON CalendarDiffDays where
2050+ toJSON (CalendarDiffDays m d) = object
2051+ [ "months" .= m
2052+ , "days" .= d
2053+ ]
2054+ toEncoding (CalendarDiffDays m d) = E.pairs
2055+ ("months" .= m <> "days" .= d)
2056+
2057+instance ToJSON DayOfWeek where
2058+ toJSON Monday = "monday"
2059+ toJSON Tuesday = "tuesday"
2060+ toJSON Wednesday = "wednesday"
2061+ toJSON Thursday = "thursday"
2062+ toJSON Friday = "friday"
2063+ toJSON Saturday = "saturday"
2064+ toJSON Sunday = "sunday"
2065+
2066+toEncodingDayOfWeek :: DayOfWeek -> E.Encoding' Text
2067+toEncodingDayOfWeek Monday = E.unsafeToEncoding "\"monday\""
2068+toEncodingDayOfWeek Tuesday = E.unsafeToEncoding "\"tuesday\""
2069+toEncodingDayOfWeek Wednesday = E.unsafeToEncoding "\"wednesday\""
2070+toEncodingDayOfWeek Thursday = E.unsafeToEncoding "\"thursday\""
2071+toEncodingDayOfWeek Friday = E.unsafeToEncoding "\"friday\""
2072+toEncodingDayOfWeek Saturday = E.unsafeToEncoding "\"saturday\""
2073+toEncodingDayOfWeek Sunday = E.unsafeToEncoding "\"sunday\""
2074+
2075+instance ToJSONKey DayOfWeek where
2076+ toJSONKey = toJSONKeyTextEnc toEncodingDayOfWeek
2077+
20322078-------------------------------------------------------------------------------
20332079-- base Monoid/Semigroup
20342080-------------------------------------------------------------------------------
aeson.cabal+5−4
@@ -113,7 +113,8 @@ library
113113
114114 -- Compat
115115 build-depends:
116− base-compat >= 0.9.1 && < 0.11
116+ base-compat >= 0.9.1 && < 0.11,
117+ time-compat >= 1.9.2.2 && < 1.10
117118
118119 if flag(bytestring-builder)
119120 build-depends: bytestring >= 0.9.2 && < 0.10.4,
@@ -211,7 +212,7 @@ test-suite tests
211212 UnitTests.NullaryConstructors
212213
213214 build-depends:
214− QuickCheck >= 2.10.0.1 && < 2.13,
215+ QuickCheck >= 2.10.0.1 && < 2.14,
215216 aeson,
216217 integer-logarithms >= 1 && <1.1,
217218 attoparsec,
@@ -236,11 +237,11 @@ test-suite tests
236237 tasty-quickcheck,
237238 text,
238239 time,
239− time-locale-compat,
240+ time-compat,
240241 unordered-containers,
241242 uuid-types,
242243 vector,
243− quickcheck-instances >= 0.3.16
244+ quickcheck-instances >= 0.3.21 && <0.4
244245
245246 if flag(bytestring-builder)
246247 build-depends: bytestring >= 0.9 && < 0.10.4,
benchmarks/aeson-benchmarks.cabal+1
@@ -46,6 +46,7 @@ library
4646 template-haskell >= 2.4,
4747 text >= 1.2.3,
4848 th-abstraction >= 0.2.2 && < 0.4,
49+ time-compat,
4950 time,
5051 transformers,
5152 unordered-containers >= 0.2.3.0,
stack-bench.yaml+8−1
@@ -1,4 +1,4 @@
1−resolver: lts-12.10
1+resolver: lts-12.26
22# We use aeson in the snapshot to
33# - avoid recompilation of criterion
44# - compare against it
@@ -9,3 +9,10 @@ resolver: lts-12.10
99work-dir: .stack-work-bench
1010packages:
1111- benchmarks
12+extra-deps:
13+- base-orphans-0.8.1
14+- hashable-time-0.2.0.1
15+- QuickCheck-2.13.1
16+- quickcheck-instances-0.3.21
17+- splitmix-0.0.2
18+- time-compat-1.9.2.2
stack-ffi-unescape.yaml+6−1
@@ -1,4 +1,4 @@
1−resolver: lts-12.10
1+resolver: lts-12.26
22packages:
33- '.'
44flags:
@@ -6,4 +6,9 @@ flags:
66 fast: true
77 cffi: true
88extra-deps:
9+- base-orphans-0.8.1
910- hashable-time-0.2.0.1
11+- QuickCheck-2.13.1
12+- quickcheck-instances-0.3.21
13+- splitmix-0.0.2
14+- time-compat-1.9.2.2
stack-lts12.yaml+5
@@ -7,4 +7,9 @@ flags:
77 fast: true
88 cffi: true
99extra-deps:
10+- base-orphans-0.8.1
1011- hashable-time-0.2.0.1
12+- QuickCheck-2.13.1
13+- quickcheck-instances-0.3.21
14+- splitmix-0.0.2
15+- time-compat-1.9.2.2
stack-nightly.yaml+2
@@ -9,3 +9,5 @@ flags:
99 fast: true
1010extra-deps:
1111- hlint-2.1.18
12+- time-compat-1.9.2.2
13+- quickcheck-instances-0.3.21
tests/PropertyRoundTrip.hs+7
@@ -14,6 +14,9 @@ import Data.Sequence (Seq)
1414import Data.Tagged (Tagged)
1515import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
1616import Data.Version (Version)
17+import Data.Time.Calendar.Compat (CalendarDiffDays, DayOfWeek)
18+import Data.Time.LocalTime.Compat (CalendarDiffTime)
19+import Data.Time.Clock.System.Compat (SystemTime)
1720import Instances ()
1821import Numeric.Natural (Natural)
1922import Test.Tasty (TestTree, testGroup)
@@ -47,6 +50,10 @@ roundTripTests =
4750 , testProperty "ZonedTime" $ roundTripEq (undefined :: ZonedTime)
4851 , testProperty "NominalDiffTime" $ roundTripEq (undefined :: NominalDiffTime)
4952 , testProperty "DiffTime" $ roundTripEq (undefined :: DiffTime)
53+ , testProperty "DayOfWeek" $ roundTripEq (undefined :: DayOfWeek)
54+ , testProperty "SystemTime" $ roundTripEq (undefined :: SystemTime)
55+ , testProperty "CalendarDiffTime" $ roundTripEq (undefined :: CalendarDiffTime)
56+ , testProperty "CalendarDiffDays" $ roundTripEq (undefined :: CalendarDiffDays)
5057 , testProperty "Version" $ roundTripEq (undefined :: Version)
5158 , testProperty "Natural" $ roundTripEq (undefined :: Natural)
5259 , testProperty "Proxy" $ roundTripEq (undefined :: Proxy Int)
tests/SerializationFormatSpec.hs+47−19
@@ -32,6 +32,9 @@ import Data.Proxy (Proxy(..))
3232import Data.Scientific (Scientific)
3333import Data.Tagged (Tagged(..))
3434import Data.Time (fromGregorian)
35+import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))
36+import Data.Time.LocalTime.Compat (CalendarDiffTime (..))
37+import Data.Time.Clock.System.Compat (SystemTime (..))
3538import Data.Word (Word8)
3639import GHC.Generics (Generic)
3740import Instances ()
@@ -68,6 +71,9 @@ jsonExamples =
6871 example "Either Left" "{\"Left\":1}" (Left 1 :: Either Int Int)
6972 , example "Either Right" "{\"Right\":1}" (Right 1 :: Either Int Int)
7073 , example "Nothing" "null" (Nothing :: Maybe Int)
74+ -- Maybe serialising is lossy
75+ -- https://github.com/bos/aeson/issues/376
76+ , Example "Just Nothing" ["null"] (Just Nothing :: Maybe (Maybe Int)) Nothing
7177 , example "Just" "1" (Just 1 :: Maybe Int)
7278 , example "Proxy Int" "null" (Proxy :: Proxy Int)
7379 , example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)
@@ -82,22 +88,22 @@ jsonExamples =
8288 , example "DList" "[1,2,3]" (DList.fromList [1, 2, 3] :: DList.DList Int)
8389 , example "()" "[]" ()
8490
85− , Example "HashMap Int Int"
91+ , ndExample "HashMap Int Int"
8692 [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]
8793 (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)
88− , Example "Map Int Int"
94+ , ndExample "Map Int Int"
8995 [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]
9096 (M.fromList [(0,1),(2,3)] :: M.Map Int Int)
91− , Example "Map (Tagged Int Int) Int"
97+ , ndExample "Map (Tagged Int Int) Int"
9298 [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]
9399 (M.fromList [(Tagged 0,1),(Tagged 2,3)] :: M.Map (Tagged Int Int) Int)
94100 , example "Map [Int] Int"
95101 "[[[0],1],[[2],3]]"
96102 (M.fromList [([0],1),([2],3)] :: M.Map [Int] Int)
97− , Example "Map [Char] Int"
103+ , ndExample "Map [Char] Int"
98104 [ "{\"ab\":1,\"cd\":3}", "{\"cd\":3,\"ab\":1}" ]
99105 (M.fromList [("ab",1),("cd",3)] :: M.Map String Int)
100− , Example "Map [I Char] Int"
106+ , ndExample "Map [I Char] Int"
101107 [ "{\"ab\":1,\"cd\":3}", "{\"cd\":3,\"ab\":1}" ]
102108 (M.fromList [(map pure "ab",1),(map pure "cd",3)] :: M.Map [I Char] Int)
103109
@@ -193,16 +199,27 @@ jsonExamples =
193199 , example "Semigroup.WrappedMonoid Int" "2" (Semigroup.WrapMonoid 2 :: Semigroup.WrappedMonoid Int)
194200 , example "Semigroup.Option Just" "2" (pure 2 :: Semigroup.Option Int)
195201 , example "Semigroup.Option Nothing" "null" (Semigroup.Option (Nothing :: Maybe Bool))
202+
203+ -- time 1.9
204+ , example "SystemTime" "123.123456789" (MkSystemTime 123 123456789)
205+ , Example "SystemTime" ["124.23456789"]
206+ (MkSystemTime 123 1234567890)
207+ (MkSystemTime 124 234567890)
208+ , ndExample "CalendarDiffTime"
209+ [ "{\"months\":12,\"time\":456.789}", "{\"time\":456.789,\"months\":12}" ]
210+ (CalendarDiffTime 12 456.789)
211+ , ndExample "CalendarDiffDays"
212+ [ "{\"months\":12,\"days\":20}", "{\"days\":20,\"months\":12}" ]
213+ (CalendarDiffDays 12 20)
214+ , example "DayOfWeek" "\"monday\"" Monday
196215 ]
197216
198217jsonEncodingExamples :: [Example]
199218jsonEncodingExamples =
200219 [
201− -- Maybe serialising is lossy
202− -- https://github.com/bos/aeson/issues/376
203− example "Just Nothing" "null" (Just Nothing :: Maybe (Maybe Int))
204220 -- infinities cannot be recovered, null is decoded as NaN
205− , example "inf :: Double" "null" (Approx $ 1/0 :: Approx Double)
221+ example "inf :: Double" "null" (Approx $ 1/0 :: Approx Double)
222+ , example "-inf :: Double" "null" (Approx $ -1/0 :: Approx Double)
206223 ]
207224
208225jsonDecodingExamples :: [Example]
@@ -224,16 +241,27 @@ jsonDecodingExamples = [
224241 ]
225242
226243data Example where
227− Example
228− :: (Eq a, Show a, ToJSON a, FromJSON a)
229− => String -> [L.ByteString] -> a -> Example -- empty bytestring will fail, any p [] == False
230− MaybeExample
231− :: (Eq a, Show a, FromJSON a)
232− => String -> L.ByteString -> Maybe a -> Example
244+ Example
245+ :: (Eq a, Show a, ToJSON a, FromJSON a)
246+ => String -- name
247+ -> [L.ByteString] -- encoded variants
248+ -> a -- input
249+ -> a -- decoded
250+ -> Example -- empty bytestring will fail, any p [] == False
251+
252+ MaybeExample
253+ :: (Eq a, Show a, FromJSON a)
254+ => String -> L.ByteString -> Maybe a -> Example
233255
234256example :: (Eq a, Show a, ToJSON a, FromJSON a)
235257 => String -> L.ByteString -> a -> Example
236−example n bs x = Example n [bs] x
258+example n bs x = Example n [bs] x x
259+
260+-- | Non-deterministic example, input encodes to some of bytestrings.
261+ndExample :: (Eq a, Show a, ToJSON a, FromJSON a)
262+ => String -> [L.ByteString] -> a -> Example
263+ndExample n bss x = Example n bss x x
264+
237265
238266data MyEither a b = MyLeft a | MyRight b
239267 deriving (Generic, Show, Eq)
@@ -246,16 +274,16 @@ instance (FromJSON a, FromJSON b) => FromJSON (MyEither a b) where
246274 parseJSON = genericParseJSON defaultOptions { sumEncoding = UntaggedValue }
247275
248276assertJsonExample :: Example -> TestTree
249−assertJsonExample (Example name bss val) = testCase name $ do
277+assertJsonExample (Example name bss val val') = testCase name $ do
250278 assertSomeEqual "encode" bss (encode val)
251279 assertSomeEqual "encode/via value" bss (encode $ toJSON val)
252280 for_ bss $ \bs ->
253− assertEqual "decode" (Just val) (decode bs)
281+ assertEqual "decode" (Just val') (decode bs)
254282assertJsonExample (MaybeExample name bs mval) = testCase name $
255283 assertEqual "decode" mval (decode bs)
256284
257285assertJsonEncodingExample :: Example -> TestTree
258−assertJsonEncodingExample (Example name bss val) = testCase name $ do
286+assertJsonEncodingExample (Example name bss val _) = testCase name $ do
259287 assertSomeEqual "encode" bss (encode val)
260288 assertSomeEqual "encode/via value" bss (encode $ toJSON val)
261289assertJsonEncodingExample (MaybeExample name _ _) = testCase name $
tests/UnitTests.hs+2−3
@@ -40,8 +40,7 @@ import Data.Scientific (Scientific, scientific)
4040import Data.Tagged (Tagged(..))
4141import Data.Text (Text)
4242import Data.Time (UTCTime)
43−import Data.Time.Format (parseTime)
44−import Data.Time.Locale.Compat (defaultTimeLocale)
43+import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)
4544import GHC.Generics (Generic)
4645import Instances ()
4746import Numeric.Natural (Natural)
@@ -215,7 +214,7 @@ utcTimeGood = do
215214 where
216215 parseWithRead :: String -> LT.Text -> UTCTime
217216 parseWithRead f s =
218− fromMaybe (error "parseTime input malformed") . parseTime defaultTimeLocale f . LT.unpack $ s
217+ fromMaybe (error "parseTime input malformed") . parseTimeM True defaultTimeLocale f . LT.unpack $ s
219218 parseWithAeson :: LT.Text -> Maybe UTCTime
220219 parseWithAeson s = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""]
221220