git.iko.soy/typeable/aeson
on master help sign in
Default methods for toJSON and parseJSON using the new DefaultSignatures extension

The methods default to the generic implementations. I had to move the generic implementations into the Types module and define and export genericToJSON and genericFromJSON. Other arrangements exists but this was the quickest to implement. Note that the default methods are only enabled when the extension is available. Currently this is the case for ghc >= 7.2.1.

commit0cdeabffadf2a4ea86fdd25aeed871f24fae9a2a authorBas van Dijk <v.dijk.bas@gmail.com> dateMon 15 Aug 2011, 17:09 (15 years ago) parent4e845da
3 files changed+325−311
compare with master
unifiedsplit
Data/Aeson/Generic.hs+5−307 Data/Aeson/Types.hs+317−4 aeson.cabal+3
Data/Aeson/Generic.hs+5−307
@@ -20,313 +20,11 @@ module Data.Aeson.Generic
2020 , toJSON
2121 ) where
2222
23−import Control.Applicative ((<$>))
24−import Control.Arrow (first)
25−import Control.Monad.State.Strict
26−import Data.Aeson.Functions
27−import Data.Aeson.Types hiding (FromJSON(..), ToJSON(..), fromJSON)
28−import Data.Attoparsec.Number (Number)
29−import Data.Generics
30−import Data.Hashable (Hashable)
31−import Data.Int (Int8, Int16, Int32, Int64)
32−import Data.IntSet (IntSet)
33−import Data.Maybe (fromJust)
34−import Data.Text (Text, pack, unpack)
35−import Data.Text.Encoding (encodeUtf8)
36−import Data.Time.Clock (UTCTime)
37−import Data.Word (Word, Word8, Word16, Word32, Word64)
38−import qualified Data.Aeson.Types as T
39−import qualified Data.ByteString as B
40−import qualified Data.ByteString.Lazy as L
41−import qualified Data.HashMap.Strict as H
42−import qualified Data.Map as Map
43−import qualified Data.Set as Set
44−import qualified Data.Text as DT
45−import qualified Data.Text.Lazy as LT
46−import qualified Data.Traversable as T
47−import qualified Data.Vector as V
48−
49−type T a = a -> Value
50−
51−toJSON :: (Data a) => a -> Value
52−toJSON = toJSON_generic
53− `ext1Q` list
54− `ext1Q` vector
55− `ext1Q` set
56− `ext2Q'` mapAny
57− `ext2Q'` hashMapAny
58− -- Use the standard encoding for all base types.
59− `extQ` (T.toJSON :: T Integer)
60− `extQ` (T.toJSON :: T Int)
61− `extQ` (T.toJSON :: T Int8)
62− `extQ` (T.toJSON :: T Int16)
63− `extQ` (T.toJSON :: T Int32)
64− `extQ` (T.toJSON :: T Int64)
65− `extQ` (T.toJSON :: T Word)
66− `extQ` (T.toJSON :: T Word8)
67− `extQ` (T.toJSON :: T Word16)
68− `extQ` (T.toJSON :: T Word32)
69− `extQ` (T.toJSON :: T Word64)
70− `extQ` (T.toJSON :: T Double)
71− `extQ` (T.toJSON :: T Number)
72− `extQ` (T.toJSON :: T Float)
73− `extQ` (T.toJSON :: T Rational)
74− `extQ` (T.toJSON :: T Char)
75− `extQ` (T.toJSON :: T Text)
76− `extQ` (T.toJSON :: T LT.Text)
77− `extQ` (T.toJSON :: T String)
78− `extQ` (T.toJSON :: T B.ByteString)
79− `extQ` (T.toJSON :: T L.ByteString)
80− `extQ` (T.toJSON :: T T.Value)
81− `extQ` (T.toJSON :: T DotNetTime)
82− `extQ` (T.toJSON :: T UTCTime)
83− `extQ` (T.toJSON :: T IntSet)
84− `extQ` (T.toJSON :: T Bool)
85− `extQ` (T.toJSON :: T ())
86− --`extQ` (T.toJSON :: T Ordering)
87− where
88− list xs = Array . V.fromList . map toJSON $ xs
89− vector v = Array . V.map toJSON $ v
90− set s = Array . V.fromList . map toJSON . Set.toList $ s
91−
92− mapAny m
93− | tyrep == typeOf DT.empty = remap id
94− | tyrep == typeOf LT.empty = remap LT.toStrict
95− | tyrep == typeOf "" = remap pack
96− | tyrep == typeOf B.empty = remap decode
97− | tyrep == typeOf L.empty = remap strict
98− | otherwise = modError "toJSON" $
99− "cannot convert map keyed by type " ++ show tyrep
100− where tyrep = typeOf . head . Map.keys $ m
101− remap f = Object . transformMap (f . fromJust . cast) toJSON $ m
102−
103− hashMapAny m
104− | tyrep == typeOf DT.empty = remap id
105− | tyrep == typeOf LT.empty = remap LT.toStrict
106− | tyrep == typeOf "" = remap pack
107− | tyrep == typeOf B.empty = remap decode
108− | tyrep == typeOf L.empty = remap strict
109− | otherwise = modError "toJSON" $
110− "cannot convert map keyed by type " ++ show tyrep
111− where tyrep = typeOf . head . H.keys $ m
112− remap f = Object . hashMap (f . fromJust . cast) toJSON $ m
113−
114−
115−toJSON_generic :: (Data a) => a -> Value
116−toJSON_generic = generic
117− where
118− -- Generic encoding of an algebraic data type.
119− generic a =
120− case dataTypeRep (dataTypeOf a) of
121− -- No constructor, so it must be an error value. Code
122− -- it anyway as Null.
123− AlgRep [] -> Null
124− -- Elide a single constructor and just code the arguments.
125− AlgRep [c] -> encodeArgs c (gmapQ toJSON a)
126− -- For multiple constructors, make an object with a
127− -- field name that is the constructor (except lower
128− -- case) and the data is the arguments encoded.
129− AlgRep _ -> encodeConstr (toConstr a) (gmapQ toJSON a)
130− rep -> err (dataTypeOf a) rep
131− where
132− err dt r = modError "toJSON" $ "not AlgRep " ++
133− show r ++ "(" ++ show dt ++ ")"
134− -- Encode nullary constructor as a string.
135− -- Encode non-nullary constructors as an object with the constructor
136− -- name as the single field and the arguments as the value.
137− -- Use an array if the are no field names, but elide singleton arrays,
138− -- and use an object if there are field names.
139− encodeConstr c [] = String . constrString $ c
140− encodeConstr c as = object [(constrString c, encodeArgs c as)]
141−
142− constrString = pack . showConstr
143−
144− encodeArgs c = encodeArgs' (constrFields c)
145− encodeArgs' [] [j] = j
146− encodeArgs' [] js = Array . V.fromList $ js
147− encodeArgs' ns js = object $ zip (map mungeField ns) js
148−
149− -- Skip leading '_' in field name so we can use keywords
150− -- etc. as field names.
151− mungeField ('_':cs) = pack cs
152− mungeField cs = pack cs
23+import Data.Aeson.Types (Value, Result, genericFromJSON, genericToJSON)
24+import Data.Data (Data)
15325
15426fromJSON :: (Data a) => Value -> Result a
155−fromJSON = parse parseJSON
156−
157−type F a = Parser a
158−
159−parseJSON :: (Data a) => Value -> Parser a
160−parseJSON j = parseJSON_generic j
161− `ext1R` list
162− `ext1R` vector
163− `ext2R'` mapAny
164− `ext2R'` hashMapAny
165− -- Use the standard encoding for all base types.
166− `extR` (value :: F Integer)
167− `extR` (value :: F Int)
168− `extR` (value :: F Int8)
169− `extR` (value :: F Int16)
170− `extR` (value :: F Int32)
171− `extR` (value :: F Int64)
172− `extR` (value :: F Word)
173− `extR` (value :: F Word8)
174− `extR` (value :: F Word16)
175− `extR` (value :: F Word32)
176− `extR` (value :: F Word64)
177− `extR` (value :: F Double)
178− `extR` (value :: F Number)
179− `extR` (value :: F Float)
180− `extR` (value :: F Rational)
181− `extR` (value :: F Char)
182− `extR` (value :: F Text)
183− `extR` (value :: F LT.Text)
184− `extR` (value :: F String)
185− `extR` (value :: F B.ByteString)
186− `extR` (value :: F L.ByteString)
187− `extR` (value :: F T.Value)
188− `extR` (value :: F DotNetTime)
189− `extR` (value :: F UTCTime)
190− `extR` (value :: F IntSet)
191− `extR` (value :: F Bool)
192− `extR` (value :: F ())
193− where
194− value :: (T.FromJSON a) => Parser a
195− value = T.parseJSON j
196− list :: (Data a) => Parser [a]
197− list = V.toList <$> parseJSON j
198− vector :: (Data a) => Parser (V.Vector a)
199− vector = case j of
200− Array js -> V.mapM parseJSON js
201− _ -> myFail
202− mapAny :: forall e f. (Data e, Data f) => Parser (Map.Map f e)
203− mapAny
204− | tyrep `elem` stringyTypes = res
205− | otherwise = myFail
206− where res = case j of
207− Object js -> Map.mapKeysMonotonic trans <$> T.mapM parseJSON js
208− _ -> myFail
209− trans
210− | tyrep == typeOf DT.empty = remap id
211− | tyrep == typeOf LT.empty = remap LT.fromStrict
212− | tyrep == typeOf "" = remap DT.unpack
213− | tyrep == typeOf B.empty = remap encodeUtf8
214− | tyrep == typeOf L.empty = remap lazy
215− | otherwise = modError "parseJSON"
216− "mapAny -- should never happen"
217− tyrep = typeOf (undefined :: f)
218− remap f = fromJust . cast . f
219− hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e)
220− hashMapAny
221− | tyrep == typeOf "" = process DT.unpack
222− | tyrep == typeOf LT.empty = process LT.fromStrict
223− | tyrep == typeOf DT.empty = process id
224− | otherwise = myFail
225− where
226− process f = maybe myFail return . cast =<< parseWith f
227− parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e)
228− parseWith f = case j of
229− Object js -> H.fromList . map (first f) . Map.toList <$>
230− T.mapM parseJSON js
231− _ -> myFail
232− tyrep = typeOf (undefined :: f)
233− myFail = modFail "parseJSON" $ "bad data: " ++ show j
234− stringyTypes = [typeOf LT.empty, typeOf DT.empty, typeOf B.empty,
235− typeOf L.empty, typeOf ""]
236−
237−parseJSON_generic :: (Data a) => Value -> Parser a
238−parseJSON_generic j = generic
239− where
240− typ = dataTypeOf $ resType generic
241− generic = case dataTypeRep typ of
242− AlgRep [] -> case j of
243− Null -> return (modError "parseJSON" "empty type")
244− _ -> modFail "parseJSON" "no-constr bad data"
245− AlgRep [_] -> decodeArgs (indexConstr typ 1) j
246− AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j'
247− rep -> modFail "parseJSON" $
248− show rep ++ "(" ++ show typ ++ ")"
249− getConstr t (Object o) | [(s, j')] <- fromJSObject o = do
250− c <- readConstr' t s
251− return (c, j')
252− getConstr t (String js) = do c <- readConstr' t (unpack js)
253− return (c, Null) -- handle nullary ctor
254− getConstr _ _ = modFail "parseJSON" "bad constructor encoding"
255− readConstr' t s =
256− maybe (modFail "parseJSON" $ "unknown constructor: " ++ s ++ " " ++
257− show t)
258− return $ readConstr t s
259−
260− decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0
261− (constrFields c0)
262− where
263− go 0 c _ Null = construct c [] -- nullary constructor
264− go 1 c [] jd = construct c [jd] -- unary constructor
265− go n c [] (Array js)
266− | n > 1 = construct c (V.toList js) -- no field names
267− -- FIXME? We could allow reading an array into a constructor
268− -- with field names.
269− go _ c fs@(_:_) (Object o) = selectFields o fs >>=
270− construct c -- field names
271− go _ c _ jd = modFail "parseJSON" $
272− "bad decodeArgs data " ++ show (c, jd)
27+fromJSON = genericFromJSON
27328
274− fromJSObject = map (first unpack) . Map.toList
275−
276− -- Build the value by stepping through the list of subparts.
277− construct c = evalStateT $ fromConstrM f c
278− where f :: (Data a) => StateT [Value] Parser a
279− f = do js <- get
280− case js of
281− [] -> lift $ modFail "construct" "empty list"
282− (j':js') -> do put js'; lift $ parseJSON j'
283−
284− -- Select the named fields from a JSON object.
285− selectFields fjs = mapM sel
286− where sel f = maybe (modFail "parseJSON" $ "field does not exist " ++
287− f) return $ Map.lookup (pack f) fjs
288−
289− -- Count how many arguments a constructor has. The value x is
290− -- used to determine what type the constructor returns.
291− numConstrArgs :: (Data a) => a -> Constr -> Int
292− numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0
293− where f = do modify (+1); return undefined
294−
295− resType :: MonadPlus m => m a -> a
296− resType _ = modError "parseJSON" "resType"
297−
298−modFail :: (Monad m) => String -> String -> m a
299−modFail func err = fail $ "Data.Aeson.Generic." ++ func ++ ": " ++ err
300−
301−modError :: String -> String -> a
302−modError func err = error $ "Data.Aeson.Generic." ++ func ++ ": " ++ err
303−
304−
305−-- Type extension for binary type constructors.
306−
307−-- | Flexible type extension
308−ext2' :: (Data a, Typeable2 t)
309− => c a
310− -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
311− -> c a
312−ext2' def ext = maybe def id (dataCast2 ext)
313−
314−-- | Type extension of queries for type constructors
315−ext2Q' :: (Data d, Typeable2 t)
316− => (d -> q)
317− -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
318− -> d -> q
319−ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))
320−
321−-- | Type extension of readers for type constructors
322−ext2R' :: (Monad m, Data d, Typeable2 t)
323− => m d
324− -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))
325− -> m d
326−ext2R' def ext = unR ((R def) `ext2'` (R ext))
327−
328−-- | The type constructor for queries
329−newtype Q q x = Q { unQ :: x -> q }
330−
331−-- | The type constructor for readers
332−newtype R m x = R { unR :: m x }
29+toJSON :: (Data a) => a -> Value
30+toJSON = genericToJSON
Data/Aeson/Types.hs+317−4
@@ -1,6 +1,12 @@
11{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving,
22 IncoherentInstances, OverlappingInstances, OverloadedStrings, Rank2Types,
3− ViewPatterns, FlexibleContexts, UndecidableInstances #-}
3+ ViewPatterns, FlexibleContexts, UndecidableInstances,
4+ ScopedTypeVariables, PatternGuards #-}
5+
6+{-# LANGUAGE CPP #-}
7+#ifdef DEFAULT_SIGNATURES
8+{-# LANGUAGE DefaultSignatures #-}
9+#endif
410
511-- |
612-- Module: Data.Aeson.Types
@@ -38,18 +44,24 @@ module Data.Aeson.Types
3844 , (.:)
3945 , (.:?)
4046 , object
47+ -- * Generic toJSON and fromJSON
48+ , genericToJSON
49+ , genericFromJSON
4150 ) where
4251
4352import Control.Applicative
53+import Control.Arrow (first)
54+import Control.Monad.State.Strict
4455import Control.DeepSeq (NFData(..))
45−import Control.Monad (MonadPlus(..), ap)
4656import Data.Aeson.Functions
4757import Data.Attoparsec.Char8 (Number(..))
48−import Data.Data (Data)
58+import Data.Generics
4959import Data.Hashable (Hashable(..))
5060import Data.Int (Int8, Int16, Int32, Int64)
61+import Data.IntSet (IntSet)
5162import Data.List (foldl')
5263import Data.Map (Map)
64+import Data.Maybe (fromJust)
5365import Data.Monoid (Dual(..), First(..), Last(..))
5466import Data.Monoid (Monoid(..))
5567import Data.Ratio (Ratio)
@@ -58,7 +70,6 @@ import Data.Text (Text, pack, unpack)
5870import Data.Text.Encoding (encodeUtf8)
5971import Data.Time.Clock (UTCTime)
6072import Data.Time.Format (FormatTime, formatTime, parseTime)
61−import Data.Typeable (Typeable)
6273import Data.Vector (Vector)
6374import Data.Word (Word, Word8, Word16, Word32, Word64)
6475import Foreign.Storable (Storable)
@@ -72,6 +83,7 @@ import qualified Data.Map as M
7283import qualified Data.Set as Set
7384import qualified Data.Text as T
7485import qualified Data.Text.Lazy as LT
86+import qualified Data.Traversable as T
7587import qualified Data.Vector as V
7688import qualified Data.Vector.Storable as VS
7789import qualified Data.Vector.Primitive as VP
@@ -301,6 +313,11 @@ object = Object . M.fromList
301313class ToJSON a where
302314 toJSON :: a -> Value
303315
316+#ifdef DEFAULT_SIGNATURES
317+ default toJSON :: Data a => a -> Value
318+ toJSON = genericToJSON
319+#endif
320+
304321-- | A type that can be converted from JSON, with the possibility of
305322-- failure.
306323--
@@ -325,6 +342,11 @@ class ToJSON a where
325342class FromJSON a where
326343 parseJSON :: Value -> Parser a
327344
345+#ifdef DEFAULT_SIGNATURES
346+ default parseJSON :: Data a => Value -> Parser a
347+ parseJSON = genericParseJSON
348+#endif
349+
328350instance (ToJSON a) => ToJSON (Maybe a) where
329351 toJSON (Just a) = toJSON a
330352 toJSON Nothing = Null
@@ -811,3 +833,294 @@ typeMismatch expected actual =
811833 Number _ -> "Number"
812834 Bool _ -> "Boolean"
813835 Null -> "Null"
836+
837+
838+--------------------------------------------------------------------------------
839+-- Generic toJSON and fromJSON
840+
841+type T a = a -> Value
842+
843+genericToJSON :: (Data a) => a -> Value
844+genericToJSON = toJSON_generic
845+ `ext1Q` list
846+ `ext1Q` vector
847+ `ext1Q` set
848+ `ext2Q'` mapAny
849+ `ext2Q'` hashMapAny
850+ -- Use the standard encoding for all base types.
851+ `extQ` (toJSON :: T Integer)
852+ `extQ` (toJSON :: T Int)
853+ `extQ` (toJSON :: T Int8)
854+ `extQ` (toJSON :: T Int16)
855+ `extQ` (toJSON :: T Int32)
856+ `extQ` (toJSON :: T Int64)
857+ `extQ` (toJSON :: T Word)
858+ `extQ` (toJSON :: T Word8)
859+ `extQ` (toJSON :: T Word16)
860+ `extQ` (toJSON :: T Word32)
861+ `extQ` (toJSON :: T Word64)
862+ `extQ` (toJSON :: T Double)
863+ `extQ` (toJSON :: T Number)
864+ `extQ` (toJSON :: T Float)
865+ `extQ` (toJSON :: T Rational)
866+ `extQ` (toJSON :: T Char)
867+ `extQ` (toJSON :: T Text)
868+ `extQ` (toJSON :: T LT.Text)
869+ `extQ` (toJSON :: T String)
870+ `extQ` (toJSON :: T B.ByteString)
871+ `extQ` (toJSON :: T LB.ByteString)
872+ `extQ` (toJSON :: T Value)
873+ `extQ` (toJSON :: T DotNetTime)
874+ `extQ` (toJSON :: T UTCTime)
875+ `extQ` (toJSON :: T IntSet)
876+ `extQ` (toJSON :: T Bool)
877+ `extQ` (toJSON :: T ())
878+ --`extQ` (T.toJSON :: T Ordering)
879+ where
880+ list xs = Array . V.fromList . map genericToJSON $ xs
881+ vector v = Array . V.map genericToJSON $ v
882+ set s = Array . V.fromList . map genericToJSON . Set.toList $ s
883+
884+ mapAny m
885+ | tyrep == typeOf T.empty = remap id
886+ | tyrep == typeOf LT.empty = remap LT.toStrict
887+ | tyrep == typeOf string = remap pack
888+ | tyrep == typeOf B.empty = remap decode
889+ | tyrep == typeOf LB.empty = remap strict
890+ | otherwise = modError "genericToJSON" $
891+ "cannot convert map keyed by type " ++ show tyrep
892+ where tyrep = typeOf . head . M.keys $ m
893+ remap f = Object . transformMap (f . fromJust . cast) genericToJSON $ m
894+
895+ hashMapAny m
896+ | tyrep == typeOf T.empty = remap id
897+ | tyrep == typeOf LT.empty = remap LT.toStrict
898+ | tyrep == typeOf string = remap pack
899+ | tyrep == typeOf B.empty = remap decode
900+ | tyrep == typeOf LB.empty = remap strict
901+ | otherwise = modError "genericToJSON" $
902+ "cannot convert map keyed by type " ++ show tyrep
903+ where tyrep = typeOf . head . H.keys $ m
904+ remap f = Object . hashMap (f . fromJust . cast) genericToJSON $ m
905+
906+
907+toJSON_generic :: (Data a) => a -> Value
908+toJSON_generic = generic
909+ where
910+ -- Generic encoding of an algebraic data type.
911+ generic a =
912+ case dataTypeRep (dataTypeOf a) of
913+ -- No constructor, so it must be an error value. Code
914+ -- it anyway as Null.
915+ AlgRep [] -> Null
916+ -- Elide a single constructor and just code the arguments.
917+ AlgRep [c] -> encodeArgs c (gmapQ genericToJSON a)
918+ -- For multiple constructors, make an object with a
919+ -- field name that is the constructor (except lower
920+ -- case) and the data is the arguments encoded.
921+ AlgRep _ -> encodeConstr (toConstr a) (gmapQ genericToJSON a)
922+ rep -> err (dataTypeOf a) rep
923+ where
924+ err dt r = modError "genericToJSON" $ "not AlgRep " ++
925+ show r ++ "(" ++ show dt ++ ")"
926+ -- Encode nullary constructor as a string.
927+ -- Encode non-nullary constructors as an object with the constructor
928+ -- name as the single field and the arguments as the value.
929+ -- Use an array if the are no field names, but elide singleton arrays,
930+ -- and use an object if there are field names.
931+ encodeConstr c [] = String . constrString $ c
932+ encodeConstr c as = object [(constrString c, encodeArgs c as)]
933+
934+ constrString = pack . showConstr
935+
936+ encodeArgs c = encodeArgs' (constrFields c)
937+ encodeArgs' [] [j] = j
938+ encodeArgs' [] js = Array . V.fromList $ js
939+ encodeArgs' ns js = object $ zip (map mungeField ns) js
940+
941+ -- Skip leading '_' in field name so we can use keywords
942+ -- etc. as field names.
943+ mungeField ('_':cs) = pack cs
944+ mungeField cs = pack cs
945+
946+genericFromJSON :: (Data a) => Value -> Result a
947+genericFromJSON = parse genericParseJSON
948+
949+type F a = Parser a
950+
951+genericParseJSON :: (Data a) => Value -> Parser a
952+genericParseJSON j = parseJSON_generic j
953+ `ext1R` list
954+ `ext1R` vector
955+ `ext2R'` mapAny
956+ `ext2R'` hashMapAny
957+ -- Use the standard encoding for all base types.
958+ `extR` (value :: F Integer)
959+ `extR` (value :: F Int)
960+ `extR` (value :: F Int8)
961+ `extR` (value :: F Int16)
962+ `extR` (value :: F Int32)
963+ `extR` (value :: F Int64)
964+ `extR` (value :: F Word)
965+ `extR` (value :: F Word8)
966+ `extR` (value :: F Word16)
967+ `extR` (value :: F Word32)
968+ `extR` (value :: F Word64)
969+ `extR` (value :: F Double)
970+ `extR` (value :: F Number)
971+ `extR` (value :: F Float)
972+ `extR` (value :: F Rational)
973+ `extR` (value :: F Char)
974+ `extR` (value :: F Text)
975+ `extR` (value :: F LT.Text)
976+ `extR` (value :: F String)
977+ `extR` (value :: F B.ByteString)
978+ `extR` (value :: F LB.ByteString)
979+ `extR` (value :: F Value)
980+ `extR` (value :: F DotNetTime)
981+ `extR` (value :: F UTCTime)
982+ `extR` (value :: F IntSet)
983+ `extR` (value :: F Bool)
984+ `extR` (value :: F ())
985+ where
986+ value :: (FromJSON a) => Parser a
987+ value = parseJSON j
988+ list :: (Data a) => Parser [a]
989+ list = V.toList <$> genericParseJSON j
990+ vector :: (Data a) => Parser (V.Vector a)
991+ vector = case j of
992+ Array js -> V.mapM genericParseJSON js
993+ _ -> myFail
994+ mapAny :: forall e f. (Data e, Data f) => Parser (Map f e)
995+ mapAny
996+ | tyrep `elem` stringyTypes = res
997+ | otherwise = myFail
998+ where res = case j of
999+ Object js -> M.mapKeysMonotonic trans <$> T.mapM genericParseJSON js
1000+ _ -> myFail
1001+ trans
1002+ | tyrep == typeOf T.empty = remap id
1003+ | tyrep == typeOf LT.empty = remap LT.fromStrict
1004+ | tyrep == typeOf string = remap T.unpack
1005+ | tyrep == typeOf B.empty = remap encodeUtf8
1006+ | tyrep == typeOf LB.empty = remap lazy
1007+ | otherwise = modError "genericParseJSON"
1008+ "mapAny -- should never happen"
1009+ tyrep = typeOf (undefined :: f)
1010+ remap f = fromJust . cast . f
1011+ hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e)
1012+ hashMapAny
1013+ | tyrep == typeOf string = process T.unpack
1014+ | tyrep == typeOf LT.empty = process LT.fromStrict
1015+ | tyrep == typeOf T.empty = process id
1016+ | otherwise = myFail
1017+ where
1018+ process f = maybe myFail return . cast =<< parseWith f
1019+ parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e)
1020+ parseWith f = case j of
1021+ Object js -> H.fromList . map (first f) . M.toList <$>
1022+ T.mapM genericParseJSON js
1023+ _ -> myFail
1024+ tyrep = typeOf (undefined :: f)
1025+ myFail = modFail "genericParseJSON" $ "bad data: " ++ show j
1026+ stringyTypes = [typeOf LT.empty, typeOf T.empty, typeOf B.empty,
1027+ typeOf LB.empty, typeOf string]
1028+
1029+parseJSON_generic :: (Data a) => Value -> Parser a
1030+parseJSON_generic j = generic
1031+ where
1032+ typ = dataTypeOf $ resType generic
1033+ generic = case dataTypeRep typ of
1034+ AlgRep [] -> case j of
1035+ Null -> return (modError "genericParseJSON" "empty type")
1036+ _ -> modFail "genericParseJSON" "no-constr bad data"
1037+ AlgRep [_] -> decodeArgs (indexConstr typ 1) j
1038+ AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j'
1039+ rep -> modFail "genericParseJSON" $
1040+ show rep ++ "(" ++ show typ ++ ")"
1041+ getConstr t (Object o) | [(s, j')] <- fromJSObject o = do
1042+ c <- readConstr' t s
1043+ return (c, j')
1044+ getConstr t (String js) = do c <- readConstr' t (unpack js)
1045+ return (c, Null) -- handle nullary ctor
1046+ getConstr _ _ = modFail "genericParseJSON" "bad constructor encoding"
1047+ readConstr' t s =
1048+ maybe (modFail "genericParseJSON" $ "unknown constructor: " ++ s ++ " " ++
1049+ show t)
1050+ return $ readConstr t s
1051+
1052+ decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0
1053+ (constrFields c0)
1054+ where
1055+ go 0 c _ Null = construct c [] -- nullary constructor
1056+ go 1 c [] jd = construct c [jd] -- unary constructor
1057+ go n c [] (Array js)
1058+ | n > 1 = construct c (V.toList js) -- no field names
1059+ -- FIXME? We could allow reading an array into a constructor
1060+ -- with field names.
1061+ go _ c fs@(_:_) (Object o) = selectFields o fs >>=
1062+ construct c -- field names
1063+ go _ c _ jd = modFail "genericParseJSON" $
1064+ "bad decodeArgs data " ++ show (c, jd)
1065+
1066+ fromJSObject = map (first unpack) . M.toList
1067+
1068+ -- Build the value by stepping through the list of subparts.
1069+ construct c = evalStateT $ fromConstrM f c
1070+ where f :: (Data a) => StateT [Value] Parser a
1071+ f = do js <- get
1072+ case js of
1073+ [] -> lift $ modFail "construct" "empty list"
1074+ (j':js') -> do put js'; lift $ genericParseJSON j'
1075+
1076+ -- Select the named fields from a JSON object.
1077+ selectFields fjs = mapM sel
1078+ where sel f = maybe (modFail "genericParseJSON" $ "field does not exist " ++
1079+ f) return $ M.lookup (pack f) fjs
1080+
1081+ -- Count how many arguments a constructor has. The value x is
1082+ -- used to determine what type the constructor returns.
1083+ numConstrArgs :: (Data a) => a -> Constr -> Int
1084+ numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0
1085+ where f = do modify (+1); return undefined
1086+
1087+ resType :: MonadPlus m => m a -> a
1088+ resType _ = modError "genericParseJSON" "resType"
1089+
1090+modFail :: (Monad m) => String -> String -> m a
1091+modFail func err = fail $ "Data.Aeson.Types." ++ func ++ ": " ++ err
1092+
1093+modError :: String -> String -> a
1094+modError func err = error $ "Data.Aeson.Types." ++ func ++ ": " ++ err
1095+
1096+string :: String
1097+string = ""
1098+
1099+-- Type extension for binary type constructors.
1100+
1101+-- | Flexible type extension
1102+ext2' :: (Data a, Typeable2 t)
1103+ => c a
1104+ -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
1105+ -> c a
1106+ext2' def ext = maybe def id (dataCast2 ext)
1107+
1108+-- | Type extension of queries for type constructors
1109+ext2Q' :: (Data d, Typeable2 t)
1110+ => (d -> q)
1111+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
1112+ -> d -> q
1113+ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))
1114+
1115+-- | Type extension of readers for type constructors
1116+ext2R' :: (Monad m, Data d, Typeable2 t)
1117+ => m d
1118+ -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))
1119+ -> m d
1120+ext2R' def ext = unR ((R def) `ext2'` (R ext))
1121+
1122+-- | The type constructor for queries
1123+newtype Q q x = Q { unQ :: x -> q }
1124+
1125+-- | The type constructor for readers
1126+newtype R m x = R { unR :: m x }
aeson.cabal+3
@@ -136,6 +136,9 @@ library
136136 ghc-options: -Werror
137137 ghc-prof-options: -auto-all
138138
139+ if(impl(ghc >= 7.2.1))
140+ cpp-options: -DDEFAULT_SIGNATURES
141+
139142 ghc-options: -Wall
140143
141144source-repository head