diff --git a/Data/Aeson/Encoding/Builder.hs b/Data/Aeson/Encoding/Builder.hs --- a/Data/Aeson/Encoding/Builder.hs +++ b/Data/Aeson/Encoding/Builder.hs @@ -292,7 +292,7 @@ where iend = off + len - outerLoop !i0 !br@(B.BufferRange op0 ope) + outerLoop !i0 br@(B.BufferRange op0 ope) | i0 >= iend = k br | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining) -- TODO: Use a loop with an integrated bound's check if outRemaining diff --git a/Data/Aeson/Internal/Time.hs b/Data/Aeson/Internal/Time.hs --- a/Data/Aeson/Internal/Time.hs +++ b/Data/Aeson/Internal/Time.hs @@ -20,14 +20,13 @@ import Prelude () import Prelude.Compat -import Data.Fixed (Pico) import Data.Int (Int64) import Data.Time import Unsafe.Coerce (unsafeCoerce) #if MIN_VERSION_base(4,7,0) -import Data.Fixed (Fixed(MkFixed)) +import Data.Fixed (Pico, Fixed(MkFixed)) toPico :: Integer -> Pico toPico = MkFixed @@ -36,6 +35,8 @@ fromPico (MkFixed i) = i #else + +import Data.Fixed (Pico) toPico :: Integer -> Pico toPico = unsafeCoerce diff --git a/Data/Aeson/Parser/Internal.hs b/Data/Aeson/Parser/Internal.hs --- a/Data/Aeson/Parser/Internal.hs +++ b/Data/Aeson/Parser/Internal.hs @@ -221,6 +221,8 @@ in Just (S a') data S = S Int# +-- This hint will no longer trigger once hlint > 1.9.41 is released. +{-# ANN S ("HLint: ignore Use newtype instead of data" :: String) #-} #else startState = False go a c diff --git a/Data/Aeson/TH.hs b/Data/Aeson/TH.hs --- a/Data/Aeson/TH.hs +++ b/Data/Aeson/TH.hs @@ -403,44 +403,27 @@ isNullary (NormalC _ []) = True isNullary _ = False -sumToValue :: Options -> Bool -> Name -> Q Exp -> Q Exp -sumToValue opts multiCons conName exp +sumToValue :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp +sumToValue opts multiCons nullary conName exp | multiCons = case sumEncoding opts of TwoElemArray -> [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp]) TaggedObject{tagFieldName, contentsFieldName} -> - [|A.object|] `appE` listE - [ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName) - , infixApp [|T.pack contentsFieldName|] [|(.=)|] exp - ] + let tag = infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName) + contents = infixApp [|T.pack contentsFieldName|] [|(.=)|] exp + in + [|A.object|] `appE` listE (if nullary then [tag] else [tag, contents]) ObjectWithSingleField -> [|A.object|] `appE` listE [ infixApp (conTxt opts conName) [|(.=)|] exp ] + UntaggedValue | nullary -> conStr opts conName UntaggedValue -> exp | otherwise = exp -nullarySumToValue :: Options -> Bool -> Name -> Q Exp -nullarySumToValue opts multiCons conName = - case sumEncoding opts of - TaggedObject{tagFieldName} -> - [|A.object|] `appE` listE - [ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName) - ] - UntaggedValue -> conStr opts conName - _ -> sumToValue opts multiCons conName [e|toJSON ([] :: [()])|] - -- | Generates code to generate the JSON encoding of a single constructor. argsToValue :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match --- Nullary constructors. Generates code that explicitly matches against the --- constructor even though it doesn't contain data. This is useful to prevent --- type errors. -argsToValue jc tjs opts multiCons (NormalC conName []) = do - ([], _) <- reifyConTys jc tjs conName - match (conP conName []) - (normalB (nullarySumToValue opts multiCons conName)) - [] -- Polyadic constructors with special case for unary constructors. argsToValue jc tjs opts multiCons (NormalC conName ts) = do @@ -471,7 +454,7 @@ (varE 'V.create `appE` doE (newMV:stmts++[ret])) match (conP conName $ map varP args) - (normalB $ sumToValue opts multiCons conName js) + (normalB $ sumToValue opts multiCons (null ts) conName js) [] -- Records. @@ -538,7 +521,7 @@ ar <- newName "argR" match (infixP (varP al) conName (varP ar)) ( normalB - $ sumToValue opts multiCons conName + $ sumToValue opts multiCons False conName $ [|toJSON|] `appE` listE [ dispatchToJSON jc conName tvMap aTy `appE` varE a | (a, aTy) <- [(al,alTy), (ar,arTy)] @@ -580,41 +563,27 @@ object :: ExpQ -> ExpQ object exp = [|E.wrapObject|] `appE` exp -sumToEncoding :: Options -> Bool -> Name -> Q Exp -> Q Exp -sumToEncoding opts multiCons conName exp +sumToEncoding :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp +sumToEncoding opts multiCons nullary conName exp | multiCons = let fexp = exp in case sumEncoding opts of TwoElemArray -> array (encStr opts conName <%> fexp) TaggedObject{tagFieldName, contentsFieldName} -> - object $ - ([|E.text (T.pack tagFieldName)|] <:> encStr opts conName) <%> - ([|E.text (T.pack contentsFieldName)|] <:> fexp) + let tag = [|E.text (T.pack tagFieldName)|] <:> encStr opts conName + contents = [|E.text (T.pack contentsFieldName)|] <:> fexp + in + object $ + if nullary then tag else tag <%> contents ObjectWithSingleField -> object (encStr opts conName <:> fexp) + UntaggedValue | nullary -> encStr opts conName UntaggedValue -> exp | otherwise = exp -nullarySumToEncoding :: Options -> Bool -> Name -> Q Exp -nullarySumToEncoding opts multiCons conName = - case sumEncoding opts of - TaggedObject{tagFieldName} -> - object $ - [|E.text (T.pack tagFieldName)|] <:> encStr opts conName - UntaggedValue -> encStr opts conName - _ -> sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|] - -- | Generates code to generate the JSON encoding of a single constructor. argsToEncoding :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match --- Nullary constructors. Generates code that explicitly matches against the --- constructor even though it doesn't contain data. This is useful to prevent --- type errors. -argsToEncoding jc tes opts multiCons (NormalC conName []) = do - ([], _) <- reifyConTys jc tes conName - match (conP conName []) - (normalB (nullarySumToEncoding opts multiCons conName)) - [] -- Polyadic constructors with special case for unary constructors. argsToEncoding jc tes opts multiCons (NormalC conName ts) = do @@ -622,6 +591,9 @@ let len = length ts args <- newNameList "arg" len js <- case zip args argTys of + -- Nullary constructors are converted to an empty array. + [] -> return [| E.emptyArray_ |] + -- Single argument is directly converted. [(e,eTy)] -> return (dispatchToEncoding jc conName tvMap eTy `appE` varE e) @@ -632,7 +604,7 @@ | (x,xTy) <- es ])) match (conP conName $ map varP args) - (normalB $ sumToEncoding opts multiCons conName js) + (normalB $ sumToEncoding opts multiCons (null ts) conName js) [] -- Records. @@ -701,7 +673,7 @@ ([alTy,arTy], tvMap) <- reifyConTys jc tes conName match (infixP (varP al) conName (varP ar)) ( normalB - $ sumToEncoding opts multiCons conName + $ sumToEncoding opts multiCons False conName $ array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap aTy `appE` varE a | (a,aTy) <- [(al,alTy), (ar,arTy)] @@ -1657,7 +1629,7 @@ -- instance C (Fam [Char]) remainingTysOrigSubst :: [Type] remainingTysOrigSubst = - map (substNamesWithKindStar (union droppedKindVarNames kvNames')) + map (substNamesWithKindStar (droppedKindVarNames `union` kvNames')) $ take remainingLength varTysOrig remainingTysOrigSubst' :: [Type] @@ -2146,7 +2118,7 @@ createKindChain = go starK where go :: Kind -> Int -> Kind - go k !0 = k + go k 0 = k #if MIN_VERSION_template_haskell(2,8,0) go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1) #else @@ -2273,7 +2245,7 @@ substNameWithKind n k = substKind (M.singleton n k) substNamesWithKindStar :: [Name] -> Type -> Type -substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns +substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns ------------------------------------------------------------------------------- -- Error messages @@ -2422,13 +2394,12 @@ -- | Does a Type have kind * or k (for some kind variable k)? canRealizeKindStar :: Type -> StarKindStatus -canRealizeKindStar t - | hasKindStar t = KindStar - | otherwise = case t of +canRealizeKindStar t = case t of + _ | hasKindStar t -> KindStar #if MIN_VERSION_template_haskell(2,8,0) - SigT _ (VarT k) -> IsKindVar k + SigT _ (VarT k) -> IsKindVar k #endif - _ -> NotKindStar + _ -> NotKindStar -- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. -- Otherwise, returns 'Nothing'. diff --git a/Data/Aeson/Types/FromJSON.hs b/Data/Aeson/Types/FromJSON.hs --- a/Data/Aeson/Types/FromJSON.hs +++ b/Data/Aeson/Types/FromJSON.hs @@ -281,12 +281,12 @@ -- -- The basic ways to signal a failed conversion are as follows: -- --- * 'empty' and 'mzero' work, but are terse and uninformative +-- * 'empty' and 'mzero' work, but are terse and uninformative; -- --- * 'fail' yields a custom error message +-- * 'fail' yields a custom error message; -- -- * 'typeMismatch' produces an informative message for cases when the --- value encountered is not of the expected type +-- value encountered is not of the expected type. -- -- An example type and instance using 'typeMismatch': -- @@ -296,27 +296,27 @@ -- -- data Coord = Coord { x :: Double, y :: Double } -- --- instance FromJSON Coord where --- parseJSON ('Object' v) = Coord --- '<$>' v '.:' \"x\" +-- instance 'FromJSON' Coord where +-- 'parseJSON' ('Object' v) = Coord +-- '<$>' v '.:' \"x\" -- '<*>' v '.:' \"y\" -- -- \-- We do not expect a non-'Object' value here. -- \-- We could use 'mzero' to fail, but 'typeMismatch' -- \-- gives a much more informative error message. --- parseJSON invalid = 'typeMismatch' \"Coord\" invalid +-- 'parseJSON' invalid = 'typeMismatch' \"Coord\" invalid -- @ -- -- For this common case of only being concerned with a single --- type of JSON value, the functions @withObject@, @withNumber@, etc. +-- type of JSON value, the functions 'withObject', 'withNumber', etc. -- are provided. Their use is to be preferred when possible, since --- they are more terse. Using @withObject@, we can rewrite the above instance +-- they are more terse. Using 'withObject', we can rewrite the above instance -- (assuming the same language extension and data type) as: -- -- @ --- instance FromJSON Coord where --- parseJSON = withObject \"Coord\" $ \v -> Coord --- '<$>' v '.:' \"x\" +-- instance 'FromJSON' Coord where +-- 'parseJSON' = 'withObject' \"Coord\" $ \v -> Coord +-- '<$>' v '.:' \"x\" -- '<*>' v '.:' \"y\" -- @ -- @@ -325,7 +325,7 @@ -- -- * "Data.Aeson.TH" provides Template Haskell functions which will derive an -- instance at compile time. The generated instance is optimized for your type --- so will probably be more efficient than the following two options: +-- so it will probably be more efficient than the following option. -- -- * The compiler can provide a default generic implementation for -- 'parseJSON'. @@ -343,18 +343,21 @@ -- -- data Coord = Coord { x :: Double, y :: Double } deriving 'Generic' -- --- instance FromJSON Coord +-- instance 'FromJSON' Coord -- @ -- --- If @DefaultSignatures@ doesn't give exactly the results you want, --- you can customize the generic decoding with only a tiny amount of --- effort, using 'genericParseJSON' with your preferred 'Options': +-- The default implementation will be equivalent to +-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; If you need different +-- options, you can customize the generic decoding by defining: -- -- @ --- instance FromJSON Coord where --- parseJSON = 'genericParseJSON' 'defaultOptions' +-- customOptions = 'defaultOptions' +-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper' +-- } +-- +-- instance 'FromJSON' Coord where +-- 'parseJSON' = 'genericParseJSON' customOptions -- @ - class FromJSON a where parseJSON :: Value -> Parser a @@ -516,7 +519,7 @@ -- -- * "Data.Aeson.TH" provides Template Haskell functions which will derive an -- instance at compile time. The generated instance is optimized for your type --- so will probably be more efficient than the following two options: +-- so it will probably be more efficient than the following option. -- -- * The compiler can provide a default generic implementation for -- 'liftParseJSON'. @@ -534,16 +537,20 @@ -- -- data Pair a b = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1' -- --- instance FromJSON a => FromJSON1 (Pair a) +-- instance 'FromJSON' a => 'FromJSON1' (Pair a) -- @ -- --- If @DefaultSignatures@ doesn't give exactly the results you want, +-- 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': -- -- @ --- instance FromJSON a => FromJSON1 (Pair a) where --- liftParseJSON = 'genericLiftParseJSON' 'defaultOptions' +-- customOptions = 'defaultOptions' +-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper' +-- } +-- +-- instance 'FromJSON' a => 'FromJSON1' (Pair a) where +-- 'liftParseJSON' = 'genericLiftParseJSON' customOptions -- @ class FromJSON1 f where liftParseJSON :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a) @@ -614,43 +621,44 @@ -- Functions ------------------------------------------------------------------------------- --- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@ --- and fails using @'typeMismatch' expected@ otherwise. +-- | @'withObject' expected f value@ applies @f@ to the 'Object' when @value@ +-- is an 'Object' and fails using @'typeMismatch' expected@ otherwise. withObject :: String -> (Object -> Parser a) -> Value -> Parser a withObject _ f (Object obj) = f obj withObject expected _ v = typeMismatch expected v {-# INLINE withObject #-} --- | @withText expected f value@ applies @f@ to the 'Text' when @value@ is a @String@ --- and fails using @'typeMismatch' expected@ otherwise. +-- | @'withText' expected f value@ applies @f@ to the 'Text' when @value@ is a +-- 'String' and fails using @'typeMismatch' expected@ otherwise. withText :: String -> (Text -> Parser a) -> Value -> Parser a withText _ f (String txt) = f txt withText expected _ v = typeMismatch expected v {-# INLINE withText #-} --- | @withArray expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@ --- and fails using @'typeMismatch' expected@ otherwise. +-- | @'withArray' expected f value@ applies @f@ to the 'Array' when @value@ is +-- an 'Array' and fails using @'typeMismatch' expected@ otherwise. withArray :: String -> (Array -> Parser a) -> Value -> Parser a withArray _ f (Array arr) = f arr withArray expected _ v = typeMismatch expected v {-# INLINE withArray #-} --- | @withNumber expected f value@ applies @f@ to the 'Number' when @value@ is a 'Number'. --- and fails using @'typeMismatch' expected@ otherwise. +-- | @'withNumber' expected f value@ applies @f@ to the 'Number' when @value@ +-- is a 'Number' and fails using @'typeMismatch' expected@ otherwise. withNumber :: String -> (Number -> Parser a) -> Value -> Parser a withNumber expected f = withScientific expected (f . scientificToNumber) {-# INLINE withNumber #-} {-# DEPRECATED withNumber "Use withScientific instead" #-} --- | @withScientific expected f value@ applies @f@ to the 'Scientific' number when @value@ is a 'Number'. --- and fails using @'typeMismatch' expected@ otherwise. +-- | @'withScientific' expected f value@ applies @f@ to the 'Scientific' number +-- when @value@ is a 'Number' and fails using @'typeMismatch' expected@ +-- otherwise. withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a withScientific _ f (Number scientific) = f scientific withScientific expected _ v = typeMismatch expected v {-# INLINE withScientific #-} --- | @withBool expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@ --- and fails using @'typeMismatch' expected@ otherwise. +-- | @'withBool' expected f value@ applies @f@ to the 'Bool' when @value@ is a +-- 'Bool' and fails using @'typeMismatch' expected@ otherwise. withBool :: String -> (Bool -> Parser a) -> Value -> Parser a withBool _ f (Bool arr) = f arr withBool expected _ v = typeMismatch expected v diff --git a/Data/Aeson/Types/Internal.hs b/Data/Aeson/Types/Internal.hs --- a/Data/Aeson/Types/Internal.hs +++ b/Data/Aeson/Types/Internal.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE RecordWildCards #-} #if __GLASGOW_HASKELL__ >= 800 -- a) THQ works on cross-compilers and unregisterised GHCs -- b) may make compilation faster as no dynamic loading is ever needed (not sure about this) @@ -75,6 +74,7 @@ import Data.Foldable (foldl') import Data.HashMap.Strict (HashMap) import Data.Hashable (Hashable(..)) +import Data.List (intercalate) import Data.Scientific (Scientific) import Data.Semigroup (Semigroup((<>))) import Data.String (IsString(..)) @@ -527,16 +527,17 @@ } instance Show Options where - show Options{..} = "Options {" ++ - "fieldLabelModifier =~ " ++ - show (fieldLabelModifier "exampleField") ++ ", " ++ - "constructorTagModifier =~ " ++ - show (constructorTagModifier "ExampleConstructor") ++ ", " ++ - "allNullaryToStringTag = " ++ show allNullaryToStringTag ++ ", " ++ - "omitNothingFields = " ++ show omitNothingFields ++ ", " ++ - "sumEncoding = " ++ show sumEncoding ++ ", " ++ - "unwrapUnaryRecords = " ++ show unwrapUnaryRecords ++ - "}" + show (Options f c a o s u) = + "Options {" + ++ intercalate ", " + [ "fieldLabelModifier =~ " ++ show (f "exampleField") + , "constructorTagModifier =~ " ++ show (c "ExampleConstructor") + , "allNullaryToStringTag = " ++ show a + , "omitNothingFields = " ++ show o + , "sumEncoding = " ++ show s + , "unwrapUnaryRecords = " ++ show u + ] + ++ "}" -- | Specifies how to encode constructors of a sum datatype. data SumEncoding = @@ -554,18 +555,18 @@ -- the 'contentsFieldName' field. | UntaggedValue -- ^ Constructor names won't be encoded. Instead only the contents of the - -- constructor will be encoded as if the type had single constructor. JSON + -- constructor will be encoded as if the type had a single constructor. JSON -- encodings have to be disjoint for decoding to work properly. -- -- When decoding, constructors are tried in the order of definition. If some -- encodings overlap, the first one defined will succeed. -- - -- /Note:/ Nullary constructors are encoded as the string (using + -- /Note:/ Nullary constructors are encoded as strings (using -- 'constructorTagModifier'). Having a nullary constructor alongside a -- single field constructor that encodes to a string leads to ambiguity. -- -- /Note:/ Only the last error is kept when decoding, so in the case of - -- mailformed JSON, only an error for the last constructor will be reported. + -- malformed JSON, only an error for the last constructor will be reported. | ObjectWithSingleField -- ^ A constructor will be encoded to an object with a single -- field named after the constructor tag (modified by the diff --git a/Data/Aeson/Types/ToJSON.hs b/Data/Aeson/Types/ToJSON.hs --- a/Data/Aeson/Types/ToJSON.hs +++ b/Data/Aeson/Types/ToJSON.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} @@ -132,6 +131,8 @@ import qualified Data.ByteString.Lazy.Internal as L #endif +{-# ANN module ("HLint: ignore Reduce duplication"::String) #-} + toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b) {-# INLINE toJSONPair #-} @@ -205,6 +206,9 @@ -- | A type that can be converted to JSON. -- +-- Instances in general /must/ specify 'toJSON' and /should/ (but don't need +-- to) specify 'toEncoding'. +-- -- An example type and instance: -- -- @ @@ -213,10 +217,10 @@ -- -- data Coord = Coord { x :: Double, y :: Double } -- --- instance ToJSON Coord where --- toJSON (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y] +-- instance 'ToJSON' Coord where +-- 'toJSON' (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y] -- --- toEncoding (Coord x y) = 'pairs' (\"x\" '.=' x '<>' \"y\" '.=' y) +-- 'toEncoding' (Coord x y) = 'pairs' (\"x\" '.=' x '<>' \"y\" '.=' y) -- @ -- -- Instead of manually writing your 'ToJSON' instance, there are two options @@ -224,17 +228,15 @@ -- -- * "Data.Aeson.TH" provides Template Haskell functions which will derive an -- instance at compile time. The generated instance is optimized for your type --- so will probably be more efficient than the following two options: +-- so it will probably be more efficient than the following option. -- -- * The compiler can provide a default generic implementation for -- 'toJSON'. -- -- To use the second, simply add a @deriving 'Generic'@ clause to your --- datatype and declare a 'ToJSON' instance for your datatype without giving --- definitions for 'toJSON' or 'toEncoding'. --- --- For example, the previous example can be simplified to a more --- minimal instance: +-- datatype and declare a 'ToJSON' instance. If you require nothing other than +-- 'defaultOptions', it is sufficient to write (and this is the only +-- alternative where the default 'toJSON' implementation is sufficient): -- -- @ -- {-\# LANGUAGE DeriveGeneric \#-} @@ -243,30 +245,41 @@ -- -- data Coord = Coord { x :: Double, y :: Double } deriving 'Generic' -- --- instance ToJSON Coord where --- toEncoding = 'genericToEncoding' 'defaultOptions' +-- instance 'ToJSON' Coord where +-- 'toEncoding' = 'genericToEncoding' 'defaultOptions' -- @ -- --- Why do we provide an implementation for 'toEncoding' here? The --- 'toEncoding' function is a relatively new addition to this class. --- To allow users of older versions of this library to upgrade without --- having to edit all of their instances or encounter surprising --- incompatibilities, the default implementation of 'toEncoding' uses --- 'toJSON'. This produces correct results, but since it performs an --- intermediate conversion to a 'Value', it will be less efficient --- than directly emitting an 'Encoding'. Our one-liner definition of --- 'toEncoding' above bypasses the intermediate 'Value'. --- --- If @DefaultSignatures@ doesn't give exactly the results you want, --- you can customize the generic encoding with only a tiny amount of --- effort, using 'genericToJSON' and 'genericToEncoding' with your --- preferred 'Options': +-- If on the other hand you wish to customize the generic decoding, you have +-- to implement both methods: -- -- @ --- instance ToJSON Coord where --- toJSON = 'genericToJSON' 'defaultOptions' --- toEncoding = 'genericToEncoding' 'defaultOptions' +-- customOptions = 'defaultOptions' +-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper' +-- } +-- +-- instance 'ToJSON' Coord where +-- 'toJSON' = 'genericToJSON' customOptions +-- 'toEncoding' = 'genericToEncoding' customOptions -- @ +-- +-- Previous versions of this library only had the 'toJSON' method. Adding +-- 'toEncoding' had to reasons: +-- +-- 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. +-- +-- 2. The choice of defaults allows a smooth transition for existing users: +-- Existing instances that do not define 'toEncoding' still +-- compile and have the correct semantics. This is ensured by making +-- the default implementation of 'toEncoding' use 'toJSON'. This produces +-- correct results, but since it performs an intermediate conversion to a +-- 'Value', it will be less efficient than directly emitting an 'Encoding'. +-- (this also means that specifying nothing more than +-- @instance ToJSON Coord@ would be sufficient as a generically decoding +-- instance, but there probably exists no good reason to not specify +-- 'toEncoding' in new instances.) class ToJSON a where -- | Convert a Haskell value to a JSON-friendly intermediate type. toJSON :: a -> Value @@ -288,8 +301,8 @@ -- extension, and then have GHC generate a method body as follows. -- -- @ - -- instance ToJSON Coord where - -- toEncoding = 'genericToEncoding' 'defaultOptions' + -- instance 'ToJSON' Coord where + -- 'toEncoding' = 'genericToEncoding' 'defaultOptions' -- @ toEncoding :: a -> Encoding @@ -491,7 +504,7 @@ -- -- * "Data.Aeson.TH" provides Template Haskell functions which will derive an -- instance at compile time. The generated instance is optimized for your type --- so will probably be more efficient than the following two options: +-- so it will probably be more efficient than the following option. -- -- * The compiler can provide a default generic implementation for -- 'toJSON1'. @@ -509,19 +522,25 @@ -- -- data Pair = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1' -- --- instance ToJSON a => ToJSON1 (Pair a) +-- instance 'ToJSON' a => 'ToJSON1' (Pair a) -- @ -- --- If @DefaultSignatures@ doesn't give exactly the results you want, +-- If the default implementation doesn't give exactly the results you want, -- you can customize the generic encoding with only a tiny amount of -- effort, using 'genericLiftToJSON' and 'genericLiftToEncoding' with -- your preferred 'Options': -- -- @ --- instance ToJSON a => ToJSON1 (Pair a) where --- liftToJSON = 'genericLiftToJSON' 'defaultOptions' --- liftToEncoding = 'genericLiftToEncoding' 'defaultOptions' +-- customOptions = 'defaultOptions' +-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper' +-- } +-- +-- instance 'ToJSON' a => 'ToJSON1' (Pair a) where +-- 'liftToJSON' = 'genericLiftToJSON' customOptions +-- 'liftToEncoding' = 'genericLiftToEncoding' customOptions -- @ +-- +-- See also 'ToJSON'. class ToJSON1 f where liftToJSON :: (a -> Value) -> ([a] -> Value) -> f a -> Value @@ -588,7 +607,7 @@ -- @ -- newtype F a = F [a] -- --- -- This instance encodes String as an array of chars +-- -- This instance encodes 'String' as an array of chars -- instance 'ToJSON1' F where -- 'liftToJSON' tj _ (F xs) = 'liftToJSON' tj ('listValue' tj) xs -- 'liftToEncoding' te _ (F xs) = 'liftToEncoding' te ('listEncoding' te) xs @@ -2809,8 +2828,8 @@ packChunks lbs = S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs) where - copyChunks !L.Empty !_pf = return () - copyChunks !(L.Chunk (S.PS fpbuf o l) lbs') !pf = do + copyChunks L.Empty _pf = return () + copyChunks (L.Chunk (S.PS fpbuf o l) lbs') pf = do withForeignPtr fpbuf $ \pbuf -> copyBytes pf (pbuf `plusPtr` o) l copyChunks lbs' (pf `plusPtr` l) diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -1,5 +1,5 @@ name: aeson -version: 1.1.1.0 +version: 1.1.2.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON diff --git a/benchmarks/AesonCompareAutoInstances.hs b/benchmarks/AesonCompareAutoInstances.hs --- a/benchmarks/AesonCompareAutoInstances.hs +++ b/benchmarks/AesonCompareAutoInstances.hs @@ -43,7 +43,7 @@ d = Record { testOne = 1234.56789 , testTwo = True - , testThree = Product "Hello World!" 'a' $ + , testThree = Product "Hello World!" 'a' Record { testOne = 9876.54321 , testTwo = False @@ -80,7 +80,7 @@ d' = Record' { testOne' = 1234.56789 , testTwo' = True - , testThree' = Product' "Hello World!" 'a' $ + , testThree' = Product' "Hello World!" 'a' Record' { testOne' = 9876.54321 , testTwo' = False diff --git a/benchmarks/AesonEncode.hs b/benchmarks/AesonEncode.hs --- a/benchmarks/AesonEncode.hs +++ b/benchmarks/AesonEncode.hs @@ -7,7 +7,6 @@ import Prelude.Compat import Control.DeepSeq -import Control.Exception import Control.Monad import Data.Aeson import Data.Attoparsec.ByteString (IResult(..), parseWith) @@ -25,7 +24,7 @@ (c:a) -> (c,a) [] -> error "Unexpected empty list" let count = read cnt :: Int - forM_ args $ \arg -> bracket (openFile arg ReadMode) hClose $ \h -> do + forM_ args $ \arg -> withFile arg ReadMode $ \h -> do putStrLn $ arg ++ ":" let refill = B.hGet h 16384 result0 <- parseWith refill json =<< refill @@ -35,7 +34,7 @@ start <- getCurrentTime let loop !n r | n >= count = return () - | otherwise = {-# SCC "loop" #-} do + | otherwise = {-# SCC "loop" #-} rnf (encode r) `seq` loop (n+1) r loop 0 r0 delta <- flip diffUTCTime start `fmap` getCurrentTime diff --git a/benchmarks/AesonMap.hs b/benchmarks/AesonMap.hs --- a/benchmarks/AesonMap.hs +++ b/benchmarks/AesonMap.hs @@ -97,16 +97,16 @@ value10000 = value 10000 encodedValue10 :: LBS.ByteString -encodedValue10 = B.encode $ value10 +encodedValue10 = B.encode value10 encodedValue100 :: LBS.ByteString -encodedValue100 = B.encode $ value100 +encodedValue100 = B.encode value100 encodedValue1000 :: LBS.ByteString -encodedValue1000 = B.encode $ value1000 +encodedValue1000 = B.encode value1000 encodedValue10000 :: LBS.ByteString -encodedValue10000 = B.encode $ value10000 +encodedValue10000 = B.encode value10000 ------------------------------------------------------------------------------- -- Helpers diff --git a/benchmarks/AesonParse.hs b/benchmarks/AesonParse.hs --- a/benchmarks/AesonParse.hs +++ b/benchmarks/AesonParse.hs @@ -8,7 +8,6 @@ import Prelude.Compat import "aeson-benchmarks" Data.Aeson -import Control.Exception import Control.Monad import Data.Attoparsec.ByteString (IResult(..), parseWith) import Data.Time.Clock @@ -21,7 +20,7 @@ (bs:cnt:args) <- getArgs let count = read cnt :: Int blkSize = read bs - forM_ args $ \arg -> bracket (openFile arg ReadMode) hClose $ \h -> do + forM_ args $ \arg -> withFile arg ReadMode $ \h -> do putStrLn $ arg ++ ":" start <- getCurrentTime let loop !good !bad diff --git a/benchmarks/AesonTuples.hs b/benchmarks/AesonTuples.hs --- a/benchmarks/AesonTuples.hs +++ b/benchmarks/AesonTuples.hs @@ -1,5 +1,3 @@ -module Main where - module Main (main) where import Prelude () diff --git a/benchmarks/Compare/JsonBench.hs b/benchmarks/Compare/JsonBench.hs --- a/benchmarks/Compare/JsonBench.hs +++ b/benchmarks/Compare/JsonBench.hs @@ -3,7 +3,6 @@ -- https://github.com/chadaustin/buffer-builder/blob/master/test.json {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -65,10 +64,10 @@ instance NFData Fruit where rnf !_ = () instance NFData Friend where - rnf Friend {..} = (rnf fId) `seq` (rnf fName) `seq` () + rnf Friend {..} = rnf fId `seq` rnf fName `seq` () instance NFData User where - rnf User {..} = (rnf uId) `seq` (rnf uIndex) `seq` (rnf uGuid) `seq` (rnf uIsActive) `seq` (rnf uBalance) `seq` (rnf uPicture) `seq` (rnf uAge) `seq` (rnf uEyeColor) `seq` (rnf uName) `seq` (rnf uGender) `seq` (rnf uCompany) `seq` (rnf uEmail) `seq` (rnf uPhone) `seq` (rnf uAddress) `seq` (rnf uAbout) `seq` (rnf uRegistered) `seq` (rnf uLatitude) `seq` (rnf uLongitude) `seq` (rnf uTags) `seq` (rnf uFriends) `seq` (rnf uGreeting) `seq` (rnf uFavouriteFruit) `seq` () + rnf User {..} = rnf uId `seq` rnf uIndex `seq` rnf uGuid `seq` rnf uIsActive `seq` rnf uBalance `seq` rnf uPicture `seq` rnf uAge `seq` rnf uEyeColor `seq` rnf uName `seq` rnf uGender `seq` rnf uCompany `seq` rnf uEmail `seq` rnf uPhone `seq` rnf uAddress `seq` rnf uAbout `seq` rnf uRegistered `seq` rnf uLatitude `seq` rnf uLongitude `seq` rnf uTags `seq` rnf uFriends `seq` rnf uGreeting `seq` rnf uFavouriteFruit `seq` () eyeColorTable :: [(Text, EyeColor)] eyeColorTable = [("brown", Brown), ("green", Green), ("blue", Blue)] diff --git a/benchmarks/CompareWithJSON.hs b/benchmarks/CompareWithJSON.hs --- a/benchmarks/CompareWithJSON.hs +++ b/benchmarks/CompareWithJSON.hs @@ -9,6 +9,7 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromString) import Control.DeepSeq (NFData(rnf)) import Criterion.Main +import Data.Maybe (fromMaybe) import qualified Data.Aeson as A import qualified Data.Aeson.Text as A import qualified Data.ByteString.Lazy as BL @@ -35,14 +36,10 @@ J.Error _ -> error "fail to parse via JSON" decodeA :: BL.ByteString -> A.Value -decodeA s = case A.decode s of - Just v -> v - Nothing -> error "fail to parse via Aeson" +decodeA s = fromMaybe (error "fail to parse via Aeson") $ A.decode s decodeA' :: BL.ByteString -> A.Value -decodeA' s = case A.decode' s of - Just v -> v - Nothing -> error "fail to parse via Aeson" +decodeA' s = fromMaybe (error "fail to parse via Aeson") $ A.decode' s encodeJ :: J.JSValue -> BL.ByteString encodeJ = toLazyByteString . fromString . J.encode diff --git a/benchmarks/Dates.hs b/benchmarks/Dates.hs --- a/benchmarks/Dates.hs +++ b/benchmarks/Dates.hs @@ -22,22 +22,22 @@ defaultMain [ bgroup "decode" [ bgroup "UTCTime" [ - env file1 $ \ ~bs -> bench "whole" $ nf utcTime bs - , env file2 $ \ ~bs -> bench "fractional" $ nf utcTime bs + env file1 $ \bs -> bench "whole" $ nf utcTime bs + , env file2 $ \bs -> bench "fractional" $ nf utcTime bs ] , bgroup "ZonedTime" [ - env file1 $ \ ~bs -> bench "whole" $ nf zTime bs - , env file2 $ \ ~bs -> bench "fractional" $ nf zTime bs + env file1 $ \bs -> bench "whole" $ nf zTime bs + , env file2 $ \bs -> bench "fractional" $ nf zTime bs ] ] , bgroup "encode" [ bgroup "UTCTime" [ - env (utcTime <$> file1) $ \ ~ts -> bench "whole" $ nf encode ts - , env (utcTime <$> file2) $ \ ~ts -> bench "fractional" $ nf encode ts + env (utcTime <$> file1) $ \ts -> bench "whole" $ nf encode ts + , env (utcTime <$> file2) $ \ts -> bench "fractional" $ nf encode ts ] , bgroup "ZonedTime" [ - env (zTime <$> file1) $ \ ~ts -> bench "whole" $ nf encode ts - , env (zTime <$> file2) $ \ ~ts -> bench "fractional" $ nf encode ts + env (zTime <$> file1) $ \ts -> bench "whole" $ nf encode ts + , env (zTime <$> file2) $ \ts -> bench "fractional" $ nf encode ts ] ] ] diff --git a/benchmarks/ReadFile.hs b/benchmarks/ReadFile.hs --- a/benchmarks/ReadFile.hs +++ b/benchmarks/ReadFile.hs @@ -20,7 +20,7 @@ main = do (cnt:args) <- getArgs let count = read cnt :: Int - forM_ args $ \arg -> bracket (openFile arg ReadMode) hClose $ \h -> do + forM_ args $ \arg -> withFile arg ReadMode $ \h -> do putStrLn $ arg ++ ":" start <- getCurrentTime let loop !n diff --git a/benchmarks/Typed/Common.hs b/benchmarks/Typed/Common.hs --- a/benchmarks/Typed/Common.hs +++ b/benchmarks/Typed/Common.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +#ifdef HAS_BOTH_AESON_AND_BENCHMARKS {-# LANGUAGE PackageImports #-} +#endif {-# OPTIONS_GHC -fno-warn-unused-imports #-} diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,11 @@ For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md). +### 1.1.2.0 + +* Fix an accidental change in the format of `deriveJSON`. Thanks to Xia Li-yao! + +* Documentation improvements regarding `ToJSON`, `FromJSON`, and `SumEncoding`. Thanks to Xia Li-yao and Lennart Spitzner! + ### 1.1.1.0 * Added a pure implementation of the C FFI code, the C FFI code. If you wish to use the pure haskell version set the `cffi` flag to `False`. This should make aeson compile when C isn't available, such as for GHCJS. Thanks to James Parker & Marcin Tolysz! diff --git a/examples/Twitter.hs b/examples/Twitter.hs --- a/examples/Twitter.hs +++ b/examples/Twitter.hs @@ -29,6 +29,9 @@ import GHC.Generics (Generic) import Prelude hiding (id) +{-# ANN module "Hlint: ignore Use camelCase" #-} +{-# ANN module "Hlint: ignore Use newtype instead of data" #-} + data Metadata = Metadata { result_type :: Text } deriving (Eq, Show, Typeable, Data, Generic) diff --git a/examples/Twitter/Generic.hs b/examples/Twitter/Generic.hs --- a/examples/Twitter/Generic.hs +++ b/examples/Twitter/Generic.hs @@ -1,6 +1,5 @@ -- Use GHC generics to automatically generate good instances. {-# LANGUAGE CPP #-} -{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Twitter.Generic diff --git a/examples/Twitter/Manual.hs b/examples/Twitter/Manual.hs --- a/examples/Twitter/Manual.hs +++ b/examples/Twitter/Manual.hs @@ -1,10 +1,13 @@ -- Manually write instances. {-# LANGUAGE CPP #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + +#ifdef HAS_BOTH_AESON_AND_BENCHMARKS +{-# LANGUAGE PackageImports #-} +#endif module Twitter.Manual ( diff --git a/pure/Data/Aeson/Parser/UnescapePure.hs b/pure/Data/Aeson/Parser/UnescapePure.hs --- a/pure/Data/Aeson/Parser/UnescapePure.hs +++ b/pure/Data/Aeson/Parser/UnescapePure.hs @@ -52,23 +52,23 @@ {-# INLINE setByte1 #-} setByte2 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a -setByte2 point word = point .|. ((fromIntegral $ word .&. 0x3f) `shiftL` 6) +setByte2 point word = point .|. (fromIntegral (word .&. 0x3f) `shiftL` 6) {-# INLINE setByte2 #-} setByte2Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a -setByte2Top point word = point .|. ((fromIntegral $ word .&. 0x1f) `shiftL` 6) +setByte2Top point word = point .|. (fromIntegral (word .&. 0x1f) `shiftL` 6) {-# INLINE setByte2Top #-} setByte3 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a -setByte3 point word = point .|. ((fromIntegral $ word .&. 0x3f) `shiftL` 12) +setByte3 point word = point .|. (fromIntegral (word .&. 0x3f) `shiftL` 12) {-# INLINE setByte3 #-} setByte3Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a -setByte3Top point word = point .|. ((fromIntegral $ word .&. 0xf) `shiftL` 12) +setByte3Top point word = point .|. (fromIntegral (word .&. 0xf) `shiftL` 12) {-# INLINE setByte3Top #-} setByte4 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a -setByte4 point word = point .|. ((fromIntegral $ word .&. 0x7) `shiftL` 18) +setByte4 point word = point .|. (fromIntegral (word .&. 0x7) `shiftL` 18) {-# INLINE setByte4 #-} decode :: Utf -> Word32 -> Word8 -> (Utf, Word32) @@ -207,12 +207,12 @@ let u = w' .|. w in -- Get next state based on surrogates. - let st = - if u >= 0xd800 && u <= 0xdbff then -- High surrogate. + let st + | u >= 0xd800 && u <= 0xdbff = -- High surrogate. StateS0 - else if u >= 0xdc00 && u <= 0xdfff then -- Low surrogate. + | u >= 0xdc00 && u <= 0xdfff = -- Low surrogate. throwDecodeError - else + | otherwise = StateNone in writeAndReturn dest pos u st diff --git a/tests/Encoders.hs b/tests/Encoders.hs --- a/tests/Encoders.hs +++ b/tests/Encoders.hs @@ -341,3 +341,16 @@ thGADTParseJSONDefault :: Value -> Parser (GADT String) thGADTParseJSONDefault = $(mkParseJSON defaultOptions ''GADT) + +-------------------------------------------------------------------------------- +-- OneConstructor encoders/decoders +-------------------------------------------------------------------------------- + +thOneConstructorToJSONDefault :: OneConstructor -> Value +thOneConstructorToJSONDefault = $(mkToJSON defaultOptions ''OneConstructor) + +thOneConstructorToEncodingDefault :: OneConstructor -> Encoding +thOneConstructorToEncodingDefault = $(mkToEncoding defaultOptions ''OneConstructor) + +thOneConstructorParseJSONDefault :: Value -> Parser OneConstructor +thOneConstructorParseJSONDefault = $(mkParseJSON defaultOptions ''OneConstructor) diff --git a/tests/Instances.hs b/tests/Instances.hs --- a/tests/Instances.hs +++ b/tests/Instances.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Instances () where @@ -44,6 +43,8 @@ #if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,8,3) import Numeric.Natural #endif + +{-# ANN module ("HLint: ignore Use fewer imports"::String) #-} -- "System" types. diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -33,7 +33,7 @@ import Numeric.Natural (Natural) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Arbitrary(..), Property, (===), (.&&.), counterexample) +import Test.QuickCheck (Arbitrary(..), Property, Testable, (===), (.&&.), counterexample) import Types import qualified Data.Attoparsec.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L @@ -149,6 +149,11 @@ -- Value properties -------------------------------------------------------------------------------- +-- | Add the formatted @Value@ to the printed counterexample when the property +-- fails. +checkValue :: Testable a => (Value -> a) -> Value -> Property +checkValue prop v = counterexample (L.unpack (encode v)) (prop v) + isString :: Value -> Bool isString (String _) = True isString _ = False @@ -182,7 +187,13 @@ isUntaggedValueETI (Array a) = length a == 2 isUntaggedValueETI _ = False +isEmptyArray :: Value -> Property +isEmptyArray = checkValue isEmptyArray' +isEmptyArray' :: Value -> Bool +isEmptyArray' = (Array mempty ==) + + -------------------------------------------------------------------------------- @@ -224,7 +235,7 @@ [ testProperty "Identity Char" $ roundTripEq (undefined :: I Int) , testProperty "Identity Char" $ roundTripEq (undefined :: I Char) - , testProperty "Identity [Char]" $ roundTripEq (undefined :: I [Char]) + , testProperty "Identity [Char]" $ roundTripEq (undefined :: I String) , testProperty "[Identity Char]" $ roundTripEq (undefined :: [I Char]) , testProperty "Compose I I Int" $ roundTripEq (undefined :: LogScaled (Compose I I Int)) @@ -410,23 +421,29 @@ , testProperty "ObjectWithSingleField unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleField thSomeTypeLiftToJSONObjectWithSingleField) ] - , testGroup "Approx" [ - testProperty "string" (isString . thApproxToJSONUnwrap) - , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault) - , testGroup "roundTrip" [ - testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap) - , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault) - ] + ] + , testGroup "Approx" [ + testProperty "string" (isString . thApproxToJSONUnwrap) + , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault) + , testGroup "roundTrip" [ + testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap) + , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault) ] - , testGroup "GADT" [ - testProperty "string" (isString . thGADTToJSONUnwrap) - , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault) - , testGroup "roundTrip" [ - testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap) - , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault) - ] + ] + , testGroup "GADT" [ + testProperty "string" (isString . thGADTToJSONUnwrap) + , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault) + , testGroup "roundTrip" [ + testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap) + , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault) ] ] + , testGroup "OneConstructor" [ + testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault) + , testGroup "roundTrip" [ + testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault) + ] + ] ] , testGroup "toEncoding" [ testProperty "NullaryString" $ @@ -466,6 +483,9 @@ thSomeTypeLiftToJSONObjectWithSingleField `sameAs1` thSomeTypeLiftToEncodingObjectWithSingleField , testProperty "SomeTypeObjectWithSingleField unary agree" $ thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField + + , testProperty "OneConstructor" $ + thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault ] ] ] diff --git a/tests/SerializationFormatSpec.hs b/tests/SerializationFormatSpec.hs --- a/tests/SerializationFormatSpec.hs +++ b/tests/SerializationFormatSpec.hs @@ -86,7 +86,7 @@ , Example "Map Int Int" "{\"0\":1,\"2\":3}" (M.fromList [(0,1),(2,3)] :: M.Map Int Int) , Example "Map (Tagged Int Int) Int" "{\"0\":1,\"2\":3}" (M.fromList [(Tagged 0,1),(Tagged 2,3)] :: M.Map (Tagged Int Int) Int) , Example "Map [Int] Int" "[[[0],1],[[2],3]]" (M.fromList [([0],1),([2],3)] :: M.Map [Int] Int) - , Example "Map [Char] Int" "{\"ab\":1,\"cd\":3}" (M.fromList [("ab",1),("cd",3)] :: M.Map [Char] Int) + , Example "Map [Char] Int" "{\"ab\":1,\"cd\":3}" (M.fromList [("ab",1),("cd",3)] :: M.Map String Int) , Example "Map [I Char] Int" "{\"ab\":1,\"cd\":3}" (M.fromList [(map pure "ab",1),(map pure "cd",3)] :: M.Map [I Char] Int) , Example "nan :: Double" "null" (Approx $ 0/0 :: Approx Double) @@ -197,9 +197,9 @@ jsonDecodingExamples = [ -- Maybe serialising is lossy -- https://github.com/bos/aeson/issues/376 - MaybeExample "Nothing" "null" (Just $ Nothing :: Maybe (Maybe Int)) + MaybeExample "Nothing" "null" (Just Nothing :: Maybe (Maybe Int)) , MaybeExample "Just" "1" (Just $ Just 1 :: Maybe (Maybe Int)) - , MaybeExample "Just Nothing" "null" (Just $ Nothing :: Maybe (Maybe (Maybe Int))) + , MaybeExample "Just Nothing" "null" (Just Nothing :: Maybe (Maybe (Maybe Int))) -- Integral values are truncated, and overflowed -- https://github.com/bos/aeson/issues/317 , MaybeExample "Word8 3" "3" (Just 3 :: Maybe Word8) diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -74,14 +74,14 @@ assertEqual "" "camel_api_case" (camelTo2 '_' "CamelAPICase") ] , testGroup "encoding" [ - testCase "goodProducer" $ goodProducer + testCase "goodProducer" goodProducer ] , testGroup "utctime" [ - testCase "good" $ utcTimeGood - , testCase "bad" $ utcTimeBad + testCase "good" utcTimeGood + , testCase "bad" utcTimeBad ] , testGroup "formatError" [ - testCase "example 1" $ formatErrorExample + testCase "example 1" formatErrorExample ] , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark , testGroup "JSONPath" $ fmap (testCase "-") jsonPath @@ -91,6 +91,7 @@ , testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions , testCase "PR #455" pr455 , testCase "Unescape string (PR #477)" unescapeString + , testCase "Show Options" showOptions ] roundTripCamel :: String -> Assertion @@ -186,11 +187,9 @@ where parseWithRead :: String -> LT.Text -> UTCTime parseWithRead f s = - case parseTime defaultTimeLocale f . LT.unpack $ s of - Nothing -> error "parseTime input malformed" - Just t -> t + fromMaybe (error "parseTime input malformed") . parseTime defaultTimeLocale f . LT.unpack $ s parseWithAeson :: LT.Text -> Maybe UTCTime - parseWithAeson s = decode . LT.encodeUtf8 $ (LT.concat ["\"", s, "\""]) + parseWithAeson s = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""] -- Test that a few non-timezone qualified timestamp formats get -- rejected if decoding to UTCTime. @@ -206,7 +205,7 @@ verifyFailParse "2015-01-03 12:13.000Z" -- decimal at the end, but no seconds where verifyFailParse (s :: LT.Text) = - let (dec :: Maybe UTCTime) = decode . LT.encodeUtf8 $ (LT.concat ["\"", s, "\""]) in + let (dec :: Maybe UTCTime) = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""] in assertEqual "verify failure" Nothing dec -- Non identifier keys should be escaped & enclosed in brackets @@ -234,11 +233,11 @@ , assertEqual ".: 42" (Just (T1 (Just 42))) (decode ex2 :: Maybe T1) , assertEqual ".: null" (Just (T1 Nothing)) (decode ex3 :: Maybe T1) - , assertEqual ".:? not-present" (Just (T2 (Nothing))) (decode ex1 :: Maybe T2) + , assertEqual ".:? not-present" (Just (T2 Nothing)) (decode ex1 :: Maybe T2) , assertEqual ".:? 42" (Just (T2 (Just 42))) (decode ex2 :: Maybe T2) , assertEqual ".:? null" (Just (T2 Nothing)) (decode ex3 :: Maybe T2) - , assertEqual ".:! not-present" (Just (T3 (Nothing))) (decode ex1 :: Maybe T3) + , assertEqual ".:! not-present" (Just (T3 Nothing)) (decode ex1 :: Maybe T3) , assertEqual ".:! 42" (Just (T3 (Just 42))) (decode ex2 :: Maybe T3) , assertEqual ".:! null" Nothing (decode ex3 :: Maybe T3) ] @@ -482,6 +481,20 @@ where foo :: Foo Int foo = FooCons FooNil + +showOptions :: Assertion +showOptions = + assertEqual + "Show Options" + ( "Options {" + ++ "fieldLabelModifier =~ \"exampleField\"" + ++ ", constructorTagModifier =~ \"ExampleConstructor\"" + ++ ", allNullaryToStringTag = True" + ++ ", omitNothingFields = False" + ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}" + ++ ", unwrapUnaryRecords = False" + ++ "}") + (show defaultOptions) deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord