diff --git a/Data/Aeson.hs b/Data/Aeson.hs --- a/Data/Aeson.hs +++ b/Data/Aeson.hs @@ -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 -- 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 diff --git a/Data/Aeson/Encode.hs b/Data/Aeson/Encode.hs --- a/Data/Aeson/Encode.hs +++ b/Data/Aeson/Encode.hs @@ -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 -- Stability: experimental -- Portability: portable diff --git a/Data/Aeson/Encode/Builder.hs b/Data/Aeson/Encode/Builder.hs --- a/Data/Aeson/Encode/Builder.hs +++ b/Data/Aeson/Encode/Builder.hs @@ -4,7 +4,7 @@ -- Module: Data.Aeson.Encode.Builder -- Copyright: (c) 2011 MailRank, Inc. -- (c) 2013 Simon Meier --- License: Apache +-- License: BSD3 -- Maintainer: Bryan O'Sullivan -- 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 diff --git a/Data/Aeson/Encode/Functions.hs b/Data/Aeson/Encode/Functions.hs --- a/Data/Aeson/Encode/Functions.hs +++ b/Data/Aeson/Encode/Functions.hs @@ -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 diff --git a/Data/Aeson/Functions.hs b/Data/Aeson/Functions.hs --- a/Data/Aeson/Functions.hs +++ b/Data/Aeson/Functions.hs @@ -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 -- Stability: experimental -- Portability: portable diff --git a/Data/Aeson/Internal.hs b/Data/Aeson/Internal.hs --- a/Data/Aeson/Internal.hs +++ b/Data/Aeson/Internal.hs @@ -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 -- Stability: experimental -- Portability: portable @@ -14,8 +14,9 @@ module Data.Aeson.Internal ( IResult(..) - , JSONPathElement + , JSONPathElement(..) , JSONPath + , () , formatError , ifromJSON , iparse diff --git a/Data/Aeson/Internal/Time.hs b/Data/Aeson/Internal/Time.hs --- a/Data/Aeson/Internal/Time.hs +++ b/Data/Aeson/Internal/Time.hs @@ -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 -- Stability: experimental -- Portability: portable diff --git a/Data/Aeson/Parser.hs b/Data/Aeson/Parser.hs --- a/Data/Aeson/Parser.hs +++ b/Data/Aeson/Parser.hs @@ -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 -- Stability: experimental -- Portability: portable diff --git a/Data/Aeson/Parser/Internal.hs b/Data/Aeson/Parser/Internal.hs --- a/Data/Aeson/Parser/Internal.hs +++ b/Data/Aeson/Parser/Internal.hs @@ -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 -- 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#) diff --git a/Data/Aeson/Parser/Time.hs b/Data/Aeson/Parser/Time.hs --- a/Data/Aeson/Parser/Time.hs +++ b/Data/Aeson/Parser/Time.hs @@ -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 -- 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 diff --git a/Data/Aeson/TH.hs b/Data/Aeson/TH.hs --- a/Data/Aeson/TH.hs +++ b/Data/Aeson/TH.hs @@ -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 diff --git a/Data/Aeson/Types.hs b/Data/Aeson/Types.hs --- a/Data/Aeson/Types.hs +++ b/Data/Aeson/Types.hs @@ -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 -- Stability: experimental -- Portability: portable @@ -39,6 +39,7 @@ -- ** Generic JSON classes , GFromJSON(..) , GToJSON(..) + , GToEncoding(..) , genericToJSON , genericToEncoding , genericParseJSON @@ -55,6 +56,7 @@ , foldable , (.:) , (.:?) + , (.:!) , (.!=) , object diff --git a/Data/Aeson/Types/Class.hs b/Data/Aeson/Types/Class.hs --- a/Data/Aeson/Types/Class.hs +++ b/Data/Aeson/Types/Class.hs @@ -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 -- 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 diff --git a/Data/Aeson/Types/Generic.hs b/Data/Aeson/Types/Generic.hs --- a/Data/Aeson/Types/Generic.hs +++ b/Data/Aeson/Types/Generic.hs @@ -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 -- 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 diff --git a/Data/Aeson/Types/Instances.hs b/Data/Aeson/Types/Instances.hs --- a/Data/Aeson/Types/Instances.hs +++ b/Data/Aeson/Types/Instances.hs @@ -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 -- 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: -- diff --git a/Data/Aeson/Types/Internal.hs b/Data/Aeson/Types/Internal.hs --- a/Data/Aeson/Types/Internal.hs +++ b/Data/Aeson/Types/Internal.hs @@ -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 -- 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 -- @@ -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 diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -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. diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -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 maintainer: Bryan O'Sullivan 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 diff --git a/benchmarks/aeson-benchmarks.cabal b/benchmarks/aeson-benchmarks.cabal --- a/benchmarks/aeson-benchmarks.cabal +++ b/benchmarks/aeson-benchmarks.cabal @@ -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 diff --git a/benchmarks/json-data/sigma.json b/benchmarks/json-data/sigma.json deleted file mode 100644 # file too large to diff: benchmarks/json-data/sigma.json diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h new file mode 100644 --- /dev/null +++ b/include/overlapping-compat.h @@ -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 diff --git a/tests/DataFamilies/Encoders.hs b/tests/DataFamilies/Encoders.hs --- a/tests/DataFamilies/Encoders.hs +++ b/tests/DataFamilies/Encoders.hs @@ -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) diff --git a/tests/DataFamilies/Instances.hs b/tests/DataFamilies/Instances.hs new file mode 100644 --- /dev/null +++ b/tests/DataFamilies/Instances.hs @@ -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) diff --git a/tests/DataFamilies/Properties.hs b/tests/DataFamilies/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/DataFamilies/Properties.hs @@ -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 + ] + ] + ] diff --git a/tests/DataFamilies/Types.hs b/tests/DataFamilies/Types.hs --- a/tests/DataFamilies/Types.hs +++ b/tests/DataFamilies/Types.hs @@ -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) diff --git a/tests/Encoders.hs b/tests/Encoders.hs --- a/tests/Encoders.hs +++ b/tests/Encoders.hs @@ -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) diff --git a/tests/Instances.hs b/tests/Instances.hs --- a/tests/Instances.hs +++ b/tests/Instances.hs @@ -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 diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -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 ] ] diff --git a/tests/Types.hs b/tests/Types.hs --- a/tests/Types.hs +++ b/tests/Types.hs @@ -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 diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -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