Use time-compat and fix MonadFail breakages

Data/Aeson/Types/FromJSON.hs

@@ -87,7 +87,7 @@ import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
 import Data.Aeson.Types.Generic
 import Data.Aeson.Types.Internal
 import Data.Bits (unsafeShiftR)
-import Data.Fixed (Fixed, HasResolution)
+import Data.Fixed (Fixed, HasResolution (resolution), Nano)
 import Data.Functor.Compose (Compose(..))
 import Data.Functor.Identity (Identity(..))
 import Data.Functor.Product (Product(..))
@@ -103,8 +103,10 @@ import Data.Scientific (Scientific, base10Exponent)
 import Data.Tagged (Tagged(..))
 import Data.Text (Text, pack, unpack)
 import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
-import Data.Time.Format (parseTime)
-import Data.Time.Locale.Compat (defaultTimeLocale)
+import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))
+import Data.Time.LocalTime.Compat (CalendarDiffTime (..))
+import Data.Time.Clock.System.Compat (SystemTime (..))
+import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)
 import Data.Traversable as Tr (sequence)
 import Data.Vector (Vector)
 import Data.Version (Version, parseVersion)
@@ -1914,7 +1916,7 @@ instance FromJSON DotNetTime where
     parseJSON = withText "DotNetTime" $ \t ->
         let (s,m) = T.splitAt (T.length t - 5) t
             t'    = T.concat [s,".",m]
-        in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
+        in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
              Just d -> pure (DotNetTime d)
              _      -> fail "could not parse .NET time"
     {-# INLINE parseJSON #-}
@@ -2008,6 +2010,40 @@ instance FromJSON DiffTime where
     parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac
     {-# INLINE parseJSON #-}
 
+instance FromJSON SystemTime where
+    parseJSON v = prependContext "SystemTime" $ do
+        n <- parseJSON v
+        let n' = floor (n * fromInteger (resolution n) :: Nano)
+        let (secs, nano) = n' `divMod` resolution n
+        return (MkSystemTime (fromInteger secs) (fromInteger nano))
+
+instance FromJSON CalendarDiffTime where
+    parseJSON = withObject "CalendarDiffTime" $ \obj -> CalendarDiffTime
+        <$> obj .: "months"
+        <*> obj .: "time"
+
+instance FromJSON CalendarDiffDays where
+    parseJSON = withObject "CalendarDiffDays" $ \obj -> CalendarDiffDays
+        <$> obj .: "months"
+        <*> obj .: "days"
+
+instance FromJSON DayOfWeek where
+    parseJSON = withText "DaysOfWeek" parseDayOfWeek
+
+parseDayOfWeek :: T.Text -> Parser DayOfWeek
+parseDayOfWeek t = case T.toLower t of
+    "monday"    -> return Monday
+    "tuesday"   -> return Tuesday
+    "wednesday" -> return Wednesday
+    "thursday"  -> return Thursday
+    "friday"    -> return Friday
+    "saturday"  -> return Saturday
+    "sunday"    -> return Sunday
+    _           -> fail "Invalid week day"
+
+instance FromJSONKey DayOfWeek where
+    fromJSONKey = FromJSONKeyTextParser parseDayOfWeek
+
 -------------------------------------------------------------------------------
 -- base Monoid/Semigroup
 -------------------------------------------------------------------------------

Data/Aeson/Types/Internal.hs

@@ -158,8 +158,10 @@ instance Monad IResult where
     IError path err >>= _ = IError path err
     {-# INLINE (>>=) #-}
 
+#if !(MIN_VERSION_base(4,13,0))
     fail = Fail.fail
     {-# INLINE fail #-}
+#endif
 
 instance Fail.MonadFail IResult where
     fail err = IError [] err
@@ -173,8 +175,10 @@ instance Monad Result where
     Error err >>= _ = Error err
     {-# INLINE (>>=) #-}
 
+#if !(MIN_VERSION_base(4,13,0))
     fail = Fail.fail
     {-# INLINE fail #-}
+#endif
 
 instance Fail.MonadFail Result where
     fail err = Error err
@@ -288,8 +292,11 @@ instance Monad Parser where
     {-# INLINE (>>=) #-}
     return = pure
     {-# INLINE return #-}
+
+#if !(MIN_VERSION_base(4,13,0))
     fail = Fail.fail
     {-# INLINE fail #-}
+#endif
 
 instance Fail.MonadFail Parser where
     fail msg = Parser $ \path kf _ks -> kf (reverse path) msg

Data/Aeson/Types/ToJSON.hs

@@ -69,7 +69,7 @@ import Data.Aeson.Types.Internal
 import Data.Attoparsec.Number (Number(..))
 import Data.Bits (unsafeShiftR)
 import Data.DList (DList)
-import Data.Fixed (Fixed, HasResolution)
+import Data.Fixed (Fixed, HasResolution, Nano)
 import Data.Foldable (toList)
 import Data.Functor.Compose (Compose(..))
 import Data.Functor.Contravariant (Contravariant (..))
@@ -86,8 +86,10 @@ import Data.Scientific (Scientific)
 import Data.Tagged (Tagged(..))
 import Data.Text (Text, pack)
 import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
-import Data.Time.Format (FormatTime, formatTime)
-import Data.Time.Locale.Compat (defaultTimeLocale)
+import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))
+import Data.Time.LocalTime.Compat (CalendarDiffTime (..))
+import Data.Time.Clock.System.Compat (SystemTime (..))
+import Data.Time.Format.Compat (FormatTime, formatTime, defaultTimeLocale)
 import Data.Vector (Vector)
 import Data.Version (Version, showVersion)
 import Data.Void (Void, absurd)
@@ -2029,6 +2031,50 @@ instance ToJSON DiffTime where
     toEncoding = E.scientific . realToFrac
     {-# INLINE toEncoding #-}
 
+-- | Encoded as number
+instance ToJSON SystemTime where
+    toJSON (MkSystemTime secs nsecs) =
+        toJSON (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)
+    toEncoding (MkSystemTime secs nsecs) =
+        toEncoding (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)
+
+instance ToJSON CalendarDiffTime where
+    toJSON (CalendarDiffTime m nt) = object
+        [ "months" .= m
+        , "time" .= nt
+        ]
+    toEncoding (CalendarDiffTime m nt) = E.pairs
+        ("months" .= m <> "time" .= nt)
+
+instance ToJSON CalendarDiffDays where
+    toJSON (CalendarDiffDays m d) = object
+        [ "months" .= m
+        , "days" .= d
+        ]
+    toEncoding (CalendarDiffDays m d) = E.pairs
+        ("months" .= m <> "days" .= d)
+
+instance ToJSON DayOfWeek where
+    toJSON Monday    = "monday"
+    toJSON Tuesday   = "tuesday"
+    toJSON Wednesday = "wednesday"
+    toJSON Thursday  = "thursday"
+    toJSON Friday    = "friday"
+    toJSON Saturday  = "saturday"
+    toJSON Sunday    = "sunday"
+
+toEncodingDayOfWeek :: DayOfWeek -> E.Encoding' Text
+toEncodingDayOfWeek Monday    = E.unsafeToEncoding "\"monday\""
+toEncodingDayOfWeek Tuesday   = E.unsafeToEncoding "\"tuesday\""
+toEncodingDayOfWeek Wednesday = E.unsafeToEncoding "\"wednesday\""
+toEncodingDayOfWeek Thursday  = E.unsafeToEncoding "\"thursday\""
+toEncodingDayOfWeek Friday    = E.unsafeToEncoding "\"friday\""
+toEncodingDayOfWeek Saturday  = E.unsafeToEncoding "\"saturday\""
+toEncodingDayOfWeek Sunday    = E.unsafeToEncoding "\"sunday\""
+
+instance ToJSONKey DayOfWeek where
+    toJSONKey = toJSONKeyTextEnc toEncodingDayOfWeek
+
 -------------------------------------------------------------------------------
 -- base Monoid/Semigroup
 -------------------------------------------------------------------------------

aeson.cabal

@@ -113,7 +113,8 @@ library
 
   -- Compat
   build-depends:
-    base-compat     >= 0.9.1    && < 0.11
+    base-compat     >= 0.9.1    && < 0.11,
+    time-compat     >= 1.9.2.2  && < 1.10
 
   if flag(bytestring-builder)
     build-depends: bytestring >= 0.9.2 && < 0.10.4,
@@ -211,7 +212,7 @@ test-suite tests
     UnitTests.NullaryConstructors
 
   build-depends:
-    QuickCheck >= 2.10.0.1 && < 2.13,
+    QuickCheck >= 2.10.0.1 && < 2.14,
     aeson,
     integer-logarithms >= 1 && <1.1,
     attoparsec,
@@ -236,11 +237,11 @@ test-suite tests
     tasty-quickcheck,
     text,
     time,
-    time-locale-compat,
+    time-compat,
     unordered-containers,
     uuid-types,
     vector,
-    quickcheck-instances >= 0.3.16
+    quickcheck-instances >= 0.3.21 && <0.4
 
   if flag(bytestring-builder)
     build-depends: bytestring >= 0.9 && < 0.10.4,

benchmarks/aeson-benchmarks.cabal

@@ -46,6 +46,7 @@ library
       template-haskell >= 2.4,
       text >= 1.2.3,
       th-abstraction >= 0.2.2 && < 0.4,
+      time-compat,
       time,
       transformers,
       unordered-containers >= 0.2.3.0,

stack-bench.yaml

@@ -1,4 +1,4 @@
-resolver: lts-12.10
+resolver: lts-12.26
 # We use aeson in the snapshot to
 # - avoid recompilation of criterion
 # - compare against it
@@ -9,3 +9,10 @@ resolver: lts-12.10
 work-dir: .stack-work-bench
 packages:
 - benchmarks
+extra-deps:
+- base-orphans-0.8.1
+- hashable-time-0.2.0.1
+- QuickCheck-2.13.1
+- quickcheck-instances-0.3.21
+- splitmix-0.0.2
+- time-compat-1.9.2.2

stack-ffi-unescape.yaml

@@ -1,9 +1,14 @@
-resolver: lts-12.10
+resolver: lts-12.26
 packages:
 - '.'
 flags:
   aeson:
     fast: true
     cffi: true
 extra-deps:
+- base-orphans-0.8.1
 - hashable-time-0.2.0.1
+- QuickCheck-2.13.1
+- quickcheck-instances-0.3.21
+- splitmix-0.0.2
+- time-compat-1.9.2.2

stack-lts12.yaml

@@ -7,4 +7,9 @@ flags:
     fast: true
     cffi: true
 extra-deps:
+- base-orphans-0.8.1
 - hashable-time-0.2.0.1
+- QuickCheck-2.13.1
+- quickcheck-instances-0.3.21
+- splitmix-0.0.2
+- time-compat-1.9.2.2

stack-nightly.yaml

@@ -9,3 +9,5 @@ flags:
     fast: true
 extra-deps:
 - hlint-2.1.18
+- time-compat-1.9.2.2
+- quickcheck-instances-0.3.21

tests/PropertyRoundTrip.hs

@@ -14,6 +14,9 @@ import Data.Sequence (Seq)
 import Data.Tagged (Tagged)
 import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
 import Data.Version (Version)
+import Data.Time.Calendar.Compat (CalendarDiffDays, DayOfWeek)
+import Data.Time.LocalTime.Compat (CalendarDiffTime)
+import Data.Time.Clock.System.Compat (SystemTime)
 import Instances ()
 import Numeric.Natural (Natural)
 import Test.Tasty (TestTree, testGroup)
@@ -47,6 +50,10 @@ roundTripTests =
     , testProperty "ZonedTime" $ roundTripEq (undefined :: ZonedTime)
     , testProperty "NominalDiffTime" $ roundTripEq (undefined :: NominalDiffTime)
     , testProperty "DiffTime" $ roundTripEq (undefined :: DiffTime)
+    , testProperty "DayOfWeek" $ roundTripEq (undefined :: DayOfWeek)
+    , testProperty "SystemTime" $ roundTripEq (undefined :: SystemTime)
+    , testProperty "CalendarDiffTime" $ roundTripEq (undefined :: CalendarDiffTime)
+    , testProperty "CalendarDiffDays" $ roundTripEq (undefined :: CalendarDiffDays)
     , testProperty "Version" $ roundTripEq (undefined :: Version)
     , testProperty "Natural" $ roundTripEq (undefined :: Natural)
     , testProperty "Proxy" $ roundTripEq (undefined :: Proxy Int)