diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -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 diff --git a/attoparsec-iso8601/src/Data/Attoparsec/Time.hs b/attoparsec-iso8601/src/Data/Attoparsec/Time.hs --- a/attoparsec-iso8601/src/Data/Attoparsec/Time.hs +++ b/attoparsec-iso8601/src/Data/Attoparsec/Time.hs @@ -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/src/Data/Aeson.hs b/src/Data/Aeson.hs --- a/src/Data/Aeson.hs +++ b/src/Data/Aeson.hs @@ -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 library. +-- +-- Those instances encode time as JSON strings in +-- 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 +-- , +-- and +-- (where the relevant parsers are defined). diff --git a/src/Data/Aeson/Encoding/Internal.hs b/src/Data/Aeson/Encoding/Internal.hs --- a/src/Data/Aeson/Encoding/Internal.hs +++ b/src/Data/Aeson/Encoding/Internal.hs @@ -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 diff --git a/src/Data/Aeson/KeyMap.hs b/src/Data/Aeson/KeyMap.hs --- a/src/Data/Aeson/KeyMap.hs +++ b/src/Data/Aeson/KeyMap.hs @@ -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 diff --git a/src/Data/Aeson/Parser/Internal.hs b/src/Data/Aeson/Parser/Internal.hs --- a/src/Data/Aeson/Parser/Internal.hs +++ b/src/Data/Aeson/Parser/Internal.hs @@ -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 diff --git a/src/Data/Aeson/Text.hs b/src/Data/Aeson/Text.hs --- a/src/Data/Aeson/Text.hs +++ b/src/Data/Aeson/Text.hs @@ -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' diff --git a/src/Data/Aeson/Types.hs b/src/Data/Aeson/Types.hs --- a/src/Data/Aeson/Types.hs +++ b/src/Data/Aeson/Types.hs @@ -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(..) diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -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 diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs --- a/src/Data/Aeson/Types/Internal.hs +++ b/src/Data/Aeson/Types/Internal.hs @@ -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 -- error location. diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/src/Data/Aeson/Types/ToJSON.hs @@ -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\"" diff --git a/tests/SerializationFormatSpec.hs b/tests/SerializationFormatSpec.hs --- a/tests/SerializationFormatSpec.hs +++ b/tests/SerializationFormatSpec.hs @@ -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 diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -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 ]