Commits

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

  • Participants
  • Parent commits d2b8c90

Comments (0)

Files changed (3)

File 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 }

File 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