1. Bryan O'Sullivan
  2. aeson

Commits

basvandijk  committed 8c9985b

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.

  • Participants
  • Parent commits 400f3c2
  • Branches default

Comments (0)

Files changed (3)

File Data/Aeson/Generic.hs

View file
     , toJSON
     ) where
 
-import Control.Applicative ((<$>))
-import Control.Arrow (first)
-import Control.Monad.State.Strict
-import Data.Aeson.Functions
-import Data.Aeson.Types hiding (FromJSON(..), ToJSON(..), fromJSON)
-import Data.Attoparsec.Number (Number)
-import Data.Generics
-import Data.Hashable (Hashable)
-import Data.Int (Int8, Int16, Int32, Int64)
-import Data.IntSet (IntSet)
-import Data.Maybe (fromJust)
-import Data.Text (Text, pack, unpack)
-import Data.Text.Encoding (encodeUtf8)
-import Data.Time.Clock (UTCTime)
-import Data.Word (Word, Word8, Word16, Word32, Word64)
-import qualified Data.Aeson.Types as T
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as L
-import qualified Data.HashMap.Strict as H
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.Text as DT
-import qualified Data.Text.Lazy as LT
-import qualified Data.Traversable as T
-import qualified Data.Vector as V
+import Data.Aeson.Types (Value, Result, genericFromJSON, genericToJSON)
+import Data.Data (Data)
 
-type T a = a -> Value
+fromJSON :: (Data a) => Value -> Result a
+fromJSON = genericFromJSON
 
 toJSON :: (Data a) => a -> Value
-toJSON = toJSON_generic
-         `ext1Q` list
-         `ext1Q` vector
-         `ext1Q` set
-         `ext2Q'` mapAny
-         `ext2Q'` hashMapAny
-         -- Use the standard encoding for all base types.
-         `extQ` (T.toJSON :: T Integer)
-         `extQ` (T.toJSON :: T Int)
-         `extQ` (T.toJSON :: T Int8)
-         `extQ` (T.toJSON :: T Int16)
-         `extQ` (T.toJSON :: T Int32)
-         `extQ` (T.toJSON :: T Int64)
-         `extQ` (T.toJSON :: T Word)
-         `extQ` (T.toJSON :: T Word8)
-         `extQ` (T.toJSON :: T Word16)
-         `extQ` (T.toJSON :: T Word32)
-         `extQ` (T.toJSON :: T Word64)
-         `extQ` (T.toJSON :: T Double)
-         `extQ` (T.toJSON :: T Number)
-         `extQ` (T.toJSON :: T Float)
-         `extQ` (T.toJSON :: T Rational)
-         `extQ` (T.toJSON :: T Char)
-         `extQ` (T.toJSON :: T Text)
-         `extQ` (T.toJSON :: T LT.Text)
-         `extQ` (T.toJSON :: T String)
-         `extQ` (T.toJSON :: T B.ByteString)
-         `extQ` (T.toJSON :: T L.ByteString)
-         `extQ` (T.toJSON :: T T.Value)
-         `extQ` (T.toJSON :: T DotNetTime)
-         `extQ` (T.toJSON :: T UTCTime)
-         `extQ` (T.toJSON :: T IntSet)
-         `extQ` (T.toJSON :: T Bool)
-         `extQ` (T.toJSON :: T ())
-         --`extQ` (T.toJSON :: T Ordering)
-  where
-    list xs = Array . V.fromList . map toJSON $ xs
-    vector v = Array . V.map toJSON $ v
-    set s = Array . V.fromList . map toJSON . Set.toList $ s
-
-    mapAny m
-      | tyrep == typeOf DT.empty = remap id
-      | tyrep == typeOf LT.empty = remap LT.toStrict
-      | tyrep == typeOf ""       = remap pack
-      | tyrep == typeOf B.empty  = remap decode
-      | tyrep == typeOf L.empty  = remap strict
-      | otherwise = modError "toJSON" $
-                             "cannot convert map keyed by type " ++ show tyrep
-      where tyrep = typeOf . head . Map.keys $ m
-            remap f = Object . transformMap (f . fromJust . cast) toJSON $ m
-
-    hashMapAny m
-      | tyrep == typeOf DT.empty = remap id
-      | tyrep == typeOf LT.empty = remap LT.toStrict
-      | tyrep == typeOf ""       = remap pack
-      | tyrep == typeOf B.empty  = remap decode
-      | tyrep == typeOf L.empty  = remap strict
-      | otherwise = modError "toJSON" $
-                             "cannot convert map keyed by type " ++ show tyrep
-      where tyrep = typeOf . head . H.keys $ m
-            remap f = Object . hashMap (f . fromJust . cast) toJSON $ m
-
-
-toJSON_generic :: (Data a) => a -> Value
-toJSON_generic = generic
-  where
-        -- Generic encoding of an algebraic data type.
-        generic a =
-            case dataTypeRep (dataTypeOf a) of
-                -- No constructor, so it must be an error value.  Code
-                -- it anyway as Null.
-                AlgRep []  -> Null
-                -- Elide a single constructor and just code the arguments.
-                AlgRep [c] -> encodeArgs c (gmapQ toJSON a)
-                -- For multiple constructors, make an object with a
-                -- field name that is the constructor (except lower
-                -- case) and the data is the arguments encoded.
-                AlgRep _   -> encodeConstr (toConstr a) (gmapQ toJSON a)
-                rep        -> err (dataTypeOf a) rep
-           where
-              err dt r = modError "toJSON" $ "not AlgRep " ++
-                                  show r ++ "(" ++ show dt ++ ")"
-        -- Encode nullary constructor as a string.
-        -- Encode non-nullary constructors as an object with the constructor
-        -- name as the single field and the arguments as the value.
-        -- Use an array if the are no field names, but elide singleton arrays,
-        -- and use an object if there are field names.
-        encodeConstr c [] = String . constrString $ c
-        encodeConstr c as = object [(constrString c, encodeArgs c as)]
-
-        constrString = pack . showConstr
-
-        encodeArgs c = encodeArgs' (constrFields c)
-        encodeArgs' [] [j] = j
-        encodeArgs' [] js  = Array . V.fromList $ js
-        encodeArgs' ns js  = object $ zip (map mungeField ns) js
-
-        -- Skip leading '_' in field name so we can use keywords
-        -- etc. as field names.
-        mungeField ('_':cs) = pack cs
-        mungeField cs       = pack cs
-
-fromJSON :: (Data a) => Value -> Result a
-fromJSON = parse parseJSON
-
-type F a = Parser a
-
-parseJSON :: (Data a) => Value -> Parser a
-parseJSON j = parseJSON_generic j
-             `ext1R` list
-             `ext1R` vector
-             `ext2R'` mapAny
-             `ext2R'` hashMapAny
-             -- Use the standard encoding for all base types.
-             `extR` (value :: F Integer)
-             `extR` (value :: F Int)
-             `extR` (value :: F Int8)
-             `extR` (value :: F Int16)
-             `extR` (value :: F Int32)
-             `extR` (value :: F Int64)
-             `extR` (value :: F Word)
-             `extR` (value :: F Word8)
-             `extR` (value :: F Word16)
-             `extR` (value :: F Word32)
-             `extR` (value :: F Word64)
-             `extR` (value :: F Double)
-             `extR` (value :: F Number)
-             `extR` (value :: F Float)
-             `extR` (value :: F Rational)
-             `extR` (value :: F Char)
-             `extR` (value :: F Text)
-             `extR` (value :: F LT.Text)
-             `extR` (value :: F String)
-             `extR` (value :: F B.ByteString)
-             `extR` (value :: F L.ByteString)
-             `extR` (value :: F T.Value)
-             `extR` (value :: F DotNetTime)
-             `extR` (value :: F UTCTime)
-             `extR` (value :: F IntSet)
-             `extR` (value :: F Bool)
-             `extR` (value :: F ())
-  where
-    value :: (T.FromJSON a) => Parser a
-    value = T.parseJSON j
-    list :: (Data a) => Parser [a]
-    list = V.toList <$> parseJSON j
-    vector :: (Data a) => Parser (V.Vector a)
-    vector = case j of
-               Array js -> V.mapM parseJSON js
-               _        -> myFail
-    mapAny :: forall e f. (Data e, Data f) => Parser (Map.Map f e)
-    mapAny
-        | tyrep `elem` stringyTypes = res
-        | otherwise = myFail
-      where res = case j of
-                Object js -> Map.mapKeysMonotonic trans <$> T.mapM parseJSON js
-                _         -> myFail
-            trans
-               | tyrep == typeOf DT.empty = remap id
-               | tyrep == typeOf LT.empty = remap LT.fromStrict
-               | tyrep == typeOf ""       = remap DT.unpack
-               | tyrep == typeOf B.empty  = remap encodeUtf8
-               | tyrep == typeOf L.empty  = remap lazy
-               | otherwise = modError "parseJSON"
-                                      "mapAny -- should never happen"
-            tyrep = typeOf (undefined :: f)
-            remap f = fromJust . cast . f
-    hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e)
-    hashMapAny
-        | tyrep == typeOf ""       = process DT.unpack
-        | tyrep == typeOf LT.empty = process LT.fromStrict
-        | tyrep == typeOf DT.empty = process id
-        | otherwise = myFail
-      where
-        process f = maybe myFail return . cast =<< parseWith f
-        parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e)
-        parseWith f = case j of
-                        Object js -> H.fromList . map (first f) . Map.toList <$>
-                                     T.mapM parseJSON js
-                        _          -> myFail
-        tyrep = typeOf (undefined :: f)
-    myFail = modFail "parseJSON" $ "bad data: " ++ show j
-    stringyTypes = [typeOf LT.empty, typeOf DT.empty, typeOf B.empty, 
-                    typeOf L.empty, typeOf ""]
-
-parseJSON_generic :: (Data a) => Value -> Parser a
-parseJSON_generic j = generic
-  where
-        typ = dataTypeOf $ resType generic
-        generic = case dataTypeRep typ of
-                    AlgRep []  -> case j of
-                                    Null -> return (modError "parseJSON" "empty type")
-                                    _ -> modFail "parseJSON" "no-constr bad data"
-                    AlgRep [_] -> decodeArgs (indexConstr typ 1) j
-                    AlgRep _   -> do (c, j') <- getConstr typ j; decodeArgs c j'
-                    rep        -> modFail "parseJSON" $
-                                  show rep ++ "(" ++ show typ ++ ")"
-        getConstr t (Object o) | [(s, j')] <- fromJSObject o = do
-                                                c <- readConstr' t s
-                                                return (c, j')
-        getConstr t (String js) = do c <- readConstr' t (unpack js)
-                                     return (c, Null) -- handle nullary ctor
-        getConstr _ _ = modFail "parseJSON" "bad constructor encoding"
-        readConstr' t s =
-          maybe (modFail "parseJSON" $ "unknown constructor: " ++ s ++ " " ++
-                         show t)
-                return $ readConstr t s
-
-        decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0
-                           (constrFields c0)
-         where
-          go 0 c  _       Null       = construct c []   -- nullary constructor
-          go 1 c []       jd         = construct c [jd] -- unary constructor
-          go n c []       (Array js)
-              | n > 1 = construct c (V.toList js)   -- no field names
-          -- FIXME? We could allow reading an array into a constructor
-          -- with field names.
-          go _ c fs@(_:_) (Object o) = selectFields o fs >>=
-                                       construct c -- field names
-          go _ c _        jd         = modFail "parseJSON" $
-                                       "bad decodeArgs data " ++ show (c, jd)
-
-        fromJSObject = map (first unpack) . Map.toList
-
-        -- Build the value by stepping through the list of subparts.
-        construct c = evalStateT $ fromConstrM f c
-          where f :: (Data a) => StateT [Value] Parser a
-                f = do js <- get
-                       case js of
-                         [] -> lift $ modFail "construct" "empty list"
-                         (j':js') -> do put js'; lift $ parseJSON j'
-
-        -- Select the named fields from a JSON object.
-        selectFields fjs = mapM sel
-          where sel f = maybe (modFail "parseJSON" $ "field does not exist " ++
-                               f) return $ Map.lookup (pack f) fjs
-
-        -- Count how many arguments a constructor has.  The value x is
-        -- used to determine what type the constructor returns.
-        numConstrArgs :: (Data a) => a -> Constr -> Int
-        numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0
-          where f = do modify (+1); return undefined
-
-        resType :: MonadPlus m => m a -> a
-        resType _ = modError "parseJSON" "resType"
-
-modFail :: (Monad m) => String -> String -> m a
-modFail func err = fail $ "Data.Aeson.Generic." ++ func ++ ": " ++ err
-
-modError :: String -> String -> a
-modError func err = error $ "Data.Aeson.Generic." ++ func ++ ": " ++ err
-
-
--- Type extension for binary type constructors.
-
--- | Flexible type extension
-ext2' :: (Data a, Typeable2 t)
-     => c a
-     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
-     -> c a
-ext2' def ext = maybe def id (dataCast2 ext)
-
--- | Type extension of queries for type constructors
-ext2Q' :: (Data d, Typeable2 t)
-      => (d -> q)
-      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
-      -> d -> q
-ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))
-
--- | Type extension of readers for type constructors
-ext2R' :: (Monad m, Data d, Typeable2 t)
-      => m d
-      -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))
-      -> m d
-ext2R' def ext = unR ((R def) `ext2'` (R ext))
-
--- | The type constructor for queries
-newtype Q q x = Q { unQ :: x -> q }
-
--- | The type constructor for readers
-newtype R m x = R { unR :: m x }
+toJSON = genericToJSON

File Data/Aeson/Types.hs

View file
 {-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving,
     IncoherentInstances, OverlappingInstances, OverloadedStrings, Rank2Types,
-    ViewPatterns, FlexibleContexts, UndecidableInstances #-}
+    ViewPatterns, FlexibleContexts, UndecidableInstances,
+    ScopedTypeVariables, PatternGuards #-}
+
+{-# LANGUAGE CPP #-}
+#ifdef DEFAULT_SIGNATURES
+{-# LANGUAGE DefaultSignatures #-}
+#endif
 
 -- |
 -- Module:      Data.Aeson.Types
     , (.:)
     , (.:?)
     , object
+    -- * Generic toJSON and fromJSON
+    , genericToJSON
+    , genericFromJSON
     ) where
 
 import Control.Applicative
+import Control.Arrow (first)
+import Control.Monad.State.Strict
 import Control.DeepSeq (NFData(..))
-import Control.Monad (MonadPlus(..), ap)
 import Data.Aeson.Functions
 import Data.Attoparsec.Char8 (Number(..))
-import Data.Data (Data)
+import Data.Generics
 import Data.Hashable (Hashable(..))
 import Data.Int (Int8, Int16, Int32, Int64)
+import Data.IntSet (IntSet)
 import Data.List (foldl')
 import Data.Map (Map)
+import Data.Maybe (fromJust)
 import Data.Monoid (Dual(..), First(..), Last(..))
 import Data.Monoid (Monoid(..))
 import Data.Ratio (Ratio)
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Time.Format (FormatTime, formatTime, parseTime)
-import Data.Typeable (Typeable)
 import Data.Vector (Vector)
 import Data.Word (Word, Word8, Word16, Word32, Word64)
 import Foreign.Storable (Storable)
 import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as LT
+import qualified Data.Traversable as T
 import qualified Data.Vector as V
 import qualified Data.Vector.Storable as VS
 import qualified Data.Vector.Primitive as VP
 class ToJSON a where
     toJSON   :: a -> Value
 
+#ifdef DEFAULT_SIGNATURES
+    default toJSON :: Data a => a -> Value
+    toJSON = genericToJSON
+#endif
+
 -- | A type that can be converted from JSON, with the possibility of
 -- failure.
 --
 class FromJSON a where
     parseJSON :: Value -> Parser a
 
+#ifdef DEFAULT_SIGNATURES
+    default parseJSON :: Data a => Value -> Parser a
+    parseJSON = genericParseJSON
+#endif
+
 instance (ToJSON a) => ToJSON (Maybe a) where
     toJSON (Just a) = toJSON a
     toJSON Nothing  = Null
              Number _ -> "Number"
              Bool _   -> "Boolean"
              Null     -> "Null"
+
+
+--------------------------------------------------------------------------------
+-- Generic toJSON and fromJSON
+
+type T a = a -> Value
+
+genericToJSON :: (Data a) => a -> Value
+genericToJSON = toJSON_generic
+         `ext1Q` list
+         `ext1Q` vector
+         `ext1Q` set
+         `ext2Q'` mapAny
+         `ext2Q'` hashMapAny
+         -- Use the standard encoding for all base types.
+         `extQ` (toJSON :: T Integer)
+         `extQ` (toJSON :: T Int)
+         `extQ` (toJSON :: T Int8)
+         `extQ` (toJSON :: T Int16)
+         `extQ` (toJSON :: T Int32)
+         `extQ` (toJSON :: T Int64)
+         `extQ` (toJSON :: T Word)
+         `extQ` (toJSON :: T Word8)
+         `extQ` (toJSON :: T Word16)
+         `extQ` (toJSON :: T Word32)
+         `extQ` (toJSON :: T Word64)
+         `extQ` (toJSON :: T Double)
+         `extQ` (toJSON :: T Number)
+         `extQ` (toJSON :: T Float)
+         `extQ` (toJSON :: T Rational)
+         `extQ` (toJSON :: T Char)
+         `extQ` (toJSON :: T Text)
+         `extQ` (toJSON :: T LT.Text)
+         `extQ` (toJSON :: T String)
+         `extQ` (toJSON :: T B.ByteString)
+         `extQ` (toJSON :: T LB.ByteString)
+         `extQ` (toJSON :: T Value)
+         `extQ` (toJSON :: T DotNetTime)
+         `extQ` (toJSON :: T UTCTime)
+         `extQ` (toJSON :: T IntSet)
+         `extQ` (toJSON :: T Bool)
+         `extQ` (toJSON :: T ())
+         --`extQ` (T.toJSON :: T Ordering)
+  where
+    list xs = Array . V.fromList . map genericToJSON $ xs
+    vector v = Array . V.map genericToJSON $ v
+    set s = Array . V.fromList . map genericToJSON . Set.toList $ s
+
+    mapAny m
+      | tyrep == typeOf T.empty  = remap id
+      | tyrep == typeOf LT.empty = remap LT.toStrict
+      | tyrep == typeOf string   = remap pack
+      | tyrep == typeOf B.empty  = remap decode
+      | tyrep == typeOf LB.empty = remap strict
+      | otherwise = modError "genericToJSON" $
+                             "cannot convert map keyed by type " ++ show tyrep
+      where tyrep = typeOf . head . M.keys $ m
+            remap f = Object . transformMap (f . fromJust . cast) genericToJSON $ m
+
+    hashMapAny m
+      | tyrep == typeOf T.empty  = remap id
+      | tyrep == typeOf LT.empty = remap LT.toStrict
+      | tyrep == typeOf string   = remap pack
+      | tyrep == typeOf B.empty  = remap decode
+      | tyrep == typeOf LB.empty = remap strict
+      | otherwise = modError "genericToJSON" $
+                             "cannot convert map keyed by type " ++ show tyrep
+      where tyrep = typeOf . head . H.keys $ m
+            remap f = Object . hashMap (f . fromJust . cast) genericToJSON $ m
+
+
+toJSON_generic :: (Data a) => a -> Value
+toJSON_generic = generic
+  where
+        -- Generic encoding of an algebraic data type.
+        generic a =
+            case dataTypeRep (dataTypeOf a) of
+                -- No constructor, so it must be an error value.  Code
+                -- it anyway as Null.
+                AlgRep []  -> Null
+                -- Elide a single constructor and just code the arguments.
+                AlgRep [c] -> encodeArgs c (gmapQ genericToJSON a)
+                -- For multiple constructors, make an object with a
+                -- field name that is the constructor (except lower
+                -- case) and the data is the arguments encoded.
+                AlgRep _   -> encodeConstr (toConstr a) (gmapQ genericToJSON a)
+                rep        -> err (dataTypeOf a) rep
+           where
+              err dt r = modError "genericToJSON" $ "not AlgRep " ++
+                                  show r ++ "(" ++ show dt ++ ")"
+        -- Encode nullary constructor as a string.
+        -- Encode non-nullary constructors as an object with the constructor
+        -- name as the single field and the arguments as the value.
+        -- Use an array if the are no field names, but elide singleton arrays,
+        -- and use an object if there are field names.
+        encodeConstr c [] = String . constrString $ c
+        encodeConstr c as = object [(constrString c, encodeArgs c as)]
+
+        constrString = pack . showConstr
+
+        encodeArgs c = encodeArgs' (constrFields c)
+        encodeArgs' [] [j] = j
+        encodeArgs' [] js  = Array . V.fromList $ js
+        encodeArgs' ns js  = object $ zip (map mungeField ns) js
+
+        -- Skip leading '_' in field name so we can use keywords
+        -- etc. as field names.
+        mungeField ('_':cs) = pack cs
+        mungeField cs       = pack cs
+
+genericFromJSON :: (Data a) => Value -> Result a
+genericFromJSON = parse genericParseJSON
+
+type F a = Parser a
+
+genericParseJSON :: (Data a) => Value -> Parser a
+genericParseJSON j = parseJSON_generic j
+             `ext1R` list
+             `ext1R` vector
+             `ext2R'` mapAny
+             `ext2R'` hashMapAny
+             -- Use the standard encoding for all base types.
+             `extR` (value :: F Integer)
+             `extR` (value :: F Int)
+             `extR` (value :: F Int8)
+             `extR` (value :: F Int16)
+             `extR` (value :: F Int32)
+             `extR` (value :: F Int64)
+             `extR` (value :: F Word)
+             `extR` (value :: F Word8)
+             `extR` (value :: F Word16)
+             `extR` (value :: F Word32)
+             `extR` (value :: F Word64)
+             `extR` (value :: F Double)
+             `extR` (value :: F Number)
+             `extR` (value :: F Float)
+             `extR` (value :: F Rational)
+             `extR` (value :: F Char)
+             `extR` (value :: F Text)
+             `extR` (value :: F LT.Text)
+             `extR` (value :: F String)
+             `extR` (value :: F B.ByteString)
+             `extR` (value :: F LB.ByteString)
+             `extR` (value :: F Value)
+             `extR` (value :: F DotNetTime)
+             `extR` (value :: F UTCTime)
+             `extR` (value :: F IntSet)
+             `extR` (value :: F Bool)
+             `extR` (value :: F ())
+  where
+    value :: (FromJSON a) => Parser a
+    value = parseJSON j
+    list :: (Data a) => Parser [a]
+    list = V.toList <$> genericParseJSON j
+    vector :: (Data a) => Parser (V.Vector a)
+    vector = case j of
+               Array js -> V.mapM genericParseJSON js
+               _        -> myFail
+    mapAny :: forall e f. (Data e, Data f) => Parser (Map f e)
+    mapAny
+        | tyrep `elem` stringyTypes = res
+        | otherwise = myFail
+      where res = case j of
+                Object js -> M.mapKeysMonotonic trans <$> T.mapM genericParseJSON js
+                _         -> myFail
+            trans
+               | tyrep == typeOf T.empty  = remap id
+               | tyrep == typeOf LT.empty = remap LT.fromStrict
+               | tyrep == typeOf string   = remap T.unpack
+               | tyrep == typeOf B.empty  = remap encodeUtf8
+               | tyrep == typeOf LB.empty = remap lazy
+               | otherwise = modError "genericParseJSON"
+                                      "mapAny -- should never happen"
+            tyrep = typeOf (undefined :: f)
+            remap f = fromJust . cast . f
+    hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e)
+    hashMapAny
+        | tyrep == typeOf string   = process T.unpack
+        | tyrep == typeOf LT.empty = process LT.fromStrict
+        | tyrep == typeOf T.empty  = process id
+        | otherwise = myFail
+      where
+        process f = maybe myFail return . cast =<< parseWith f
+        parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e)
+        parseWith f = case j of
+                        Object js -> H.fromList . map (first f) . M.toList <$>
+                                     T.mapM genericParseJSON js
+                        _          -> myFail
+        tyrep = typeOf (undefined :: f)
+    myFail = modFail "genericParseJSON" $ "bad data: " ++ show j
+    stringyTypes = [typeOf LT.empty, typeOf T.empty, typeOf B.empty,
+                    typeOf LB.empty, typeOf string]
+
+parseJSON_generic :: (Data a) => Value -> Parser a
+parseJSON_generic j = generic
+  where
+        typ = dataTypeOf $ resType generic
+        generic = case dataTypeRep typ of
+                    AlgRep []  -> case j of
+                                    Null -> return (modError "genericParseJSON" "empty type")
+                                    _ -> modFail "genericParseJSON" "no-constr bad data"
+                    AlgRep [_] -> decodeArgs (indexConstr typ 1) j
+                    AlgRep _   -> do (c, j') <- getConstr typ j; decodeArgs c j'
+                    rep        -> modFail "genericParseJSON" $
+                                  show rep ++ "(" ++ show typ ++ ")"
+        getConstr t (Object o) | [(s, j')] <- fromJSObject o = do
+                                                c <- readConstr' t s
+                                                return (c, j')
+        getConstr t (String js) = do c <- readConstr' t (unpack js)
+                                     return (c, Null) -- handle nullary ctor
+        getConstr _ _ = modFail "genericParseJSON" "bad constructor encoding"
+        readConstr' t s =
+          maybe (modFail "genericParseJSON" $ "unknown constructor: " ++ s ++ " " ++
+                         show t)
+                return $ readConstr t s
+
+        decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0
+                           (constrFields c0)
+         where
+          go 0 c  _       Null       = construct c []   -- nullary constructor
+          go 1 c []       jd         = construct c [jd] -- unary constructor
+          go n c []       (Array js)
+              | n > 1 = construct c (V.toList js)   -- no field names
+          -- FIXME? We could allow reading an array into a constructor
+          -- with field names.
+          go _ c fs@(_:_) (Object o) = selectFields o fs >>=
+                                       construct c -- field names
+          go _ c _        jd         = modFail "genericParseJSON" $
+                                       "bad decodeArgs data " ++ show (c, jd)
+
+        fromJSObject = map (first unpack) . M.toList
+
+        -- Build the value by stepping through the list of subparts.
+        construct c = evalStateT $ fromConstrM f c
+          where f :: (Data a) => StateT [Value] Parser a
+                f = do js <- get
+                       case js of
+                         [] -> lift $ modFail "construct" "empty list"
+                         (j':js') -> do put js'; lift $ genericParseJSON j'
+
+        -- Select the named fields from a JSON object.
+        selectFields fjs = mapM sel
+          where sel f = maybe (modFail "genericParseJSON" $ "field does not exist " ++
+                               f) return $ M.lookup (pack f) fjs
+
+        -- Count how many arguments a constructor has.  The value x is
+        -- used to determine what type the constructor returns.
+        numConstrArgs :: (Data a) => a -> Constr -> Int
+        numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0
+          where f = do modify (+1); return undefined
+
+        resType :: MonadPlus m => m a -> a
+        resType _ = modError "genericParseJSON" "resType"
+
+modFail :: (Monad m) => String -> String -> m a
+modFail func err = fail $ "Data.Aeson.Types." ++ func ++ ": " ++ err
+
+modError :: String -> String -> a
+modError func err = error $ "Data.Aeson.Types." ++ func ++ ": " ++ err
+
+string :: String
+string = ""
+
+-- Type extension for binary type constructors.
+
+-- | Flexible type extension
+ext2' :: (Data a, Typeable2 t)
+     => c a
+     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
+     -> c a
+ext2' def ext = maybe def id (dataCast2 ext)
+
+-- | Type extension of queries for type constructors
+ext2Q' :: (Data d, Typeable2 t)
+      => (d -> q)
+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
+      -> d -> q
+ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))
+
+-- | Type extension of readers for type constructors
+ext2R' :: (Monad m, Data d, Typeable2 t)
+      => m d
+      -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))
+      -> m d
+ext2R' def ext = unR ((R def) `ext2'` (R ext))
+
+-- | The type constructor for queries
+newtype Q q x = Q { unQ :: x -> q }
+
+-- | The type constructor for readers
+newtype R m x = R { unR :: m x }

File aeson.cabal

View file
     ghc-options: -Werror
     ghc-prof-options: -auto-all
 
+  if(impl(ghc >= 7.2.1))
+    cpp-options: -DDEFAULT_SIGNATURES
+
   ghc-options:      -Wall
 
 source-repository head