aeson 2.0.3.0 → 2.1.0.0

raw patch · 14 files changed

+374/−36 lines, 14 filesdep +genericallydep ~ghc-primdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: generically

Dependency ranges changed: ghc-prim, template-haskell

API changes (from Hackage documentation)

Files

• aeson.cabal +7/−3
• attoparsec-iso8601/src/Data/Attoparsec/Time.hs +79/−4
• changelog.md +11/−0
• src/Data/Aeson.hs +39/−0
• src/Data/Aeson/Encoding/Internal.hs +4/−3
• src/Data/Aeson/KeyMap.hs +10/−2
• src/Data/Aeson/Parser/Internal.hs +5/−5
• src/Data/Aeson/Text.hs +9/−9
• src/Data/Aeson/Types.hs +10/−2
• src/Data/Aeson/Types/FromJSON.hs +26/−2
• src/Data/Aeson/Types/Internal.hs +23/−0
• src/Data/Aeson/Types/ToJSON.hs +29/−3
• tests/SerializationFormatSpec.hs +6/−2
• tests/UnitTests.hs +116/−1

@@ -1,5 +1,5 @@ name:               aeson-version:            2.0.3.0+version:            2.1.0.0 license:            BSD3 license-file:       LICENSE category:           Text, Web, JSON@@ -16,8 +16,10 @@    || ==8.4.4    || ==8.6.5    || ==8.8.4-   || ==8.10.4-   || ==9.0.1+   || ==8.10.7+   || ==9.0.2+   || ==9.2.3+   || ==9.4.1  synopsis:           Fast JSON parsing and encoding cabal-version:      >=1.10@@ -105,6 +107,7 @@   -- Compat   build-depends:       base-compat-batteries  >=0.10.0 && <0.13+    , generically            >=0.1    && <0.2     , time-compat            >=1.9.6  && <1.10    if !impl(ghc >=8.6)@@ -192,6 +195,7 @@     , dlist     , filepath     , generic-deriving      >=1.10     && <1.15+    , generically     , ghc-prim              >=0.2     , hashable     , indexed-traversable

@@ -19,6 +19,7 @@     , timeZone     , utcTime     , zonedTime+    , year     , month     , quarter     ) where@@ -27,7 +28,7 @@  import Control.Applicative ((<|>)) import Control.Monad (void, when)-import Data.Attoparsec.Text (Parser, char, decimal, digit, option, anyChar, peekChar, peekChar', takeWhile1, satisfy)+import Data.Attoparsec.Text (Parser, char, digit, option, anyChar, peekChar, peekChar', takeWhile1, satisfy) import Data.Attoparsec.Time.Internal (toPico) import Data.Bits ((.&.)) import Data.Char (isDigit, ord)@@ -35,6 +36,7 @@ import Data.Int (Int64) import Data.Maybe (fromMaybe) import Data.Time.Calendar (Day, fromGregorianValid)+import Data.Time.Calendar.Compat (Year) import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..), fromYearQuarter) import Data.Time.Calendar.Month.Compat (Month, fromYearMonthValid) import Data.Time.Clock (UTCTime(..))@@ -42,27 +44,37 @@ import qualified Data.Time.LocalTime as Local  -- | Parse a date of the form @[+,-]YYYY-MM-DD@.+--+-- The year must contain at least 4 digits, to avoid the Y2K problem:+-- a two-digit year @YY@ may mean @YY@, @19YY@, or @20YY@, and we make it+-- an error to prevent the ambiguity.+-- Years from @0000@ to @0999@ must thus be zero-padded.+-- The year may have more than 4 digits. day :: Parser Day day = do   absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id-  y <- (decimal <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD"+  y <- (year <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD"   m <- (twoDigits <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD"   d <- twoDigits <|> fail "date must be of form [+,-]YYYY-MM-DD"   maybe (fail "invalid date") return (fromGregorianValid (absOrNeg y) m d)  -- | Parse a month of the form @[+,-]YYYY-MM@.+--+-- See also 'day' for details about the year format. month :: Parser Month month = do   absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id-  y <- (decimal <* char '-') <|> fail "month must be of form [+,-]YYYY-MM"+  y <- (year <* char '-') <|> fail "month must be of form [+,-]YYYY-MM"   m <- twoDigits <|> fail "month must be of form [+,-]YYYY-MM"   maybe (fail "invalid month") return (fromYearMonthValid (absOrNeg y) m)  -- | Parse a quarter of the form @[+,-]YYYY-QN@.+--+-- See also 'day' for details about the year format. quarter :: Parser Quarter quarter = do   absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id-  y <- (decimal <* char '-') <|> fail "month must be of form [+,-]YYYY-MM"+  y <- (year <* char '-') <|> fail "month must be of form [+,-]YYYY-MM"   _ <- char 'q' <|> char 'Q'   q <- parseQ   return $! fromYearQuarter (absOrNeg y) q@@ -72,6 +84,19 @@       <|> Q3 <$ char '3'       <|> Q4 <$ char '4' +-- | Parse a year @YYYY@, with at least 4 digits. Does not include any sign.+--+-- Note: 'Year' is a type synonym for 'Integer'.+--+-- @since 1.1.0.0+year :: Parser Year+year = do+  ds <- takeWhile1 isDigit+  if T.length ds < 4 then+    fail "expected year with at least 4 digits"+  else+    pure (txtToInteger ds)+ -- | Parse a two-digit integer (e.g. day of month, hour). twoDigits :: Parser Int twoDigits = do@@ -172,3 +197,53 @@  utc :: Local.TimeZone utc = Local.TimeZone 0 False ""++------------------ Copy-pasted and adapted from base ------------------------++txtToInteger :: T.Text -> Integer+txtToInteger bs+    | l > 40    = valInteger 10 l [ fromIntegral (ord w - 48) | w <- T.unpack bs ]+    | otherwise = txtToIntegerSimple bs+  where+    l = T.length bs++txtToIntegerSimple :: T.Text -> Integer+txtToIntegerSimple = T.foldl' step 0 where+  step a b = a * 10 + fromIntegral (ord b - 48) -- 48 = '0'++-- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b+-- digits are combined into a single radix b^2 digit. This process is+-- repeated until we are left with a single digit. This algorithm+-- performs well only on large inputs, so we use the simple algorithm+-- for smaller inputs.+valInteger :: Integer -> Int -> [Integer] -> Integer+valInteger = go+  where+    go :: Integer -> Int -> [Integer] -> Integer+    go _ _ []  = 0+    go _ _ [d] = d+    go b l ds+        | l > 40 = b' `seq` go b' l' (combine b ds')+        | otherwise = valSimple b ds+      where+        -- ensure that we have an even number of digits+        -- before we call combine:+        ds' = if even l then ds else 0 : ds+        b' = b * b+        l' = (l + 1) `quot` 2++    combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)+      where+        d = d1 * b + d2+    combine _ []  = []+    combine _ [_] = errorWithoutStackTrace "this should not happen"++-- The following algorithm is only linear for types whose Num operations+-- are in constant time.+valSimple :: Integer -> [Integer] -> Integer+valSimple base = go 0+  where+    go r [] = r+    go r (d : ds) = r' `seq` go r' ds+      where+        r' = r * base + fromIntegral d

@@ -1,5 +1,16 @@ For the latest version of this document, please see [https://github.com/haskell/aeson/blob/master/changelog.md](https://github.com/haskell/aeson/blob/master/changelog.md). +### 2.1.0.0++- Change time instances of types with year (`Day`, `UTCTime`) to require years with at least 4 digits.+- Change `KeyValue` instances to be more general (and use equality to constraint them) instead of being more lax flexible instances.+- Export `Key` type also from `Data.Aeson.KeyMap` module.+- Export `mapWithKey` from `Data.Aeson.KeyMap` module.+- Export `ifromJSON` and `iparse` from `Data.Aeson.Types`. Add `iparseEither`.+- Add `MonadFix Parser` instance.+- Make `Semigroup Series` slightly lazier+- Add instances for `Generically` type+ ### 2.0.3.0  * `text-2.0` support

@@ -34,6 +34,12 @@      -- ** Direct encoding     -- $encoding++    -- * Remarks on specific encodings+    -- ** Time+    -- $time++    -- * Main encoding and decoding functions       decode     , decode'     , eitherDecode@@ -528,3 +534,36 @@ -- > > import Data.Sequence as Seq -- > > encode (Seq.fromList [1,2,3]) -- > "[1,2,3]"++-- $time+--+-- This module contains instances of 'ToJSON' and 'FromJSON' for types from+-- the <https://hackage.haskell.org/package/time time> library.+--+-- Those instances encode time as JSON strings in+-- <https://en.wikipedia.org/wiki/ISO_8601 ISO 8601> formats, with the+-- following general form for 'Data.Time.Clock.UTCTime' and+-- 'Data.Time.LocalTime.ZonedTime', while other time types use subsets of those+-- fields:+--+-- > [+,-]YYYY-MM-DDThh:mm[:ss[.sss]]Z+--+-- where+--+-- - @[+,-]@ is an optional sign, @+@ or @-@.+-- - @YYYY@ is the year, which must have at least 4 digits to prevent Y2K problems.+--   Years from @0000@ to @0999@ must thus be zero-padded.+-- - @MM@ is a two-digit month.+-- - @DD@ is a two-digit day.+-- - @T@ is a literal @\'T\'@ character separating the date and the time of+--   day. It may be a space instead.+-- - @hh@ is a two-digit hour.+-- - @mm@ is a two-digit minute.+-- - @ss@ is a two-digit second.+-- - @sss@ is a decimal fraction of a second; it may have any nonzero number of digits.+-- - @Z@ is a time zone; it may be preceded by an optional space.+--+-- For more information, see <https://en.wikipedia.org/wiki/ISO_8601 ISO 8601>+-- <https://hackage.haskell.org/package/time time>,+-- and <https://hackage.haskell.org/package/attoparsec-iso8601 attoparsec-iso8601>+-- (where the relevant parsers are defined).

@@ -158,9 +158,10 @@ {-# INLINE unsafePairSBS #-}  instance Semigroup Series where-    Empty   <> a       = a-    a       <> Empty   = a-    Value a <> Value b = Value (a >< comma >< b)+    Empty   <> a = a+    Value a <> b = Value $ a >< case b of+        Empty   -> empty+        Value x -> comma >< x  instance Monoid Series where     mempty  = Empty

@@ -65,6 +65,7 @@     -- * Traversal     -- ** Map     map,+    mapWithKey,     mapKeyVal,     traverse,     traverseWithKey,@@ -85,6 +86,9 @@     filterWithKey,     mapMaybe,     mapMaybeWithKey,++    -- * Key Type+    Key, ) where  -- Import stuff from Prelude explicitly@@ -191,6 +195,8 @@ map = fmap  -- | Map a function over all values in the map.+--+-- @since 2.1.0.0 mapWithKey :: (Key -> a -> b) -> KeyMap a -> KeyMap b mapWithKey f (KeyMap m) = KeyMap (M.mapWithKey f m) @@ -245,7 +251,7 @@  -- | Return a list of this map' elements. ----- @since 2.0.2.0+-- @since 2.0.3.0 elems :: KeyMap v -> [v] elems = M.elems . unKeyMap @@ -392,6 +398,8 @@ map = fmap  -- | Map a function over all values in the map.+--+-- @since 2.1.0.0 mapWithKey :: (Key -> a -> b) -> KeyMap a -> KeyMap b mapWithKey f (KeyMap m) = KeyMap (H.mapWithKey f m) @@ -446,7 +454,7 @@  -- | Return a list of this map' elements. ----- @since 2.0.2.0+-- @since 2.0.3.0 elems :: KeyMap v -> [v] elems = H.elems . unKeyMap 

@@ -133,11 +133,11 @@ -- mkObject outside of the recursive loop for proper inlining.  object_ :: ([(Key, Value)] -> Either String Object) -> Parser Value -> Parser Value-object_ mkObject val = {-# SCC "object_" #-} Object <$> objectValues mkObject key val+object_ mkObject val = Object <$> objectValues mkObject key val {-# INLINE object_ #-}  object_' :: ([(Key, Value)] -> Either String Object) -> Parser Value -> Parser Value-object_' mkObject val' = {-# SCC "object_'" #-} do+object_' mkObject val' = do   !vals <- objectValues mkObject key' val'   return (Object vals)  where@@ -172,11 +172,11 @@ {-# INLINE objectValues #-}  array_ :: Parser Value -> Parser Value-array_ val = {-# SCC "array_" #-} Array <$> arrayValues val+array_ val = Array <$> arrayValues val {-# INLINE array_ #-}  array_' :: Parser Value -> Parser Value-array_' val = {-# SCC "array_'" #-} do+array_' val = do   !vals <- arrayValues val   return (Array vals) {-# INLINE array_' #-}@@ -344,7 +344,7 @@  jstringSlow :: B.ByteString -> Parser Text {-# INLINE jstringSlow #-}-jstringSlow s' = {-# SCC "jstringSlow" #-} do+jstringSlow s' = do   s <- A.scan startState go <* A.anyWord8   case unescapeText (B.append s' s) of     Right r  -> return r

@@ -56,18 +56,18 @@ encodeToTextBuilder =     go . toJSON   where-    go Null       = {-# SCC "go/Null" #-} "null"-    go (Bool b)   = {-# SCC "go/Bool" #-} if b then "true" else "false"-    go (Number s) = {-# SCC "go/Number" #-} fromScientific s-    go (String s) = {-# SCC "go/String" #-} string s+    go Null       = "null"+    go (Bool b)   = if b then "true" else "false"+    go (Number s) = fromScientific s+    go (String s) = string s     go (Array v)-        | V.null v = {-# SCC "go/Array" #-} "[]"-        | otherwise = {-# SCC "go/Array" #-}+        | V.null v = "[]"+        | otherwise =                        TB.singleton '[' <>                       go (V.unsafeHead v) <>                       V.foldr f (TB.singleton ']') (V.unsafeTail v)       where f a z = TB.singleton ',' <> go a <> z-    go (Object m) = {-# SCC "go/Object" #-}+    go (Object m) =          case KM.toList m of           (x:xs) -> TB.singleton '{' <> one x <> foldr f (TB.singleton '}') xs           _      -> "{}"@@ -75,12 +75,12 @@             one (k,v) = string (Key.toText k) <> TB.singleton ':' <> go v  string :: T.Text -> Builder-string s = {-# SCC "string" #-} TB.singleton '"' <> quote s <> TB.singleton '"'+string s = TB.singleton '"' <> quote s <> TB.singleton '"'   where     quote q = case T.uncons t of                 Nothing      -> TB.fromText h                 Just (!c,t') -> TB.fromText h <> escape c <> quote t'-        where (h,t) = {-# SCC "break" #-} T.break isEscape q+        where (h,t) = T.break isEscape q     isEscape c = c == '\"' ||                  c == '\\' ||                  c < '\x20'

@@ -29,6 +29,7 @@     , typeMismatch     , unexpected     -- * Type conversion+    -- ** Parsing     , Parser     , Result(..)     , FromJSON(..)@@ -37,12 +38,19 @@     , parseEither     , parseMaybe     , parseFail-    , ToJSON(..)-    , KeyValue(..)+    -- ** Parser error handling     , modifyFailure     , prependFailure     , parserThrowError     , parserCatchError+    -- ** Parsing with paths+    , IResult (..)+    , ifromJSON+    , iparse+    , iparseEither+    -- ** Encoding+    , ToJSON(..)+    , KeyValue(..)      -- ** Keys for maps     , ToJSONKey(..)

@@ -118,6 +118,9 @@ import Foreign.Storable (Storable) import Foreign.C.Types (CTime (..)) import GHC.Generics+#if !MIN_VERSION_base(4,17,0)+import GHC.Generics.Generically (Generically (..), Generically1 (..))+#endif import Numeric.Natural (Natural) import Text.ParserCombinators.ReadP (readP_to_S) import Unsafe.Coerce (unsafeCoerce)@@ -362,6 +365,12 @@ -- instance 'FromJSON' Coord -- @ --+-- or using the [DerivingVia extension](https://downloads.haskell.org/ghc/9.2.3/docs/html/users_guide/exts/deriving_via.html)+--+-- @+-- deriving via 'Generically' Coord instance 'FromJSON' Coord+-- @+-- -- The default implementation will be equivalent to -- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different -- options, you can customize the generic decoding by defining:@@ -386,6 +395,10 @@         . V.toList         $ a +-- | @since 2.1.0.0+instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (Generically a) where+    parseJSON = coerce (genericParseJSON defaultOptions :: Value -> Parser a)+ ------------------------------------------------------------------------------- --  Classes and types for map keys -------------------------------------------------------------------------------@@ -509,7 +522,7 @@  -- | Fail parsing due to a type mismatch, with a descriptive message. ----- The following wrappers should generally be prefered:+-- The following wrappers should generally be preferred: -- 'withObject', 'withArray', 'withText', 'withBool'. -- -- ==== Error message example@@ -575,6 +588,12 @@ -- instance 'FromJSON' a => 'FromJSON1' (Pair a) -- @ --+-- or+--+-- @+-- deriving via 'Generically1' (Pair a) instance 'FromJSON1' (Pair a)+-- @+-- -- If the default implementation doesn't give exactly the results you want, -- you can customize the generic decoding with only a tiny amount of -- effort, using 'genericLiftParseJSON' with your preferred 'Options':@@ -597,6 +616,11 @@     liftParseJSONList :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser [f a]     liftParseJSONList f g v = listParser (liftParseJSON f g) v +-- | @since 2.1.0.0+instance (Generic1 f, GFromJSON One (Rep1 f)) => FromJSON1 (Generically1 f) where+    liftParseJSON :: forall a. (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (Generically1 f a)+    liftParseJSON = coerce (genericLiftParseJSON defaultOptions :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a))+ -- | Lift the standard 'parseJSON' function through the type constructor. parseJSON1 :: (FromJSON1 f, FromJSON a) => Value -> Parser (f a) parseJSON1 = liftParseJSON parseJSON parseJSONList@@ -1697,7 +1721,7 @@  -- | @since 2.0.2.0 instance FromJSON ST.ShortText where-    parseJSON = withText "Lazy Text" $ pure . ST.fromText+    parseJSON = withText "ShortText" $ pure . ST.fromText  -- | @since 2.0.2.0 instance FromJSONKey ST.ShortText where

@@ -43,6 +43,7 @@     , JSONPathElement(..)     , JSONPath     , iparse+    , iparseEither     , parse     , parseEither     , parseMaybe@@ -89,6 +90,7 @@ import Control.Applicative (Alternative(..)) import Control.DeepSeq (NFData(..)) import Control.Monad (MonadPlus(..), ap)+import Control.Monad.Fix (MonadFix (..)) import Data.Char (isLower, isUpper, toLower, isAlpha, isAlphaNum) import Data.Aeson.Key (Key) import Data.Data (Data)@@ -306,6 +308,19 @@     {-# INLINE fail #-} #endif +-- |+--+-- @since 2.1.0.0+instance MonadFix Parser where+    mfix f = Parser $ \path kf ks -> let x = runParser (f (fromISuccess x)) path IError ISuccess in+        case x of+            IError p e -> kf p e+            ISuccess y -> ks y+      where+        fromISuccess :: IResult a -> a+        fromISuccess (ISuccess x)      = x+        fromISuccess (IError path msg) = error $ "mfix @Aeson.Parser: " ++ formatPath path ++ ": " ++ msg+ instance Fail.MonadFail Parser where     fail msg = Parser $ \path kf _ks -> kf (reverse path) msg     {-# INLINE fail #-}@@ -579,6 +594,14 @@ parseEither m v = runParser (m v) [] onError Right   where onError path msg = Left (formatError path msg) {-# INLINE parseEither #-}++-- | Run a 'Parser' with an 'Either' result type.+-- If the parse fails, the 'Left' payload will contain an error message and a json path to failed element.+--+-- @since 2.1.0.0+iparseEither :: (a -> Parser b) -> a -> Either (JSONPath, String) b+iparseEither m v = runParser (m v) [] (\path msg -> Left (path, msg)) Right+{-# INLINE iparseEither #-}  -- | Annotate an error message with a -- <http://goessner.net/articles/JsonPath/ JSONPath> error location.

@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}@@ -68,6 +69,7 @@ import qualified Data.Aeson.KeyMap as KM import Data.Attoparsec.Number (Number(..)) import Data.Bits (unsafeShiftR)+import Data.Coerce (coerce) import Data.DList (DList) import Data.Fixed (Fixed, HasResolution, Nano) import Data.Foldable (toList)@@ -101,6 +103,9 @@ import Foreign.Storable (Storable) import Foreign.C.Types (CTime (..)) import GHC.Generics+#if !MIN_VERSION_base(4,17,0)+import GHC.Generics.Generically (Generically (..), Generically1 (..))+#endif import Numeric.Natural (Natural) import qualified Data.Aeson.Encoding as E import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding, key)@@ -256,6 +261,12 @@ --     'toEncoding' = 'genericToEncoding' 'defaultOptions' -- @ --+-- or more conveniently using the [DerivingVia extension](https://downloads.haskell.org/ghc/9.2.3/docs/html/users_guide/exts/deriving_via.html)+--+-- @+-- deriving via 'Generically' Coord instance 'ToJSON' Coord+-- @+-- -- If on the other hand you wish to customize the generic decoding, you have -- to implement both methods: --@@ -272,7 +283,7 @@ -- Previous versions of this library only had the 'toJSON' method. Adding -- 'toEncoding' had two reasons: ----- 1. toEncoding is more efficient for the common case that the output of+-- 1. 'toEncoding' is more efficient for the common case that the output of -- 'toJSON' is directly serialized to a @ByteString@. -- Further, expressing either method in terms of the other would be -- non-optimal.@@ -321,6 +332,11 @@     toEncodingList :: [a] -> Encoding     toEncodingList = listEncoding toEncoding +-- | @since 2.1.0.0+instance (Generic a, GToJSON' Value Zero (Rep a), GToJSON' Encoding Zero (Rep a)) => ToJSON (Generically a) where+    toJSON     = coerce (genericToJSON     defaultOptions :: a -> Value)+    toEncoding = coerce (genericToEncoding defaultOptions :: a -> Encoding)+ ------------------------------------------------------------------------------- -- Object key-value pairs -------------------------------------------------------------------------------@@ -334,14 +350,14 @@     name .= value = E.pair name (toEncoding value)     {-# INLINE (.=) #-} -instance KeyValue Pair where+instance (key ~ Key, value ~ Value) => KeyValue (key, value) where     name .= value = (name, toJSON value)     {-# INLINE (.=) #-}  -- | Constructs a singleton 'KM.KeyMap'. For calling functions that --   demand an 'Object' for constructing objects. To be used in --   conjunction with 'mconcat'. Prefer to use 'object' where possible.-instance KeyValue Object where+instance value ~ Value => KeyValue (KM.KeyMap value) where     name .= value = KM.singleton name (toJSON value)     {-# INLINE (.=) #-} @@ -615,6 +631,14 @@     liftToEncodingList :: (a -> Encoding) -> ([a] -> Encoding) -> [f a] -> Encoding     liftToEncodingList f g = listEncoding (liftToEncoding f g) +-- | @since 2.1.0.0+instance (Generic1 f, GToJSON' Value One (Rep1 f), GToJSON' Encoding One (Rep1 f)) => ToJSON1 (Generically1 f) where+    liftToJSON :: forall a. (a -> Value) -> ([a] -> Value) -> Generically1 f a -> Value+    liftToJSON = coerce (genericLiftToJSON defaultOptions :: (a -> Value) -> ([a] -> Value) -> f a -> Value)++    liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> Generically1 f a -> Encoding+    liftToEncoding = coerce (genericLiftToEncoding defaultOptions :: (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding)+ -- | Lift the standard 'toJSON' function through the type constructor. toJSON1 :: (ToJSON1 f, ToJSON a) => f a -> Value toJSON1 = liftToJSON toJSON toJSONList@@ -1979,6 +2003,8 @@     toJSON Q2 = "q2"     toJSON Q3 = "q3"     toJSON Q4 = "q4"++    toEncoding = toEncodingQuarterOfYear  toEncodingQuarterOfYear :: QuarterOfYear -> E.Encoding' a toEncodingQuarterOfYear Q1 = E.unsafeToEncoding "\"q1\""

@@ -31,8 +31,8 @@ import Data.Tagged (Tagged(..)) import Data.Text (Text) import Data.These (These (..))-import Data.Time (fromGregorian)-import Data.Time.Calendar.Month.Compat (fromYearMonth)+import Data.Time (Day, fromGregorian)+import Data.Time.Calendar.Month.Compat (Month, fromYearMonth) import Data.Time.Calendar.Quarter.Compat (fromYearQuarter, QuarterOfYear (..)) import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..)) import Data.Time.LocalTime.Compat (CalendarDiffTime (..))@@ -159,12 +159,14 @@   , example "Maybe String" "\"foo\""          (pure "foo" :: Maybe String)   , example "Maybe [Identity Char]" "\"xy\""  (pure [pure 'x', pure 'y'] :: Maybe [Identity Char]) +  , example "Day; year >= 10000" "\"10000-01-01\""      (fromGregorian 10000   1  1)   , example "Day; year >= 1000" "\"1999-10-12\""        (fromGregorian 1999    10 12)   , example "Day; year > 0 && < 1000" "\"0500-03-04\""  (fromGregorian 500     3  4)   , example "Day; year == 0" "\"0000-02-20\""           (fromGregorian 0       2  20)   , example "Day; year < 0" "\"-0234-01-01\""           (fromGregorian (-234)  1  1)   , example "Day; year < -1000" "\"-1234-01-01\""       (fromGregorian (-1234) 1  1) +  , example "Month; year >= 10000" "\"10000-01\""      (fromYearMonth 10000   1)   , example "Month; year >= 1000" "\"1999-10\""        (fromYearMonth 1999    10)   , example "Month; year > 0 && < 1000" "\"0500-03\""  (fromYearMonth 500     3)   , example "Month; year == 0" "\"0000-02\""           (fromYearMonth 0       2)@@ -297,6 +299,8 @@   , MaybeExample "Word8 300"  "300"  (Nothing :: Maybe Word8)   -- Negative zero year, encoding never produces such:   , MaybeExample "Day -0000-02-03" "\"-0000-02-03\"" (Just (fromGregorian 0 2 3))+  , MaybeExample "Day; year too short" "\"10-10-10\"" (Nothing :: Maybe Day)+  , MaybeExample "Month; year too short" "\"10-10\"" (Nothing :: Maybe Month)   ]  data Example where

@@ -7,7 +7,13 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecursiveDo #-} +#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif+ -- For Data.Aeson.Types.camelTo {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -37,7 +43,9 @@ import Data.Aeson.Types   ( Options(..), Result(Success, Error), ToJSON(..)   , Value(Array, Bool, Null, Number, Object, String), camelTo, camelTo2-  , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse)+  , explicitParseField, liftParseJSON, listParser+  , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse, parseMaybe)+import qualified Data.Aeson.Types import qualified Data.Aeson.KeyMap as KM import Data.Attoparsec.ByteString (Parser, parseOnly) import Data.Char (toUpper, GeneralCategory(Control,Surrogate), generalCategory)@@ -52,6 +60,7 @@ import Data.Time (UTCTime) import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale) import GHC.Generics (Generic)+import GHC.Generics.Generically (Generically (..)) import Instances () import Numeric.Natural (Natural) import System.Directory (getDirectoryContents)@@ -71,6 +80,7 @@ import qualified Data.Vector as Vector import qualified ErrorMessages import qualified SerializationFormatSpec+import qualified Data.Map as Map -- Lazy!  roundTripCamel :: String -> Assertion roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name)@@ -93,9 +103,13 @@  instance FromJSON Wibble +#if __GLASGOW_HASKELL__ >= 806+deriving via Generically Wibble instance ToJSON Wibble+#else instance ToJSON Wibble where     toJSON     = genericToJSON defaultOptions     toEncoding = genericToEncoding defaultOptions+#endif  -- Test that if we put a bomb in a data structure, but only demand -- part of it via lazy encoding, we do not unexpectedly fail.@@ -718,6 +732,106 @@ deriveToJSON1 defaultOptions ''Newtype757  -------------------------------------------------------------------------------+-- MonadFix+-------------------------------------------------------------------------------++monadFixDecoding1 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion+monadFixDecoding1 p = do+    fmap (take 10) (parseMaybe p value) @?= Just "xyzxyzxyzx"+  where+    value = object+        [ "foo" .= ('x', "bar" :: String)+        , "bar" .= ('y', "quu" :: String)+        , "quu" .= ('z', "foo" :: String)+        ]++monadFixDecoding2 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion+monadFixDecoding2 p = do+    fmap (take 10) (parseMaybe p value) @?= Nothing+  where+    value = object+        [ "foo" .= ('x', "bar" :: String)+        , "bar" .= ('y', "???" :: String)+        , "quu" .= ('z', "foo" :: String)+        ]++monadFixDecoding3 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion+monadFixDecoding3 p =+    fmap (take 10) (parseMaybe p value) @?= Nothing+  where+    value = object+        [ "foo" .= ('x', "bar" :: String)+        , "bar" .= Null+        , "quu" .= ('z', "foo" :: String)+        ]++monadFixDecoding4 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion+monadFixDecoding4 p =+    fmap (take 10) (parseMaybe p value) @?= Nothing+  where+    value = object+        [ "els" .= ('x', "bar" :: String)+        , "bar" .= Null+        , "quu" .= ('z', "foo" :: String)+        ]++-- Parser with explicit references+monadFixParserA :: Value -> Data.Aeson.Types.Parser [Char]+monadFixParserA = withObject "Rec" $ \obj -> mdo+    let p'' :: Value -> Data.Aeson.Types.Parser String+        p'' "foo" = return foo+        p'' "bar" = return bar+        p'' "quu" = return quu+        p'' _     = fail "Invalid reference"++    let p' :: Value -> Data.Aeson.Types.Parser [Char]+        p' v = do+            (c, cs) <- liftParseJSON p'' (listParser p'') v+            return (c : cs)++    foo <- explicitParseField p' obj "foo"+    bar <- explicitParseField p' obj "bar"+    quu <- explicitParseField p' obj "quu"+    return foo++-- Parser with arbitrary references!+monadFixParserB :: Value -> Data.Aeson.Types.Parser [Char]+monadFixParserB = withObject "Rec" $ \obj -> mdo+    let p'' :: Value -> Data.Aeson.Types.Parser String+        p'' key' = do+            key <- parseJSON key'+            -- this is ugly: we look whether key is in original obj+            -- but then query from refs.+            --+            -- This way we are lazier. Map.traverse isn't lazy enough.+            case KM.lookup key obj of+                Just _  -> return (refs Map.! key)+                Nothing -> fail "Invalid reference"++    let p' :: Value -> Data.Aeson.Types.Parser [Char]+        p' v = do+            (c, cs) <- liftParseJSON p'' (listParser p'') v+            return (c : cs)++    refs <- traverse p' (KM.toMap obj)+    case Map.lookup "foo" refs of+        Nothing   -> fail "No foo node"+        Just root -> return root++monadFixTests :: TestTree+monadFixTests = testGroup "MonadFix"+    [ testCase "Example1a" $ monadFixDecoding1 monadFixParserA+    , testCase "Example2a" $ monadFixDecoding2 monadFixParserA+    , testCase "Example3a" $ monadFixDecoding3 monadFixParserA+    , testCase "Example4a" $ monadFixDecoding4 monadFixParserA++    , testCase "Example1b" $ monadFixDecoding1 monadFixParserB+    , testCase "Example2b" $ monadFixDecoding2 monadFixParserB+    , testCase "Example3b" $ monadFixDecoding3 monadFixParserB+    , testCase "Example4b" $ monadFixDecoding4 monadFixParserB+    ]++------------------------------------------------------------------------------- -- Tests trees ------------------------------------------------------------------------------- @@ -779,4 +893,5 @@     [ testCase "example" $       assertEqual "" (object ["foo" .= True]) [aesonQQ| {"foo": true } |]     ]+  , monadFixTests   ]