@@ -4,8 +4,8 @@
44 ScopedTypeVariables, PatternGuards #-}
55
66{-# LANGUAGE CPP #-}
7−#ifdef DEFAULT_SIGNATURES
8−{-# LANGUAGE DefaultSignatures #-}
7+#ifdef GENERICS
8+{-# LANGUAGE DefaultSignatures, TypeOperators #-}
99#endif
1010
1111-- |
@@ -23,7 +23,7 @@ module Data.Aeson.Types.Internal
2323 -- * Core JSON types
2424 Value(..)
2525 , Array
26− , emptyArray
26+ , emptyArray, isEmptyArray
2727 , Pair
2828 , Object
2929 , emptyObject
@@ -44,33 +44,28 @@ module Data.Aeson.Types.Internal
4444 , (.:)
4545 , (.:?)
4646 , object
47− -- * Generic toJSON and fromJSON
48− , genericToJSON
49− , genericFromJSON
5047 ) where
5148
5249import Control.Applicative
53−import Control.Arrow (first)
54−import Control.Monad.State.Strict
5550import Control.DeepSeq (NFData(..))
51+import Control.Monad.State.Strict
5652import Data.Aeson.Functions
5753import Data.Attoparsec.Char8 (Number(..))
58−import Data.Generics
54+import Data.Data (Data)
5955import Data.Hashable (Hashable(..))
6056import Data.Int (Int8, Int16, Int32, Int64)
61−import Data.IntSet (IntSet)
6257import Data.List (foldl')
6358import Data.Map (Map)
64−import Data.Maybe (fromJust)
6559import Data.Monoid (Dual(..), First(..), Last(..))
6660import Data.Monoid (Monoid(..))
6761import Data.Ratio (Ratio)
6862import Data.String (IsString(..))
69−import Data.Text (Text, pack, unpack)
7063import Data.Text.Encoding (encodeUtf8)
64+import Data.Text (Text, pack, unpack)
7165import Data.Time.Clock (UTCTime)
7266import Data.Time.Format (FormatTime, formatTime, parseTime)
73−import Data.Vector (Vector)
67+import Data.Typeable (Typeable)
68+import Data.Vector (Vector, (!?))
7469import Data.Word (Word, Word8, Word16, Word32, Word64)
7570import Foreign.Storable (Storable)
7671import System.Locale (defaultTimeLocale)
@@ -84,13 +79,15 @@ import qualified Data.Map as M
8479import qualified Data.Set as Set
8580import qualified Data.Text as T
8681import qualified Data.Text.Lazy as LT
87−import qualified Data.Traversable as T
8882import qualified Data.Vector as V
8983import qualified Data.Vector.Storable as VS
9084import qualified Data.Vector.Primitive as VP
9185import qualified Data.Vector.Unboxed as VU
9286import qualified Data.Vector.Generic as VG
9387
88+#ifdef GENERICS
89+import GHC.Generics
90+#endif
9491
9592-- | The result of running a 'Parser'.
9693data Result a = Error String
@@ -170,7 +167,7 @@ instance Applicative Parser where
170167 {-# INLINE pure #-}
171168 (<*>) = apP
172169 {-# INLINE (<*>) #-}
173−
170+
174171instance Alternative Parser where
175172 empty = fail "empty"
176173 {-# INLINE empty #-}
@@ -236,6 +233,12 @@ instance Hashable Value where
236233emptyArray :: Value
237234emptyArray = Array V.empty
238235
236+-- | Determines if the 'Value' is an empty 'Array'.
237+-- Note that: @isEmptyArray 'emptyArray'@.
238+isEmptyArray :: Value -> Bool
239+isEmptyArray (Array arr) = V.null arr
240+isEmptyArray _ = False
241+
239242-- | The empty object.
240243emptyObject :: Value
241244emptyObject = Object M.empty
@@ -311,12 +314,31 @@ object = Object . M.fromList
311314-- @
312315--
313316-- This example assumes the OverloadedStrings language option is enabled.
317+--
318+-- If your compiler has support for the @DeriveGeneric@ and @DefaultSignatures@
319+-- language extensions, @toJSON@ will have a default generic implementation.
320+--
321+-- To use this, simply add a @deriving 'Generic'@ clause to your datatype and
322+-- declare a @ToJSON@ instance for your datatype without giving a definition for
323+-- @toJSON@. For example the previous example can be simplified to just:
324+--
325+-- @{-\# LANGUAGE DeriveGeneric \#-}
326+--
327+-- import GHC.Generics
328+--
329+-- data Coord { x :: Double, y :: Double } deriving Generic
330+--
331+-- instance ToJSON Coord
332+-- @
333+--
334+-- (Another way to automatically derive a @ToJSON@ instance is to use the
335+-- template-haskell template 'deriveToJSON' from "Data.Aeson.TH".)
314336class ToJSON a where
315337 toJSON :: a -> Value
316338
317−#ifdef DEFAULT_SIGNATURES
318− default toJSON :: Data a => a -> Value
319− toJSON = genericToJSON
339+#ifdef GENERICS
340+ default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value
341+ toJSON = gToJSON . from
320342#endif
321343
322344-- | A type that can be converted from JSON, with the possibility of
@@ -329,7 +351,7 @@ class ToJSON a where
329351-- An example type and instance:
330352--
331353-- @data Coord { x :: Double, y :: Double }
332−--
354+--
333355-- instance FromJSON Coord where
334356-- parseJSON ('Object' v) = Coord '<$>'
335357-- v '.:' \"x\" '<*>'
@@ -340,19 +362,38 @@ class ToJSON a where
340362-- @
341363--
342364-- This example assumes the OverloadedStrings language option is enabled.
365+--
366+-- If your compiler has support for the @DeriveGeneric@ and @DefaultSignatures@
367+-- language extensions, @parseJSON@ will have a default generic implementation.
368+--
369+-- To use this, simply add a @deriving 'Generic'@ clause to your datatype and
370+-- declare a @FromJSON@ instance for your datatype without giving a definition for
371+-- @parseJSON@. For example the previous example can be simplified to just:
372+--
373+-- @{-\# LANGUAGE DeriveGeneric \#-}
374+--
375+-- import GHC.Generics
376+--
377+-- data Coord { x :: Double, y :: Double } deriving Generic
378+--
379+-- instance FromJSON Coord
380+-- @
381+--
382+-- (Another way to automatically derive a @FromJSON@ instance is to use the
383+-- template-haskell template 'deriveFromJSON' from "Data.Aeson.TH".)
343384class FromJSON a where
344385 parseJSON :: Value -> Parser a
345386
346−#ifdef DEFAULT_SIGNATURES
347− default parseJSON :: Data a => Value -> Parser a
348− parseJSON = genericParseJSON
387+#ifdef GENERICS
388+ default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
389+ parseJSON = fmap to . gParseJSON
349390#endif
350391
351392instance (ToJSON a) => ToJSON (Maybe a) where
352393 toJSON (Just a) = toJSON a
353394 toJSON Nothing = Null
354395 {-# INLINE toJSON #-}
355−
396+
356397instance (FromJSON a) => FromJSON (Maybe a) where
357398 parseJSON Null = pure Nothing
358399 parseJSON a = Just <$> parseJSON a
@@ -362,7 +403,7 @@ instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
362403 toJSON (Left a) = object [left .= a]
363404 toJSON (Right b) = object [right .= b]
364405 {-# INLINE toJSON #-}
365−
406+
366407instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
367408 parseJSON (Object (M.toList -> [(key, value)]))
368409 | key == left = Left <$> parseJSON value
@@ -588,7 +629,7 @@ instance FromJSON LB.ByteString where
588629instance (ToJSON a) => ToJSON [a] where
589630 toJSON = Array . V.fromList . map toJSON
590631 {-# INLINE toJSON #-}
591−
632+
592633instance (FromJSON a) => FromJSON [a] where
593634 parseJSON (Array a) = mapM parseJSON (V.toList a)
594635 parseJSON v = typeMismatch "[a]" v
@@ -597,7 +638,7 @@ instance (FromJSON a) => FromJSON [a] where
597638instance (ToJSON a) => ToJSON (Vector a) where
598639 toJSON = Array . V.map toJSON
599640 {-# INLINE toJSON #-}
600−
641+
601642instance (FromJSON a) => FromJSON (Vector a) where
602643 parseJSON (Array a) = V.mapM parseJSON a
603644 parseJSON v = typeMismatch "Vector a" v
@@ -633,7 +674,7 @@ instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
633674instance (ToJSON a) => ToJSON (Set.Set a) where
634675 toJSON = toJSON . Set.toList
635676 {-# INLINE toJSON #-}
636−
677+
637678instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
638679 parseJSON = fmap Set.fromList . parseJSON
639680 {-# INLINE parseJSON #-}
@@ -641,7 +682,7 @@ instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
641682instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
642683 toJSON = toJSON . HashSet.toList
643684 {-# INLINE toJSON #-}
644−
685+
645686instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
646687 parseJSON = fmap HashSet.fromList . parseJSON
647688 {-# INLINE parseJSON #-}
@@ -649,7 +690,7 @@ instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
649690instance ToJSON IntSet.IntSet where
650691 toJSON = toJSON . IntSet.toList
651692 {-# INLINE toJSON #-}
652−
693+
653694instance FromJSON IntSet.IntSet where
654695 parseJSON = fmap IntSet.fromList . parseJSON
655696 {-# INLINE parseJSON #-}
@@ -657,7 +698,7 @@ instance FromJSON IntSet.IntSet where
657698instance ToJSON a => ToJSON (IntMap.IntMap a) where
658699 toJSON = toJSON . IntMap.toList
659700 {-# INLINE toJSON #-}
660−
701+
661702instance FromJSON a => FromJSON (IntMap.IntMap a) where
662703 parseJSON = fmap IntMap.fromList . parseJSON
663704 {-# INLINE parseJSON #-}
@@ -843,293 +884,164 @@ typeMismatch expected actual =
843884 Bool _ -> "Boolean"
844885 Null -> "Null"
845886
846−
887+#ifdef GENERICS
847888--------------------------------------------------------------------------------
848889-- Generic toJSON and fromJSON
849890
850−type T a = a -> Value
851−
852−genericToJSON :: (Data a) => a -> Value
853−genericToJSON = toJSON_generic
854− `ext1Q` list
855− `ext1Q` vector
856− `ext1Q` set
857− `ext2Q'` mapAny
858− `ext2Q'` hashMapAny
859− -- Use the standard encoding for all base types.
860− `extQ` (toJSON :: T Integer)
861− `extQ` (toJSON :: T Int)
862− `extQ` (toJSON :: T Int8)
863− `extQ` (toJSON :: T Int16)
864− `extQ` (toJSON :: T Int32)
865− `extQ` (toJSON :: T Int64)
866− `extQ` (toJSON :: T Word)
867− `extQ` (toJSON :: T Word8)
868− `extQ` (toJSON :: T Word16)
869− `extQ` (toJSON :: T Word32)
870− `extQ` (toJSON :: T Word64)
871− `extQ` (toJSON :: T Double)
872− `extQ` (toJSON :: T Number)
873− `extQ` (toJSON :: T Float)
874− `extQ` (toJSON :: T Rational)
875− `extQ` (toJSON :: T Char)
876− `extQ` (toJSON :: T Text)
877− `extQ` (toJSON :: T LT.Text)
878− `extQ` (toJSON :: T String)
879− `extQ` (toJSON :: T B.ByteString)
880− `extQ` (toJSON :: T LB.ByteString)
881− `extQ` (toJSON :: T Value)
882− `extQ` (toJSON :: T DotNetTime)
883− `extQ` (toJSON :: T UTCTime)
884− `extQ` (toJSON :: T IntSet)
885− `extQ` (toJSON :: T Bool)
886− `extQ` (toJSON :: T ())
887− --`extQ` (T.toJSON :: T Ordering)
888− where
889− list xs = Array . V.fromList . map genericToJSON $ xs
890− vector v = Array . V.map genericToJSON $ v
891− set s = Array . V.fromList . map genericToJSON . Set.toList $ s
892−
893− mapAny m
894− | tyrep == typeOf T.empty = remap id
895− | tyrep == typeOf LT.empty = remap LT.toStrict
896− | tyrep == typeOf string = remap pack
897− | tyrep == typeOf B.empty = remap decode
898− | tyrep == typeOf LB.empty = remap strict
899− | otherwise = modError "genericToJSON" $
900− "cannot convert map keyed by type " ++ show tyrep
901− where tyrep = typeOf . head . M.keys $ m
902− remap f = Object . transformMap (f . fromJust . cast) genericToJSON $ m
903−
904− hashMapAny m
905− | tyrep == typeOf T.empty = remap id
906− | tyrep == typeOf LT.empty = remap LT.toStrict
907− | tyrep == typeOf string = remap pack
908− | tyrep == typeOf B.empty = remap decode
909− | tyrep == typeOf LB.empty = remap strict
910− | otherwise = modError "genericToJSON" $
911− "cannot convert map keyed by type " ++ show tyrep
912− where tyrep = typeOf . head . H.keys $ m
913− remap f = Object . hashMap (f . fromJust . cast) genericToJSON $ m
914−
915−
916−toJSON_generic :: (Data a) => a -> Value
917−toJSON_generic = generic
918− where
919− -- Generic encoding of an algebraic data type.
920− generic a =
921− case dataTypeRep (dataTypeOf a) of
922− -- No constructor, so it must be an error value. Code
923− -- it anyway as Null.
924− AlgRep [] -> Null
925− -- Elide a single constructor and just code the arguments.
926− AlgRep [c] -> encodeArgs c (gmapQ genericToJSON a)
927− -- For multiple constructors, make an object with a
928− -- field name that is the constructor (except lower
929− -- case) and the data is the arguments encoded.
930− AlgRep _ -> encodeConstr (toConstr a) (gmapQ genericToJSON a)
931− rep -> err (dataTypeOf a) rep
932− where
933− err dt r = modError "genericToJSON" $ "not AlgRep " ++
934− show r ++ "(" ++ show dt ++ ")"
935− -- Encode nullary constructor as a string.
936− -- Encode non-nullary constructors as an object with the constructor
937− -- name as the single field and the arguments as the value.
938− -- Use an array if the are no field names, but elide singleton arrays,
939− -- and use an object if there are field names.
940− encodeConstr c [] = String . constrString $ c
941− encodeConstr c as = object [(constrString c, encodeArgs c as)]
942−
943− constrString = pack . showConstr
944−
945− encodeArgs c = encodeArgs' (constrFields c)
946− encodeArgs' [] [j] = j
947− encodeArgs' [] js = Array . V.fromList $ js
948− encodeArgs' ns js = object $ zip (map mungeField ns) js
949−
950− -- Skip leading '_' in field name so we can use keywords
951− -- etc. as field names.
952− mungeField ('_':cs) = pack cs
953− mungeField cs = pack cs
954−
955−genericFromJSON :: (Data a) => Value -> Result a
956−genericFromJSON = parse genericParseJSON
957−
958−type F a = Parser a
959−
960−genericParseJSON :: (Data a) => Value -> Parser a
961−genericParseJSON j = parseJSON_generic j
962− `ext1R` list
963− `ext1R` vector
964− `ext2R'` mapAny
965− `ext2R'` hashMapAny
966− -- Use the standard encoding for all base types.
967− `extR` (value :: F Integer)
968− `extR` (value :: F Int)
969− `extR` (value :: F Int8)
970− `extR` (value :: F Int16)
971− `extR` (value :: F Int32)
972− `extR` (value :: F Int64)
973− `extR` (value :: F Word)
974− `extR` (value :: F Word8)
975− `extR` (value :: F Word16)
976− `extR` (value :: F Word32)
977− `extR` (value :: F Word64)
978− `extR` (value :: F Double)
979− `extR` (value :: F Number)
980− `extR` (value :: F Float)
981− `extR` (value :: F Rational)
982− `extR` (value :: F Char)
983− `extR` (value :: F Text)
984− `extR` (value :: F LT.Text)
985− `extR` (value :: F String)
986− `extR` (value :: F B.ByteString)
987− `extR` (value :: F LB.ByteString)
988− `extR` (value :: F Value)
989− `extR` (value :: F DotNetTime)
990− `extR` (value :: F UTCTime)
991− `extR` (value :: F IntSet)
992− `extR` (value :: F Bool)
993− `extR` (value :: F ())
994− where
995− value :: (FromJSON a) => Parser a
996− value = parseJSON j
997− list :: (Data a) => Parser [a]
998− list = V.toList <$> genericParseJSON j
999− vector :: (Data a) => Parser (V.Vector a)
1000− vector = case j of
1001− Array js -> V.mapM genericParseJSON js
1002− _ -> myFail
1003− mapAny :: forall e f. (Data e, Data f) => Parser (Map f e)
1004− mapAny
1005− | tyrep `elem` stringyTypes = res
1006− | otherwise = myFail
1007− where res = case j of
1008− Object js -> M.mapKeysMonotonic trans <$> T.mapM genericParseJSON js
1009− _ -> myFail
1010− trans
1011− | tyrep == typeOf T.empty = remap id
1012− | tyrep == typeOf LT.empty = remap LT.fromStrict
1013− | tyrep == typeOf string = remap T.unpack
1014− | tyrep == typeOf B.empty = remap encodeUtf8
1015− | tyrep == typeOf LB.empty = remap lazy
1016− | otherwise = modError "genericParseJSON"
1017− "mapAny -- should never happen"
1018− tyrep = typeOf (undefined :: f)
1019− remap f = fromJust . cast . f
1020− hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e)
1021− hashMapAny
1022− | tyrep == typeOf string = process T.unpack
1023− | tyrep == typeOf LT.empty = process LT.fromStrict
1024− | tyrep == typeOf T.empty = process id
1025− | otherwise = myFail
1026− where
1027− process f = maybe myFail return . cast =<< parseWith f
1028− parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e)
1029− parseWith f = case j of
1030− Object js -> H.fromList . map (first f) . M.toList <$>
1031− T.mapM genericParseJSON js
1032− _ -> myFail
1033− tyrep = typeOf (undefined :: f)
1034− myFail = modFail "genericParseJSON" $ "bad data: " ++ show j
1035− stringyTypes = [typeOf LT.empty, typeOf T.empty, typeOf B.empty,
1036− typeOf LB.empty, typeOf string]
1037−
1038−parseJSON_generic :: (Data a) => Value -> Parser a
1039−parseJSON_generic j = generic
1040− where
1041− typ = dataTypeOf $ resType generic
1042− generic = case dataTypeRep typ of
1043− AlgRep [] -> case j of
1044− Null -> return (modError "genericParseJSON" "empty type")
1045− _ -> modFail "genericParseJSON" "no-constr bad data"
1046− AlgRep [_] -> decodeArgs (indexConstr typ 1) j
1047− AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j'
1048− rep -> modFail "genericParseJSON" $
1049− show rep ++ "(" ++ show typ ++ ")"
1050− getConstr t (Object o) | [(s, j')] <- fromJSObject o = do
1051− c <- readConstr' t s
1052− return (c, j')
1053− getConstr t (String js) = do c <- readConstr' t (unpack js)
1054− return (c, Null) -- handle nullary ctor
1055− getConstr _ _ = modFail "genericParseJSON" "bad constructor encoding"
1056− readConstr' t s =
1057− maybe (modFail "genericParseJSON" $ "unknown constructor: " ++ s ++ " " ++
1058− show t)
1059− return $ readConstr t s
1060−
1061− decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0
1062− (constrFields c0)
1063− where
1064− go 0 c _ Null = construct c [] -- nullary constructor
1065− go 1 c [] jd = construct c [jd] -- unary constructor
1066− go n c [] (Array js)
1067− | n > 1 = construct c (V.toList js) -- no field names
1068− -- FIXME? We could allow reading an array into a constructor
1069− -- with field names.
1070− go _ c fs@(_:_) (Object o) = selectFields o fs >>=
1071− construct c -- field names
1072− go _ c _ jd = modFail "genericParseJSON" $
1073− "bad decodeArgs data " ++ show (c, jd)
1074−
1075− fromJSObject = map (first unpack) . M.toList
1076−
1077− -- Build the value by stepping through the list of subparts.
1078− construct c = evalStateT $ fromConstrM f c
1079− where f :: (Data a) => StateT [Value] Parser a
1080− f = do js <- get
1081− case js of
1082− [] -> lift $ modFail "construct" "empty list"
1083− (j':js') -> do put js'; lift $ genericParseJSON j'
1084−
1085− -- Select the named fields from a JSON object.
1086− selectFields fjs = mapM sel
1087− where sel f = maybe (modFail "genericParseJSON" $ "field does not exist " ++
1088− f) return $ M.lookup (pack f) fjs
1089−
1090− -- Count how many arguments a constructor has. The value x is
1091− -- used to determine what type the constructor returns.
1092− numConstrArgs :: (Data a) => a -> Constr -> Int
1093− numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0
1094− where f = do modify (+1); return undefined
1095−
1096− resType :: MonadPlus m => m a -> a
1097− resType _ = modError "genericParseJSON" "resType"
1098−
1099−modFail :: (Monad m) => String -> String -> m a
1100−modFail func err = fail $ "Data.Aeson.Types." ++ func ++ ": " ++ err
1101−
1102−modError :: String -> String -> a
1103−modError func err = error $ "Data.Aeson.Types." ++ func ++ ": " ++ err
1104−
1105−string :: String
1106−string = ""
1107−
1108−-- Type extension for binary type constructors.
1109−
1110−-- | Flexible type extension
1111−ext2' :: (Data a, Typeable2 t)
1112− => c a
1113− -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
1114− -> c a
1115−ext2' def ext = maybe def id (dataCast2 ext)
1116−
1117−-- | Type extension of queries for type constructors
1118−ext2Q' :: (Data d, Typeable2 t)
1119− => (d -> q)
1120− -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
1121− -> d -> q
1122−ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))
1123−
1124−-- | Type extension of readers for type constructors
1125−ext2R' :: (Monad m, Data d, Typeable2 t)
1126− => m d
1127− -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))
1128− -> m d
1129−ext2R' def ext = unR ((R def) `ext2'` (R ext))
1130−
1131−-- | The type constructor for queries
1132−newtype Q q x = Q { unQ :: x -> q }
1133−
1134−-- | The type constructor for readers
1135−newtype R m x = R { unR :: m x }
891+class GToJSON f where
892+ gToJSON :: f a -> Value
893+
894+class GFromJSON f where
895+ gParseJSON :: Value -> Parser (f a)
896+
897+--------------------------------------------------------------------------------
898+
899+-- | Meta-information is stripped:
900+instance (GToJSON a) => GToJSON (M1 i c a) where
901+ gToJSON = gToJSON . unM1
902+
903+-- | Meta-information is added:
904+instance (GFromJSON a) => GFromJSON (M1 i c a) where
905+ gParseJSON = fmap M1 . gParseJSON
906+
907+
908+-- | Constants are converted using toJSON:
909+instance (ToJSON a) => GToJSON (K1 i a) where
910+ gToJSON = toJSON . unK1
911+
912+-- | Constants are parsed using parseJSON:
913+instance (FromJSON a) => GFromJSON (K1 i a) where
914+ gParseJSON = fmap K1 . parseJSON
915+
916+
917+-- | Constructors without arguments are converted to the empty array:
918+instance GToJSON U1 where
919+ gToJSON _ = emptyArray
920+
921+-- | Constructors without arguments must be represented by the empty array:
922+instance GFromJSON U1 where
923+ gParseJSON v
924+ | isEmptyArray v = pure U1
925+ | otherwise = typeMismatch "unary constructor (U1)" v
926+
927+
928+-- | Each value of a sum type is converted to an object
929+-- with a single key-value association where the key is the name of the constructor:
930+instance (GObject a, GObject b) => GToJSON (a :+: b) where
931+ gToJSON (L1 x) = Object $ gObject x
932+ gToJSON (R1 x) = Object $ gObject x
933+
934+-- | A sum type must be represented by an object with a single key-value association.
935+-- When this is the case, the sum will be recursively parsed using gParseSum:
936+instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
937+ gParseJSON (Object (M.toList -> [keyVal])) = gParseSum keyVal
938+ gParseJSON v = typeMismatch "sum (:+:)" v
939+
940+
941+-- | Product types without field names are flattened and converted to an array:
942+instance (GToJSON a, Flatten b) => GToJSON (S1 NoSelector a :*: b) where
943+ gToJSON = toJSON . flatten
944+
945+-- | Product types without field names must be represented as an array.
946+-- When this is the case the product will be recursively parsed sing gParseProduct:
947+instance (GFromJSON a, GFromProduct b) => GFromJSON (S1 NoSelector a :*: b) where
948+ gParseJSON (Array arr) = gParseProduct arr 0
949+ gParseJSON v = typeMismatch "product (:*:)" v
950+
951+
952+-- | Other product types, so the ones with field names (records),
953+-- are converted to a single object.
954+instance (GObject a, GObject b) => GToJSON (a :*: b) where
955+ gToJSON = Object . gObject
956+
957+-- | Product types with field names (records) must be represented as a single object.
958+-- If this is the case the product will be recursively parsed using gParseRecord.
959+instance (GFromRecord a, GFromRecord b) => GFromJSON (a :*: b) where
960+ gParseJSON (Object obj) = gParseRecord obj
961+ gParseJSON v = typeMismatch "record (:*:)" v
962+
963+--------------------------------------------------------------------------------
964+
965+-- | Flatten /flattens/ a product type. For example:
966+-- a :*: (b :*: (c :*: d)) is converted to:
967+-- [gToJSON a, gToJSON b, gToJSON c, gToJSON d]
968+class Flatten f where
969+ flatten :: f a -> [Value]
970+
971+instance (GToJSON a, Flatten b) => Flatten (S1 NoSelector a :*: b) where
972+ flatten (m1 :*: r) = gToJSON m1 : flatten r
973+
974+instance (GToJSON a) => Flatten (S1 NoSelector a) where
975+ flatten m1 = [gToJSON $ unM1 m1]
976+
977+--------------------------------------------------------------------------------
978+
979+class GObject f where
980+ gObject :: f a -> Object
981+
982+instance (GObject a, GObject b) => GObject (a :+: b) where
983+ gObject (L1 x) = gObject x
984+ gObject (R1 x) = gObject x
985+
986+instance (GObject a, GObject b) => GObject (a :*: b) where
987+ gObject (a :*: b) = gObject a `M.union` gObject b
988+
989+instance (Selector s, GToJSON a) => GObject (S1 s a) where
990+ gObject = objectNamed selName
991+
992+instance (Constructor c, GToJSON a) => GObject (C1 c a) where
993+ gObject = objectNamed conName
994+
995+objectNamed :: GToJSON f => (M1 i c f p -> String) -> M1 i c f p -> Object
996+objectNamed getName m1 = M.singleton (pack (getName m1)) (gToJSON (unM1 m1))
997+
998+--------------------------------------------------------------------------------
999+
1000+class GFromSum f where
1001+ gParseSum :: Pair -> Parser (f a)
1002+
1003+instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
1004+ gParseSum keyVal = fmap L1 (gParseSum keyVal) <|> fmap R1 (gParseSum keyVal)
1005+
1006+instance (Constructor c, GFromJSON a) => GFromSum (C1 c a) where
1007+ gParseSum (key, value)
1008+ | key == pack (conName (undefined :: t c a p)) = gParseJSON value
1009+ | otherwise = notFound $ unpack key
1010+
1011+notFound :: String -> Parser a
1012+notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
1013+
1014+--------------------------------------------------------------------------------
1015+
1016+class GFromProduct f where
1017+ gParseProduct :: Array -> Int -> Parser (f a)
1018+
1019+instance (GFromJSON a, GFromProduct b) => GFromProduct (a :*: b) where
1020+ gParseProduct arr ix =
1021+ case arr !? ix of
1022+ Nothing -> arrayToSmall ix
1023+ Just v -> (:*:) <$> gParseJSON v <*> gParseProduct arr (ix+1)
1024+
1025+instance (GFromJSON a) => GFromProduct (S1 NoSelector a) where
1026+ gParseProduct arr ix = case arr !? ix of
1027+ Nothing -> arrayToSmall ix
1028+ Just v -> gParseJSON v
1029+
1030+arrayToSmall :: Int -> Parser a
1031+arrayToSmall ix = fail $ "Expected an array of at least " ++ show ix ++ " values"
1032+
1033+--------------------------------------------------------------------------------
1034+
1035+class GFromRecord f where
1036+ gParseRecord :: Object -> Parser (f a)
1037+
1038+instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
1039+ gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj
1040+
1041+instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
1042+ gParseRecord obj = case M.lookup (T.pack key) obj of
1043+ Nothing -> notFound key
1044+ Just v -> gParseJSON v
1045+ where
1046+ key = selName (undefined :: t s a p)
1047+#endif