aeson 0.10.0.0 → 0.11.0.0

raw patch · 31 files changed

+1410/−490 lines, 31 filesdep +faildep +quickcheck-instancesdep +semigroupsdep ~attoparsecdep ~basedep ~containersnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: fail, quickcheck-instances, semigroups

Dependency ranges changed: attoparsec, base, containers, deepseq, dlist, hashable, mtl, syb, template-haskell, text, time, transformers, unordered-containers, vector

API changes (from Hackage documentation)

Files

• Data/Aeson.hs +4/−2
• Data/Aeson/Encode.hs +2/−2
• Data/Aeson/Encode/Builder.hs +6/−1
• Data/Aeson/Encode/Functions.hs +8/−2
• Data/Aeson/Functions.hs +2/−2
• Data/Aeson/Internal.hs +4/−3
• Data/Aeson/Internal/Time.hs +2/−2
• Data/Aeson/Parser.hs +2/−2
• Data/Aeson/Parser/Internal.hs +6/−3
• Data/Aeson/Parser/Time.hs +16/−11
• Data/Aeson/TH.hs +406/−126
• Data/Aeson/Types.hs +4/−2
• Data/Aeson/Types/Class.hs +7/−4
• Data/Aeson/Types/Generic.hs +213/−195
• Data/Aeson/Types/Instances.hs +114/−29
• Data/Aeson/Types/Internal.hs +105/−28
• README.markdown +1/−1
• aeson.cabal +20/−5
• benchmarks/aeson-benchmarks.cabal +7/−0
• benchmarks/json-data/sigma.json too large to diff
• changelog.md +62/−0
• include/overlapping-compat.h +15/−0
• tests/DataFamilies/Encoders.hs +25/−1
• tests/DataFamilies/Instances.hs +40/−0
• tests/DataFamilies/Properties.hs +80/−0
• tests/DataFamilies/Types.hs +12/−1
• tests/Encoders.hs +25/−1
• tests/Instances.hs +33/−41
• tests/Properties.hs +40/−18
• tests/Types.hs +14/−2
• tests/UnitTests.hs +135/−6

@@ -1,8 +1,8 @@ -- | -- Module:      Data.Aeson--- Copyright:   (c) 2011-2015 Bryan O'Sullivan+-- Copyright:   (c) 2011-2016 Bryan O'Sullivan --              (c) 2011 MailRank, Inc.--- License:     Apache+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable@@ -60,6 +60,7 @@     -- ** Generic JSON classes and options     , GFromJSON(..)     , GToJSON(..)+    , GToEncoding(..)     , genericToJSON     , genericToEncoding     , genericParseJSON@@ -78,6 +79,7 @@     , foldable     , (.:)     , (.:?)+    , (.:!)     , (.!=)     , object     -- * Parsing

@@ -2,9 +2,9 @@  -- | -- Module:      Data.Aeson.Encode--- Copyright:   (c) 2012-2015 Bryan O'Sullivan+-- Copyright:   (c) 2012-2016 Bryan O'Sullivan --              (c) 2011 MailRank, Inc.--- License:     Apache+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable

@@ -4,7 +4,7 @@ -- Module:      Data.Aeson.Encode.Builder -- Copyright:   (c) 2011 MailRank, Inc. --              (c) 2013 Simon Meier <iridcode@gmail.com>--- License:     Apache+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable@@ -23,6 +23,7 @@     , text     , string     , unquoted+    , quote     , number     , day     , localTime@@ -98,6 +99,10 @@ -- | Encode a JSON string, without enclosing quotes. unquoted :: T.Text -> Builder unquoted t = TE.encodeUtf8BuilderEscaped escapeAscii t++-- | Add quotes surrounding a builder+quote :: Builder -> Builder+quote b = B.char8 '"' <> b <> B.char8 '"'  -- | Encode a JSON string. string :: String -> Builder

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Data.Aeson.Encode.Functions     (       brackets@@ -14,10 +16,14 @@ import Data.Aeson.Types.Internal import Data.ByteString.Builder (Builder, char7) import Data.ByteString.Builder.Prim (primBounded)-import Data.Foldable (Foldable, foldMap)-import Data.Monoid ((<>), mempty)+import Data.Monoid ((<>)) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as L++#if !MIN_VERSION_base(4,8,0)+import Data.Foldable (Foldable, foldMap)+import Data.Monoid (mempty)+#endif  builder :: ToJSON a => a -> Builder builder = fromEncoding . toEncoding

@@ -1,8 +1,8 @@ -- | -- Module:      Data.Aeson.Functions--- Copyright:   (c) 2011-2015 Bryan O'Sullivan+-- Copyright:   (c) 2011-2016 Bryan O'Sullivan --              (c) 2011 MailRank, Inc.--- License:     Apache+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable

@@ -1,7 +1,7 @@ -- | -- Module:      Data.Aeson.Internal--- Copyright:   (c) 2015 Bryan O'Sullivan--- License:     Apache+-- Copyright:   (c) 2015-2016 Bryan O'Sullivan+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable@@ -14,8 +14,9 @@ module Data.Aeson.Internal     (       IResult(..)-    , JSONPathElement+    , JSONPathElement(..)     , JSONPath+    , (<?>)     , formatError     , ifromJSON     , iparse

@@ -2,8 +2,8 @@  -- | -- Module:      Data.Aeson.Internal.Time--- Copyright:   (c) 2015 Bryan O'Sullivan--- License:     Apache+-- Copyright:   (c) 2015-2016 Bryan O'Sullivan+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable

@@ -2,9 +2,9 @@  -- | -- Module:      Data.Aeson.Parser--- Copyright:   (c) 2012-2015 Bryan O'Sullivan+-- Copyright:   (c) 2012-2016 Bryan O'Sullivan --              (c) 2011 MailRank, Inc.--- License:     Apache+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable

@@ -5,9 +5,9 @@  -- | -- Module:      Data.Aeson.Parser.Internal--- Copyright:   (c) 2011-2015 Bryan O'Sullivan+-- Copyright:   (c) 2011-2016 Bryan O'Sullivan --              (c) 2011 MailRank, Inc.--- License:     Apache+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable@@ -31,7 +31,6 @@     , eitherDecodeStrictWith     ) where -import Control.Applicative ((*>), (<$>), (<*), pure) import Control.Monad.IO.Class (liftIO) import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..)) import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,@@ -58,6 +57,10 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Unsafe as B import qualified Data.HashMap.Strict as H++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((*>), (<$>), (<*), pure)+#endif  #if MIN_VERSION_ghc_prim(0,3,1) import GHC.Base (Int#, (==#), isTrue#, orI#, word2Int#)

@@ -1,9 +1,9 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}  -- | -- Module:      Data.Aeson.Parser.Time--- Copyright:   (c) 2015 Bryan O'Sullivan--- License:     Apache+-- Copyright:   (c) 2015-2016 Bryan O'Sullivan+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable@@ -21,7 +21,6 @@     , zonedTime     ) where -import Control.Applicative ((<$>), (<*>), (<*), (*>)) import Control.Monad (when, void) import Data.Aeson.Internal.Time (toPico) import Data.Attoparsec.Text as A@@ -37,6 +36,10 @@ import qualified Data.Text as T import qualified Data.Time.LocalTime as Local +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>), (<*), (*>))+#endif+ -- | Run an attoparsec parser as an aeson parser. run :: Parser a -> Text -> Aeson.Parser a run p t = case A.parseOnly (p <* endOfInput) t of@@ -59,12 +62,12 @@   let c2d c = ord c .&. 15   return $! c2d a * 10 + c2d b --- | Parse a time of the form @HH:MM:SS[.SSS]@.+-- | Parse a time of the form @HH:MM[:SS[.SSS]]@. timeOfDay :: Parser Local.TimeOfDay timeOfDay = do-  h <- twoDigits <* char ':'-  m <- twoDigits <* char ':'-  s <- seconds+  h <- twoDigits+  m <- char ':' *> twoDigits+  s <- option 0 (char ':' *> seconds)   if h < 24 && m < 60 && s < 61     then return (Local.TimeOfDay h m s)     else fail "invalid time"@@ -117,9 +120,9 @@               let !tz = Local.minutesToTimeZone off               in return (Just tz) --- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.--- The space may be replaced with a @T@.  The number of seconds may be--- followed by a fractional component.+-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM[:SS[.SSS]]@.+-- The space may be replaced with a @T@.  The number of seconds is optional+-- and may be followed by a fractional component. localTime :: Parser Local.LocalTime localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay   where daySep = satisfy (\c -> c == 'T' || c == ' ')@@ -137,7 +140,9 @@  -- | Parse a date with time zone info. Acceptable formats: --+-- @YYYY-MM-DD HH:MM Z@ -- @YYYY-MM-DD HH:MM:SS Z@+-- @YYYY-MM-DD HH:MM:SS.SSS Z@ -- -- The first space may instead be a @T@, and the second space is -- optional.  The @Z@ represents UTC.  The @Z@ may be replaced with a

@@ -1,12 +1,21 @@-{-# LANGUAGE CPP, FlexibleInstances, IncoherentInstances, NamedFieldPuns,-    NoImplicitPrelude, OverlappingInstances, TemplateHaskell,-    UndecidableInstances #-}+{-# LANGUAGE CPP, FlexibleInstances, NamedFieldPuns,+    NoImplicitPrelude, UndecidableInstances #-}+#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)+-- c) removes one hindrance to have code inferred as SafeHaskell safe+{-# LANGUAGE TemplateHaskellQuotes #-}+#else+{-# LANGUAGE TemplateHaskell #-}+#endif +#include "overlapping-compat.h"+ {-| Module:      Data.Aeson.TH-Copyright:   (c) 2011-2015 Bryan O'Sullivan+Copyright:   (c) 2011-2016 Bryan O'Sullivan              (c) 2011 MailRank, Inc.-License:     Apache+License:     BSD3 Stability:   experimental Portability: portable @@ -88,7 +97,6 @@     ) where  import Control.Applicative ( pure, (<$>), (<*>) )-import Control.Monad       ( return, mapM, liftM2, fail ) import Data.Aeson ( toJSON, Object, (.=), (.:), (.:?)                   , ToJSON, toEncoding, toJSON                   , FromJSON, parseJSON@@ -100,36 +108,42 @@                         , defaultTaggedObject                         ) import Data.Aeson.Types.Internal (Encoding(..))-import Control.Monad       ( return, mapM, liftM2, fail, join )+import Control.Monad       ( liftM2, return, mapM, fail ) import Data.Bool           ( Bool(False, True), otherwise, (&&), not ) import Data.Either         ( Either(Left, Right) ) import Data.Eq             ( (==) ) import Data.Function       ( ($), (.), flip ) import Data.Functor        ( fmap ) import Data.Int            ( Int )-import Data.List           ( (++), all, any, filter, find, foldl, foldl'+import Data.List           ( (++), all, any, find, foldl, foldl'                            , genericLength , intercalate , intersperse, length, map                            , partition, zip                            )+import Data.Map            ( Map ) import Data.Maybe          ( Maybe(Nothing, Just), catMaybes ) import Data.Monoid         ( (<>), mconcat ) import Language.Haskell.TH import Language.Haskell.TH.Syntax ( VarStrictType ) import Prelude             ( String, (-), Integer, error, foldr1, fromIntegral-                           , snd, uncurry+                           , splitAt, zipWith                            )-#if MIN_VERSION_template_haskell(2,8,0) && __GLASGOW_HASKELL__ < 710-import Prelude             ( drop )+#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))+import Data.Foldable              ( foldr' )+import qualified Data.Map as M    ( singleton )+import Data.List                  ( nub )+import Language.Haskell.TH.Syntax ( mkNameG_tc )+import Prelude                    ( concatMap, uncurry ) #endif+#if MIN_VERSION_template_haskell(2,11,0)+import Prelude             ( head )+#endif import Text.Printf         ( printf ) import Text.Show           ( show ) import qualified Data.Aeson as A import qualified Data.Aeson.Encode.Builder as E import qualified Data.Aeson.Encode.Functions as E import qualified Data.HashMap.Strict as H ( lookup, toList )-#if MIN_VERSION_template_haskell(2,8,0) && __GLASGOW_HASKELL__ < 710-import qualified Data.Set as Set ( Set, empty, singleton, size, union, unions )-#endif+import qualified Data.Map as M ( fromList, findWithDefault ) import qualified Data.Text as T ( Text, pack, unpack ) import qualified Data.Vector as V ( unsafeIndex, null, length, create, fromList ) import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )@@ -181,9 +195,10 @@     withType name $ \name' tvbs cons mbTys -> fmap (:[]) $ fromCons name' tvbs cons mbTys   where     fromCons :: Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec-    fromCons name' tvbs cons mbTys =-        instanceD instanceCxt-                  instanceType+    fromCons name' tvbs cons mbTys = do+        (instanceCxt, instanceType) <- buildTypeInstance name' ''ToJSON tvbs mbTys+        instanceD (return instanceCxt)+                  (return instanceType)                   [ funD 'toJSON                          [ clause []                                   (normalB $ consToValue opts cons)@@ -195,9 +210,6 @@                                   []                          ]                   ]-      where-        (instanceCxt, instanceType) =-            buildTypeInstance name' ''ToJSON tvbs mbTys  -- | Generates a lambda expression which encodes the given data type or -- data family instance constructor as a 'Value'.@@ -419,6 +431,15 @@ argsToValue opts multiCons (ForallC _ _ con) =     argsToValue opts multiCons con +#if MIN_VERSION_template_haskell(2,11,0)+-- GADTs.+argsToValue opts multiCons (GadtC conNames ts _) =+    argsToValue opts multiCons $ NormalC (head conNames) ts++argsToValue opts multiCons (RecGadtC conNames ts _) =+    argsToValue opts multiCons $ RecC (head conNames) ts+#endif+ isMaybe :: (a, (b, c, Type)) -> Bool isMaybe (_, (_, _, AppT (ConT t) _)) = t == ''Maybe isMaybe _                            = False@@ -505,11 +526,16 @@         (maybes, rest) = partition isMaybe argCons          maybeToPair (arg, (field, _, _)) =-            infixApp (infixE (Just $ toFieldName field)-                             [|(.=)|]-                             Nothing)-                     [|(<$>)|]-                     (varE arg)+            infixApp+              (infixApp+                (infixE+                  (Just $ toFieldName field <^> [|E.char7 ':'|])+                  [|(<>)|]+                  Nothing)+                [|(.)|]+                [|E.builder|])+              [|(<$>)|]+              (varE arg)          toPair (arg, (field, _, _)) =           toFieldName field <:> [|E.builder|] `appE` varE arg@@ -548,7 +574,15 @@ argsToEncoding opts multiCons (ForallC _ _ con) =     argsToEncoding opts multiCons con +#if MIN_VERSION_template_haskell(2,11,0)+-- GADTs.+argsToEncoding opts multiCons (GadtC conNames ts _) =+    argsToEncoding opts multiCons $ NormalC (head conNames) ts +argsToEncoding opts multiCons (RecGadtC conNames ts _) =+    argsToEncoding opts multiCons $ RecC (head conNames) ts+#endif+ -------------------------------------------------------------------------------- -- FromJSON --------------------------------------------------------------------------------@@ -565,18 +599,16 @@     withType name $ \name' tvbs cons mbTys -> fmap (:[]) $ fromCons name' tvbs cons mbTys   where     fromCons :: Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec-    fromCons name' tvbs cons mbTys =-        instanceD instanceCxt-                  instanceType+    fromCons name' tvbs cons mbTys = do+        (instanceCxt, instanceType) <- buildTypeInstance name' ''FromJSON tvbs mbTys+        instanceD (return instanceCxt)+                  (return instanceType)                   [ funD 'parseJSON                          [ clause []                                   (normalB $ consFromJSON name' opts cons)                                   []                          ]                   ]-      where-        (instanceCxt, instanceType) =-            buildTypeInstance name' ''FromJSON tvbs mbTys  -- | Generates a lambda expression which parses the JSON encoding of the given -- data type or data family instance constructor.@@ -864,11 +896,11 @@ parseArgs tName opts (RecC conName ts) (Right valName) = case (unwrapUnaryRecords opts,ts) of   (True,[(_,st,ty)])-> parseArgs tName opts (NormalC conName [(st,ty)]) (Right valName)   _ -> do-  obj <- newName "recObj"-  caseE (varE valName)-    [ match (conP 'Object [varP obj]) (normalB $ parseRecord opts tName conName ts obj) []-    , matchFailed tName conName "Object"-    ]+    obj <- newName "recObj"+    caseE (varE valName)+      [ match (conP 'Object [varP obj]) (normalB $ parseRecord opts tName conName ts obj) []+      , matchFailed tName conName "Object"+      ]  -- Infix constructors. Apart from syntax these are the same as -- polyadic constructors.@@ -882,6 +914,16 @@ parseArgs tName opts (ForallC _ _ con) contents =     parseArgs tName opts con contents +#if MIN_VERSION_template_haskell(2,11,0)+-- GADTs. We ignore the refined return type and proceed as if it were a+-- NormalC or RecC.+parseArgs tName opts (GadtC conNames ts _) contents =+    parseArgs tName opts (NormalC (head conNames) ts) contents++parseArgs tName opts (RecGadtC conNames ts _) contents =+    parseArgs tName opts (RecC (head conNames) ts) contents+#endif+ -- | Generates code to parse the JSON encoding of an n-ary -- constructor. parseProduct :: Name -- ^ Name of the type to which the constructor belongs.@@ -947,14 +989,14 @@ class (FromJSON a) => LookupField a where     lookupField :: String -> String -> Object -> T.Text -> Parser a -instance (FromJSON a) => LookupField a where+instance OVERLAPPABLE_ (FromJSON a) => LookupField a where     lookupField tName rec obj key =         case H.lookup key obj of           Nothing -> unknownFieldFail tName rec (T.unpack key)           Just v  -> parseJSON v  instance (FromJSON a) => LookupField (Maybe a) where-    lookupField _ _ obj key = join <$> obj .:? key+    lookupField _ _ = (.:?)  unknownFieldFail :: String -> String -> String -> Parser fail unknownFieldFail tName rec key =@@ -1032,8 +1074,13 @@     case info of       TyConI dec ->         case dec of-          DataD    _ _ tvbs cons _ -> f name tvbs cons Nothing-          NewtypeD _ _ tvbs con  _ -> f name tvbs [con] Nothing+#if MIN_VERSION_template_haskell(2,11,0)+          DataD    _ _ tvbs _ cons _ -> f name tvbs cons Nothing+          NewtypeD _ _ tvbs _ con  _ -> f name tvbs [con] Nothing+#else+          DataD    _ _ tvbs   cons _ -> f name tvbs cons Nothing+          NewtypeD _ _ tvbs   con  _ -> f name tvbs [con] Nothing+#endif           other -> error $ ns ++ "Unsupported type: " ++ show other #if MIN_VERSION_template_haskell(2,11,0)       DataConI _ _ parentName   -> do@@ -1048,14 +1095,22 @@           FamilyI (FamilyD DataFam _ tvbs _) decs -> #endif             let instDec = flip find decs $ \dec -> case dec of-                  DataInstD    _ _ _ cons _ -> any ((name ==) . getConName) cons-                  NewtypeInstD _ _ _ con  _ -> name == getConName con+#if MIN_VERSION_template_haskell(2,11,0)+                  DataInstD    _ _ _ _ cons _ -> any ((name ==) . getConName) cons+                  NewtypeInstD _ _ _ _ con  _ -> name == getConName con+#else+                  DataInstD    _ _ _   cons _ -> any ((name ==) . getConName) cons+                  NewtypeInstD _ _ _   con  _ -> name == getConName con+#endif                   _ -> error $ ns ++ "Must be a data or newtype instance."              in case instDec of-                  Just (DataInstD    _ _ instTys cons _)-                    -> f parentName tvbs cons $ Just instTys-                  Just (NewtypeInstD _ _ instTys con  _)-                    -> f parentName tvbs [con] $ Just instTys+#if MIN_VERSION_template_haskell(2,11,0)+                  Just (DataInstD    _ _ instTys _ cons _) -> f parentName tvbs cons $ Just instTys+                  Just (NewtypeInstD _ _ instTys _ con  _) -> f parentName tvbs [con] $ Just instTys+#else+                  Just (DataInstD    _ _ instTys   cons _) -> f parentName tvbs cons $ Just instTys+                  Just (NewtypeInstD _ _ instTys   con  _) -> f parentName tvbs [con] $ Just instTys+#endif                   _ -> error $ ns ++                     "Could not find data or newtype instance constructor."           _ -> error $ ns ++ "Data constructor " ++ show name ++@@ -1083,110 +1138,275 @@                   -> Maybe [Type]                   -- ^ 'Just' the types used to instantiate a data family instance,                   -- or 'Nothing' if it's a plain data type-                  -> (Q Cxt, Q Type)+                  -> Q (Cxt, Type)                   -- ^ The resulting 'Cxt' and 'Type' to use in a class instance -- Plain data type/newtype case buildTypeInstance tyConName constraint tvbs Nothing =-    (applyCon constraint typeNames, conT constraint `appT` instanceType)-  where-    typeNames :: [Name]-    typeNames = map tvbName tvbs--    instanceType :: Q Type-    instanceType = applyTyCon tyConName $ map varT typeNames+    let varTys :: [Type]+        varTys = map tvbToType tvbs+    in buildTypeInstanceFromTys tyConName constraint varTys False -- Data family instance case-buildTypeInstance dataFamName constraint tvbs (Just instTysAndKinds) =-    (applyCon constraint lhsTvbNames, conT constraint `appT` instanceType)-  where-    -- We need to make sure that type variables in the instance head which have-    -- constraints aren't poly-kinded, e.g.,-    ---    -- @-    -- instance ToJSON a => ToJSON (Foo (a :: k)) where-    -- @-    ---    -- To do this, we remove every kind ascription (i.e., strip off every 'SigT').-    instanceType :: Q Type-    instanceType = applyTyCon dataFamName $ map (return . unSigT) rhsTypes--    -- We need to mindful of an old GHC bug which causes kind variables appear in-    -- @instTysAndKinds@ (as the name suggests) if (1) @PolyKinds@ is enabled, and-    -- (2) either GHC 7.6 or 7.8 is being used (for more info, see-    -- https://ghc.haskell.org/trac/ghc/ticket/9692).-    ---    -- Since Template Haskell doesn't seem to have a mechanism for detecting which-    -- language extensions are enabled, we do the next-best thing by counting-    -- the number of distinct kind variables in the data family declaration, and-    -- then dropping that number of entries from @instTysAndKinds@-    instTypes :: [Type]-    instTypes =-#if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))-        instTysAndKinds+--+-- The CPP is present to work around a couple of annoying old GHC bugs.+-- See Note [Polykinded data families in Template Haskell]+buildTypeInstance dataFamName constraint tvbs (Just instTysAndKinds) = do+#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)+    let instTys :: [Type]+        instTys = zipWith stealKindForType tvbs instTysAndKinds #else-        drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) tvbs)-             instTysAndKinds-#endif+    let kindVarNames :: [Name]+        kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs -    lhsTvbNames :: [Name]-    lhsTvbNames = map (tvbName . uncurry replaceTyVarName)-                . filter (isTyVar . snd)-                $ zip tvbs rhsTypes+        -- Gets all of the type/kind variable names mentioned somewhere in a Type.+        tyVarNamesOfType :: Type -> [Name]+        tyVarNamesOfType = go+          where+            go :: Type -> [Name]+            go (AppT t1 t2) = go t1 ++ go t2+            go (SigT t k)   = go t  ++ go k+            go (VarT n)     = [n]+            go _            = [] -    -- In GHC 7.8, only the @Type@s up to the rightmost non-eta-reduced type variable-    -- in @instTypes@ are provided (as a result of this bug:-    -- https://ghc.haskell.org/trac/ghc/ticket/9692). To work around this, we borrow-    -- some type variables from the data family instance declaration.-    rhsTypes :: [Type]-    rhsTypes =-#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710-            instTypes ++ map tvbToType-                             (drop (length instTypes)-                                   tvbs)-#else-            instTypes+        numKindVars :: Int+        numKindVars = length kindVarNames++        givenKinds, givenKinds' :: [Kind]+        givenTys                :: [Type]+        (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds+        givenKinds' = map sanitizeStars givenKinds++        -- A GHC 7.6-specific bug requires us to replace all occurrences of+        -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.+        -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.+        sanitizeStars :: Kind -> Kind+        sanitizeStars = go+          where+            go :: Kind -> Kind+            go (AppT t1 t2)                 = AppT (go t1) (go t2)+            go (SigT t k)                   = SigT (go t) (go k)+            go (ConT n) | n == starKindName = StarT+            go t                            = t++            -- It's quite awkward to import * from GHC.Prim, so we'll just+            -- hack our way around it.+            starKindName :: Name+            starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"++        -- Generate a list of fresh names with a common prefix, and numbered suffixes.+        newNameList :: String -> Int -> Q [Name]+        newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]++    -- If we run this code with GHC 7.8, we might have to generate extra type+    -- variables to compensate for any type variables that Template Haskell+    -- eta-reduced away.+    -- See Note [Polykinded data families in Template Haskell]+    xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys)++    let xTys   :: [Type]+        xTys = map VarT xTypeNames+        -- ^ Because these type variables were eta-reduced away, we can only+        --   determine their kind by using stealKindForType. Therefore, we mark+        --   them as VarT to ensure they will be given an explicit kind annotation+        --   (and so the kind inference machinery has the right information).++        substNameWithKind :: Name -> Kind -> Type -> Type+        substNameWithKind n k = substType (M.singleton n k)++        substNamesWithKinds :: [(Name, Kind)] -> Type -> Type+        substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks++        -- The types from the data family instance might not have explicit kind+        -- annotations, which the kind machinery needs to work correctly. To+        -- compensate, we use stealKindForType to explicitly annotate any+        -- types without kind annotations.+        instTys :: [Type]+        instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))+                  -- Note that due to a GHC 7.8-specific bug+                  -- (see Note [Polykinded data families in Template Haskell]),+                  -- there may be more kind variable names than there are kinds+                  -- to substitute. But this is OK! If a kind is eta-reduced, it+                  -- means that is was not instantiated to something more specific,+                  -- so we need not substitute it. Using stealKindForType will+                  -- grab the correct kind.+                $ zipWith stealKindForType tvbs (givenTys ++ xTys) #endif+    buildTypeInstanceFromTys dataFamName constraint instTys True -#if MIN_VERSION_template_haskell(2,8,0) && __GLASGOW_HASKELL__ < 710-distinctKindVars :: Kind -> Set.Set Name-distinctKindVars (AppT k1 k2) = distinctKindVars k1 `Set.union` distinctKindVars k2-distinctKindVars (SigT k _)   = distinctKindVars k-distinctKindVars (VarT k)     = Set.singleton k-distinctKindVars _            = Set.empty+-- For the given Types, generate an instance context and head.+buildTypeInstanceFromTys :: Name+                         -- ^ The type constructor or data family name+                         -> Name+                         -- ^ The typeclass name ('ToJSON' or 'FromJSON')+                         -> [Type]+                         -- ^ The types to instantiate the instance with+                         -> Bool+                         -- ^ True if it's a data family, False otherwise+                         -> Q (Cxt, Type)+buildTypeInstanceFromTys tyConName constraint varTysOrig isDataFamily = do+    -- Make sure to expand through type/kind synonyms! Otherwise, we won't+    -- be able to infer constraints as accurately.+    varTysExp <- mapM expandSyn varTysOrig +    let preds    :: [Maybe Pred]+        -- Derive instance constraints for type variables of kind *+        preds = map (deriveConstraint constraint) varTysExp++        varTys :: [Type]+        -- See Note [Kind signatures in derived instances] for an explanation+        -- of the isDataFamily check.+        varTys =+          if isDataFamily+             then varTysOrig+             else map unSigT varTysOrig++        instanceCxt :: Cxt+        instanceCxt = catMaybes preds++        instanceType :: Type+        instanceType = AppT (ConT constraint)+                     $ applyTyCon tyConName varTys++    return (instanceCxt, instanceType)++-- | Attempt to derive a constraint on a Type. If it's of kind *,+-- we give it Just a ToJSON/FromJSON constraint. Otherwise, return Nothing.+deriveConstraint :: Name -> Type -> Maybe Pred+deriveConstraint constraint t+  | isTyVar t && hasKindStar t = Just $ applyCon constraint $ varTToName t+  | otherwise                  = Nothing++{-+Note [Polykinded data families in Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In order to come up with the correct instance context and head for an instance, e.g.,++  instance C a => C (Data a) where ...++We need to know the exact types and kinds used to instantiate the instance. For+plain old datatypes, this is simple: every type must be a type variable, and+Template Haskell reliably tells us the type variables and their kinds.++Doing the same for data families proves to be much harder for three reasons:++1. On any version of Template Haskell, it may not tell you what an instantiated+   type's kind is. For instance, in the following data family instance:++     data family Fam (f :: * -> *) (a :: *)+     data instance Fam f a++   Then if we use TH's reify function, it would tell us the TyVarBndrs of the+   data family declaration are:++     [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]++   and the instantiated types of the data family instance are:++     [VarT f1,VarT a1]++   We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we+   have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the+   kind is in case an instantiated type isn't a SigT, so we use the stealKindForType+   function to ensure all of the instantiated types are SigTs before passing them+   to buildTypeInstanceFromTys.+2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of+   the specified kinds of a data family instance efore any of the instantiated+   types. Fortunately, this is easy to deal with: you simply count the number of+   distinct kind variables in the data family declaration, take that many elements+   from the front of the  Types list of the data family instance, substitute the+   kind variables with their respective instantiated kinds (which you took earlier),+   and proceed as normal.+3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template+   Haskell might not even list all of the Types of a data family instance, since+   they are eta-reduced away! And yes, kinds can be eta-reduced too.++   The simplest workaround is to count how many instantiated types are missing from+   the list and generate extra type variables to use in their place. Luckily, we+   needn't worry much if its kind was eta-reduced away, since using stealKindForType+   will get it back.++Note [Kind signatures in derived instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is possible to put explicit kind signatures into the derived instances, e.g.,++  instance C a => C (Data (f :: * -> *)) where ...++But it is preferable to avoid this if possible. If we come up with an incorrect+kind signature (which is entirely possible, since Template Haskell doesn't always+have the best track record with reifying kind signatures), then GHC will flat-out+reject the instance, which is quite unfortunate.++Plain old datatypes have the advantage that you can avoid using any kind signatures+at all in their instances. This is because a datatype declaration uses all type+variables, so the types that we use in a derived instance uniquely determine their+kinds. As long as we plug in the right types, the kind inferencer can do the rest+of the work. For this reason, we use unSigT to remove all kind signatures before+splicing in the instance context and head.++Data family instances are trickier, since a data family can have two instances that+are distinguished by kind alone, e.g.,++  data family Fam (a :: k)+  data instance Fam (a :: * -> *)+  data instance Fam (a :: *)++If we dropped the kind signatures for C (Fam a), then GHC will have no way of+knowing which instance we are talking about. To avoid this scenario, we always+include explicit kind signatures in data family instances. There is a chance that+the inferred kind signatures will be incorrect, but if so, we can always fall back+on the mk- functions.+-}++-- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.+stealKindForType :: TyVarBndr -> Type -> Type+stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)+stealKindForType _   t        = t+ -- | Extracts the kind from a type variable binder. tvbKind :: TyVarBndr -> Kind-tvbKind (PlainTV  _  ) = starK-tvbKind (KindedTV _ k) = k+#if MIN_VERSION_template_haskell(2,8,0)+tvbKind (PlainTV  _  ) = StarT+#else+tvbKind (PlainTV  _  ) = StarK #endif+tvbKind (KindedTV _ k) = k -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 tvbToType :: TyVarBndr -> Type tvbToType (PlainTV n)    = VarT n tvbToType (KindedTV n k) = SigT (VarT n) k++-- | Returns True if a Type has kind *.+hasKindStar :: Type -> Bool+hasKindStar VarT{}         = True+#if MIN_VERSION_template_haskell(2,8,0)+hasKindStar (SigT _ StarT) = True+#else+hasKindStar (SigT _ StarK) = True #endif+hasKindStar _              = False +-- | Extract the Name from a type variable. If the argument Type is not a+-- type variable, throw an error.+varTToName :: Type -> Name+varTToName (VarT n)   = n+varTToName (SigT t _) = varTToName t+varTToName _          = error "Not a type variable!"+ -- | Extracts the name from a constructor. getConName :: Con -> Name getConName (NormalC name _)  = name getConName (RecC name _)     = name getConName (InfixC _ name _) = name getConName (ForallC _ _ con) = getConName con---- | Extracts the name from a type variable binder.-tvbName :: TyVarBndr -> Name-tvbName (PlainTV  name  ) = name-tvbName (KindedTV name _) = name---- | Replace the Name of a TyVarBndr with one from a Type (if the Type has a Name).-replaceTyVarName :: TyVarBndr -> Type -> TyVarBndr-replaceTyVarName tvb            (SigT t _) = replaceTyVarName tvb t-replaceTyVarName (PlainTV  _)   (VarT n)   = PlainTV  n-replaceTyVarName (KindedTV _ k) (VarT n)   = KindedTV n k-replaceTyVarName tvb            _          = tvb+#if MIN_VERSION_template_haskell(2,11,0)+getConName (GadtC    names _ _) = head names+getConName (RecGadtC names _ _) = head names+#endif  -- | Fully applies a type constructor to its type variables.-applyTyCon :: Name -> [Q Type] -> Q Type-applyTyCon = foldl' appT . conT+applyTyCon :: Name -> [Type] -> Type+applyTyCon = foldl' AppT . ConT  -- | Is the given type a variable? isTyVar :: Type -> Bool@@ -1222,11 +1442,71 @@ valueConName (Bool   _) = "Boolean" valueConName Null       = "Null" -applyCon :: Name -> [Name] -> Q [Pred]-applyCon con typeNames = return (map apply typeNames)-  where apply t =+applyCon :: Name -> Name -> Pred+applyCon con t = #if MIN_VERSION_template_haskell(2,10,0)           AppT (ConT con) (VarT t) #else           ClassP con [VarT t] #endif++-------------------------------------------------------------------------------+-- Expanding type synonyms+-------------------------------------------------------------------------------++-- | Expands all type synonyms in a type. Written by Dan Rosén in the+-- @genifunctors@ package (licensed under BSD3).+expandSyn :: Type -> Q Type+expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t+expandSyn t@AppT{}            = expandSynApp t []+expandSyn t@ConT{}            = expandSynApp t []+expandSyn (SigT t k)          = do t' <- expandSyn t+                                   k' <- expandSynKind k+                                   return (SigT t' k')+expandSyn t                   = return t++expandSynKind :: Kind -> Q Kind+#if MIN_VERSION_template_haskell(2,8,0)+expandSynKind = expandSyn+#else+expandSynKind = return -- There are no kind synonyms to deal with+#endif++expandSynApp :: Type -> [Type] -> Q Type+expandSynApp (AppT t1 t2) ts = do+    t2' <- expandSyn t2+    expandSynApp t1 (t2':ts)+expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts+expandSynApp t@(ConT n) ts = do+    info <- reify n+    case info of+        TyConI (TySynD _ tvs rhs) ->+            let (ts', ts'') = splitAt (length tvs) ts+                subs = mkSubst tvs ts'+                rhs' = substType subs rhs+             in expandSynApp rhs' ts''+        _ -> return $ foldl' AppT t ts+expandSynApp t ts = do+    t' <- expandSyn t+    return $ foldl' AppT t' ts++type TypeSubst = Map Name Type++mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst+mkSubst vs ts =+   let vs' = map un vs+       un (PlainTV v)    = v+       un (KindedTV v _) = v+   in M.fromList $ zip vs' ts++substType :: TypeSubst -> Type -> Type+substType subs (ForallT v c t) = ForallT v c $ substType subs t+substType subs t@(VarT n)      = M.findWithDefault t n subs+substType subs (AppT t1 t2)    = AppT (substType subs t1) (substType subs t2)+substType subs (SigT t k)      = SigT (substType subs t)+#if MIN_VERSION_template_haskell(2,8,0)+                                      (substType subs k)+#else+                                      k+#endif+substType _ t                  = t

@@ -1,8 +1,8 @@ -- | -- Module:      Data.Aeson.Types--- Copyright:   (c) 2011-2015 Bryan O'Sullivan+-- Copyright:   (c) 2011-2016 Bryan O'Sullivan --              (c) 2011 MailRank, Inc.--- License:     Apache+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable@@ -39,6 +39,7 @@     -- ** Generic JSON classes     , GFromJSON(..)     , GToJSON(..)+    , GToEncoding(..)     , genericToJSON     , genericToEncoding     , genericParseJSON@@ -55,6 +56,7 @@     , foldable     , (.:)     , (.:?)+    , (.:!)     , (.!=)     , object 

@@ -2,9 +2,9 @@  -- | -- Module:      Data.Aeson.Types.Class--- Copyright:   (c) 2011-2015 Bryan O'Sullivan+-- Copyright:   (c) 2011-2016 Bryan O'Sullivan --              (c) 2011 MailRank, Inc.--- License:     Apache+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable@@ -19,6 +19,7 @@     -- * Generic JSON classes     , GFromJSON(..)     , GToJSON(..)+    , GToEncoding(..)     , genericToJSON     , genericToEncoding     , genericParseJSON@@ -40,6 +41,9 @@     -- default generic implementation of 'toJSON'.     gToJSON :: Options -> f a -> Value +-- | Class of generic representation types ('Rep') that can be converted to+-- a JSON 'Encoding'.+class GToEncoding f where     -- | This method (applied to 'defaultOptions') can be used as the     -- default generic implementation of 'toEncoding'.     gToEncoding :: Options -> f a -> Encoding@@ -59,7 +63,7 @@ -- | A configurable generic JSON encoder. This function applied to -- 'defaultOptions' is used as the default for 'toEncoding' when the type -- is an instance of 'Generic'.-genericToEncoding :: (Generic a, GToJSON (Rep a)) => Options -> a -> Encoding+genericToEncoding :: (Generic a, GToEncoding (Rep a)) => Options -> a -> Encoding genericToEncoding opts = gToEncoding opts . from  -- | A configurable generic JSON decoder. This function applied to@@ -135,7 +139,6 @@ class ToJSON a where     -- | Convert a Haskell value to a JSON-friendly intermediate type.     toJSON     :: a -> Value-    {-# MINIMAL toJSON #-}      default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value     toJSON = genericToJSON defaultOptions

@@ -1,16 +1,18 @@-{-# LANGUAGE DefaultSignatures, EmptyDataDecls, FlexibleInstances,-    FunctionalDependencies, KindSignatures, OverlappingInstances,+{-# LANGUAGE CPP, DefaultSignatures, EmptyDataDecls, FlexibleInstances,+    FunctionalDependencies, KindSignatures,     ScopedTypeVariables, TypeOperators, UndecidableInstances,     ViewPatterns, NamedFieldPuns, FlexibleContexts, PatternGuards,-    RecordWildCards #-}+    RecordWildCards, DataKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +#include "overlapping-compat.h"+ -- | -- Module:      Data.Aeson.Types.Generic--- Copyright:   (c) 2012-2015 Bryan O'Sullivan+-- Copyright:   (c) 2012-2016 Bryan O'Sullivan --              (c) 2011, 2012 Bas Van Dijk --              (c) 2011 MailRank, Inc.--- License:     Apache+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable@@ -19,8 +21,8 @@  module Data.Aeson.Types.Generic ( ) where -import Control.Applicative ((<*>), (<$>), (<|>), pure)-import Control.Monad ((<=<), join)+import Control.Applicative ((<|>))+import Control.Monad ((<=<)) import Control.Monad.ST (ST) import Data.Aeson.Encode.Builder (emptyArray_) import Data.Aeson.Encode.Functions (builder)@@ -30,49 +32,38 @@ import Data.ByteString.Builder as B import Data.DList (DList, toList, empty) import Data.Maybe (fromMaybe)-import Data.Monoid ((<>), mempty)+import Data.Monoid ((<>)) import Data.Text (Text, pack, unpack) import GHC.Generics import qualified Data.HashMap.Strict as H import qualified Data.Vector as V import qualified Data.Vector.Mutable as VM +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<*>), (<$>), pure)+import Data.Monoid (mempty)+#endif+ -------------------------------------------------------------------------------- -- Generic toJSON -instance (GToJSON a) => GToJSON (M1 i c a) where+instance OVERLAPPABLE_ (GToJSON a) => GToJSON (M1 i c a) where     -- Meta-information, which is not handled elsewhere, is ignored:     gToJSON opts = gToJSON opts . unM1-    {-# INLINE gToJSON #-} -    gToEncoding opts = gToEncoding opts . unM1-    {-# INLINE gToEncoding #-}- instance (ToJSON a) => GToJSON (K1 i a) where     -- Constant values are encoded using their ToJSON instance:     gToJSON _opts = toJSON . unK1-    {-# INLINE gToJSON #-} -    gToEncoding _opts = toEncoding . unK1-    {-# INLINE gToEncoding #-}- instance GToJSON U1 where     -- Empty constructors are encoded to an empty array:     gToJSON _opts _ = emptyArray-    {-# INLINE gToJSON #-} -    gToEncoding _opts _ = emptyArray_-    {-# INLINE gToEncoding #-}- instance (ConsToJSON a) => GToJSON (C1 c a) where     -- Constructors need to be encoded differently depending on whether they're     -- a record or not. This distinction is made by 'consToJSON':     gToJSON opts = consToJSON opts . unM1-    {-# INLINE gToJSON #-} -    gToEncoding opts = Encoding . consToEncoding opts . unM1-    {-# INLINE gToEncoding #-}- instance ( WriteProduct a, WriteProduct b          , ProductSize  a, ProductSize  b ) => GToJSON (a :*: b) where     -- Products are encoded to an array. Here we allocate a mutable vector of@@ -86,11 +77,7 @@         where           lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)                        productSize-    {-# INLINE gToJSON #-} -    gToEncoding opts p = Encoding $-                         B.char7 '[' <> encodeProduct opts p <> B.char7 ']'- instance ( AllNullary (a :+: b) allNullary          , SumToJSON  (a :+: b) allNullary ) => GToJSON (a :+: b) where     -- If all constructors of a sum datatype are nullary and the@@ -98,46 +85,65 @@     -- strings.  This distinction is made by 'sumToJSON':     gToJSON opts = (unTagged :: Tagged allNullary Value -> Value)                  . sumToJSON opts-    {-# INLINE gToJSON #-} +--------------------------------------------------------------------------------+-- Generic toEncoding++instance OVERLAPPABLE_ (GToEncoding a) => GToEncoding (M1 i c a) where+    -- Meta-information, which is not handled elsewhere, is ignored:+    gToEncoding opts = gToEncoding opts . unM1++instance (ToJSON a) => GToEncoding (K1 i a) where+    -- Constant values are encoded using their ToJSON instance:+    gToEncoding _opts = toEncoding . unK1++instance GToEncoding U1 where+    -- Empty constructors are encoded to an empty array:+    gToEncoding _opts _ = emptyArray_++instance (ConsToEncoding a) => GToEncoding (C1 c a) where+    -- Constructors need to be encoded differently depending on whether they're+    -- a record or not. This distinction is made by 'consToEncoding':+    gToEncoding opts = Encoding . consToEncoding opts . unM1++instance ( EncodeProduct a, EncodeProduct b ) => GToEncoding (a :*: b) where+    -- Products are encoded to an array. Here we allocate a mutable vector of+    -- the same size as the product and write the product's elements to it using+    -- 'encodeProduct':+    gToEncoding opts p = Encoding $+                         B.char7 '[' <> encodeProduct opts p <> B.char7 ']'++instance ( AllNullary    (a :+: b) allNullary+         , SumToEncoding (a :+: b) allNullary ) => GToEncoding (a :+: b) where+    -- If all constructors of a sum datatype are nullary and the+    -- 'allNullaryToStringTag' option is set they are encoded to+    -- strings.  This distinction is made by 'sumToEncoding':     gToEncoding opts = Encoding .                        (unTagged :: Tagged allNullary B.Builder -> B.Builder) .                        sumToEncoding opts-    {-# INLINE gToEncoding #-}  --------------------------------------------------------------------------------  class SumToJSON f allNullary where     sumToJSON :: Options -> f a -> Tagged allNullary Value-    sumToEncoding :: Options -> f a -> Tagged allNullary B.Builder -instance ( GetConName            f-         , TaggedObject     f-         , ObjectWithSingleField f-         , TwoElemArray          f ) => SumToJSON f True where+instance ( GetConName               f+         , TaggedObjectPairs        f+         , ObjectWithSingleFieldObj f+         , TwoElemArrayObj          f ) => SumToJSON f True where     sumToJSON opts         | allNullaryToStringTag opts = Tagged . String . pack                                      . constructorTagModifier opts . getConName         | otherwise = Tagged . nonAllNullarySumToJSON opts-    {-# INLINE sumToJSON #-} -    sumToEncoding opts-        | allNullaryToStringTag opts = Tagged . builder .-                                       constructorTagModifier opts . getConName-        | otherwise = Tagged . nonAllNullarySumToEncoding opts-    {-# INLINE sumToEncoding #-}--instance ( TwoElemArray          f-         , TaggedObject          f-         , ObjectWithSingleField f ) => SumToJSON f False where+instance ( TwoElemArrayObj          f+         , TaggedObjectPairs        f+         , ObjectWithSingleFieldObj f ) => SumToJSON f False where     sumToJSON opts = Tagged . nonAllNullarySumToJSON opts-    {-# INLINE sumToJSON #-}-    sumToEncoding opts = Tagged . nonAllNullarySumToEncoding opts-    {-# INLINE sumToEncoding #-} -nonAllNullarySumToJSON :: ( TwoElemArray          f-                          , TaggedObject          f-                          , ObjectWithSingleField f+nonAllNullarySumToJSON :: ( TwoElemArrayObj          f+                          , TaggedObjectPairs        f+                          , ObjectWithSingleFieldObj f                           ) => Options -> f a -> Value nonAllNullarySumToJSON opts =     case sumEncoding opts of@@ -145,50 +151,83 @@         object . taggedObjectPairs opts tagFieldName contentsFieldName       ObjectWithSingleField -> Object . objectWithSingleFieldObj opts       TwoElemArray          -> Array  . twoElemArrayObj opts-{-# INLINE nonAllNullarySumToJSON #-} -nonAllNullarySumToEncoding :: ( TwoElemArray          f-                          , TaggedObject          f-                          , ObjectWithSingleField f-                          ) => Options -> f a -> B.Builder+--------------------------------------------------------------------------------++class SumToEncoding f allNullary where+    sumToEncoding :: Options -> f a -> Tagged allNullary B.Builder++instance ( GetConName               f+         , TaggedObjectEnc          f+         , ObjectWithSingleFieldEnc f+         , TwoElemArrayEnc          f ) => SumToEncoding f True where+    sumToEncoding opts+        | allNullaryToStringTag opts = Tagged . builder .+                                       constructorTagModifier opts . getConName+        | otherwise = Tagged . nonAllNullarySumToEncoding opts++instance ( TwoElemArrayEnc          f+         , TaggedObjectEnc          f+         , ObjectWithSingleFieldEnc f ) => SumToEncoding f False where+    sumToEncoding opts = Tagged . nonAllNullarySumToEncoding opts++nonAllNullarySumToEncoding :: ( TwoElemArrayEnc          f+                              , TaggedObjectEnc          f+                              , ObjectWithSingleFieldEnc f+                              ) => Options -> f a -> B.Builder nonAllNullarySumToEncoding opts =     case sumEncoding opts of       TaggedObject{..}      ->         taggedObjectEnc opts tagFieldName contentsFieldName       ObjectWithSingleField -> objectWithSingleFieldEnc opts       TwoElemArray          -> twoElemArrayEnc opts-{-# INLINE nonAllNullarySumToEncoding #-}  -------------------------------------------------------------------------------- -class TaggedObject f where+class TaggedObjectPairs f where     taggedObjectPairs :: Options -> String -> String -> f a -> [Pair]-    taggedObjectEnc :: Options -> String -> String -> f a -> B.Builder -instance ( TaggedObject a-         , TaggedObject b ) => TaggedObject (a :+: b) where+instance ( TaggedObjectPairs a+         , TaggedObjectPairs b ) => TaggedObjectPairs (a :+: b) where     taggedObjectPairs opts tagFieldName contentsFieldName (L1 x) =         taggedObjectPairs opts tagFieldName contentsFieldName     x     taggedObjectPairs opts tagFieldName contentsFieldName (R1 x) =         taggedObjectPairs opts tagFieldName contentsFieldName     x-    {-# INLINE taggedObjectPairs #-} -    taggedObjectEnc opts tagFieldName contentsFieldName (L1 x) =-        taggedObjectEnc opts tagFieldName contentsFieldName     x-    taggedObjectEnc opts tagFieldName contentsFieldName (R1 x) =-        taggedObjectEnc opts tagFieldName contentsFieldName     x-    {-# INLINE taggedObjectEnc #-}--instance ( IsRecord      a isRecord-         , TaggedObject' a isRecord-         , Constructor c ) => TaggedObject (C1 c a) where+instance ( IsRecord           a isRecord+         , TaggedObjectPairs' a isRecord+         , Constructor c ) => TaggedObjectPairs (C1 c a) where     taggedObjectPairs opts tagFieldName contentsFieldName =         (pack tagFieldName .= constructorTagModifier opts                                  (conName (undefined :: t c a p)) :) .         (unTagged :: Tagged isRecord [Pair] -> [Pair]) .           taggedObjectPairs' opts contentsFieldName . unM1-    {-# INLINE taggedObjectPairs #-} +class TaggedObjectPairs' f isRecord where+    taggedObjectPairs' :: Options -> String -> f a -> Tagged isRecord [Pair]++instance (RecordToPairs f) => TaggedObjectPairs' f True where+    taggedObjectPairs' opts _ = Tagged . toList . recordToPairs opts++instance (GToJSON f) => TaggedObjectPairs' f False where+    taggedObjectPairs' opts contentsFieldName =+        Tagged . (:[]) . (pack contentsFieldName .=) . gToJSON opts++--------------------------------------------------------------------------------++class TaggedObjectEnc f where+    taggedObjectEnc :: Options -> String -> String -> f a -> B.Builder++instance ( TaggedObjectEnc a+         , TaggedObjectEnc b ) => TaggedObjectEnc (a :+: b) where+    taggedObjectEnc opts tagFieldName contentsFieldName (L1 x) =+        taggedObjectEnc opts tagFieldName contentsFieldName     x+    taggedObjectEnc opts tagFieldName contentsFieldName (R1 x) =+        taggedObjectEnc opts tagFieldName contentsFieldName     x++instance ( IsRecord         a isRecord+         , TaggedObjectEnc' a isRecord+         , Constructor c ) => TaggedObjectEnc (C1 c a) where     taggedObjectEnc opts tagFieldName contentsFieldName v =         B.char7 '{' <>         (builder tagFieldName <>@@ -198,28 +237,17 @@         ((unTagged :: Tagged isRecord B.Builder -> B.Builder) .          taggedObjectEnc' opts contentsFieldName . unM1 $ v) <>         B.char7 '}'-    {-# INLINE taggedObjectEnc #-} -class TaggedObject' f isRecord where-    taggedObjectPairs' :: Options -> String -> f a -> Tagged isRecord [Pair]+class TaggedObjectEnc' f isRecord where     taggedObjectEnc' :: Options -> String -> f a -> Tagged isRecord B.Builder -instance (RecordTo f) => TaggedObject' f True where-    taggedObjectPairs' opts _ = Tagged . toList . recordToPairs opts-    {-# INLINE taggedObjectPairs' #-}-+instance (RecordToEncoding f) => TaggedObjectEnc' f True where     taggedObjectEnc' opts _ = Tagged . recordToEncoding opts-    {-# INLINE taggedObjectEnc' #-} -instance (GToJSON f) => TaggedObject' f False where-    taggedObjectPairs' opts contentsFieldName =-        Tagged . (:[]) . (pack contentsFieldName .=) . gToJSON opts-    {-# INLINE taggedObjectPairs' #-}-+instance (GToEncoding f) => TaggedObjectEnc' f False where     taggedObjectEnc' opts contentsFieldName =         Tagged . (\z -> builder contentsFieldName <> B.char7 ':' <> z) .         gbuilder opts-    {-# INLINE taggedObjectEnc' #-}  -------------------------------------------------------------------------------- @@ -230,132 +258,139 @@ instance (GetConName a, GetConName b) => GetConName (a :+: b) where     getConName (L1 x) = getConName x     getConName (R1 x) = getConName x-    {-# INLINE getConName #-} -instance (Constructor c, GToJSON a, ConsToJSON a) => GetConName (C1 c a) where+instance (Constructor c) => GetConName (C1 c a) where     getConName = conName-    {-# INLINE getConName #-}  -------------------------------------------------------------------------------- -class TwoElemArray f where+class TwoElemArrayObj f where     twoElemArrayObj :: Options -> f a -> V.Vector Value-    twoElemArrayEnc :: Options -> f a -> B.Builder -instance (TwoElemArray a, TwoElemArray b) => TwoElemArray (a :+: b) where+instance (TwoElemArrayObj a, TwoElemArrayObj b) => TwoElemArrayObj (a :+: b) where     twoElemArrayObj opts (L1 x) = twoElemArrayObj opts x     twoElemArrayObj opts (R1 x) = twoElemArrayObj opts x-    {-# INLINE twoElemArrayObj #-} -    twoElemArrayEnc opts (L1 x) = twoElemArrayEnc opts x-    twoElemArrayEnc opts (R1 x) = twoElemArrayEnc opts x-    {-# INLINE twoElemArrayEnc #-}- instance ( GToJSON a, ConsToJSON a-         , Constructor c ) => TwoElemArray (C1 c a) where+         , Constructor c ) => TwoElemArrayObj (C1 c a) where     twoElemArrayObj opts x = V.create $ do       mv <- VM.unsafeNew 2       VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts                                    $ conName (undefined :: t c a p)       VM.unsafeWrite mv 1 $ gToJSON opts x       return mv-    {-# INLINE twoElemArrayObj #-} +--------------------------------------------------------------------------------++class TwoElemArrayEnc f where+    twoElemArrayEnc :: Options -> f a -> B.Builder++instance (TwoElemArrayEnc a, TwoElemArrayEnc b) => TwoElemArrayEnc (a :+: b) where+    twoElemArrayEnc opts (L1 x) = twoElemArrayEnc opts x+    twoElemArrayEnc opts (R1 x) = twoElemArrayEnc opts x++instance ( GToEncoding a, ConsToEncoding a+         , Constructor c ) => TwoElemArrayEnc (C1 c a) where     twoElemArrayEnc opts x = fromEncoding . tuple $       builder (constructorTagModifier opts (conName (undefined :: t c a p))) >*<       gbuilder opts x-    {-# INLINE twoElemArrayEnc #-}  --------------------------------------------------------------------------------  class ConsToJSON f where     consToJSON     :: Options -> f a -> Value-    consToEncoding :: Options -> f a -> B.Builder  class ConsToJSON' f isRecord where     consToJSON'     :: Options -> Bool -- ^ Are we a record with one field?                     -> f a -> Tagged isRecord Value-    consToEncoding' :: Options -> Bool -- ^ Are we a record with one field?-                    -> f a -> Tagged isRecord B.Builder  instance ( IsRecord    f isRecord          , ConsToJSON' f isRecord ) => ConsToJSON f where     consToJSON opts = (unTagged :: Tagged isRecord Value -> Value)                     . consToJSON' opts (isUnary (undefined :: f a))-    {-# INLINE consToJSON #-} -    consToEncoding opts = (unTagged :: Tagged isRecord B.Builder -> B.Builder)-                          . consToEncoding' opts (isUnary (undefined :: f a))-    {-# INLINE consToEncoding #-}--instance (RecordTo f) => ConsToJSON' f True where+instance (RecordToPairs f) => ConsToJSON' f True where     consToJSON' opts isUn f = let       vals = toList $ recordToPairs opts f       in case (unwrapUnaryRecords opts,isUn,vals) of         (True,True,[(_,val)]) -> Tagged val         _ -> Tagged $ object vals-    {-# INLINE consToJSON' #-} +instance GToJSON f => ConsToJSON' f False where+    consToJSON' opts _ = Tagged . gToJSON opts++--------------------------------------------------------------------------------++class ConsToEncoding f where+    consToEncoding :: Options -> f a -> B.Builder++class ConsToEncoding' f isRecord where+    consToEncoding' :: Options -> Bool -- ^ Are we a record with one field?+                    -> f a -> Tagged isRecord B.Builder++instance ( IsRecord        f isRecord+         , ConsToEncoding' f isRecord ) => ConsToEncoding f where+    consToEncoding opts = (unTagged :: Tagged isRecord B.Builder -> B.Builder)+                          . consToEncoding' opts (isUnary (undefined :: f a))++instance (RecordToEncoding f) => ConsToEncoding' f True where     consToEncoding' opts isUn x       | (True,True) <- (unwrapUnaryRecords opts,isUn) = Tagged $   recordToEncoding opts x       | otherwise = Tagged $           B.char7 '{' <>           recordToEncoding opts x <>           B.char7 '}'-    {-# INLINE consToEncoding' #-} -instance GToJSON f => ConsToJSON' f False where-    consToJSON' opts _ = Tagged . gToJSON opts-    {-# INLINE consToJSON' #-}+instance GToEncoding f => ConsToEncoding' f False where     consToEncoding' opts _ = Tagged . gbuilder opts-    {-# INLINE consToEncoding' #-}  -------------------------------------------------------------------------------- -class RecordTo f where+class RecordToPairs f where     recordToPairs    :: Options -> f a -> DList Pair-    recordToEncoding :: Options -> f a -> B.Builder -instance (RecordTo a, RecordTo b) => RecordTo (a :*: b) where+instance (RecordToPairs a, RecordToPairs b) => RecordToPairs (a :*: b) where     recordToPairs opts (a :*: b) = recordToPairs opts a <>                                    recordToPairs opts b-    {-# INLINE recordToPairs #-} -    recordToEncoding opts (a :*: b) = recordToEncoding opts a <>-                                      B.char7 ',' <>-                                      recordToEncoding opts b-    {-# INLINE recordToEncoding #-}--instance (Selector s, GToJSON a) => RecordTo (S1 s a) where+instance (Selector s, GToJSON a) => RecordToPairs (S1 s a) where     recordToPairs = fieldToPair-    {-# INLINE recordToPairs #-} -    recordToEncoding = fieldToEncoding-    {-# INLINE recordToEncoding #-}--instance (Selector s, ToJSON a) => RecordTo (S1 s (K1 i (Maybe a))) where+instance OVERLAPPING_ (Selector s, ToJSON a) =>+  RecordToPairs (S1 s (K1 i (Maybe a))) where     recordToPairs opts (M1 k1) | omitNothingFields opts                                , K1 Nothing <- k1 = empty     recordToPairs opts m1 = fieldToPair opts m1-    {-# INLINE recordToPairs #-} -    recordToEncoding opts (M1 k1) | omitNothingFields opts-                                  , K1 Nothing <- k1 = mempty-    recordToEncoding opts m1 = fieldToEncoding opts m1-    {-# INLINE recordToEncoding #-}- fieldToPair :: (Selector s, GToJSON a) => Options -> S1 s a p -> DList Pair fieldToPair opts m1 = pure ( pack $ fieldLabelModifier opts $ selName m1                            , gToJSON opts (unM1 m1)                            )-{-# INLINE fieldToPair #-} -fieldToEncoding :: (Selector s, GToJSON a) => Options -> S1 s a p -> B.Builder+--------------------------------------------------------------------------------++class RecordToEncoding f where+    recordToEncoding :: Options -> f a -> B.Builder++instance (RecordToEncoding a, RecordToEncoding b) => RecordToEncoding (a :*: b) where+    recordToEncoding opts (a :*: b) = recordToEncoding opts a <>+                                      B.char7 ',' <>+                                      recordToEncoding opts b++instance (Selector s, GToEncoding a) => RecordToEncoding (S1 s a) where+    recordToEncoding = fieldToEncoding++instance OVERLAPPING_ (Selector s, ToJSON a) =>+  RecordToEncoding (S1 s (K1 i (Maybe a))) where+    recordToEncoding opts (M1 k1) | omitNothingFields opts+                                  , K1 Nothing <- k1 = mempty+    recordToEncoding opts m1 = fieldToEncoding opts m1++fieldToEncoding :: (Selector s, GToEncoding a) => Options -> S1 s a p -> B.Builder fieldToEncoding opts m1 =     builder (fieldLabelModifier opts $ selName m1) <>     B.char7 ':' <>     gbuilder opts (unM1 m1)-{-# INLINE fieldToEncoding #-}  -------------------------------------------------------------------------------- @@ -366,7 +401,6 @@                  -> Int -- ^ length                  -> f a                  -> ST s ()-    encodeProduct :: Options -> f a -> B.Builder  instance ( WriteProduct a          , WriteProduct b ) => WriteProduct (a :*: b) where@@ -377,44 +411,53 @@           lenL = len `unsafeShiftR` 1           lenR = len - lenL           ixR  = ix  + lenL-    {-# INLINE writeProduct #-} +instance OVERLAPPABLE_ (GToJSON a) => WriteProduct a where+    writeProduct opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts++--------------------------------------------------------------------------------++class EncodeProduct f where+    encodeProduct :: Options -> f a -> B.Builder++instance ( EncodeProduct a+         , EncodeProduct b ) => EncodeProduct (a :*: b) where     encodeProduct opts (a :*: b) = encodeProduct opts a <>                                    B.char7 ',' <>                                    encodeProduct opts b-    {-# INLINE encodeProduct #-} -instance (GToJSON a) => WriteProduct a where-    writeProduct opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts-    {-# INLINE writeProduct #-}-+instance OVERLAPPABLE_ (GToEncoding a) => EncodeProduct a where     encodeProduct opts = gbuilder opts-    {-# INLINE encodeProduct #-}  -------------------------------------------------------------------------------- -class ObjectWithSingleField f where+class ObjectWithSingleFieldObj f where     objectWithSingleFieldObj :: Options -> f a -> Object-    objectWithSingleFieldEnc :: Options -> f a -> B.Builder -instance ( ObjectWithSingleField a-         , ObjectWithSingleField b ) => ObjectWithSingleField (a :+: b) where+instance ( ObjectWithSingleFieldObj a+         , ObjectWithSingleFieldObj b ) => ObjectWithSingleFieldObj (a :+: b) where     objectWithSingleFieldObj opts (L1 x) = objectWithSingleFieldObj opts x     objectWithSingleFieldObj opts (R1 x) = objectWithSingleFieldObj opts x-    {-# INLINE objectWithSingleFieldObj #-} -    objectWithSingleFieldEnc opts (L1 x) = objectWithSingleFieldEnc opts x-    objectWithSingleFieldEnc opts (R1 x) = objectWithSingleFieldEnc opts x-    {-# INLINE objectWithSingleFieldEnc #-}- instance ( GToJSON a, ConsToJSON a-         , Constructor c ) => ObjectWithSingleField (C1 c a) where+         , Constructor c ) => ObjectWithSingleFieldObj (C1 c a) where     objectWithSingleFieldObj opts = H.singleton typ . gToJSON opts         where           typ = pack $ constructorTagModifier opts $                          conName (undefined :: t c a p)-    {-# INLINE objectWithSingleFieldObj #-} +--------------------------------------------------------------------------------++class ObjectWithSingleFieldEnc f where+    objectWithSingleFieldEnc :: Options -> f a -> B.Builder++instance ( ObjectWithSingleFieldEnc a+         , ObjectWithSingleFieldEnc b ) => ObjectWithSingleFieldEnc (a :+: b) where+    objectWithSingleFieldEnc opts (L1 x) = objectWithSingleFieldEnc opts x+    objectWithSingleFieldEnc opts (R1 x) = objectWithSingleFieldEnc opts x++instance ( GToEncoding a, ConsToEncoding a+         , Constructor c ) => ObjectWithSingleFieldEnc (C1 c a) where     objectWithSingleFieldEnc opts v =       B.char7 '{' <>       builder (constructorTagModifier opts@@ -422,37 +465,32 @@       B.char7 ':' <>       gbuilder opts v <>       B.char7 '}'-    {-# INLINE objectWithSingleFieldEnc #-} -gbuilder :: GToJSON f => Options -> f a -> Builder+gbuilder :: GToEncoding f => Options -> f a -> Builder gbuilder opts = fromEncoding . gToEncoding opts  -------------------------------------------------------------------------------- -- Generic parseJSON -instance (GFromJSON a) => GFromJSON (M1 i c a) where+instance OVERLAPPABLE_ (GFromJSON a) => GFromJSON (M1 i c a) where     -- Meta-information, which is not handled elsewhere, is just added to the     -- parsed value:     gParseJSON opts = fmap M1 . gParseJSON opts-    {-# INLINE gParseJSON #-}  instance (FromJSON a) => GFromJSON (K1 i a) where     -- Constant values are decoded using their FromJSON instance:     gParseJSON _opts = fmap K1 . parseJSON-    {-# INLINE gParseJSON #-}  instance GFromJSON U1 where     -- Empty constructors are expected to be encoded as an empty array:     gParseJSON _opts v         | isEmptyArray v = pure U1         | otherwise      = typeMismatch "unit constructor (U1)" v-    {-# INLINE gParseJSON #-}  instance (ConsFromJSON a) => GFromJSON (C1 c a) where     -- Constructors need to be decoded differently depending on whether they're     -- a record or not. This distinction is made by consParseJSON:     gParseJSON opts = fmap M1 . consParseJSON opts-    {-# INLINE gParseJSON #-}  instance ( FromProduct a, FromProduct b          , ProductSize a, ProductSize b ) => GFromJSON (a :*: b) where@@ -468,7 +506,6 @@       else fail $ "When expecting a product of " ++ show lenProduct ++                   " values, encountered an Array of " ++ show lenArray ++                   " elements instead"-    {-# INLINE gParseJSON #-}  instance ( AllNullary (a :+: b) allNullary          , ParseSum   (a :+: b) allNullary ) => GFromJSON   (a :+: b) where@@ -478,7 +515,6 @@     gParseJSON opts = (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->                                                      (Parser ((a :+: b) d)))                     . parseSum opts-    {-# INLINE gParseJSON #-}  -------------------------------------------------------------------------------- @@ -491,12 +527,10 @@     parseSum opts         | allNullaryToStringTag opts = Tagged . parseAllNullarySum    opts         | otherwise                  = Tagged . parseNonAllNullarySum opts-    {-# INLINE parseSum #-}  instance ( FromPair         (a :+: b)          , FromTaggedObject (a :+: b) ) => ParseSum (a :+: b) False where     parseSum opts = Tagged . parseNonAllNullarySum opts-    {-# INLINE parseSum #-}  -------------------------------------------------------------------------------- @@ -504,7 +538,6 @@ parseAllNullarySum opts = withText "Text" $ \key ->                             maybe (notFound $ unpack key) return $                               parseSumFromString opts key-{-# INLINE parseAllNullarySum #-}  class SumFromString f where     parseSumFromString :: Options -> Text -> Maybe (f a)@@ -512,7 +545,6 @@ instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where     parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>                                   (R1 <$> parseSumFromString opts key)-    {-# INLINE parseSumFromString #-}  instance (Constructor c) => SumFromString (C1 c U1) where     parseSumFromString opts key | key == name = Just $ M1 U1@@ -520,7 +552,6 @@         where           name = pack $ constructorTagModifier opts $                           conName (undefined :: t c U1 p)-    {-# INLINE parseSumFromString #-}  -------------------------------------------------------------------------------- @@ -550,7 +581,6 @@                                    parsePair opts (tag, V.unsafeIndex arr 1)                    _ -> fail "First element is not a String"             else fail "Array doesn't have 2 elements"-{-# INLINE parseNonAllNullarySum #-}  -------------------------------------------------------------------------------- @@ -563,7 +593,6 @@         parseFromTaggedObject opts contentsFieldName obj tag =             (fmap L1 <$> parseFromTaggedObject opts contentsFieldName obj tag) <|>             (fmap R1 <$> parseFromTaggedObject opts contentsFieldName obj tag)-        {-# INLINE parseFromTaggedObject #-}  instance ( FromTaggedObject' f          , Constructor c ) => FromTaggedObject (C1 c f) where@@ -574,7 +603,6 @@         where           name = pack $ constructorTagModifier opts $                           conName (undefined :: t c f p)-    {-# INLINE parseFromTaggedObject #-}  -------------------------------------------------------------------------------- @@ -591,16 +619,13 @@     parseFromTaggedObject' opts contentsFieldName =         (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .         parseFromTaggedObject'' opts contentsFieldName-    {-# INLINE parseFromTaggedObject' #-}  instance (FromRecord f) => FromTaggedObject'' f True where     parseFromTaggedObject'' opts _ = Tagged . parseRecord opts Nothing-    {-# INLINE parseFromTaggedObject'' #-}  instance (GFromJSON f) => FromTaggedObject'' f False where     parseFromTaggedObject'' opts contentsFieldName = Tagged .       (gParseJSON opts <=< (.: pack contentsFieldName))-    {-# INLINE parseFromTaggedObject'' #-}  -------------------------------------------------------------------------------- @@ -622,17 +647,14 @@         _ ->(v,Nothing)       in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))                        $ consParseJSON' opts lab v2-    {-# INLINE consParseJSON #-}   instance (FromRecord f) => ConsFromJSON' f True where     consParseJSON' opts mlab = Tagged . (withObject "record (:*:)"                                 $ parseRecord opts mlab)-    {-# INLINE consParseJSON' #-}  instance (GFromJSON f) => ConsFromJSON' f False where     consParseJSON' opts _ = Tagged . gParseJSON opts-    {-# INLINE consParseJSON' #-}  -------------------------------------------------------------------------------- @@ -644,7 +666,6 @@ instance (FromRecord a, FromRecord b) => FromRecord (a :*: b) where     parseRecord opts _ obj = (:*:) <$> parseRecord opts Nothing obj                                    <*> parseRecord opts Nothing obj-    {-# INLINE parseRecord #-}  instance (Selector s, GFromJSON a) => FromRecord (S1 s a) where     parseRecord opts (Just lab) = maybe (notFound $ unpack lab)@@ -653,15 +674,14 @@                       (gParseJSON opts) . H.lookup (pack label)         where           label = fieldLabelModifier opts $ selName (undefined :: t s a p)-    {-# INLINE parseRecord #-} -instance (Selector s, FromJSON a) => FromRecord (S1 s (K1 i (Maybe a))) where-    parseRecord _ (Just lab) obj = (M1 . K1) . join <$> obj .:? lab-    parseRecord opts Nothing obj = (M1 . K1) . join <$> obj .:? pack label+instance OVERLAPPING_ (Selector s, FromJSON a) =>+  FromRecord (S1 s (K1 i (Maybe a))) where+    parseRecord _ (Just lab) obj = (M1 . K1) <$> obj .:? lab+    parseRecord opts Nothing obj = (M1 . K1) <$> obj .:? pack label         where           label = fieldLabelModifier opts $                     selName (undefined :: t s (K1 i (Maybe a)) p)-    {-# INLINE parseRecord #-}  -------------------------------------------------------------------------------- @@ -671,11 +691,9 @@ instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where     productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +                             unTagged2 (productSize :: Tagged2 b Int)-    {-# INLINE productSize #-}  instance ProductSize (S1 s a) where     productSize = Tagged2 1-    {-# INLINE productSize #-}  -------------------------------------------------------------------------------- @@ -690,11 +708,9 @@           lenL = len `unsafeShiftR` 1           ixR  = ix + lenL           lenR = len - lenL-    {-# INLINE parseProduct #-}  instance (GFromJSON a) => FromProduct (S1 s a) where     parseProduct opts arr ix _ = gParseJSON opts $ V.unsafeIndex arr ix-    {-# INLINE parseProduct #-}  -------------------------------------------------------------------------------- @@ -704,7 +720,6 @@ instance (FromPair a, FromPair b) => FromPair (a :+: b) where     parsePair opts pair = (fmap L1 <$> parsePair opts pair) <|>                           (fmap R1 <$> parsePair opts pair)-    {-# INLINE parsePair #-}  instance (Constructor c, GFromJSON a, ConsFromJSON a) => FromPair (C1 c a) where     parsePair opts (tag, value)@@ -713,7 +728,6 @@         where           tag' = pack $ constructorTagModifier opts $                           conName (undefined :: t c a p)-    {-# INLINE parsePair #-}  -------------------------------------------------------------------------------- @@ -724,7 +738,11 @@  instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord   where isUnary = const False-instance IsRecord (M1 S NoSelector f) False+#if MIN_VERSION_base(4,9,0)+instance OVERLAPPING_ IsRecord (M1 S ('MetaSel 'Nothing u ss ds) f) False+#else+instance OVERLAPPING_ IsRecord (M1 S NoSelector f) False+#endif instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord instance IsRecord (K1 i c) True instance IsRecord U1 False

@@ -1,8 +1,12 @@ {-# LANGUAGE CPP, BangPatterns, DeriveDataTypeable, FlexibleContexts,-    FlexibleInstances, GeneralizedNewtypeDeriving, IncoherentInstances,-    OverlappingInstances, OverloadedStrings, UndecidableInstances,+    FlexibleInstances, GeneralizedNewtypeDeriving,+    OverloadedStrings, UndecidableInstances,     ViewPatterns #-} {-# LANGUAGE DefaultSignatures #-}++#define NEEDS_INCOHERENT+#include "overlapping-compat.h"+ {-# OPTIONS_GHC -fno-warn-orphans #-}  -- TODO: Drop this when we remove support for Data.Attoparsec.Number@@ -10,9 +14,9 @@  -- | -- Module:      Data.Aeson.Types.Instances--- Copyright:   (c) 2011-2015 Bryan O'Sullivan+-- Copyright:   (c) 2011-2016 Bryan O'Sullivan --              (c) 2011 MailRank, Inc.--- License:     Apache+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable@@ -29,6 +33,7 @@     -- ** Generic JSON classes     , GFromJSON(..)     , GToJSON(..)+    , GToEncoding(..)     , genericToJSON     , genericToEncoding     , genericParseJSON@@ -49,34 +54,37 @@     , ifromJSON     , (.:)     , (.:?)+    , (.:!)     , (.!=)     , tuple     , (>*<)     , typeMismatch     ) where -import Control.Applicative ((<$>), (<*>), pure) import Data.Aeson.Encode.Functions (brackets, builder, encode, foldable, list) import Data.Aeson.Functions (hashMapKey, mapHashKeyVal, mapKey, mapKeyVal) import Data.Aeson.Types.Class import Data.Aeson.Types.Internal import Data.Attoparsec.Number (Number(..)) import Data.Fixed (Fixed, HasResolution)-import Data.Foldable (Foldable, toList)+import Data.Foldable (toList) import Data.Functor.Identity (Identity(..)) import Data.Hashable (Hashable(..)) import Data.Int (Int8, Int16, Int32, Int64) import Data.Maybe (fromMaybe)-import Data.Monoid ((<>), mempty)+import Data.Monoid ((<>)) import Data.Monoid (Dual(..), First(..), Last(..)) import Data.Ratio (Ratio, (%), numerator, denominator) import Data.Scientific (Scientific) import Data.Text (Text, pack, unpack)-import Data.Time (Day, LocalTime, NominalDiffTime, UTCTime, ZonedTime)+import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime,+                  ZonedTime) import Data.Time.Format (FormatTime, formatTime, parseTime)-import Data.Traversable as Tr (sequence, traverse)+import Data.Traversable as Tr (sequence) import Data.Vector (Vector)-import Data.Word (Word, Word8, Word16, Word32, Word64)+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Version (Version, showVersion, parseVersion)+import Text.ParserCombinators.ReadP (readP_to_S) import Foreign.Storable (Storable) import Prelude hiding (foldr) import qualified Data.Aeson.Encode.Builder as E@@ -102,6 +110,15 @@ import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU +#if MIN_VERSION_base(4,8,0)+import Numeric.Natural+#else+import Control.Applicative ((<$>), (<*>), pure)+import Data.Monoid (mempty)+import Data.Traversable as Tr (traverse)+import Data.Word (Word)+#endif+ #if MIN_VERSION_time(1,5,0) import Data.Time.Format (defaultTimeLocale) #else@@ -142,15 +159,15 @@     {-# INLINE toJSON #-}      toEncoding (Left a) = Encoding $-      B.shortByteString "{\"left\":" <> builder a <> B.char7 '}'+      B.shortByteString "{\"Left\":" <> builder a <> B.char7 '}'     toEncoding (Right a) = Encoding $-      B.shortByteString "{\"right\":" <> builder a <> B.char7 '}'+      B.shortByteString "{\"Right\":" <> builder a <> B.char7 '}'     {-# INLINE toEncoding #-}  instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where     parseJSON (Object (H.toList -> [(key, value)]))-        | key == left  = Left  <$> parseJSON value-        | key == right = Right <$> parseJSON value+        | key == left  = Left  <$> parseJSON value <?> Key left+        | key == right = Right <$> parseJSON value <?> Key right     parseJSON _        = fail $         "expected an object with a single property " ++         "where the property key should be either " ++@@ -172,6 +189,24 @@     parseJSON = withBool "Bool" pure     {-# INLINE parseJSON #-} +instance ToJSON Ordering where+  toJSON     = toJSON     . orderingToText+  toEncoding = toEncoding . orderingToText++orderingToText :: Ordering -> T.Text+orderingToText o = case o of+                     LT -> "LT"+                     EQ -> "EQ"+                     GT -> "GT"++instance FromJSON Ordering where+  parseJSON = withText "Ordering" $ \s ->+    case s of+      "LT" -> return LT+      "EQ" -> return EQ+      "GT" -> return GT+      _ -> fail "Parsing Ordering value failed: expected \"LT\", \"EQ\", or \"GT\""+ instance ToJSON () where     toJSON _ = emptyArray     {-# INLINE toJSON #-}@@ -186,14 +221,14 @@                     else fail "Expected an empty array"     {-# INLINE parseJSON #-} -instance ToJSON [Char] where+instance INCOHERENT_ ToJSON [Char] where     toJSON = String . T.pack     {-# INLINE toJSON #-}      toEncoding = Encoding . E.string     {-# INLINE toEncoding #-} -instance FromJSON [Char] where+instance INCOHERENT_ FromJSON [Char] where     parseJSON = withText "String" $ pure . T.unpack     {-# INLINE parseJSON #-} @@ -318,6 +353,21 @@     parseJSON = withScientific "Integral" $ pure . truncate     {-# INLINE parseJSON #-} +#if MIN_VERSION_base(4,8,0)+instance ToJSON Natural where+    toJSON = toJSON . toInteger+    {-# INLINE toJSON #-}++    toEncoding = toEncoding . toInteger+    {-# INLINE toEncoding #-}++instance FromJSON Natural where+    parseJSON = withScientific "Natural" $ \s ->+      if Scientific.coefficient s < 0+        then fail $ "Expected a Natural number but got the negative number: " <> show s+        else pure $ truncate s+#endif+ instance ToJSON Int8 where     toJSON = Number . fromIntegral     {-# INLINE toJSON #-}@@ -441,19 +491,19 @@     parseJSON = withText "Lazy Text" $ pure . LT.fromStrict     {-# INLINE parseJSON #-} -instance (ToJSON a) => ToJSON [a] where+instance OVERLAPPABLE_ (ToJSON a) => ToJSON [a] where     toJSON = Array . V.fromList . map toJSON     {-# INLINE toJSON #-}      toEncoding xs = list xs     {-# INLINE toEncoding #-} -instance (FromJSON a) => FromJSON [a] where+instance OVERLAPPABLE_ (FromJSON a) => FromJSON [a] where     parseJSON = withArray "[a]" $ Tr.sequence .                 zipWith parseIndexedJSON [0..] . V.toList     {-# INLINE parseJSON #-} -instance (Foldable t, ToJSON a) => ToJSON (t a) where+instance (ToJSON a) => ToJSON (Seq.Seq a) where     toJSON = toJSON . toList     {-# INLINE toJSON #-} @@ -461,7 +511,9 @@     {-# INLINE toEncoding #-}  instance (FromJSON a) => FromJSON (Seq.Seq a) where-    parseJSON = withArray "Seq a" $ traverse parseJSON . Seq.fromList . V.toList+    parseJSON = withArray "Seq a" $+      fmap Seq.fromList .+      Tr.sequence . zipWith parseIndexedJSON [0..] . V.toList     {-# INLINE parseJSON #-}  instance (ToJSON a) => ToJSON (Vector a) where@@ -713,14 +765,21 @@  instance ToJSON Day where     toJSON       = stringEncoding-    toEncoding z = Encoding (E.day z)+    toEncoding z = Encoding (E.quote $ E.day z)  instance FromJSON Day where     parseJSON = withText "Day" (Time.run Time.day) +instance ToJSON TimeOfDay where+    toJSON       = stringEncoding+    toEncoding z = Encoding (E.quote $ E.timeOfDay z)++instance FromJSON TimeOfDay where+    parseJSON = withText "TimeOfDay" (Time.run Time.timeOfDay)+ instance ToJSON LocalTime where     toJSON       = stringEncoding-    toEncoding z = Encoding (E.localTime z)+    toEncoding z = Encoding (E.quote $ E.localTime z)  instance FromJSON LocalTime where     parseJSON = withText "LocalTime" (Time.run Time.localTime)@@ -728,7 +787,7 @@ instance ToJSON ZonedTime where     toJSON = stringEncoding -    toEncoding z = Encoding (E.zonedTime z)+    toEncoding z = Encoding (E.quote $ E.zonedTime z)  formatMillis :: (FormatTime t) => t -> String formatMillis = take 3 . formatTime defaultTimeLocale "%q"@@ -739,11 +798,11 @@ instance ToJSON UTCTime where     toJSON = stringEncoding -    toEncoding t = Encoding (E.utcTime t)+    toEncoding t = Encoding (E.quote $ E.utcTime t)  -- | Encode something to a JSON string. stringEncoding :: (ToJSON a) => a -> Value-stringEncoding = String . T.decodeLatin1 . L.toStrict . encode+stringEncoding = String . T.dropAround (== '"') . T.decodeLatin1 . L.toStrict . encode {-# INLINE stringEncoding #-}  instance FromJSON UTCTime where@@ -1456,6 +1515,21 @@     parseJSON = fmap Last . parseJSON     {-# INLINE parseJSON #-} +instance ToJSON Version where+    toJSON = toJSON . showVersion+    {-# INLINE toJSON #-}++    toEncoding = toEncoding . showVersion+    {-# INLINE toEncoding #-}++instance FromJSON Version where+    {-# INLINE parseJSON #-}+    parseJSON = withText "Version" $ go . readP_to_S parseVersion . unpack+      where+        go [(v,[])] = return v+        go (_ : xs) = go xs+        go _        = fail $ "could not parse Version"+ -- | @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@@ -1523,7 +1597,7 @@ -- -- This accessor is appropriate if the key and value /must/ be present -- in an object for it to be valid.  If the key and value are--- optional, use '(.:?)' instead.+-- optional, use '.:?' instead. (.:) :: (FromJSON a) => Object -> Text -> Parser a obj .: key = case H.lookup key obj of                Nothing -> fail $ "key " ++ show key ++ " not present"@@ -1539,23 +1613,34 @@ -- -- This accessor is most useful if the key and value can be absent -- from an object without affecting its validity.  If the key and--- value are mandatory, use '(.:)' instead.+-- value are mandatory, use '.:' instead. (.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a) obj .:? key = case H.lookup key obj of                Nothing -> pure Nothing                Just v  -> modifyFailure addKeyName-                        $ Just <$> parseJSON v <?> Key key+                        $ parseJSON v <?> Key key   where     addKeyName = (("failed to parse field " <> unpack key <> ": ") <>) {-# INLINE (.:?) #-} +-- | Like '.:?', but the resulting parser will fail,+-- if the key is present but is 'Null'.+(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)+obj .:! key = case H.lookup key obj of+               Nothing -> pure Nothing+               Just v  -> modifyFailure addKeyName+                        $ Just <$> parseJSON v <?> Key key+  where+    addKeyName = (("failed to parse field " <> unpack key <> ": ") <>)+{-# INLINE (.:!) #-}+ -- | Helper for use in combination with '.:?' to provide default -- values for optional JSON object fields. -- -- This combinator is most useful if the key and value can be absent -- from an object without affecting its validity and we know a default -- value to assign in that case.  If the key and value are mandatory,--- use '(.:)' instead.+-- use '.:' instead. -- -- Example usage: --

@@ -1,11 +1,19 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, Rank2Types,+{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, Rank2Types,     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)+-- c) removes one hindrance to have code inferred as SafeHaskell safe+{-# LANGUAGE TemplateHaskellQuotes #-}+#else+{-# LANGUAGE TemplateHaskell #-}+#endif  -- | -- Module:      Data.Aeson.Types.Internal--- Copyright:   (c) 2011-2015 Bryan O'Sullivan+-- Copyright:   (c) 2011-2016 Bryan O'Sullivan --              (c) 2011 MailRank, Inc.--- License:     Apache+-- License:     BSD3 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- Stability:   experimental -- Portability: portable@@ -53,27 +61,35 @@     , DotNetTime(..)     ) where +import Control.Arrow (first) import Control.Applicative import Control.DeepSeq (NFData(..)) import Control.Monad (MonadPlus(..), ap)+import qualified Control.Monad.Fail as Fail import Data.ByteString.Builder (Builder, char7, toLazyByteString)-import Data.Char (isLower, isUpper, toLower)+import Data.Char (isLower, isUpper, toLower, isAlpha, isAlphaNum) import Data.Data (Data)-import Data.Foldable (Foldable(..)) import Data.HashMap.Strict (HashMap) import Data.Hashable (Hashable(..))-import Data.Monoid (Monoid(..), (<>))+import Data.Semigroup (Semigroup((<>))) import Data.Scientific (Scientific) import Data.String (IsString(..)) import Data.Text (Text, pack, unpack) import Data.Time (UTCTime) import Data.Time.Format (FormatTime)-import Data.Traversable (Traversable(..)) import Data.Typeable (Typeable) import Data.Vector (Vector) import qualified Data.HashMap.Strict as H+import qualified Data.Scientific as S import qualified Data.Vector as V+import qualified Language.Haskell.TH.Syntax as TH +#if !MIN_VERSION_base(4,8,0)+import Data.Foldable (Foldable(..))+import Data.Monoid (Monoid(..))+import Data.Traversable (Traversable(..))+#endif+ -- | Elements of a JSON path used to describe the location of an -- error. data JSONPathElement = Key Text@@ -118,35 +134,43 @@     {-# INLINE fmap #-}  instance Monad IResult where-    return = ISuccess+    return = pure     {-# INLINE return #-}      ISuccess a      >>= k = k a     IError path err >>= _ = IError path err     {-# INLINE (>>=) #-} +    fail = Fail.fail+    {-# INLINE fail #-}++instance Fail.MonadFail IResult where     fail err = IError [] err     {-# INLINE fail #-}  instance Monad Result where-    return = Success+    return = pure     {-# INLINE return #-}      Success a >>= k = k a     Error err >>= _ = Error err     {-# INLINE (>>=) #-} +    fail = Fail.fail+    {-# INLINE fail #-}++instance Fail.MonadFail Result where     fail err = Error err     {-# INLINE fail #-}  instance Applicative IResult where-    pure  = return+    pure  = ISuccess     {-# INLINE pure #-}     (<*>) = ap     {-# INLINE (<*>) #-}  instance Applicative Result where-    pure  = return+    pure  = Success     {-# INLINE pure #-}     (<*>) = ap     {-# INLINE (<*>) #-}@@ -177,16 +201,24 @@     (<|>) = mplus     {-# INLINE (<|>) #-} +instance Semigroup (IResult a) where+    (<>) = mplus+    {-# INLINE (<>) #-}+ instance Monoid (IResult a) where     mempty  = fail "mempty"     {-# INLINE mempty #-}-    mappend = mplus+    mappend = (<>)     {-# INLINE mappend #-} +instance Semigroup (Result a) where+    (<>) = mplus+    {-# INLINE (<>) #-}+ instance Monoid (Result a) where     mempty  = fail "mempty"     {-# INLINE mempty #-}-    mappend = mplus+    mappend = (<>)     {-# INLINE mappend #-}  instance Foldable IResult where@@ -235,8 +267,12 @@     m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks                                        in runParser m path kf ks'     {-# INLINE (>>=) #-}-    return a = Parser $ \_path _kf ks -> ks a+    return = pure     {-# INLINE return #-}+    fail = Fail.fail+    {-# INLINE fail #-}++instance Fail.MonadFail Parser where     fail msg = Parser $ \path kf _ks -> kf (reverse path) msg     {-# INLINE fail #-} @@ -246,7 +282,7 @@     {-# INLINE fmap #-}  instance Applicative Parser where-    pure  = return+    pure a = Parser $ \_path _kf ks -> ks a     {-# INLINE pure #-}     (<*>) = apP     {-# INLINE (<*>) #-}@@ -264,10 +300,14 @@                                          in runParser a path kf' ks     {-# INLINE mplus #-} +instance Semigroup (Parser a) where+    (<>) = mplus+    {-# INLINE (<>) #-}+ instance Monoid (Parser a) where     mempty  = fail "mempty"     {-# INLINE mempty #-}-    mappend = mplus+    mappend = (<>)     {-# INLINE mappend #-}  apP :: Parser (a -> b) -> Parser a -> Parser b@@ -296,7 +336,7 @@ newtype Encoding = Encoding {       fromEncoding :: Builder       -- ^ Acquire the underlying bytestring builder.-    } deriving (Monoid)+    } deriving (Semigroup,Monoid)  instance Show Encoding where     show (Encoding e) = show (toLazyByteString e)@@ -313,16 +353,18 @@             | Value Encoding             deriving (Typeable) -instance Monoid Series where-    mempty              = Empty--    mappend Empty a     = a-    mappend (Value a) b =+instance Semigroup Series where+    Empty   <> a = a+    Value a <> b =         Value $         a <> case b of                Empty   -> mempty                Value c -> Encoding (char7 ',') <> c +instance Monoid Series where+    mempty  = Empty+    mappend = (<>)+ -- | A newtype wrapper for 'UTCTime' that uses the same non-standard -- serialization format as Microsoft .NET, whose -- <https://msdn.microsoft.com/en-us/library/system.datetime(v=vs.110).aspx System.DateTime>@@ -361,6 +403,21 @@ instance Hashable Value where     hashWithSalt = hashValue +-- @since 0.11.0.0+instance TH.Lift Value where+    lift Null = [| Null |]+    lift (Bool b) = [| Bool b |]+    lift (Number n) = [| Number (S.scientific c e) |]+      where+        c = S.coefficient n+        e = S.base10Exponent n+    lift (String t) = [| String (pack s) |]+      where s = unpack t+    lift (Array a) = [| Array (V.fromList a') |]+      where a' = V.toList a+    lift (Object o) = [| Object (H.fromList . map (first pack) $ o') |]+      where o' = map (first unpack) . H.toList $ o+ -- | The empty array. emptyArray :: Value emptyArray = Array V.empty@@ -402,10 +459,29 @@ formatError :: JSONPath -> String -> String formatError path msg = "Error in " ++ (format "$" path) ++ ": " ++ msg   where+    format :: String -> JSONPath -> String     format pfx []                = pfx     format pfx (Index idx:parts) = format (pfx ++ "[" ++ show idx ++ "]") parts-    format pfx (Key key:parts)   = format (pfx ++ "." ++ unpack key) parts+    format pfx (Key key:parts)   = format (pfx ++ formatKey key) parts +    formatKey :: Text -> String+    formatKey key+       | isIdentifierKey strKey = "." ++ strKey+       | otherwise              = "['" ++ escapeKey strKey ++ "']"+      where strKey = unpack key++    isIdentifierKey :: String -> Bool+    isIdentifierKey []     = False+    isIdentifierKey (x:xs) = isAlpha x && all isAlphaNum xs++    escapeKey :: String -> String+    escapeKey = concatMap escapeChar++    escapeChar :: Char -> String+    escapeChar '\'' = "\\'"+    escapeChar '\\' = "\\\\"+    escapeChar c    = [c]+ -- | A key\/value pair for an 'Object'. type Pair = (Text, Value) @@ -417,19 +493,20 @@  -- | Add JSON Path context to a parser ----- When parsing complex structure it helps to annotate (sub)parsers--- with context so that if error occurs you can find it's location.+-- When parsing a complex structure, it helps to annotate (sub)parsers+-- with context, so that if an error occurs, you can find its location. -- -- > withObject "Person" $ \o -> -- >   Person -- >     <$> o .: "name" <?> Key "name" -- >     <*> o .: "age"  <?> Key "age" ----- (except for standard methods like '(.:)' already do that)+-- (Standard methods like '(.:)' already do this.) ----- After that in case of error you will get a JSON Path location of that error.+-- With such annotations, if an error occurs, you will get a JSON Path+-- location of that error. ----- Since 0.9+-- Since 0.10 (<?>) :: Parser a -> JSONPathElement -> Parser a p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks 

@@ -1,4 +1,4 @@-# Welcome to aeson+# Welcome to `aeson` [![Hackage](https://img.shields.io/hackage/v/aeson.svg)](https://hackage.haskell.org/package/aeson) [![Build Status](https://travis-ci.org/bos/aeson.svg)](https://travis-ci.org/bos/aeson)  aeson is a fast Haskell library for working with JSON data. 

@@ -1,16 +1,16 @@ name:            aeson-version:         0.10.0.0+version:         0.11.0.0 license:         BSD3 license-file:    LICENSE category:        Text, Web, JSON-copyright:       (c) 2011-2015 Bryan O'Sullivan+copyright:       (c) 2011-2016 Bryan O'Sullivan                  (c) 2011 MailRank, Inc. author:          Bryan O'Sullivan <bos@serpentine.com> maintainer:      Bryan O'Sullivan <bos@serpentine.com> stability:       experimental-tested-with:     GHC == 7.4, GHC == 7.6, GHC == 7.8, GHC == 7.10+tested-with:     GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2 synopsis:        Fast JSON parsing and encoding-cabal-version:   >= 1.8+cabal-version:   >= 1.10 homepage:        https://github.com/bos/aeson bug-reports:     https://github.com/bos/aeson/issues build-type:      Simple@@ -46,10 +46,12 @@     benchmarks/Makefile     benchmarks/Typed/*.hs     benchmarks/json-data/*.json+    include/overlapping-compat.h     changelog.md     examples/*.cabal     examples/*.hs     examples/Twitter/*.hs+    include/*.h  flag developer   description: operate in developer mode@@ -63,6 +65,8 @@   default: False  library+  default-language: Haskell2010+   exposed-modules:     Data.Aeson     Data.Aeson.Encode@@ -90,6 +94,7 @@     containers,     deepseq,     dlist >= 0.2,+    fail == 4.9.*,     ghc-prim >= 0.2,     hashable >= 1.1.2.0,     mtl,@@ -101,6 +106,10 @@     unordered-containers >= 0.2.5.0,     vector >= 0.7.1 +  if !impl(ghc >= 8.0)+    -- `Data.Semigroup` is available in base only since GHC 8.0+    build-depends: semigroups >= 0.16.1+   if flag(old-locale)     build-depends: time < 1.5, old-locale   else@@ -112,11 +121,16 @@    ghc-options: -O2 -Wall +  include-dirs: include+ test-suite tests+  default-language: Haskell2010   type:           exitcode-stdio-1.0   hs-source-dirs: tests   main-is:        Tests.hs   other-modules:+    DataFamilies.Properties+    DataFamilies.Instances     DataFamilies.Encoders     DataFamilies.Types     Encoders@@ -145,7 +159,8 @@     text,     time,     unordered-containers,-    vector+    vector,+    quickcheck-instances >=0.3.12    if flag(old-locale)     build-depends: time < 1.5, old-locale

@@ -38,6 +38,7 @@     containers,     deepseq,     dlist >= 0.2,+    fail == 4.9.*,     ghc-prim >= 0.2,     hashable >= 1.1.2.0,     mtl,@@ -50,10 +51,16 @@     unordered-containers >= 0.2.3.0,     vector >= 0.7.1 +  if !impl(ghc >= 8.0)+    -- `Data.Semigroup` is available in base only since GHC 8.0+    build-depends: semigroups >= 0.16.1+   if flag(old-locale)     build-depends: time < 1.5, old-locale   else     build-depends: time >= 1.5++  include-dirs: ../include    ghc-options: -O2 -Wall   cpp-options: -DGENERICS

file too large to diff

@@ -1,3 +1,57 @@+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).++# 0.11.0.0++This release should be close to backwards compatible with aeson 0.9.++If you are upgrading from aeson 0.10 it might be easier to go back in+history to the point you were still using 0.9.++**Breaking changes**:++* Revert `.:?` to behave like it did in 0.9. If you want the 0.10+  behavior use `.:!` instead.++* Revert JSON format of `Either` to 0.9, `Left` and `Right` are now+  serialized with an initial uppercase letter. If you want the names+  in lowercase you can add a newtype with an instance.++* All `ToJSON` and `FromJSON` instances except for `[a]` are no longer+  `OVERLAPPABLE`. Mark your instance as `OVERLAPPING` if it overlaps+  any of the other aeson instances.++* All `ToJSON` and `FromJSON` instances except for `[Char]` are no+  longer incoherent, this means you may need to replace your+  incoherent instances with a newtyped instance.++**Additions**:++* Introduce `.:!` that behaves like `.:?` did in 0.10.++* Allow `HH:MM` format for `ZonedTime` and `UTCTime`.+  This is one of the formats allowed by+  [ISO 8601](https://en.wikipedia.org/wiki/ISO_8601#Times).++* Added `ToJSON` and `FromJSON` instances for the+  `Version`, `Ordering`, and `Natural` types.++**Bug fixes**:++* JSONPath identifiers are now escaped if they contain invalid characters.++* Fixed JSONPath messages for Seq to include indices.++* Fixed JSONPath messages for Either to include `left`/`right`.++* Fix missing quotes surrounding time encodings.++* Fix #293: Type error in TH when using `omitNothingFields = True`.++**Compatibility**:++* Various updates to support GHC 8.++ # 0.10.0.0  ## Performance improvements@@ -67,6 +121,9 @@ * New `ToJSON` and `FromJSON` instances for the following time-related   types: `Day`, `LocalTime`. +* `FromJSON` `UTCTime` parser accepts the same values as for `ZonedTime`,+  but converts any time zone offset into a UTC time.+ * The `Result` type is now an instance of `Foldable` and `Traversable`.  * The `Data.Aeson.Generic` module has been removed. It was deprecated in@@ -77,7 +134,12 @@ * The instance of `Monad` for the `Result` type lacked an implementation   of `fail` (oops).  This has been corrected. +* Semantics of `(.:?)` operator are changed. It's doesn't anymore accept+  present `Null` value. +* Added `(Foldable t, ToJSON a) => ToJSON (t a)` overlappable instance.+  You might see `No instance for (Foldable YourPolymorphicType) arising from a+  use of ‘.=’` -errors due this change.  # 0.9.0.1 

@@ -0,0 +1,15 @@+#if __GLASGOW_HASKELL__ >= 710+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}+#define OVERLAPPING_  {-# OVERLAPPING #-}+#ifdef NEEDS_INCOHERENT+#define INCOHERENT_ {-# INCOHERENT #-}+#endif+#else+{-# LANGUAGE OverlappingInstances #-}+#define OVERLAPPABLE_+#define OVERLAPPING_+#ifdef NEEDS_INCOHERENT+{-# LANGUAGE IncoherentInstances #-}+#define INCOHERENT_+#endif+#endif

@@ -1,4 +1,5 @@-{-# Language TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}  module DataFamilies.Encoders where @@ -112,3 +113,26 @@  thApproxParseJSONDefault :: Value -> Parser (Approx String) thApproxParseJSONDefault = $(mkParseJSON defaultOptions 'Approx)++--------------------------------------------------------------------------------+-- GADT encoders/decoders+--------------------------------------------------------------------------------++thGADTToJSONUnwrap :: GADT String -> Value+thGADTToJSONUnwrap = $(mkToJSON optsUnwrapUnaryRecords 'GADT)++thGADTToEncodingUnwrap :: GADT String -> Encoding+thGADTToEncodingUnwrap = $(mkToEncoding optsUnwrapUnaryRecords 'GADT)++thGADTParseJSONUnwrap :: Value -> Parser (GADT String)+thGADTParseJSONUnwrap = $(mkParseJSON optsUnwrapUnaryRecords 'GADT)+++thGADTToJSONDefault :: GADT String -> Value+thGADTToJSONDefault = $(mkToJSON defaultOptions 'GADT)++thGADTToEncodingDefault :: GADT String -> Encoding+thGADTToEncodingDefault = $(mkToEncoding defaultOptions 'GADT)++thGADTParseJSONDefault :: Value -> Parser (GADT String)+thGADTParseJSONDefault = $(mkParseJSON defaultOptions 'GADT)

@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module DataFamilies.Instances where++import Control.Applicative+import Data.Aeson.TH+import Data.Aeson.Types (FromJSON(..))+import DataFamilies.Types+import Test.QuickCheck (Arbitrary(..), elements, oneof)+import Prelude++instance (Arbitrary a) => Arbitrary (Approx a) where+    arbitrary = Approx <$> arbitrary++instance Arbitrary (Nullary Int) where+    arbitrary = elements [C1, C2, C3]++instance Arbitrary a => Arbitrary (SomeType c () a) where+    arbitrary = oneof [ pure Nullary+                      , Unary   <$> arbitrary+                      , Product <$> arbitrary <*> arbitrary <*> arbitrary+                      , Record  <$> arbitrary <*> arbitrary <*> arbitrary+                      ]++instance Arbitrary (GADT String) where+    arbitrary = GADT <$> arbitrary++deriveJSON defaultOptions 'C1+deriveJSON defaultOptions 'Nullary+deriveJSON defaultOptions 'Approx++deriveToJSON defaultOptions 'GADT+-- We must write the FromJSON instance head ourselves+-- due to the refined GADT return type+instance FromJSON (GADT String) where+    parseJSON = $(mkParseJSON defaultOptions 'GADT)

@@ -0,0 +1,80 @@+module DataFamilies.Properties (tests) where++import DataFamilies.Encoders+import DataFamilies.Instances ()++import Properties hiding (tests)++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)++--------------------------------------------------------------------------------++tests :: Test+tests = testGroup "data families" [+  testGroup "template-haskell" [+      testGroup "toJSON" [+        testGroup "Nullary" [+            testProperty "string" (isString . thNullaryToJSONString)+          , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)+          , testProperty "TaggedObject" (isTaggedObjectValue . thNullaryToJSONTaggedObject)+          , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)++          , testGroup "roundTrip" [+              testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)+            , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)+            , testProperty "TaggedObject" (toParseJSON thNullaryParseJSONTaggedObject thNullaryToJSONTaggedObject)+            , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)+            ]+        ]+      , testGroup "SomeType" [+          testProperty "2ElemArray" (is2ElemArray . thSomeTypeToJSON2ElemArray)+        , testProperty "TaggedObject" (isTaggedObject . thSomeTypeToJSONTaggedObject)+        , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thSomeTypeToJSONObjectWithSingleField)+        , testGroup "roundTrip" [+            testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray thSomeTypeToJSON2ElemArray)+          , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject)+          , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField)+          ]+      , 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 "toEncoding" [+        testProperty "NullaryString" $+        thNullaryToJSONString `sameAs` thNullaryToEncodingString+      , testProperty "Nullary2ElemArray" $+        thNullaryToJSON2ElemArray `sameAs` thNullaryToEncoding2ElemArray+      , testProperty "NullaryTaggedObject" $+        thNullaryToJSONTaggedObject `sameAs` thNullaryToEncodingTaggedObject+      , testProperty "NullaryObjectWithSingleField" $+        thNullaryToJSONObjectWithSingleField `sameAs`+        thNullaryToEncodingObjectWithSingleField+      , testProperty "ApproxUnwrap" $+        thApproxToJSONUnwrap `sameAs` thApproxToEncodingUnwrap+      , testProperty "ApproxDefault" $+        thApproxToJSONDefault `sameAs` thApproxToEncodingDefault+      , testProperty "SomeType2ElemArray" $+        thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray+      , testProperty "SomeTypeTaggedObject" $+        thSomeTypeToJSONTaggedObject `sameAs` thSomeTypeToEncodingTaggedObject+      , testProperty "SomeTypeObjectWithSingleField" $+        thSomeTypeToJSONObjectWithSingleField `sameAs`+        thSomeTypeToEncodingObjectWithSingleField+      ]+    ]+  ]

@@ -1,4 +1,8 @@-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}  module DataFamilies.Types where @@ -23,3 +27,10 @@  instance (ApproxEq a) => Eq (Approx a) where     Approx a == Approx b = a =~ b++data family GADT a+data instance GADT a where+    GADT :: { gadt :: String } -> GADT String++deriving instance Eq   (GADT a)+deriving instance Show (GADT a)

@@ -1,4 +1,5 @@-{-# Language TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}  module Encoders where @@ -173,3 +174,26 @@  gApproxParseJSONDefault :: Value -> Parser (Approx String) gApproxParseJSONDefault = genericParseJSON defaultOptions++--------------------------------------------------------------------------------+-- GADT encoders/decoders+--------------------------------------------------------------------------------++thGADTToJSONUnwrap :: GADT String -> Value+thGADTToJSONUnwrap = $(mkToJSON optsUnwrapUnaryRecords ''GADT)++thGADTToEncodingUnwrap :: GADT String -> Encoding+thGADTToEncodingUnwrap = $(mkToEncoding optsUnwrapUnaryRecords ''GADT)++thGADTParseJSONUnwrap :: Value -> Parser (GADT String)+thGADTParseJSONUnwrap = $(mkParseJSON optsUnwrapUnaryRecords ''GADT)+++thGADTToJSONDefault :: GADT String -> Value+thGADTToJSONDefault = $(mkToJSON defaultOptions ''GADT)++thGADTToEncodingDefault :: GADT String -> Encoding+thGADTToEncodingDefault = $(mkToEncoding defaultOptions ''GADT)++thGADTParseJSONDefault :: Value -> Parser (GADT String)+thGADTParseJSONDefault = $(mkParseJSON defaultOptions ''GADT)

@@ -1,4 +1,8 @@-{-# Language OverloadedStrings, RecordWildCards, StandaloneDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Instances where@@ -6,55 +10,27 @@ import Types import Data.Function (on) import Control.Monad-import Test.QuickCheck (Arbitrary(..), Gen, choose, oneof, elements)-import Data.Time.Clock (DiffTime, UTCTime(..), picosecondsToDiffTime)-import Data.Fixed (Pico)-import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..),-                  hoursToTimeZone, Day(..), TimeOfDay(..),-                  NominalDiffTime)-import qualified Data.Text as T-import qualified Data.Map as Map-import Data.Text (Text)+import Test.QuickCheck (Arbitrary(..), getNonNegative, elements,+                        listOf1, oneof, resize)+import Data.Time.Clock (UTCTime(..))+import Data.Time (ZonedTime(..), TimeZone(..))+import Data.Version import Data.Aeson.Types import Control.Applicative import Functions --- "System" types.--instance Arbitrary Text where-    arbitrary = T.pack <$> arbitrary--instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where-    arbitrary = Map.fromList <$> arbitrary--instance Arbitrary LocalTime where-    arbitrary = return $ LocalTime (ModifiedJulianDay 1) (TimeOfDay 1 2 3)--instance Arbitrary TimeZone where-    arbitrary = do-      offset <- choose (0,2) :: Gen Int-      return $ hoursToTimeZone offset--instance Arbitrary Day where-    arbitrary = ModifiedJulianDay `liftM` arbitrary--instance Arbitrary DiffTime where-    arbitrary = (picosecondsToDiffTime . (* 1000000000)) <$>-                choose (0, 86400000)+import Test.QuickCheck.Instances () -instance Arbitrary UTCTime where-    arbitrary = liftM2 UTCTime arbitrary arbitrary+-- "System" types.  instance Arbitrary DotNetTime where     arbitrary = DotNetTime `liftM` arbitrary--instance Arbitrary ZonedTime where-    arbitrary = liftM2 ZonedTime arbitrary arbitrary--instance Arbitrary NominalDiffTime where-    arbitrary = realToFrac <$> (arbitrary :: Gen Pico)+    shrink = map DotNetTime . shrink . fromDotNetTime -deriving instance Eq ZonedTime+-- | Compare timezone part only on 'timeZoneMinutes'+instance Eq ZonedTime where+  ZonedTime a (TimeZone a' _ _) == ZonedTime b (TimeZone b' _ _) =+    a == b && a' == b'  -- Compare equality to within a millisecond, allowing for rounding -- error (ECMA 262 requires milliseconds to rounded to zero, not@@ -148,8 +124,24 @@                       , Record  <$> arbitrary <*> arbitrary <*> arbitrary                       ] +instance Arbitrary (GADT String) where+    arbitrary = GADT <$> arbitrary+ instance ApproxEq Char where     (=~) = (==)  instance (ApproxEq a) => ApproxEq [a] where     a =~ b = length a == length b && all (uncurry (=~)) (zip a b)++instance Arbitrary Version where+    arbitrary = makeVersion . fmap getNonNegative <$> resize 4 (listOf1 arbitrary)++-- Version tags are deprecated, so we avoid using them in the Arbitrary+-- instance. However, the recommended constructor 'makeVersion' is not+-- exported by "Data.Version" until base-4.8.0.0. For previous versions,+-- a definition is given below.++#if !MIN_VERSION_base(4,8,0)+makeVersion :: [Int] -> Version+makeVersion b = Version b []+#endif

@@ -9,12 +9,14 @@ import Data.Aeson.Types import Data.ByteString.Builder (toLazyByteString) import Data.Int (Int8)-import Data.Time (Day, LocalTime, NominalDiffTime, UTCTime, ZonedTime)+import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime,+                  ZonedTime)+import Data.Version (Version) import Encoders import Instances () import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck (Arbitrary(..), Property, (===))+import Test.QuickCheck (Arbitrary(..), Property, (===), (.&&.), counterexample) import Types import qualified Data.Attoparsec.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L@@ -39,17 +41,32 @@       IError path msg -> failure "parse" (formatError path msg) x       ISuccess x'     -> x === x' -roundTrip :: (FromJSON a, ToJSON a, Show a) =>+roundTripEnc :: (FromJSON a, ToJSON a, Show a) =>              (a -> a -> Property) -> a -> a -> Property-roundTrip eq _ i =-    case fmap ifromJSON . L.parse value . encode . toJSON $ i of+roundTripEnc eq _ i =+    case fmap ifromJSON . L.parse value . encode $ i of       L.Done _ (ISuccess v)      -> v `eq` i       L.Done _ (IError path err) -> failure "fromJSON" (formatError path err) i       L.Fail _ _ err             -> failure "parse" err i +roundTripNoEnc :: (FromJSON a, ToJSON a, Show a) =>+             (a -> a -> Property) -> a -> a -> Property+roundTripNoEnc eq _ i =+    case ifromJSON . toJSON $ i of+      (ISuccess v)      -> v `eq` i+      (IError path err) -> failure "fromJSON" (formatError path err) i+ roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property-roundTripEq x y = roundTrip (===) x y+roundTripEq x y = roundTripEnc (===) x y .&&. roundTripNoEnc (===) x y +infix 4 ==~+(==~) :: (ApproxEq a, Show a) => a -> a -> Property+x ==~ y =+  counterexample (show x ++ " /= " ++ show y) (x =~ y)++roundTripApproxEq :: (ApproxEq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property+roundTripApproxEq x y = roundTripEnc (==~) x y .&&. roundTripNoEnc (==~) x y+ toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a, Show a) => a -> Property toFromJSON x = case ifromJSON (toJSON x) of                 IError path err -> failure "fromJSON" (formatError path err) x@@ -63,16 +80,11 @@     result :: Result ()     result = parse parser () --- | Perform a bit-for-bit comparison of two encoding methods.+-- | Perform a structural comparison of the results of two encoding+-- methods. Compares decoded values to account for HashMap-driven+-- variation in JSON object key ordering. sameAs :: (a -> Value) -> (a -> Encoding) -> a -> Property sameAs toVal toEnc v =-  toLazyByteString (encodeToBuilder (toVal v)) ===-  toLazyByteString (fromEncoding (toEnc v))---- | Behaves like 'sameAs', but compares decoded values to account for--- HashMap-driven variation in JSON object key ordering.-sameAsV :: (a -> Value) -> (a -> Encoding) -> a -> Property-sameAsV toVal toEnc v =   eitherDecode (toLazyByteString (fromEncoding (toEnc v))) === Right (toVal v)  type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()@@ -120,11 +132,13 @@     , testProperty "Text" $ roundTripEq T.empty     , testProperty "Foo" $ roundTripEq (undefined :: Foo)     , testProperty "Day" $ roundTripEq (undefined :: Day)-    , testProperty "DotNetTime" $ roundTripEq (undefined :: DotNetTime)+    , testProperty "DotNetTime" $ roundTripApproxEq (undefined :: DotNetTime)     , testProperty "LocalTime" $ roundTripEq (undefined :: LocalTime)+    , testProperty "TimeOfDay" $ roundTripEq (undefined :: TimeOfDay)     , testProperty "UTCTime" $ roundTripEq (undefined :: UTCTime)     , testProperty "ZonedTime" $ roundTripEq (undefined :: ZonedTime)     , testProperty "NominalDiffTime" $ roundTripEq (undefined :: NominalDiffTime)+    , testProperty "Version" $ roundTripEq (undefined :: Version)     , testGroup "ghcGenerics" [         testProperty "OneConstructor" $ roundTripEq OneConstructor       , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)@@ -174,6 +188,14 @@               , 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 "toEncoding" [@@ -191,11 +213,11 @@       , testProperty "ApproxDefault" $         thApproxToJSONDefault `sameAs` thApproxToEncodingDefault       , testProperty "SomeType2ElemArray" $-        thSomeTypeToJSON2ElemArray `sameAsV` thSomeTypeToEncoding2ElemArray+        thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray       , testProperty "SomeTypeTaggedObject" $-        thSomeTypeToJSONTaggedObject `sameAsV` thSomeTypeToEncodingTaggedObject+        thSomeTypeToJSONTaggedObject `sameAs` thSomeTypeToEncodingTaggedObject       , testProperty "SomeTypeObjectWithSingleField" $-        thSomeTypeToJSONObjectWithSingleField `sameAsV`+        thSomeTypeToJSONObjectWithSingleField `sameAs`         thSomeTypeToEncodingObjectWithSingleField       ]     ]

@@ -1,5 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}  module Types where @@ -53,6 +57,14 @@                          , testTwo   :: Maybe Bool                          , testThree :: Maybe a                          } deriving (Eq, Show)++data GADT a where+    GADT :: { gadt :: String } -> GADT String+  deriving Typeable++deriving instance Data (GADT String)+deriving instance Eq   (GADT a)+deriving instance Show (GADT a)  deriving instance Generic Foo deriving instance Generic UFoo

@@ -1,14 +1,20 @@-{-# LANGUAGE CPP, DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE CPP, DeriveGeneric, OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-}+ module UnitTests (ioTests, tests) where  import Control.Monad (forM)-import Data.Aeson (decode, eitherDecode, encode, genericToJSON, genericToEncoding)+import Data.Aeson (decode, eitherDecode, encode, genericToJSON, genericToEncoding, FromJSON(..), withObject, (.:), (.:?), (.:!)) import Data.Aeson.Encode (encodeToTextBuilder)-import Data.Aeson.Types (ToJSON(..), Value, camelTo, camelTo2, defaultOptions)+import Data.Aeson.Internal (JSONPathElement(..), formatError)+import Data.Aeson.TH (deriveJSON)+import Data.Aeson.Types (ToJSON(..), Value, camelTo, camelTo2, defaultOptions, omitNothingFields) import Data.Char (toUpper)+import Data.Maybe (fromMaybe) import Data.Time (UTCTime) import Data.Time.Format (parseTime)+import Data.Sequence (Seq) import GHC.Generics (Generic) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase)@@ -46,6 +52,14 @@       testCase "good" $ utcTimeGood     , testCase "bad"  $ utcTimeBad     ]+  , testGroup "formatError" [+      testCase "example 1" $ formatErrorExample+    ]+  , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark+  , testGroup "To JSON representation" $ fmap (testCase "-") jsonEncoding+  , testGroup "From JSON representation" $ fmap (testCase "-") jsonDecoding+  , testGroup "JSONPath" $ fmap (testCase "-") jsonPath+  , testGroup "Issue #351" $ fmap (testCase "-") issue351   ]  roundTripCamel :: String -> Assertion@@ -58,7 +72,7 @@ camelFrom c s = let (p:ps) = split c s                 in concat $ p : map capitalize ps   where-    split c s = map L.unpack $ L.split c $ L.pack s+    split c' s' = map L.unpack $ L.split c' $ L.pack s'     capitalize t = toUpper (head t) : tail t  data Wibble = Wibble {@@ -77,9 +91,12 @@                            '{' (L.head (encode wibble))   where     wibble = Wibble {-                 wibbleString = replicate 4030 'a'-               , wibbleInt = undefined+                 wibbleString = replicate k 'a'+               , wibbleInt = 1                }+    k | arch32bit = 4047+      | otherwise = 4030+    arch32bit     = (maxBound :: Int) == 2147483647  -- Test decoding various UTC time formats --@@ -120,6 +137,18 @@   -- ts8 wraps around to the next day in UTC   assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T01:00:00Z") t8   assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T02:30:00Z") t9++  -- Seconds in Time can be omitted+  let ts10 = "2015-01-03T12:13Z" :: LT.Text+  let ts11 = "2015-01-03 12:13Z" :: LT.Text+  let ts12 = "2015-01-01T12:30-02" :: LT.Text+  let (Just (t10 ::  UTCTime)) = parseWithAeson ts10+  let (Just (t11 ::  UTCTime)) = parseWithAeson ts11+  let (Just (t12 ::  UTCTime)) = parseWithAeson ts12+  assertEqual "utctime" (parseWithRead "%FT%H:%MZ" ts10) t10+  assertEqual "utctime" (parseWithRead "%F %H:%MZ" ts11) t11+  assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t12+   where     parseWithRead :: String -> LT.Text -> UTCTime     parseWithRead f s =@@ -140,13 +169,103 @@   verifyFailParse "2015-01-01T12:30:00.00+00Z" -- no Zulu if offset given   verifyFailParse "2015-01-01T12:30:00.00+00:00Z" -- no Zulu if offset given   verifyFailParse "2015-01-03 12:13:00.Z" -- decimal at the end but no digits+  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       assertEqual "verify failure" Nothing dec +-- Non identifier keys should be escaped & enclosed in brackets+formatErrorExample :: Assertion+formatErrorExample =+  let rhs = formatError [Index 0, Key "foo", Key "bar", Key "a.b.c", Key "", Key "'\\", Key "end"] "error msg"+      lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg"+  in assertEqual "formatError example" lhs rhs  ------------------------------------------------------------------------------+-- Comparison (.:?) and (.:!)+------------------------------------------------------------------------------++newtype T1 = T1 (Maybe Int) deriving (Eq, Show)+newtype T2 = T2 (Maybe Int) deriving (Eq, Show)+newtype T3 = T3 (Maybe Int) deriving (Eq, Show)++instance FromJSON T1 where parseJSON = fmap T1 . withObject "T1" (.: "value")+instance FromJSON T2 where parseJSON = fmap T2 . withObject "T2" (.:? "value")+instance FromJSON T3 where parseJSON = fmap T3 . withObject "T3" (.:! "value")++dotColonMark :: [Assertion]+dotColonMark = [+    assertEqual ".:  not-present" Nothing               (decode ex1 :: Maybe T1)+  , 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 ".:? 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 ".:! 42"          (Just (T3 (Just 42))) (decode ex2 :: Maybe T3)+  , assertEqual ".:! null"        Nothing               (decode ex3 :: Maybe T3)+  ]+  where ex1 = "{}"+        ex2 = "{\"value\": 42 }"+        ex3 = "{\"value\": null }"++------------------------------------------------------------------------------+-- These tests assert that the JSON serialization doesn't change by accident.+-----------------------------------------------------------------------------++jsonEncoding :: [Assertion]+jsonEncoding = [+    assertEqual "Either Left" "{\"Left\":1}" $ encode (Left 1 :: Either Int Int)+  , assertEqual "Either Right" "{\"Right\":1}" $ encode (Right 1 :: Either Int Int)+  , assertEqual "Nothing"  "null" $ encode (Nothing :: Maybe Int)+  , assertEqual "Just"  "1" $ encode (Just 1 :: Maybe Int)+  , assertEqual "Just Nothing" "null" $ encode (Just Nothing :: Maybe (Maybe Int))+  , assertEqual "Tuple" "[1,2]" $ encode ((1, 2) :: (Int, Int))+  ]++jsonDecoding :: [Assertion]+jsonDecoding = [+    assertEqual "Nothing" (Nothing :: Maybe Int) (decode "null")+  , assertEqual "Just"    (Just 1 :: Maybe Int) (decode "1")+  , assertEqual "Just Nothing" (Just Nothing :: Maybe (Maybe Int)) (decode "null")+  ]++------------------------------------------------------------------------------+-- These tests check that JSONPath is tracked correctly+-----------------------------------------------------------------------------++jsonPath :: [Assertion]+jsonPath = [+    -- issue #356+    assertEqual "Either"+      (Left "Error in $[1].Left[1]: expected Bool, encountered Number")+      (eitherDecode "[1,{\"Left\":[2,3]}]"+         :: Either String (Int, Either (Int, Bool) ()))+    -- issue #358+  , assertEqual "Seq a"+      (Left "Error in $[2]: expected Int, encountered Boolean")+      (eitherDecode "[0,1,true]" :: Either String (Seq Int))+  ]++------------------------------------------------------------------------------+-- Regressions+------------------------------------------------------------------------------++-- A regression test for: https://github.com/bos/aeson/issues/351+overlappingRegression :: FromJSON a => L.ByteString -> [a]+overlappingRegression bs = fromMaybe [] $ decode bs++issue351 :: [Assertion]+issue351 = [+    assertEqual "Int"  ([1, 2, 3] :: [Int])  $ overlappingRegression "[1, 2, 3]"+  , assertEqual "Char" (""        :: String) $ overlappingRegression "\"abc\""+  , assertEqual "Char" ("abc"     :: String) $ overlappingRegression "[\"a\", \"b\", \"c\"]"+  ]++------------------------------------------------------------------------------ -- Comparison between bytestring and text encoders ------------------------------------------------------------------------------ @@ -184,3 +303,13 @@     , "twitter100.json"     , "twitter50.json"     ]++-- A regression test for: https://github.com/bos/aeson/issues/293+data MyRecord = MyRecord {_field1 :: Maybe Int, _field2 :: Maybe Bool}+deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord++data MyRecord2 = MyRecord2 {_field3 :: Maybe Int, _field4 :: Maybe Bool}+  deriving Generic++instance ToJSON   MyRecord2+instance FromJSON MyRecord2