basvandijk avatar basvandijk committed e9857b2

Use the new GHC generics for the default toJSON and parseJSON implementations.
The SYB code is moved back into Data.Aeson.Generics

Comments (0)

Files changed (3)

Data/Aeson/Generic.hs

     , toJSON
     ) where
 
-import Data.Aeson.Types.Internal (Value, Result, genericFromJSON, genericToJSON)
-import Data.Data (Data)
+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
+
+type T a = a -> Value
+
+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 = genericFromJSON
+fromJSON = parse parseJSON
 
-toJSON :: (Data a) => a -> Value
-toJSON = genericToJSON
+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 }

Data/Aeson/Types/Internal.hs

     ScopedTypeVariables, PatternGuards #-}
 
 {-# LANGUAGE CPP #-}
-#ifdef DEFAULT_SIGNATURES
-{-# LANGUAGE DefaultSignatures #-}
+#ifdef GENERICS
+{-# LANGUAGE DefaultSignatures, TypeOperators #-}
 #endif
 
 -- |
     -- * Core JSON types
       Value(..)
     , Array
-    , emptyArray
+    , emptyArray, isEmptyArray
     , Pair
     , Object
     , emptyObject
     , (.:)
     , (.:?)
     , object
-    -- * Generic toJSON and fromJSON
-    , genericToJSON
-    , genericFromJSON
     ) where
 
 import Control.Applicative
-import Control.Arrow (first)
+import Control.DeepSeq (NFData(..))
 import Control.Monad.State.Strict
-import Control.DeepSeq (NFData(..))
 import Data.Aeson.Functions
 import Data.Attoparsec.Char8 (Number(..))
-import Data.Generics
+import Data.Data (Data)
 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.String (IsString(..))
+import Data.Text.Encoding (encodeUtf8)
 import Data.Text (Text, pack, unpack)
-import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Time.Format (FormatTime, formatTime, parseTime)
-import Data.Vector (Vector)
+import Data.Typeable (Typeable)
+import Data.Vector (Vector, (!?))
 import Data.Word (Word, Word8, Word16, Word32, Word64)
 import Foreign.Storable (Storable)
 import System.Locale (defaultTimeLocale)
 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
 import qualified Data.Vector.Unboxed as VU
 import qualified Data.Vector.Generic as VG
 
+#ifdef GENERICS
+import GHC.Generics
+#endif
 
 -- | The result of running a 'Parser'.
 data Result a = Error String
     {-# INLINE pure #-}
     (<*>) = apP
     {-# INLINE (<*>) #-}
-    
+
 instance Alternative Parser where
     empty = fail "empty"
     {-# INLINE empty #-}
 emptyArray :: Value
 emptyArray = Array V.empty
 
+-- | Determines if the 'Value' is an empty 'Array'.
+-- Note that: @isEmptyArray 'emptyArray'@.
+isEmptyArray :: Value -> Bool
+isEmptyArray (Array arr) = V.null arr
+isEmptyArray _ = False
+
 -- | The empty object.
 emptyObject :: Value
 emptyObject = Object M.empty
 -- @
 --
 -- This example assumes the OverloadedStrings language option is enabled.
+--
+-- If your compiler has support for the @DeriveGeneric@ and @DefaultSignatures@
+-- language extensions, @toJSON@ will have a default generic implementation.
+--
+-- To use this, simply add a @deriving 'Generic'@ clause to your datatype and
+-- declare a @ToJSON@ instance for your datatype without giving a definition for
+-- @toJSON@. For example the previous example can be simplified to just:
+--
+-- @{-\# LANGUAGE DeriveGeneric \#-}
+--
+-- import GHC.Generics
+--
+-- data Coord { x :: Double, y :: Double } deriving Generic
+--
+-- instance ToJSON Coord
+-- @
+--
+-- (Another way to automatically derive a @ToJSON@ instance is to use the
+-- template-haskell template 'deriveToJSON' from "Data.Aeson.TH".)
 class ToJSON a where
     toJSON   :: a -> Value
 
-#ifdef DEFAULT_SIGNATURES
-    default toJSON :: Data a => a -> Value
-    toJSON = genericToJSON
+#ifdef GENERICS
+    default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value
+    toJSON = gToJSON . from
 #endif
 
 -- | A type that can be converted from JSON, with the possibility of
 -- An example type and instance:
 --
 -- @data Coord { x :: Double, y :: Double }
--- 
+--
 -- instance FromJSON Coord where
 --   parseJSON ('Object' v) = Coord '<$>'
 --                         v '.:' \"x\" '<*>'
 -- @
 --
 -- This example assumes the OverloadedStrings language option is enabled.
+--
+-- If your compiler has support for the @DeriveGeneric@ and @DefaultSignatures@
+-- language extensions, @parseJSON@ will have a default generic implementation.
+--
+-- To use this, simply add a @deriving 'Generic'@ clause to your datatype and
+-- declare a @FromJSON@ instance for your datatype without giving a definition for
+-- @parseJSON@. For example the previous example can be simplified to just:
+--
+-- @{-\# LANGUAGE DeriveGeneric \#-}
+--
+-- import GHC.Generics
+--
+-- data Coord { x :: Double, y :: Double } deriving Generic
+--
+-- instance FromJSON Coord
+-- @
+--
+-- (Another way to automatically derive a @FromJSON@ instance is to use the
+-- template-haskell template 'deriveFromJSON' from "Data.Aeson.TH".)
 class FromJSON a where
     parseJSON :: Value -> Parser a
 
-#ifdef DEFAULT_SIGNATURES
-    default parseJSON :: Data a => Value -> Parser a
-    parseJSON = genericParseJSON
+#ifdef GENERICS
+    default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
+    parseJSON = fmap to . gParseJSON
 #endif
 
 instance (ToJSON a) => ToJSON (Maybe a) where
     toJSON (Just a) = toJSON a
     toJSON Nothing  = Null
     {-# INLINE toJSON #-}
-    
+
 instance (FromJSON a) => FromJSON (Maybe a) where
     parseJSON Null   = pure Nothing
     parseJSON a      = Just <$> parseJSON a
     toJSON (Left a)  = object [left  .= a]
     toJSON (Right b) = object [right .= b]
     {-# INLINE toJSON #-}
-    
+
 instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
     parseJSON (Object (M.toList -> [(key, value)]))
         | key == left  = Left  <$> parseJSON value
 instance (ToJSON a) => ToJSON [a] where
     toJSON = Array . V.fromList . map toJSON
     {-# INLINE toJSON #-}
-    
+
 instance (FromJSON a) => FromJSON [a] where
     parseJSON (Array a) = mapM parseJSON (V.toList a)
     parseJSON v         = typeMismatch "[a]" v
 instance (ToJSON a) => ToJSON (Vector a) where
     toJSON = Array . V.map toJSON
     {-# INLINE toJSON #-}
-    
+
 instance (FromJSON a) => FromJSON (Vector a) where
     parseJSON (Array a) = V.mapM parseJSON a
     parseJSON v         = typeMismatch "Vector a" v
 instance (ToJSON a) => ToJSON (Set.Set a) where
     toJSON = toJSON . Set.toList
     {-# INLINE toJSON #-}
-    
+
 instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
     parseJSON = fmap Set.fromList . parseJSON
     {-# INLINE parseJSON #-}
 instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
     toJSON = toJSON . HashSet.toList
     {-# INLINE toJSON #-}
-    
+
 instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
     parseJSON = fmap HashSet.fromList . parseJSON
     {-# INLINE parseJSON #-}
 instance ToJSON IntSet.IntSet where
     toJSON = toJSON . IntSet.toList
     {-# INLINE toJSON #-}
-    
+
 instance FromJSON IntSet.IntSet where
     parseJSON = fmap IntSet.fromList . parseJSON
     {-# INLINE parseJSON #-}
 instance ToJSON a => ToJSON (IntMap.IntMap a) where
     toJSON = toJSON . IntMap.toList
     {-# INLINE toJSON #-}
-  
+
 instance FromJSON a => FromJSON (IntMap.IntMap a) where
     parseJSON = fmap IntMap.fromList . parseJSON
     {-# INLINE parseJSON #-}
              Bool _   -> "Boolean"
              Null     -> "Null"
 
-
+#ifdef GENERICS
 --------------------------------------------------------------------------------
 -- Generic toJSON and fromJSON
 
-type T a = a -> Value
+class GToJSON f where
+    gToJSON :: f 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
+class GFromJSON f where
+    gParseJSON :: Value -> Parser (f a)
 
-    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
+-- | Meta-information is stripped:
+instance (GToJSON a) => GToJSON (M1 i c a) where
+    gToJSON = gToJSON . unM1
 
+-- | Meta-information is added:
+instance (GFromJSON a) => GFromJSON (M1 i c a) where
+    gParseJSON = fmap M1 . gParseJSON
 
-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
+-- | Constants are converted using toJSON:
+instance (ToJSON a) => GToJSON (K1 i a) where
+    gToJSON = toJSON . unK1
 
-        encodeArgs c = encodeArgs' (constrFields c)
-        encodeArgs' [] [j] = j
-        encodeArgs' [] js  = Array . V.fromList $ js
-        encodeArgs' ns js  = object $ zip (map mungeField ns) js
+-- | Constants are parsed using parseJSON:
+instance (FromJSON a) => GFromJSON (K1 i a) where
+    gParseJSON = fmap K1 . parseJSON
 
-        -- 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
+-- | Constructors without arguments are converted to the empty array:
+instance GToJSON U1 where
+    gToJSON _ = emptyArray
 
-type F a = Parser a
+-- | Constructors without arguments must be represented by the empty array:
+instance GFromJSON U1 where
+    gParseJSON v
+        | isEmptyArray v = pure U1
+        | otherwise      = typeMismatch "unary constructor (U1)" v
 
-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
+-- | Each value of a sum type is converted to an object
+-- with a single key-value association where the key is the name of the constructor:
+instance (GObject a, GObject b) => GToJSON (a :+: b) where
+    gToJSON (L1 x) = Object $ gObject x
+    gToJSON (R1 x) = Object $ gObject x
 
-        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)
+-- | A sum type must be represented by an object with a single key-value association.
+-- When this is the case, the sum will be recursively parsed using gParseSum:
+instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
+    gParseJSON (Object (M.toList -> [keyVal])) = gParseSum keyVal
+    gParseJSON v = typeMismatch "sum (:+:)" v
 
-        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'
+-- | Product types without field names are flattened and converted to an array:
+instance (GToJSON a, Flatten b) => GToJSON (S1 NoSelector a :*: b) where
+    gToJSON = toJSON . flatten
 
-        -- 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
+-- | Product types without field names must be represented as an array.
+-- When this is the case the product will be recursively parsed sing gParseProduct:
+instance (GFromJSON a, GFromProduct b) => GFromJSON (S1 NoSelector a :*: b) where
+    gParseJSON (Array arr) = gParseProduct arr 0
+    gParseJSON v = typeMismatch "product (:*:)" v
 
-        -- 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"
+-- | Other product types, so the ones with field names (records),
+-- are converted to a single object.
+instance (GObject a, GObject b) => GToJSON (a :*: b) where
+    gToJSON = Object . gObject
 
-modFail :: (Monad m) => String -> String -> m a
-modFail func err = fail $ "Data.Aeson.Types." ++ func ++ ": " ++ err
+-- | Product types with field names (records) must be represented as a single object.
+-- If this is the case the product will be recursively parsed using gParseRecord.
+instance (GFromRecord a, GFromRecord b) => GFromJSON (a :*: b) where
+    gParseJSON (Object obj) = gParseRecord obj
+    gParseJSON v = typeMismatch "record (:*:)" v
 
-modError :: String -> String -> a
-modError func err = error $ "Data.Aeson.Types." ++ func ++ ": " ++ err
+--------------------------------------------------------------------------------
 
-string :: String
-string = ""
+-- | Flatten /flattens/ a product type. For example:
+-- a :*: (b :*: (c :*: d)) is converted to:
+-- [gToJSON a, gToJSON b, gToJSON c, gToJSON d]
+class Flatten f where
+    flatten :: f a -> [Value]
 
--- Type extension for binary type constructors.
+instance (GToJSON a, Flatten b) => Flatten (S1 NoSelector a :*: b) where
+    flatten (m1 :*: r) = gToJSON m1 : flatten r
 
--- | 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)
+instance (GToJSON a) => Flatten (S1 NoSelector a) where
+    flatten m1 = [gToJSON $ unM1 m1]
 
--- | 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))
+class GObject f where
+    gObject :: f a -> Object
 
--- | The type constructor for queries
-newtype Q q x = Q { unQ :: x -> q }
+instance (GObject a, GObject b) => GObject (a :+: b) where
+    gObject (L1 x) = gObject x
+    gObject (R1 x) = gObject x
 
--- | The type constructor for readers
-newtype R m x = R { unR :: m x }
+instance (GObject a, GObject b) => GObject (a :*: b) where
+    gObject (a :*: b) = gObject a `M.union` gObject b
+
+instance (Selector s, GToJSON a) => GObject (S1 s a) where
+    gObject = objectNamed selName
+
+instance (Constructor c, GToJSON a) => GObject (C1 c a) where
+    gObject = objectNamed conName
+
+objectNamed :: GToJSON f => (M1 i c f p -> String) -> M1 i c f p -> Object
+objectNamed getName m1 = M.singleton (pack (getName m1)) (gToJSON (unM1 m1))
+
+--------------------------------------------------------------------------------
+
+class GFromSum f where
+    gParseSum :: Pair -> Parser (f a)
+
+instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
+    gParseSum keyVal = fmap L1 (gParseSum keyVal) <|> fmap R1 (gParseSum keyVal)
+
+instance (Constructor c, GFromJSON a) => GFromSum (C1 c a) where
+    gParseSum (key, value)
+        | key == pack (conName (undefined :: t c a p)) = gParseJSON value
+        | otherwise = notFound $ unpack key
+
+notFound :: String -> Parser a
+notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
+
+--------------------------------------------------------------------------------
+
+class GFromProduct f where
+    gParseProduct :: Array -> Int -> Parser (f a)
+
+instance (GFromJSON a, GFromProduct b) => GFromProduct (a :*: b) where
+    gParseProduct arr ix =
+        case arr !? ix of
+          Nothing -> arrayToSmall ix
+          Just v  -> (:*:) <$> gParseJSON v <*> gParseProduct arr (ix+1)
+
+instance (GFromJSON a) => GFromProduct (S1 NoSelector a) where
+    gParseProduct arr ix = case arr !? ix of
+                             Nothing -> arrayToSmall ix
+                             Just v  -> gParseJSON v
+
+arrayToSmall :: Int -> Parser a
+arrayToSmall ix = fail $ "Expected an array of at least " ++ show ix ++ " values"
+
+--------------------------------------------------------------------------------
+
+class GFromRecord f where
+    gParseRecord :: Object -> Parser (f a)
+
+instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
+    gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj
+
+instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
+    gParseRecord obj = case M.lookup (T.pack key) obj of
+                         Nothing -> notFound key
+                         Just v  -> gParseJSON v
+        where
+          key = selName (undefined :: t s a p)
+#endif
     ghc-prof-options: -auto-all
 
   if impl(ghc >= 7.2.1)
-    cpp-options: -DDEFAULT_SIGNATURES
+    cpp-options: -DGENERICS
+    build-depends: ghc-prim >= 0.2 -- Exports GHC.Generics
 
   ghc-options:      -Wall
 
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.