    {-# LANGUAGE DefaultSignatures, EmptyDataDecls, FlexibleInstances,
        FunctionalDependencies, KindSignatures, OverlappingInstances,
        ScopedTypeVariables, TypeOperators, UndecidableInstances,
        ViewPatterns, NamedFieldPuns, FlexibleContexts, PatternGuards,
        RecordWildCards #-}
    {-# OPTIONS_GHC -fno-warn-orphans #-}

    -- |
    -- Module:      Data.Aeson.Types.Generic
    -- Copyright:   (c) 2012-2015 Bryan O'Sullivan
    --              (c) 2011, 2012 Bas Van Dijk
    --              (c) 2011 MailRank, Inc.
    -- License:     Apache
    -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>
    -- Stability:   experimental
    -- Portability: portable
    --
    -- Types for working with JSON data.

    module Data.Aeson.Types.Generic ( ) where

    import Control.Applicative ((<*>), (<$>), (<|>), pure)
    import Control.Monad ((<=<), join)
    import Control.Monad.ST (ST)
    import Data.Aeson.Encode.Builder (emptyArray_)
    import Data.Aeson.Encode.Functions (builder)
    import Data.Aeson.Types.Instances
    import Data.Aeson.Types.Internal
    import Data.Bits (unsafeShiftR)
    import Data.ByteString.Builder as B
    import Data.DList (DList, toList, empty)
    import Data.Maybe (fromMaybe)
    import Data.Monoid ((<>), mempty)
    import Data.Text (Text, pack, unpack)
    import GHC.Generics
    import qualified Data.HashMap.Strict as H
    import qualified Data.Vector as V
    import qualified Data.Vector.Mutable as VM

    --------------------------------------------------------------------------------
    -- Generic toJSON

    instance (GToJSON a) => GToJSON (M1 i c a) where
        -- Meta-information, which is not handled elsewhere, is ignored:
        gToJSON opts = gToJSON opts . unM1
        {-# INLINE gToJSON #-}

        gToEncoding opts = gToEncoding opts . unM1
        {-# INLINE gToEncoding #-}

    instance (ToJSON a) => GToJSON (K1 i a) where
        -- Constant values are encoded using their ToJSON instance:
        gToJSON _opts = toJSON . unK1
        {-# INLINE gToJSON #-}

        gToEncoding _opts = toEncoding . unK1
        {-# INLINE gToEncoding #-}

    instance GToJSON U1 where
        -- Empty constructors are encoded to an empty array:
        gToJSON _opts _ = emptyArray
        {-# INLINE gToJSON #-}

        gToEncoding _opts _ = emptyArray_
        {-# INLINE gToEncoding #-}

    instance (ConsToJSON a) => GToJSON (C1 c a) where
        -- Constructors need to be encoded differently depending on whether they're
        -- a record or not. This distinction is made by 'consToJSON':
        gToJSON opts = consToJSON opts . unM1
        {-# INLINE gToJSON #-}

        gToEncoding opts = Encoding . consToEncoding opts . unM1
        {-# INLINE gToEncoding #-}

    instance ( WriteProduct a, WriteProduct b
             , ProductSize  a, ProductSize  b ) => GToJSON (a :*: b) where
        -- Products are encoded to an array. Here we allocate a mutable vector of
        -- the same size as the product and write the product's elements to it using
        -- 'writeProduct':
        gToJSON opts p =
            Array $ V.create $ do
              mv <- VM.unsafeNew lenProduct
              writeProduct opts mv 0 lenProduct p
              return mv
            where
              lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
                           productSize
        {-# INLINE gToJSON #-}

        gToEncoding opts p = Encoding $
                             B.char7 '[' <> encodeProduct opts p <> B.char7 ']'

    instance ( AllNullary (a :+: b) allNullary
             , SumToJSON  (a :+: b) allNullary ) => GToJSON (a :+: b) where
        -- If all constructors of a sum datatype are nullary and the
        -- 'allNullaryToStringTag' option is set they are encoded to
        -- strings.  This distinction is made by 'sumToJSON':
        gToJSON opts = (unTagged :: Tagged allNullary Value -> Value)
                     . sumToJSON opts
        {-# INLINE gToJSON #-}

        gToEncoding opts = Encoding .
                           (unTagged :: Tagged allNullary B.Builder -> B.Builder) .
                           sumToEncoding opts
        {-# INLINE gToEncoding #-}

    --------------------------------------------------------------------------------

    class SumToJSON f allNullary where
        sumToJSON :: Options -> f a -> Tagged allNullary Value
        sumToEncoding :: Options -> f a -> Tagged allNullary B.Builder

    instance ( GetConName            f
             , TaggedObject     f
             , ObjectWithSingleField f
             , TwoElemArray          f ) => SumToJSON f True where
        sumToJSON opts
            | allNullaryToStringTag opts = Tagged . String . pack
                                         . constructorTagModifier opts . getConName
            | otherwise = Tagged . nonAllNullarySumToJSON opts
        {-# INLINE sumToJSON #-}

        sumToEncoding opts
            | allNullaryToStringTag opts = Tagged . builder .
                                           constructorTagModifier opts . getConName
            | otherwise = Tagged . nonAllNullarySumToEncoding opts
        {-# INLINE sumToEncoding #-}

    instance ( TwoElemArray          f
             , TaggedObject          f
             , ObjectWithSingleField f ) => SumToJSON f False where
        sumToJSON opts = Tagged . nonAllNullarySumToJSON opts
        {-# INLINE sumToJSON #-}
        sumToEncoding opts = Tagged . nonAllNullarySumToEncoding opts
        {-# INLINE sumToEncoding #-}

    nonAllNullarySumToJSON :: ( TwoElemArray          f
                              , TaggedObject          f
                              , ObjectWithSingleField f
                              ) => Options -> f a -> Value
    nonAllNullarySumToJSON opts =
        case sumEncoding opts of
          TaggedObject{..}      ->
            object . taggedObjectPairs opts tagFieldName contentsFieldName
          ObjectWithSingleField -> Object . objectWithSingleFieldObj opts
          TwoElemArray          -> Array  . twoElemArrayObj opts
    {-# INLINE nonAllNullarySumToJSON #-}

    nonAllNullarySumToEncoding :: ( TwoElemArray          f
                              , TaggedObject          f
                              , ObjectWithSingleField f
                              ) => Options -> f a -> B.Builder
    nonAllNullarySumToEncoding opts =
        case sumEncoding opts of
          TaggedObject{..}      ->
            taggedObjectEnc opts tagFieldName contentsFieldName
          ObjectWithSingleField -> objectWithSingleFieldEnc opts
          TwoElemArray          -> twoElemArrayEnc opts
    {-# INLINE nonAllNullarySumToEncoding #-}

    --------------------------------------------------------------------------------

    class TaggedObject f where
        taggedObjectPairs :: Options -> String -> String -> f a -> [Pair]
        taggedObjectEnc :: Options -> String -> String -> f a -> B.Builder

    instance ( TaggedObject a
             , TaggedObject b ) => TaggedObject (a :+: b) where
        taggedObjectPairs opts tagFieldName contentsFieldName (L1 x) =
            taggedObjectPairs opts tagFieldName contentsFieldName     x
        taggedObjectPairs opts tagFieldName contentsFieldName (R1 x) =
            taggedObjectPairs opts tagFieldName contentsFieldName     x
        {-# INLINE taggedObjectPairs #-}

        taggedObjectEnc opts tagFieldName contentsFieldName (L1 x) =
            taggedObjectEnc opts tagFieldName contentsFieldName     x
        taggedObjectEnc opts tagFieldName contentsFieldName (R1 x) =
            taggedObjectEnc opts tagFieldName contentsFieldName     x
        {-# INLINE taggedObjectEnc #-}

    instance ( IsRecord      a isRecord
             , TaggedObject' a isRecord
             , Constructor c ) => TaggedObject (C1 c a) where
        taggedObjectPairs opts tagFieldName contentsFieldName =
            (pack tagFieldName .= constructorTagModifier opts
                                     (conName (undefined :: t c a p)) :) .
            (unTagged :: Tagged isRecord [Pair] -> [Pair]) .
              taggedObjectPairs' opts contentsFieldName . unM1
        {-# INLINE taggedObjectPairs #-}

        taggedObjectEnc opts tagFieldName contentsFieldName v =
            B.char7 '{' <>
            (builder tagFieldName <>
             B.char7 ':' <>
             builder (constructorTagModifier opts (conName (undefined :: t c a p)))) <>
            B.char7 ',' <>
            ((unTagged :: Tagged isRecord B.Builder -> B.Builder) .
             taggedObjectEnc' opts contentsFieldName . unM1 $ v) <>
            B.char7 '}'
        {-# INLINE taggedObjectEnc #-}

    class TaggedObject' f isRecord where
        taggedObjectPairs' :: Options -> String -> f a -> Tagged isRecord [Pair]
        taggedObjectEnc' :: Options -> String -> f a -> Tagged isRecord B.Builder

    instance (RecordTo f) => TaggedObject' f True where
        taggedObjectPairs' opts _ = Tagged . toList . recordToPairs opts
        {-# INLINE taggedObjectPairs' #-}

        taggedObjectEnc' opts _ = Tagged . recordToEncoding opts
        {-# INLINE taggedObjectEnc' #-}

    instance (GToJSON f) => TaggedObject' f False where
        taggedObjectPairs' opts contentsFieldName =
            Tagged . (:[]) . (pack contentsFieldName .=) . gToJSON opts
        {-# INLINE taggedObjectPairs' #-}

        taggedObjectEnc' opts contentsFieldName =
            Tagged . (\z -> builder contentsFieldName <> B.char7 ':' <> z) .
            gbuilder opts
        {-# INLINE taggedObjectEnc' #-}

    --------------------------------------------------------------------------------

    -- | Get the name of the constructor of a sum datatype.
    class GetConName f where
        getConName :: f a -> String

    instance (GetConName a, GetConName b) => GetConName (a :+: b) where
        getConName (L1 x) = getConName x
        getConName (R1 x) = getConName x
        {-# INLINE getConName #-}

    instance (Constructor c, GToJSON a, ConsToJSON a) => GetConName (C1 c a) where
        getConName = conName
        {-# INLINE getConName #-}

    --------------------------------------------------------------------------------

    class TwoElemArray f where
        twoElemArrayObj :: Options -> f a -> V.Vector Value
        twoElemArrayEnc :: Options -> f a -> B.Builder

    instance (TwoElemArray a, TwoElemArray b) => TwoElemArray (a :+: b) where
        twoElemArrayObj opts (L1 x) = twoElemArrayObj opts x
        twoElemArrayObj opts (R1 x) = twoElemArrayObj opts x
        {-# INLINE twoElemArrayObj #-}

        twoElemArrayEnc opts (L1 x) = twoElemArrayEnc opts x
        twoElemArrayEnc opts (R1 x) = twoElemArrayEnc opts x
        {-# INLINE twoElemArrayEnc #-}

    instance ( GToJSON a, ConsToJSON a
             , Constructor c ) => TwoElemArray (C1 c a) where
        twoElemArrayObj opts x = V.create $ do
          mv <- VM.unsafeNew 2
          VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts
                                       $ conName (undefined :: t c a p)
          VM.unsafeWrite mv 1 $ gToJSON opts x
          return mv
        {-# INLINE twoElemArrayObj #-}

        twoElemArrayEnc opts x = fromEncoding . tuple $
          builder (constructorTagModifier opts (conName (undefined :: t c a p))) >*<
          gbuilder opts x
        {-# INLINE twoElemArrayEnc #-}

    --------------------------------------------------------------------------------

    class ConsToJSON f where
        consToJSON     :: Options -> f a -> Value
        consToEncoding :: Options -> f a -> B.Builder

    class ConsToJSON' f isRecord where
        consToJSON'     :: Options -> Bool -- ^ Are we a record with one field?
                        -> f a -> Tagged isRecord Value
        consToEncoding' :: Options -> Bool -- ^ Are we a record with one field?
                        -> f a -> Tagged isRecord B.Builder

    instance ( IsRecord    f isRecord
             , ConsToJSON' f isRecord ) => ConsToJSON f where
        consToJSON opts = (unTagged :: Tagged isRecord Value -> Value)
                        . consToJSON' opts (isUnary (undefined :: f a))
        {-# INLINE consToJSON #-}

        consToEncoding opts = (unTagged :: Tagged isRecord B.Builder -> B.Builder)
                              . consToEncoding' opts (isUnary (undefined :: f a))
        {-# INLINE consToEncoding #-}

    instance (RecordTo f) => ConsToJSON' f True where
        consToJSON' opts isUn f = let
          vals = toList $ recordToPairs opts f
          in case (unwrapUnaryRecords opts,isUn,vals) of
            (True,True,[(_,val)]) -> Tagged val
            _ -> Tagged $ object vals
        {-# INLINE consToJSON' #-}

        consToEncoding' opts isUn x
          | (True,True) <- (unwrapUnaryRecords opts,isUn) = Tagged $   recordToEncoding opts x
          | otherwise = Tagged $
              B.char7 '{' <>
              recordToEncoding opts x <>
              B.char7 '}'
        {-# INLINE consToEncoding' #-}

    instance GToJSON f => ConsToJSON' f False where
        consToJSON' opts _ = Tagged . gToJSON opts
        {-# INLINE consToJSON' #-}
        consToEncoding' opts _ = Tagged . gbuilder opts
        {-# INLINE consToEncoding' #-}

    --------------------------------------------------------------------------------

    class RecordTo f where
        recordToPairs    :: Options -> f a -> DList Pair
        recordToEncoding :: Options -> f a -> B.Builder

    instance (RecordTo a, RecordTo b) => RecordTo (a :*: b) where
        recordToPairs opts (a :*: b) = recordToPairs opts a <>
                                       recordToPairs opts b
        {-# INLINE recordToPairs #-}

        recordToEncoding opts (a :*: b) = recordToEncoding opts a <>
                                          B.char7 ',' <>
                                          recordToEncoding opts b
        {-# INLINE recordToEncoding #-}

    instance (Selector s, GToJSON a) => RecordTo (S1 s a) where
        recordToPairs = fieldToPair
        {-# INLINE recordToPairs #-}

        recordToEncoding = fieldToEncoding
        {-# INLINE recordToEncoding #-}

    instance (Selector s, ToJSON a) => RecordTo (S1 s (K1 i (Maybe a))) where
        recordToPairs opts (M1 k1) | omitNothingFields opts
                                   , K1 Nothing <- k1 = empty
        recordToPairs opts m1 = fieldToPair opts m1
        {-# INLINE recordToPairs #-}

        recordToEncoding opts (M1 k1) | omitNothingFields opts
                                      , K1 Nothing <- k1 = mempty
        recordToEncoding opts m1 = fieldToEncoding opts m1
        {-# INLINE recordToEncoding #-}

    fieldToPair :: (Selector s, GToJSON a) => Options -> S1 s a p -> DList Pair
    fieldToPair opts m1 = pure ( pack $ fieldLabelModifier opts $ selName m1
                               , gToJSON opts (unM1 m1)
                               )
    {-# INLINE fieldToPair #-}

    fieldToEncoding :: (Selector s, GToJSON a) => Options -> S1 s a p -> B.Builder
    fieldToEncoding opts m1 =
        builder (fieldLabelModifier opts $ selName m1) <>
        B.char7 ':' <>
        gbuilder opts (unM1 m1)
    {-# INLINE fieldToEncoding #-}

    --------------------------------------------------------------------------------

    class WriteProduct f where
        writeProduct :: Options
                     -> VM.MVector s Value
                     -> Int -- ^ index
                     -> Int -- ^ length
                     -> f a
                     -> ST s ()
        encodeProduct :: Options -> f a -> B.Builder

    instance ( WriteProduct a
             , WriteProduct b ) => WriteProduct (a :*: b) where
        writeProduct opts mv ix len (a :*: b) = do
          writeProduct opts mv ix  lenL a
          writeProduct opts mv ixR lenR b
            where
              lenL = len `unsafeShiftR` 1
              lenR = len - lenL
              ixR  = ix  + lenL
        {-# INLINE writeProduct #-}

        encodeProduct opts (a :*: b) = encodeProduct opts a <>
                                       B.char7 ',' <>
                                       encodeProduct opts b
        {-# INLINE encodeProduct #-}

    instance (GToJSON a) => WriteProduct a where
        writeProduct opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts
        {-# INLINE writeProduct #-}

        encodeProduct opts = gbuilder opts
        {-# INLINE encodeProduct #-}

    --------------------------------------------------------------------------------

    class ObjectWithSingleField f where
        objectWithSingleFieldObj :: Options -> f a -> Object
        objectWithSingleFieldEnc :: Options -> f a -> B.Builder

    instance ( ObjectWithSingleField a
             , ObjectWithSingleField b ) => ObjectWithSingleField (a :+: b) where
        objectWithSingleFieldObj opts (L1 x) = objectWithSingleFieldObj opts x
        objectWithSingleFieldObj opts (R1 x) = objectWithSingleFieldObj opts x
        {-# INLINE objectWithSingleFieldObj #-}

        objectWithSingleFieldEnc opts (L1 x) = objectWithSingleFieldEnc opts x
        objectWithSingleFieldEnc opts (R1 x) = objectWithSingleFieldEnc opts x
        {-# INLINE objectWithSingleFieldEnc #-}

    instance ( GToJSON a, ConsToJSON a
             , Constructor c ) => ObjectWithSingleField (C1 c a) where
        objectWithSingleFieldObj opts = H.singleton typ . gToJSON opts
            where
              typ = pack $ constructorTagModifier opts $
                             conName (undefined :: t c a p)
        {-# INLINE objectWithSingleFieldObj #-}

        objectWithSingleFieldEnc opts v =
          B.char7 '{' <>
          builder (constructorTagModifier opts
                   (conName (undefined :: t c a p))) <>
          B.char7 ':' <>
          gbuilder opts v <>
          B.char7 '}'
        {-# INLINE objectWithSingleFieldEnc #-}

    gbuilder :: GToJSON f => Options -> f a -> Builder
    gbuilder opts = fromEncoding . gToEncoding opts

    --------------------------------------------------------------------------------
    -- Generic parseJSON

    instance (GFromJSON a) => GFromJSON (M1 i c a) where
        -- Meta-information, which is not handled elsewhere, is just added to the
        -- parsed value:
        gParseJSON opts = fmap M1 . gParseJSON opts
        {-# INLINE gParseJSON #-}

    instance (FromJSON a) => GFromJSON (K1 i a) where
        -- Constant values are decoded using their FromJSON instance:
        gParseJSON _opts = fmap K1 . parseJSON
        {-# INLINE gParseJSON #-}

    instance GFromJSON U1 where
        -- Empty constructors are expected to be encoded as an empty array:
        gParseJSON _opts v
            | isEmptyArray v = pure U1
            | otherwise      = typeMismatch "unit constructor (U1)" v
        {-# INLINE gParseJSON #-}

    instance (ConsFromJSON a) => GFromJSON (C1 c a) where
        -- Constructors need to be decoded differently depending on whether they're
        -- a record or not. This distinction is made by consParseJSON:
        gParseJSON opts = fmap M1 . consParseJSON opts
        {-# INLINE gParseJSON #-}

    instance ( FromProduct a, FromProduct b
             , ProductSize a, ProductSize b ) => GFromJSON (a :*: b) where
        -- Products are expected to be encoded to an array. Here we check whether we
        -- got an array of the same size as the product, then parse each of the
        -- product's elements using parseProduct:
        gParseJSON opts = withArray "product (:*:)" $ \arr ->
          let lenArray = V.length arr
              lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
                           productSize in
          if lenArray == lenProduct
          then parseProduct opts arr 0 lenProduct
          else fail $ "When expecting a product of " ++ show lenProduct ++
                      " values, encountered an Array of " ++ show lenArray ++
                      " elements instead"
        {-# INLINE gParseJSON #-}

    instance ( AllNullary (a :+: b) allNullary
             , ParseSum   (a :+: b) allNullary ) => GFromJSON   (a :+: b) where
        -- If all constructors of a sum datatype are nullary and the
        -- 'allNullaryToStringTag' option is set they are expected to be
        -- encoded as strings.  This distinction is made by 'parseSum':
        gParseJSON opts = (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->
                                                         (Parser ((a :+: b) d)))
                        . parseSum opts
        {-# INLINE gParseJSON #-}

    --------------------------------------------------------------------------------

    class ParseSum f allNullary where
        parseSum :: Options -> Value -> Tagged allNullary (Parser (f a))

    instance ( SumFromString    (a :+: b)
             , FromPair         (a :+: b)
             , FromTaggedObject (a :+: b) ) => ParseSum (a :+: b) True where
        parseSum opts
            | allNullaryToStringTag opts = Tagged . parseAllNullarySum    opts
            | otherwise                  = Tagged . parseNonAllNullarySum opts
        {-# INLINE parseSum #-}

    instance ( FromPair         (a :+: b)
             , FromTaggedObject (a :+: b) ) => ParseSum (a :+: b) False where
        parseSum opts = Tagged . parseNonAllNullarySum opts
        {-# INLINE parseSum #-}

    --------------------------------------------------------------------------------

    parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)
    parseAllNullarySum opts = withText "Text" $ \key ->
                                maybe (notFound $ unpack key) return $
                                  parseSumFromString opts key
    {-# INLINE parseAllNullarySum #-}

    class SumFromString f where
        parseSumFromString :: Options -> Text -> Maybe (f a)

    instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
        parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
                                      (R1 <$> parseSumFromString opts key)
        {-# INLINE parseSumFromString #-}

    instance (Constructor c) => SumFromString (C1 c U1) where
        parseSumFromString opts key | key == name = Just $ M1 U1
                                    | otherwise   = Nothing
            where
              name = pack $ constructorTagModifier opts $
                              conName (undefined :: t c U1 p)
        {-# INLINE parseSumFromString #-}

    --------------------------------------------------------------------------------

    parseNonAllNullarySum :: ( FromPair                       (a :+: b)
                             , FromTaggedObject               (a :+: b)
                             ) => Options -> Value -> Parser ((a :+: b) c)
    parseNonAllNullarySum opts =
        case sumEncoding opts of
          TaggedObject{..} ->
              withObject "Object" $ \obj -> do
                tag <- obj .: pack tagFieldName
                fromMaybe (notFound $ unpack tag) $
                  parseFromTaggedObject opts contentsFieldName obj tag

          ObjectWithSingleField ->
              withObject "Object" $ \obj ->
                case H.toList obj of
                  [pair@(tag, _)] -> fromMaybe (notFound $ unpack tag) $
                                       parsePair opts pair
                  _ -> fail "Object doesn't have a single field"

          TwoElemArray ->
              withArray "Array" $ \arr ->
                if V.length arr == 2
                then case V.unsafeIndex arr 0 of
                       String tag -> fromMaybe (notFound $ unpack tag) $
                                       parsePair opts (tag, V.unsafeIndex arr 1)
                       _ -> fail "First element is not a String"
                else fail "Array doesn't have 2 elements"
    {-# INLINE parseNonAllNullarySum #-}

    --------------------------------------------------------------------------------

    class FromTaggedObject f where
        parseFromTaggedObject :: Options -> String -> Object -> Text
                              -> Maybe (Parser (f a))

    instance (FromTaggedObject a, FromTaggedObject b) =>
        FromTaggedObject (a :+: b) where
            parseFromTaggedObject opts contentsFieldName obj tag =
                (fmap L1 <$> parseFromTaggedObject opts contentsFieldName obj tag) <|>
                (fmap R1 <$> parseFromTaggedObject opts contentsFieldName obj tag)
            {-# INLINE parseFromTaggedObject #-}

    instance ( FromTaggedObject' f
             , Constructor c ) => FromTaggedObject (C1 c f) where
        parseFromTaggedObject opts contentsFieldName obj tag
            | tag == name = Just $ M1 <$> parseFromTaggedObject'
                                            opts contentsFieldName obj
            | otherwise = Nothing
            where
              name = pack $ constructorTagModifier opts $
                              conName (undefined :: t c f p)
        {-# INLINE parseFromTaggedObject #-}

    --------------------------------------------------------------------------------

    class FromTaggedObject' f where
        parseFromTaggedObject' :: Options -> String -> Object -> Parser (f a)

    class FromTaggedObject'' f isRecord where
        parseFromTaggedObject'' :: Options -> String -> Object
                                -> Tagged isRecord (Parser (f a))

    instance ( IsRecord             f isRecord
             , FromTaggedObject''   f isRecord
             ) => FromTaggedObject' f where
        parseFromTaggedObject' opts contentsFieldName =
            (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
            parseFromTaggedObject'' opts contentsFieldName
        {-# INLINE parseFromTaggedObject' #-}

    instance (FromRecord f) => FromTaggedObject'' f True where
        parseFromTaggedObject'' opts _ = Tagged . parseRecord opts Nothing
        {-# INLINE parseFromTaggedObject'' #-}

    instance (GFromJSON f) => FromTaggedObject'' f False where
        parseFromTaggedObject'' opts contentsFieldName = Tagged .
          (gParseJSON opts <=< (.: pack contentsFieldName))
        {-# INLINE parseFromTaggedObject'' #-}

    --------------------------------------------------------------------------------

    class ConsFromJSON f where
        consParseJSON  :: Options -> Value -> Parser (f a)

    class ConsFromJSON' f isRecord where
        consParseJSON' :: Options -> (Maybe Text) -- ^ A dummy label
                                               --   (Nothing to use proper label)
                       -> Value -> Tagged isRecord (Parser (f a))

    instance ( IsRecord        f isRecord
             , ConsFromJSON'   f isRecord
             ) => ConsFromJSON f where
        consParseJSON opts v = let
          (v2,lab) = case (unwrapUnaryRecords opts,isUnary (undefined :: f a)) of
                           -- use a dummy object with a dummy label
            (True,True) -> ((object [(pack "dummy",v)]),Just $ pack "dummy")
            _ ->(v,Nothing)
          in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
                           $ consParseJSON' opts lab v2
        {-# INLINE consParseJSON #-}

    instance (FromRecord f) => ConsFromJSON' f True where
        consParseJSON' opts mlab = Tagged . (withObject "record (:*:)"
                                    $ parseRecord opts mlab)
        {-# INLINE consParseJSON' #-}

    instance (GFromJSON f) => ConsFromJSON' f False where
        consParseJSON' opts _ = Tagged . gParseJSON opts
        {-# INLINE consParseJSON' #-}

    --------------------------------------------------------------------------------

    class FromRecord f where
        parseRecord :: Options -> (Maybe Text) -- ^ A dummy label
                                               --   (Nothing to use proper label)
                     -> Object -> Parser (f a)

    instance (FromRecord a, FromRecord b) => FromRecord (a :*: b) where
        parseRecord opts _ obj = (:*:) <$> parseRecord opts Nothing obj
                                       <*> parseRecord opts Nothing obj
        {-# INLINE parseRecord #-}

    instance (Selector s, GFromJSON a) => FromRecord (S1 s a) where
        parseRecord opts (Just lab) = maybe (notFound $ unpack lab)
                          (gParseJSON opts) . H.lookup lab
        parseRecord opts Nothing    = maybe (notFound label)
                          (gParseJSON opts) . H.lookup (pack label)
            where
              label = fieldLabelModifier opts $ selName (undefined :: t s a p)
        {-# INLINE parseRecord #-}

    instance (Selector s, FromJSON a) => FromRecord (S1 s (K1 i (Maybe a))) where
        parseRecord _ (Just lab) obj = (M1 . K1) . join <$> obj .:? lab
        parseRecord opts Nothing obj = (M1 . K1) . join <$> obj .:? pack label
            where
              label = fieldLabelModifier opts $
                        selName (undefined :: t s (K1 i (Maybe a)) p)
        {-# INLINE parseRecord #-}

    --------------------------------------------------------------------------------

    class ProductSize f where
        productSize :: Tagged2 f Int

    instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where
        productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +
                                unTagged2 (productSize :: Tagged2 b Int)
        {-# INLINE productSize #-}

    instance ProductSize (S1 s a) where
        productSize = Tagged2 1
        {-# INLINE productSize #-}

    --------------------------------------------------------------------------------

    class FromProduct f where
        parseProduct :: Options -> Array -> Int -> Int -> Parser (f a)

    instance (FromProduct a, FromProduct b) => FromProduct (a :*: b) where
        parseProduct opts arr ix len =
            (:*:) <$> parseProduct opts arr ix  lenL
                  <*> parseProduct opts arr ixR lenR
            where
              lenL = len `unsafeShiftR` 1
              ixR  = ix + lenL
              lenR = len - lenL
        {-# INLINE parseProduct #-}

    instance (GFromJSON a) => FromProduct (S1 s a) where
        parseProduct opts arr ix _ = gParseJSON opts $ V.unsafeIndex arr ix
        {-# INLINE parseProduct #-}

    --------------------------------------------------------------------------------

    class FromPair f where
        parsePair :: Options -> Pair -> Maybe (Parser (f a))

    instance (FromPair a, FromPair b) => FromPair (a :+: b) where
        parsePair opts pair = (fmap L1 <$> parsePair opts pair) <|>
                              (fmap R1 <$> parsePair opts pair)
        {-# INLINE parsePair #-}

    instance (Constructor c, GFromJSON a, ConsFromJSON a) => FromPair (C1 c a) where
        parsePair opts (tag, value)
            | tag == tag' = Just $ gParseJSON opts value
            | otherwise   = Nothing
            where
              tag' = pack $ constructorTagModifier opts $
                              conName (undefined :: t c a p)
        {-# INLINE parsePair #-}

    --------------------------------------------------------------------------------

    class IsRecord (f :: * -> *) isRecord | f -> isRecord
      where
        isUnary :: f a -> Bool
        isUnary = const True

    instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord
      where isUnary = const False
    instance IsRecord (M1 S NoSelector f) False
    instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord
    instance IsRecord (K1 i c) True
    instance IsRecord U1 False
      where isUnary = const False

    --------------------------------------------------------------------------------

    class AllNullary (f :: * -> *) allNullary | f -> allNullary

    instance ( AllNullary a allNullaryL
             , AllNullary b allNullaryR
             , And allNullaryL allNullaryR allNullary
             ) => AllNullary (a :+: b) allNullary
    instance AllNullary a allNullary => AllNullary (M1 i c a) allNullary
    instance AllNullary (a :*: b) False
    instance AllNullary (K1 i c) False
    instance AllNullary U1 True

    --------------------------------------------------------------------------------

    data True
    data False

    class    And bool1 bool2 bool3 | bool1 bool2 -> bool3

    instance And True  True  True
    instance And False False False
    instance And False True  False
    instance And True  False False

    --------------------------------------------------------------------------------

    newtype Tagged s b = Tagged {unTagged :: b}

    newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}

    --------------------------------------------------------------------------------

    notFound :: String -> Parser a
    notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
    {-# INLINE notFound #-}