    {-# LANGUAGE CPP, 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 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 ((<=<))
    import Control.Monad.ST (ST)
    import Data.Aeson.Types.Class
    import Data.Aeson.Types.Internal
    import Data.Bits
    import Data.DList (DList, toList, empty)
    import Data.Maybe (fromMaybe)
    import Data.Monoid (mappend)
    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 #-}

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

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

    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 'constToJSON':
        gToJSON opts = consToJSON opts . unM1
        {-# INLINE gToJSON #-}

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

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

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

    class SumToJSON f allNullary where
        sumToJSON :: Options -> f a -> Tagged allNullary Value

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

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

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

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

    class TaggedObject f where
        taggedObject :: Options -> String -> String -> f a -> [Pair]

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

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

    class TaggedObject' f isRecord where
        taggedObject' :: Options -> String -> f a -> Tagged isRecord [Pair]

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

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

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

    -- | 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
        twoElemArray :: Options -> f a -> V.Vector Value

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

    instance ( GToJSON a, ConsToJSON a
             , Constructor c ) => TwoElemArray (C1 c a) where
        twoElemArray 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 twoElemArray #-}

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

    class ConsToJSON f where
        consToJSON  :: Options -> f a -> Value

    class ConsToJSON' f isRecord where
        consToJSON' :: Options -> f a -> Tagged isRecord Value

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

    instance (RecordToPairs f) => ConsToJSON' f True where
        consToJSON' opts = Tagged . object . toList . recordToPairs opts
        {-# INLINE consToJSON' #-}

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

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

    class RecordToPairs f where
        recordToPairs :: Options -> f a -> DList Pair

    instance (RecordToPairs a, RecordToPairs b) => RecordToPairs (a :*: b) where
        recordToPairs opts (a :*: b) = recordToPairs opts a `mappend`
                                       recordToPairs opts b
        {-# INLINE recordToPairs #-}

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

    instance (Selector s, ToJSON a) => RecordToPairs (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 #-}

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

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

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

    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
    #if MIN_VERSION_base(4,5,0)
              lenL = len `unsafeShiftR` 1
    #else
              lenL = len `shiftR` 1
    #endif
              lenR = len - lenL
              ixR  = ix  + lenL
        {-# INLINE writeProduct #-}

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

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

    class ObjectWithSingleField f where
        objectWithSingleField :: Options -> f a -> Object

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

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

    --------------------------------------------------------------------------------
    -- 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
        {-# 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 -> Value -> Tagged isRecord (Parser (f a))

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

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

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

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

    class FromRecord f where
        parseRecord :: Options -> Object -> Parser (f a)

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

    instance (Selector s, GFromJSON a) => FromRecord (S1 s a) where
        parseRecord opts = 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 opts obj = (M1 . K1) <$> 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
    #if MIN_VERSION_base(4,5,0)
              lenL = len `unsafeShiftR` 1
    #else
              lenL = len `shiftR` 1
    #endif
              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

    instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord
    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

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

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