@@ -4,8 +4,14 @@
44 ScopedTypeVariables, PatternGuards #-}
55
66{-# LANGUAGE CPP #-}
7−#ifdef DEFAULT_SIGNATURES
8−{-# LANGUAGE DefaultSignatures #-}
7+#ifdef GENERICS
8+{-# LANGUAGE DefaultSignatures
9+ , TypeOperators
10+ , EmptyDataDecls
11+ , KindSignatures
12+ , MultiParamTypeClasses
13+ , FunctionalDependencies
14+ #-}
915#endif
1016
1117-- |
@@ -23,7 +29,7 @@ module Data.Aeson.Types.Internal
2329 -- * Core JSON types
2430 Value(..)
2531 , Array
26− , emptyArray
32+ , emptyArray, isEmptyArray
2733 , Pair
2834 , Object
2935 , emptyObject
@@ -44,33 +50,28 @@ module Data.Aeson.Types.Internal
4450 , (.:)
4551 , (.:?)
4652 , object
47− -- * Generic toJSON and fromJSON
48− , genericToJSON
49− , genericFromJSON
5053 ) where
5154
5255import Control.Applicative
53−import Control.Arrow (first)
54−import Control.Monad.State.Strict
5556import Control.DeepSeq (NFData(..))
57+import Control.Monad.State.Strict
5658import Data.Aeson.Functions
5759import Data.Attoparsec.Char8 (Number(..))
58−import Data.Generics
60+import Data.Data (Data)
5961import Data.Hashable (Hashable(..))
6062import Data.Int (Int8, Int16, Int32, Int64)
61−import Data.IntSet (IntSet)
6263import Data.List (foldl')
6364import Data.Map (Map)
64−import Data.Maybe (fromJust)
6565import Data.Monoid (Dual(..), First(..), Last(..))
6666import Data.Monoid (Monoid(..))
6767import Data.Ratio (Ratio)
6868import Data.String (IsString(..))
69−import Data.Text (Text, pack, unpack)
7069import Data.Text.Encoding (encodeUtf8)
70+import Data.Text (Text, pack, unpack)
7171import Data.Time.Clock (UTCTime)
7272import Data.Time.Format (FormatTime, formatTime, parseTime)
73−import Data.Vector (Vector)
73+import Data.Typeable (Typeable)
74+import Data.Vector (Vector, (!?))
7475import Data.Word (Word, Word8, Word16, Word32, Word64)
7576import Foreign.Storable (Storable)
7677import System.Locale (defaultTimeLocale)
@@ -84,13 +85,15 @@ import qualified Data.Map as M
8485import qualified Data.Set as Set
8586import qualified Data.Text as T
8687import qualified Data.Text.Lazy as LT
87−import qualified Data.Traversable as T
8888import qualified Data.Vector as V
8989import qualified Data.Vector.Storable as VS
9090import qualified Data.Vector.Primitive as VP
9191import qualified Data.Vector.Unboxed as VU
9292import qualified Data.Vector.Generic as VG
9393
94+#ifdef GENERICS
95+import GHC.Generics
96+#endif
9497
9598-- | The result of running a 'Parser'.
9699data Result a = Error String
@@ -170,7 +173,7 @@ instance Applicative Parser where
170173 {-# INLINE pure #-}
171174 (<*>) = apP
172175 {-# INLINE (<*>) #-}
173−
176+
174177instance Alternative Parser where
175178 empty = fail "empty"
176179 {-# INLINE empty #-}
@@ -236,6 +239,12 @@ instance Hashable Value where
236239emptyArray :: Value
237240emptyArray = Array V.empty
238241
242+-- | Determines if the 'Value' is an empty 'Array'.
243+-- Note that: @isEmptyArray 'emptyArray'@.
244+isEmptyArray :: Value -> Bool
245+isEmptyArray (Array arr) = V.null arr
246+isEmptyArray _ = False
247+
239248-- | The empty object.
240249emptyObject :: Value
241250emptyObject = Object M.empty
@@ -312,23 +321,43 @@ object = Object . M.fromList
312321-- toJSON (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y]
313322-- @
314323--
315−-- We use the @OverloadedStrings@ language extension so that we can
316−-- write 'Text' values as normal double-quoted strings.
324+-- Note the use of the @OverloadedStrings@ language extension which enables
325+-- 'Text' values to be written as string literals.
326+--
327+-- Instead of manually writing your 'ToJSON' instance, there are three options
328+-- to do it automatically:
329+--
330+-- * 'Data.Aeson.TH' provides template-haskell functions which will derive an
331+-- instance at compile-time. The generated instance is optimized for your type
332+-- so will probably be more efficient than the following two options:
333+--
334+-- * 'Data.Aeson.Generic' provides a generic @toJSON@ function that accepts any
335+-- type which is an instance of 'Data'.
336+--
337+-- * If your compiler has support for the @DeriveGeneric@ and
338+-- @DefaultSignatures@ language extensions, @toJSON@ will have a default generic
339+-- implementation.
340+--
341+-- To use the latter option, simply add a @deriving 'Generic'@ clause to your
342+-- datatype and declare a @ToJSON@ instance for your datatype without giving a
343+-- definition for @toJSON@.
344+--
345+-- For example the previous example can be simplified to just:
346+--
347+-- @{-\# LANGUAGE DeriveGeneric \#-}
317348--
318−-- If you do not want to write your own 'ToJSON' instances, you have
319−-- two options:
349+-- import GHC.Generics
320350--
321−-- * The 'Data.Aeson.TH' module will automatically derive an instance
322−-- for you with a single line of code.
351+-- data Coord { x :: Double, y :: Double } deriving Generic
323352--
324−-- * The 'Data.Aeson.Generic' module will work with most data types
325−-- that are instances of 'Data' (but note, this can be slow).
353+-- instance ToJSON Coord
354+-- @
326355class ToJSON a where
327356 toJSON :: a -> Value
328357
329−#ifdef DEFAULT_SIGNATURES
330− default toJSON :: Data a => a -> Value
331− toJSON = genericToJSON
358+#ifdef GENERICS
359+ default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value
360+ toJSON = gToJSON . from
332361#endif
333362
334363-- | A type that can be converted from JSON, with the possibility of
@@ -345,38 +374,58 @@ class ToJSON a where
345374-- data Coord { x :: Double, y :: Double }
346375--
347376-- instance FromJSON Coord where
348−-- parseJSON ('Object' v) = Coord '<$>'
349−-- v '.:' \"x\" '<*>'
350−-- v '.:' \"y\"
377+-- parseJSON ('Object' v) = Coord '<$>'
378+-- v '.:' \"x\" '<*>'
379+-- v '.:' \"y\"
351380--
352381-- \-- A non-'Object' value is of the wrong type, so use 'mzero' to fail.
353382-- parseJSON _ = 'mzero'
354383-- @
355384--
356−-- We use the @OverloadedStrings@ language extension so that we can
357−-- write 'Text' values as normal double-quoted strings.
385+-- Note the use of the @OverloadedStrings@ language extension which enables
386+-- 'Text' values to be written as string literals.
387+--
388+-- Instead of manually writing your 'FromJSON' instance, there are three options
389+-- to do it automatically:
390+--
391+-- * 'Data.Aeson.TH' provides template-haskell functions which will derive an
392+-- instance at compile-time. The generated instance is optimized for your type
393+-- so will probably be more efficient than the following two options:
394+--
395+-- * 'Data.Aeson.Generic' provides a generic @fromJSON@ function that parses to
396+-- any type which is an instance of 'Data'.
397+--
398+-- * If your compiler has support for the @DeriveGeneric@ and
399+-- @DefaultSignatures@ language extensions, @parseJSON@ will have a default
400+-- generic implementation.
401+--
402+-- To use this, simply add a @deriving 'Generic'@ clause to your datatype and
403+-- declare a @FromJSON@ instance for your datatype without giving a definition
404+-- for @parseJSON@.
405+--
406+-- For example the previous example can be simplified to just:
358407--
359−-- If you do not want to write your own 'FromJSON' instances, you have
360−-- two options:
408+-- @{-\# LANGUAGE DeriveGeneric \#-}
361409--
362−-- * The 'Data.Aeson.TH' module will automatically derive an instance
363−-- for you with a single line of code.
410+-- import GHC.Generics
364411--
365−-- * The 'Data.Aeson.Generic' module will work with most data types
366−-- that are instances of 'Data' (but note, this can be slow).
412+-- data Coord { x :: Double, y :: Double } deriving Generic
413+--
414+-- instance FromJSON Coord
415+-- @
367416class FromJSON a where
368417 parseJSON :: Value -> Parser a
369418
370−#ifdef DEFAULT_SIGNATURES
371− default parseJSON :: Data a => Value -> Parser a
372− parseJSON = genericParseJSON
419+#ifdef GENERICS
420+ default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
421+ parseJSON = fmap to . gParseJSON
373422#endif
374423
375424instance (ToJSON a) => ToJSON (Maybe a) where
376425 toJSON (Just a) = toJSON a
377426 toJSON Nothing = Null
378427 {-# INLINE toJSON #-}
379−
428+
380429instance (FromJSON a) => FromJSON (Maybe a) where
381430 parseJSON Null = pure Nothing
382431 parseJSON a = Just <$> parseJSON a
@@ -386,7 +435,7 @@ instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
386435 toJSON (Left a) = object [left .= a]
387436 toJSON (Right b) = object [right .= b]
388437 {-# INLINE toJSON #-}
389−
438+
390439instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
391440 parseJSON (Object (M.toList -> [(key, value)]))
392441 | key == left = Left <$> parseJSON value
@@ -612,7 +661,7 @@ instance FromJSON LB.ByteString where
612661instance (ToJSON a) => ToJSON [a] where
613662 toJSON = Array . V.fromList . map toJSON
614663 {-# INLINE toJSON #-}
615−
664+
616665instance (FromJSON a) => FromJSON [a] where
617666 parseJSON (Array a) = mapM parseJSON (V.toList a)
618667 parseJSON v = typeMismatch "[a]" v
@@ -621,7 +670,7 @@ instance (FromJSON a) => FromJSON [a] where
621670instance (ToJSON a) => ToJSON (Vector a) where
622671 toJSON = Array . V.map toJSON
623672 {-# INLINE toJSON #-}
624−
673+
625674instance (FromJSON a) => FromJSON (Vector a) where
626675 parseJSON (Array a) = V.mapM parseJSON a
627676 parseJSON v = typeMismatch "Vector a" v
@@ -657,7 +706,7 @@ instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
657706instance (ToJSON a) => ToJSON (Set.Set a) where
658707 toJSON = toJSON . Set.toList
659708 {-# INLINE toJSON #-}
660−
709+
661710instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
662711 parseJSON = fmap Set.fromList . parseJSON
663712 {-# INLINE parseJSON #-}
@@ -665,7 +714,7 @@ instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
665714instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
666715 toJSON = toJSON . HashSet.toList
667716 {-# INLINE toJSON #-}
668−
717+
669718instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
670719 parseJSON = fmap HashSet.fromList . parseJSON
671720 {-# INLINE parseJSON #-}
@@ -673,7 +722,7 @@ instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
673722instance ToJSON IntSet.IntSet where
674723 toJSON = toJSON . IntSet.toList
675724 {-# INLINE toJSON #-}
676−
725+
677726instance FromJSON IntSet.IntSet where
678727 parseJSON = fmap IntSet.fromList . parseJSON
679728 {-# INLINE parseJSON #-}
@@ -681,7 +730,7 @@ instance FromJSON IntSet.IntSet where
681730instance ToJSON a => ToJSON (IntMap.IntMap a) where
682731 toJSON = toJSON . IntMap.toList
683732 {-# INLINE toJSON #-}
684−
733+
685734instance FromJSON a => FromJSON (IntMap.IntMap a) where
686735 parseJSON = fmap IntMap.fromList . parseJSON
687736 {-# INLINE parseJSON #-}
@@ -867,293 +916,230 @@ typeMismatch expected actual =
867916 Bool _ -> "Boolean"
868917 Null -> "Null"
869918
919+#ifdef GENERICS
920+--------------------------------------------------------------------------------
921+-- Generic toJSON
922+
923+class GToJSON f where
924+ gToJSON :: f a -> Value
925+
926+instance (GToJSON a) => GToJSON (M1 i c a) where
927+ gToJSON = gToJSON . unM1
928+ {-# INLINE gToJSON #-}
929+
930+instance (ToJSON a) => GToJSON (K1 i a) where
931+ gToJSON = toJSON . unK1
932+ {-# INLINE gToJSON #-}
933+
934+instance GToJSON U1 where
935+ gToJSON _ = emptyArray
936+ {-# INLINE gToJSON #-}
937+
938+instance (ConsToJSON a) => GToJSON (C1 c a) where
939+ gToJSON = consToJSON . unM1
940+ {-# INLINE gToJSON #-}
941+
942+instance (GProductToValues a, GProductToValues b) => GToJSON (a :*: b) where
943+ gToJSON = toJSON . toList . gProductToValues
944+ {-# INLINE gToJSON #-}
945+
946+instance (GObject a, GObject b) => GToJSON (a :+: b) where
947+ gToJSON (L1 x) = Object $ gObject x
948+ gToJSON (R1 x) = Object $ gObject x
949+ {-# INLINE gToJSON #-}
870950
871951--------------------------------------------------------------------------------
872−-- Generic toJSON and fromJSON
873−
874−type T a = a -> Value
875−
876−genericToJSON :: (Data a) => a -> Value
877−genericToJSON = toJSON_generic
878− `ext1Q` list
879− `ext1Q` vector
880− `ext1Q` set
881− `ext2Q'` mapAny
882− `ext2Q'` hashMapAny
883− -- Use the standard encoding for all base types.
884− `extQ` (toJSON :: T Integer)
885− `extQ` (toJSON :: T Int)
886− `extQ` (toJSON :: T Int8)
887− `extQ` (toJSON :: T Int16)
888− `extQ` (toJSON :: T Int32)
889− `extQ` (toJSON :: T Int64)
890− `extQ` (toJSON :: T Word)
891− `extQ` (toJSON :: T Word8)
892− `extQ` (toJSON :: T Word16)
893− `extQ` (toJSON :: T Word32)
894− `extQ` (toJSON :: T Word64)
895− `extQ` (toJSON :: T Double)
896− `extQ` (toJSON :: T Number)
897− `extQ` (toJSON :: T Float)
898− `extQ` (toJSON :: T Rational)
899− `extQ` (toJSON :: T Char)
900− `extQ` (toJSON :: T Text)
901− `extQ` (toJSON :: T LT.Text)
902− `extQ` (toJSON :: T String)
903− `extQ` (toJSON :: T B.ByteString)
904− `extQ` (toJSON :: T LB.ByteString)
905− `extQ` (toJSON :: T Value)
906− `extQ` (toJSON :: T DotNetTime)
907− `extQ` (toJSON :: T UTCTime)
908− `extQ` (toJSON :: T IntSet)
909− `extQ` (toJSON :: T Bool)
910− `extQ` (toJSON :: T ())
911− --`extQ` (T.toJSON :: T Ordering)
912− where
913− list xs = Array . V.fromList . map genericToJSON $ xs
914− vector v = Array . V.map genericToJSON $ v
915− set s = Array . V.fromList . map genericToJSON . Set.toList $ s
916−
917− mapAny m
918− | tyrep == typeOf T.empty = remap id
919− | tyrep == typeOf LT.empty = remap LT.toStrict
920− | tyrep == typeOf string = remap pack
921− | tyrep == typeOf B.empty = remap decode
922− | tyrep == typeOf LB.empty = remap strict
923− | otherwise = modError "genericToJSON" $
924− "cannot convert map keyed by type " ++ show tyrep
925− where tyrep = typeOf . head . M.keys $ m
926− remap f = Object . transformMap (f . fromJust . cast) genericToJSON $ m
927−
928− hashMapAny m
929− | tyrep == typeOf T.empty = remap id
930− | tyrep == typeOf LT.empty = remap LT.toStrict
931− | tyrep == typeOf string = remap pack
932− | tyrep == typeOf B.empty = remap decode
933− | tyrep == typeOf LB.empty = remap strict
934− | otherwise = modError "genericToJSON" $
935− "cannot convert map keyed by type " ++ show tyrep
936− where tyrep = typeOf . head . H.keys $ m
937− remap f = Object . hashMap (f . fromJust . cast) genericToJSON $ m
938−
939−
940−toJSON_generic :: (Data a) => a -> Value
941−toJSON_generic = generic
942− where
943− -- Generic encoding of an algebraic data type.
944− generic a =
945− case dataTypeRep (dataTypeOf a) of
946− -- No constructor, so it must be an error value. Code
947− -- it anyway as Null.
948− AlgRep [] -> Null
949− -- Elide a single constructor and just code the arguments.
950− AlgRep [c] -> encodeArgs c (gmapQ genericToJSON a)
951− -- For multiple constructors, make an object with a
952− -- field name that is the constructor (except lower
953− -- case) and the data is the arguments encoded.
954− AlgRep _ -> encodeConstr (toConstr a) (gmapQ genericToJSON a)
955− rep -> err (dataTypeOf a) rep
956− where
957− err dt r = modError "genericToJSON" $ "not AlgRep " ++
958− show r ++ "(" ++ show dt ++ ")"
959− -- Encode nullary constructor as a string.
960− -- Encode non-nullary constructors as an object with the constructor
961− -- name as the single field and the arguments as the value.
962− -- Use an array if the are no field names, but elide singleton arrays,
963− -- and use an object if there are field names.
964− encodeConstr c [] = String . constrString $ c
965− encodeConstr c as = object [(constrString c, encodeArgs c as)]
966−
967− constrString = pack . showConstr
968−
969− encodeArgs c = encodeArgs' (constrFields c)
970− encodeArgs' [] [j] = j
971− encodeArgs' [] js = Array . V.fromList $ js
972− encodeArgs' ns js = object $ zip (map mungeField ns) js
973−
974− -- Skip leading '_' in field name so we can use keywords
975− -- etc. as field names.
976− mungeField ('_':cs) = pack cs
977− mungeField cs = pack cs
978−
979−genericFromJSON :: (Data a) => Value -> Result a
980−genericFromJSON = parse genericParseJSON
981−
982−type F a = Parser a
983−
984−genericParseJSON :: (Data a) => Value -> Parser a
985−genericParseJSON j = parseJSON_generic j
986− `ext1R` list
987− `ext1R` vector
988− `ext2R'` mapAny
989− `ext2R'` hashMapAny
990− -- Use the standard encoding for all base types.
991− `extR` (value :: F Integer)
992− `extR` (value :: F Int)
993− `extR` (value :: F Int8)
994− `extR` (value :: F Int16)
995− `extR` (value :: F Int32)
996− `extR` (value :: F Int64)
997− `extR` (value :: F Word)
998− `extR` (value :: F Word8)
999− `extR` (value :: F Word16)
1000− `extR` (value :: F Word32)
1001− `extR` (value :: F Word64)
1002− `extR` (value :: F Double)
1003− `extR` (value :: F Number)
1004− `extR` (value :: F Float)
1005− `extR` (value :: F Rational)
1006− `extR` (value :: F Char)
1007− `extR` (value :: F Text)
1008− `extR` (value :: F LT.Text)
1009− `extR` (value :: F String)
1010− `extR` (value :: F B.ByteString)
1011− `extR` (value :: F LB.ByteString)
1012− `extR` (value :: F Value)
1013− `extR` (value :: F DotNetTime)
1014− `extR` (value :: F UTCTime)
1015− `extR` (value :: F IntSet)
1016− `extR` (value :: F Bool)
1017− `extR` (value :: F ())
1018− where
1019− value :: (FromJSON a) => Parser a
1020− value = parseJSON j
1021− list :: (Data a) => Parser [a]
1022− list = V.toList <$> genericParseJSON j
1023− vector :: (Data a) => Parser (V.Vector a)
1024− vector = case j of
1025− Array js -> V.mapM genericParseJSON js
1026− _ -> myFail
1027− mapAny :: forall e f. (Data e, Data f) => Parser (Map f e)
1028− mapAny
1029− | tyrep `elem` stringyTypes = res
1030− | otherwise = myFail
1031− where res = case j of
1032− Object js -> M.mapKeysMonotonic trans <$> T.mapM genericParseJSON js
1033− _ -> myFail
1034− trans
1035− | tyrep == typeOf T.empty = remap id
1036− | tyrep == typeOf LT.empty = remap LT.fromStrict
1037− | tyrep == typeOf string = remap T.unpack
1038− | tyrep == typeOf B.empty = remap encodeUtf8
1039− | tyrep == typeOf LB.empty = remap lazy
1040− | otherwise = modError "genericParseJSON"
1041− "mapAny -- should never happen"
1042− tyrep = typeOf (undefined :: f)
1043− remap f = fromJust . cast . f
1044− hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e)
1045− hashMapAny
1046− | tyrep == typeOf string = process T.unpack
1047− | tyrep == typeOf LT.empty = process LT.fromStrict
1048− | tyrep == typeOf T.empty = process id
1049− | otherwise = myFail
1050− where
1051− process f = maybe myFail return . cast =<< parseWith f
1052− parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e)
1053− parseWith f = case j of
1054− Object js -> H.fromList . map (first f) . M.toList <$>
1055− T.mapM genericParseJSON js
1056− _ -> myFail
1057− tyrep = typeOf (undefined :: f)
1058− myFail = modFail "genericParseJSON" $ "bad data: " ++ show j
1059− stringyTypes = [typeOf LT.empty, typeOf T.empty, typeOf B.empty,
1060− typeOf LB.empty, typeOf string]
1061−
1062−parseJSON_generic :: (Data a) => Value -> Parser a
1063−parseJSON_generic j = generic
1064− where
1065− typ = dataTypeOf $ resType generic
1066− generic = case dataTypeRep typ of
1067− AlgRep [] -> case j of
1068− Null -> return (modError "genericParseJSON" "empty type")
1069− _ -> modFail "genericParseJSON" "no-constr bad data"
1070− AlgRep [_] -> decodeArgs (indexConstr typ 1) j
1071− AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j'
1072− rep -> modFail "genericParseJSON" $
1073− show rep ++ "(" ++ show typ ++ ")"
1074− getConstr t (Object o) | [(s, j')] <- fromJSObject o = do
1075− c <- readConstr' t s
1076− return (c, j')
1077− getConstr t (String js) = do c <- readConstr' t (unpack js)
1078− return (c, Null) -- handle nullary ctor
1079− getConstr _ _ = modFail "genericParseJSON" "bad constructor encoding"
1080− readConstr' t s =
1081− maybe (modFail "genericParseJSON" $ "unknown constructor: " ++ s ++ " " ++
1082− show t)
1083− return $ readConstr t s
1084−
1085− decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0
1086− (constrFields c0)
1087− where
1088− go 0 c _ Null = construct c [] -- nullary constructor
1089− go 1 c [] jd = construct c [jd] -- unary constructor
1090− go n c [] (Array js)
1091− | n > 1 = construct c (V.toList js) -- no field names
1092− -- FIXME? We could allow reading an array into a constructor
1093− -- with field names.
1094− go _ c fs@(_:_) (Object o) = selectFields o fs >>=
1095− construct c -- field names
1096− go _ c _ jd = modFail "genericParseJSON" $
1097− "bad decodeArgs data " ++ show (c, jd)
1098−
1099− fromJSObject = map (first unpack) . M.toList
1100−
1101− -- Build the value by stepping through the list of subparts.
1102− construct c = evalStateT $ fromConstrM f c
1103− where f :: (Data a) => StateT [Value] Parser a
1104− f = do js <- get
1105− case js of
1106− [] -> lift $ modFail "construct" "empty list"
1107− (j':js') -> do put js'; lift $ genericParseJSON j'
1108−
1109− -- Select the named fields from a JSON object.
1110− selectFields fjs = mapM sel
1111− where sel f = maybe (modFail "genericParseJSON" $ "field does not exist " ++
1112− f) return $ M.lookup (pack f) fjs
1113−
1114− -- Count how many arguments a constructor has. The value x is
1115− -- used to determine what type the constructor returns.
1116− numConstrArgs :: (Data a) => a -> Constr -> Int
1117− numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0
1118− where f = do modify (+1); return undefined
1119−
1120− resType :: MonadPlus m => m a -> a
1121− resType _ = modError "genericParseJSON" "resType"
1122−
1123−modFail :: (Monad m) => String -> String -> m a
1124−modFail func err = fail $ "Data.Aeson.Types." ++ func ++ ": " ++ err
1125−
1126−modError :: String -> String -> a
1127−modError func err = error $ "Data.Aeson.Types." ++ func ++ ": " ++ err
1128−
1129−string :: String
1130−string = ""
1131−
1132−-- Type extension for binary type constructors.
1133−
1134−-- | Flexible type extension
1135−ext2' :: (Data a, Typeable2 t)
1136− => c a
1137− -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
1138− -> c a
1139−ext2' def ext = maybe def id (dataCast2 ext)
1140−
1141−-- | Type extension of queries for type constructors
1142−ext2Q' :: (Data d, Typeable2 t)
1143− => (d -> q)
1144− -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
1145− -> d -> q
1146−ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))
1147−
1148−-- | Type extension of readers for type constructors
1149−ext2R' :: (Monad m, Data d, Typeable2 t)
1150− => m d
1151− -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))
1152− -> m d
1153−ext2R' def ext = unR ((R def) `ext2'` (R ext))
1154−
1155−-- | The type constructor for queries
1156−newtype Q q x = Q { unQ :: x -> q }
1157−
1158−-- | The type constructor for readers
1159−newtype R m x = R { unR :: m x }
952+
953+class ConsToJSON f where consToJSON :: f a -> Value
954+class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)
955+
956+instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
957+ consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))
958+ {-# INLINE consToJSON #-}
959+
960+instance (GRecordToPairs f) => ConsToJSON' True f where
961+ consToJSON' = Tagged (object . toList . gRecordToPairs)
962+ {-# INLINE consToJSON' #-}
963+
964+instance GToJSON f => ConsToJSON' False f where
965+ consToJSON' = Tagged gToJSON
966+ {-# INLINE consToJSON' #-}
967+
968+--------------------------------------------------------------------------------
969+
970+class GRecordToPairs f where
971+ gRecordToPairs :: f a -> DList Pair
972+
973+instance (GRecordToPairs a, GRecordToPairs b) => GRecordToPairs (a :*: b) where
974+ gRecordToPairs (a :*: b) = gRecordToPairs a `append` gRecordToPairs b
975+ {-# INLINE gRecordToPairs #-}
976+
977+instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where
978+ gRecordToPairs m1 = singleton (pack (selName m1), gToJSON (unM1 m1))
979+ {-# INLINE gRecordToPairs #-}
980+
981+--------------------------------------------------------------------------------
982+
983+class GProductToValues f where
984+ gProductToValues :: f a -> DList Value
985+
986+instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
987+ gProductToValues (a :*: b) = gProductToValues a `append` gProductToValues b
988+ {-# INLINE gProductToValues #-}
989+
990+instance (GToJSON a) => GProductToValues a where
991+ gProductToValues = singleton . gToJSON
992+ {-# INLINE gProductToValues #-}
993+
994+--------------------------------------------------------------------------------
995+
996+class GObject f where
997+ gObject :: f a -> Object
998+
999+instance (GObject a, GObject b) => GObject (a :+: b) where
1000+ gObject (L1 x) = gObject x
1001+ gObject (R1 x) = gObject x
1002+ {-# INLINE gObject #-}
1003+
1004+instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where
1005+ gObject m1 = M.singleton (pack (conName m1)) (gToJSON m1)
1006+ {-# INLINE gObject #-}
1007+
1008+--------------------------------------------------------------------------------
1009+-- Generic parseJSON
1010+
1011+class GFromJSON f where
1012+ gParseJSON :: Value -> Parser (f a)
1013+
1014+instance (GFromJSON a) => GFromJSON (M1 i c a) where
1015+ gParseJSON = fmap M1 . gParseJSON
1016+ {-# INLINE gParseJSON #-}
1017+
1018+instance (FromJSON a) => GFromJSON (K1 i a) where
1019+ gParseJSON = fmap K1 . parseJSON
1020+ {-# INLINE gParseJSON #-}
1021+
1022+instance GFromJSON U1 where
1023+ gParseJSON v
1024+ | isEmptyArray v = pure U1
1025+ | otherwise = typeMismatch "unit constructor (U1)" v
1026+ {-# INLINE gParseJSON #-}
1027+
1028+instance (ConsFromJSON a) => GFromJSON (C1 c a) where
1029+ gParseJSON = fmap M1 . consParseJSON
1030+ {-# INLINE gParseJSON #-}
1031+
1032+instance (GFromProduct a, GFromProduct b) => GFromJSON (a :*: b) where
1033+ gParseJSON (Array arr) = gParseProduct arr
1034+ gParseJSON v = typeMismatch "product (:*:)" v
1035+ {-# INLINE gParseJSON #-}
1036+
1037+instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
1038+ gParseJSON (Object (M.toList -> [keyVal])) = gParseSum keyVal
1039+ gParseJSON v = typeMismatch "sum (:+:)" v
1040+ {-# INLINE gParseJSON #-}
1041+
1042+--------------------------------------------------------------------------------
1043+
1044+class ConsFromJSON f where consParseJSON :: Value -> Parser (f a)
1045+class ConsFromJSON' b f where consParseJSON' :: Tagged b (Value -> Parser (f a))
1046+
1047+instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where
1048+ consParseJSON = unTagged (consParseJSON' :: Tagged b (Value -> Parser (f a)))
1049+ {-# INLINE consParseJSON #-}
1050+
1051+instance (GFromRecord f) => ConsFromJSON' True f where
1052+ consParseJSON' = Tagged parseRecord
1053+ where
1054+ parseRecord (Object obj) = gParseRecord obj
1055+ parseRecord v = typeMismatch "record (:*:)" v
1056+ {-# INLINE consParseJSON' #-}
1057+
1058+instance (GFromJSON f) => ConsFromJSON' False f where
1059+ consParseJSON' = Tagged gParseJSON
1060+ {-# INLINE consParseJSON' #-}
1061+
1062+--------------------------------------------------------------------------------
1063+
1064+class GFromRecord f where
1065+ gParseRecord :: Object -> Parser (f a)
1066+
1067+instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
1068+ gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj
1069+ {-# INLINE gParseRecord #-}
1070+
1071+instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
1072+ gParseRecord obj = case M.lookup (T.pack key) obj of
1073+ Nothing -> notFound key
1074+ Just v -> gParseJSON v
1075+ where
1076+ key = selName (undefined :: t s a p)
1077+ {-# INLINE gParseRecord #-}
1078+
1079+--------------------------------------------------------------------------------
1080+
1081+class GFromProduct f where
1082+ gParseProduct :: Array -> Parser (f a)
1083+
1084+instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
1085+ gParseProduct arr = (:*:) <$> gParseProduct arrL <*> gParseProduct arrR
1086+ where
1087+ (arrL, arrR) = V.splitAt (V.length arr `div` 2) arr
1088+ {-# INLINE gParseProduct #-}
1089+
1090+instance (GFromJSON a) => GFromProduct a where
1091+ gParseProduct ((!? 0) -> Just v) = gParseJSON v
1092+ gParseProduct _ = fail "Array to small"
1093+ {-# INLINE gParseProduct #-}
1094+
1095+--------------------------------------------------------------------------------
1096+
1097+class GFromSum f where
1098+ gParseSum :: Pair -> Parser (f a)
1099+
1100+instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
1101+ gParseSum keyVal = (L1 <$> gParseSum keyVal) <|> (R1 <$> gParseSum keyVal)
1102+ {-# INLINE gParseSum #-}
1103+
1104+instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where
1105+ gParseSum (key, value)
1106+ | key == pack (conName (undefined :: t c a p)) = gParseJSON value
1107+ | otherwise = notFound $ unpack key
1108+ {-# INLINE gParseSum #-}
1109+
1110+notFound :: String -> Parser a
1111+notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
1112+
1113+--------------------------------------------------------------------------------
1114+
1115+newtype Tagged s b = Tagged {unTagged :: b}
1116+
1117+data True
1118+data False
1119+
1120+class IsRecord (f :: * -> *) b | f -> b
1121+
1122+instance (IsRecord f b) => IsRecord (f :*: g) b
1123+instance IsRecord (M1 S NoSelector f) False
1124+instance (IsRecord f b) => IsRecord (M1 S c f) b
1125+instance IsRecord (K1 i c) True
1126+instance IsRecord U1 False
1127+
1128+--------------------------------------------------------------------------------
1129+
1130+type DList a = [a] -> [a]
1131+
1132+toList :: DList a -> [a]
1133+toList = ($ [])
1134+{-# INLINE toList #-}
1135+
1136+singleton :: a -> DList a
1137+singleton = (:)
1138+{-# INLINE singleton #-}
1139+
1140+append :: DList a -> DList a -> DList a
1141+append = (.)
1142+{-# INLINE append #-}
1143+
1144+--------------------------------------------------------------------------------
1145+#endif