git.iko.soy/typeable/aeson
on master help sign in
Merge
commitcbd6d66653babda631368985a84d685a85941b8e authorBryan O'Sullivan <bos@serpentine.com> dateSun 21 Aug 2011, 22:49 (15 years ago) parent47928390cdeabf
3 files changed+358−311
compare with master
unifiedsplit
Data/Aeson/Generic.hs+5−307 Data/Aeson/Types.hs+350−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+350−4
@@ -1,6 +1,12 @@
11{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving,
22 IncoherentInstances, OverlappingInstances, OverloadedStrings, Rank2Types,
3− ViewPatterns #-}
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,9 +70,9 @@ 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)
75+import Foreign.Storable (Storable)
6476import System.Locale (defaultTimeLocale)
6577import qualified Data.ByteString as B
6678import qualified Data.ByteString.Lazy as LB
@@ -71,7 +83,13 @@ import qualified Data.Map as M
7183import qualified Data.Set as Set
7284import qualified Data.Text as T
7385import qualified Data.Text.Lazy as LT
86+import qualified Data.Traversable as T
7487import qualified Data.Vector as V
88+import qualified Data.Vector.Storable as VS
89+import qualified Data.Vector.Primitive as VP
90+import qualified Data.Vector.Unboxed as VU
91+import qualified Data.Vector.Generic as VG
92+
7593
7694-- | The result of running a 'Parser'.
7795data Result a = Error String
@@ -295,6 +313,11 @@ object = Object . M.fromList
295313class ToJSON a where
296314 toJSON :: a -> Value
297315
316+#ifdef DEFAULT_SIGNATURES
317+ default toJSON :: Data a => a -> Value
318+ toJSON = genericToJSON
319+#endif
320+
298321-- | A type that can be converted from JSON, with the possibility of
299322-- failure.
300323--
@@ -319,6 +342,11 @@ class ToJSON a where
319342class FromJSON a where
320343 parseJSON :: Value -> Parser a
321344
345+#ifdef DEFAULT_SIGNATURES
346+ default parseJSON :: Data a => Value -> Parser a
347+ parseJSON = genericParseJSON
348+#endif
349+
322350instance (ToJSON a) => ToJSON (Maybe a) where
323351 toJSON (Just a) = toJSON a
324352 toJSON Nothing = Null
@@ -574,6 +602,33 @@ instance (FromJSON a) => FromJSON (Vector a) where
574602 parseJSON v = typeMismatch "Vector a" v
575603 {-# INLINE parseJSON #-}
576604
605+vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value
606+vectorToJSON = Array . V.map toJSON . V.convert
607+{-# INLINE vectorToJSON #-}
608+
609+vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)
610+vectorParseJSON _ (Array a) = V.convert <$> V.mapM parseJSON a
611+vectorParseJSON s v = typeMismatch s v
612+{-# INLINE vectorParseJSON #-}
613+
614+instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where
615+ toJSON = vectorToJSON
616+
617+instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
618+ parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"
619+
620+instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where
621+ toJSON = vectorToJSON
622+
623+instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
624+ parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"
625+
626+instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where
627+ toJSON = vectorToJSON
628+
629+instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
630+ parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"
631+
577632instance (ToJSON a) => ToJSON (Set.Set a) where
578633 toJSON = toJSON . Set.toList
579634 {-# INLINE toJSON #-}
@@ -778,3 +833,294 @@ typeMismatch expected actual =
778833 Number _ -> "Number"
779834 Bool _ -> "Boolean"
780835 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