{-# LANGUAGE BangPatterns #-}

{-# LANGUAGE CPP #-}

{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE NamedFieldPuns #-}

{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE UndecidableInstances #-}

#if __GLASGOW_HASKELL__ >= 800

-- a) THQ works on cross-compilers and unregisterised GHCs

-- b) may make compilation faster as no dynamic loading is ever needed (not sure about this)

-- c) removes one hindrance to have code inferred as SafeHaskell safe

{-# LANGUAGE TemplateHaskellQuotes #-}

#else

{-# LANGUAGE TemplateHaskell #-}

#endif

#include "incoherent-compat.h"

#include "overlapping-compat.h"

{-|

Module:      Data.Aeson.TH

Copyright:   (c) 2011-2016 Bryan O'Sullivan

             (c) 2011 MailRank, Inc.

License:     BSD3

Stability:   experimental

Portability: portable

Functions to mechanically derive 'ToJSON' and 'FromJSON' instances. Note that

you need to enable the @TemplateHaskell@ language extension in order to use this

module.

An example shows how instances are generated for arbitrary data types. First we

define a data type:

@

data D a = Nullary

         | Unary Int

         | Product String Char a

         | Record { testOne   :: Double

                  , testTwo   :: Bool

                  , testThree :: D a

                  } deriving Eq

@

Next we derive the necessary instances. Note that we make use of the

feature to change record field names. In this case we drop the first 4

characters of every field name. We also modify constructor names by

lower-casing them:

@

$('deriveJSON' 'defaultOptions'{'fieldLabelModifier' = 'drop' 4, 'constructorTagModifier' = map toLower} ''D)

@

Now we can use the newly created instances.

@

d :: D 'Int'

d = Record { testOne = 3.14159

           , testTwo = 'True'

           , testThree = Product \"test\" \'A\' 123

           }

@

>>> fromJSON (toJSON d) == Success d

> True

This also works for data family instances, but instead of passing in the data

family name (with double quotes), we pass in a data family instance

constructor (with a single quote):

@

data family DF a

data instance DF Int = DF1 Int

                     | DF2 Int Int

                     deriving Eq

$('deriveJSON' 'defaultOptions' 'DF1)

-- Alternatively, one could pass 'DF2 instead

@

Please note that you can derive instances for tuples using the following syntax:

@

-- FromJSON and ToJSON instances for 4-tuples.

$('deriveJSON' 'defaultOptions' ''(,,,))

@

-}

module Data.Aeson.TH

    (

      -- * Encoding configuration

      Options(..)

    , SumEncoding(..)

    , defaultOptions

    , defaultTaggedObject

     -- * FromJSON and ToJSON derivation

    , deriveJSON

    , deriveJSON1

    , deriveJSON2

    , deriveToJSON

    , deriveToJSON1

    , deriveToJSON2

    , deriveFromJSON

    , deriveFromJSON1

    , deriveFromJSON2

    , mkToJSON

    , mkLiftToJSON

    , mkLiftToJSON2

    , mkToEncoding

    , mkLiftToEncoding

    , mkLiftToEncoding2

    , mkParseJSON

    , mkLiftParseJSON

    , mkLiftParseJSON2

    ) where

import Prelude ()

import Prelude.Compat hiding (exp)

import Control.Applicative ((<|>))

import Data.Aeson (Object, (.=), (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))

import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)

import Data.Aeson.Types.Internal ((), JSONPathElement(Key))

import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)

import Control.Monad (liftM2, unless, when)

import Data.Foldable (foldr')

#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)

import Data.List (nub)

#endif

import Data.List (foldl', genericLength, intercalate, partition, union)

import Data.List.NonEmpty ((<|), NonEmpty((:|)))

import Data.Map (Map)

import Data.Maybe (catMaybes, fromMaybe, mapMaybe)

import Data.Set (Set)

#if MIN_VERSION_template_haskell(2,8,0)

import Language.Haskell.TH hiding (Arity)

#else

import Language.Haskell.TH

#endif

import Language.Haskell.TH.Datatype

#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))

import Language.Haskell.TH.Lib (starK)

#endif

#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))

import Language.Haskell.TH.Syntax (mkNameG_tc)

#endif

import Text.Printf (printf)

import qualified Data.Aeson as A

import qualified Data.Aeson.Encoding.Internal as E

import qualified Data.Foldable as F (all)

import qualified Data.HashMap.Strict as H (lookup, toList)

import qualified Data.List.NonEmpty as NE (length, reverse)

import qualified Data.Map as M (fromList, keys, lookup , singleton, size)

import qualified Data.Semigroup as Semigroup (Option(..))

import qualified Data.Set as Set (empty, insert, member)

import qualified Data.Text as T (Text, pack, unpack)

import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)

import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)

{-# ANN module "Hlint: ignore Reduce duplication" #-}

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

-- Convenience

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

-- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given

-- data type or data family instance constructor.

--

-- This is a convienience function which is equivalent to calling both

-- 'deriveToJSON' and 'deriveFromJSON'.

deriveJSON :: Options

           -- ^ Encoding options.

           -> Name

           -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'

           -- instances.

           -> Q [Dec]

deriveJSON = deriveJSONBoth deriveToJSON deriveFromJSON

-- | Generates both 'ToJSON1' and 'FromJSON1' instance declarations for the given

-- data type or data family instance constructor.

--

-- This is a convienience function which is equivalent to calling both

-- 'deriveToJSON1' and 'deriveFromJSON1'.

deriveJSON1 :: Options

            -- ^ Encoding options.

            -> Name

            -- ^ Name of the type for which to generate 'ToJSON1' and 'FromJSON1'

            -- instances.

            -> Q [Dec]

deriveJSON1 = deriveJSONBoth deriveToJSON1 deriveFromJSON1

-- | Generates both 'ToJSON2' and 'FromJSON2' instance declarations for the given

-- data type or data family instance constructor.

--

-- This is a convienience function which is equivalent to calling both

-- 'deriveToJSON2' and 'deriveFromJSON2'.

deriveJSON2 :: Options

            -- ^ Encoding options.

            -> Name

            -- ^ Name of the type for which to generate 'ToJSON2' and 'FromJSON2'

            -- instances.

            -> Q [Dec]

deriveJSON2 = deriveJSONBoth deriveToJSON2 deriveFromJSON2

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

-- ToJSON

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

{-

TODO: Don't constrain phantom type variables.

data Foo a = Foo Int

instance (ToJSON a) ⇒ ToJSON Foo where ...

The above (ToJSON a) constraint is not necessary and perhaps undesirable.

-}

-- | Generates a 'ToJSON' instance declaration for the given data type or

-- data family instance constructor.

deriveToJSON :: Options

             -- ^ Encoding options.

             -> Name

             -- ^ Name of the type for which to generate a 'ToJSON' instance

             -- declaration.

             -> Q [Dec]

deriveToJSON = deriveToJSONCommon toJSONClass

-- | Generates a 'ToJSON1' instance declaration for the given data type or

-- data family instance constructor.

deriveToJSON1 :: Options

              -- ^ Encoding options.

              -> Name

              -- ^ Name of the type for which to generate a 'ToJSON1' instance

              -- declaration.

              -> Q [Dec]

deriveToJSON1 = deriveToJSONCommon toJSON1Class

-- | Generates a 'ToJSON2' instance declaration for the given data type or

-- data family instance constructor.

deriveToJSON2 :: Options

              -- ^ Encoding options.

              -> Name

              -- ^ Name of the type for which to generate a 'ToJSON2' instance

              -- declaration.

              -> Q [Dec]

deriveToJSON2 = deriveToJSONCommon toJSON2Class

deriveToJSONCommon :: JSONClass

                   -- ^ The ToJSON variant being derived.

                   -> Options

                   -- ^ Encoding options.

                   -> Name

                   -- ^ Name of the type for which to generate an instance.

                   -> Q [Dec]

deriveToJSONCommon = deriveJSONClass [ (ToJSON,     \jc _ -> consToValue Value jc)

                                     , (ToEncoding, \jc _ -> consToValue Encoding jc)

                                     ]

-- | Generates a lambda expression which encodes the given data type or

-- data family instance constructor as a 'Value'.

mkToJSON :: Options -- ^ Encoding options.

         -> Name -- ^ Name of the type to encode.

         -> Q Exp

mkToJSON = mkToJSONCommon toJSONClass

-- | Generates a lambda expression which encodes the given data type or

-- data family instance constructor as a 'Value' by using the given encoding

-- function on occurrences of the last type parameter.

mkLiftToJSON :: Options -- ^ Encoding options.

             -> Name -- ^ Name of the type to encode.

             -> Q Exp

mkLiftToJSON = mkToJSONCommon toJSON1Class

-- | Generates a lambda expression which encodes the given data type or

-- data family instance constructor as a 'Value' by using the given encoding

-- functions on occurrences of the last two type parameters.

mkLiftToJSON2 :: Options -- ^ Encoding options.

              -> Name -- ^ Name of the type to encode.

              -> Q Exp

mkLiftToJSON2 = mkToJSONCommon toJSON2Class

mkToJSONCommon :: JSONClass -- ^ Which class's method is being derived.

               -> Options -- ^ Encoding options.

               -> Name -- ^ Name of the encoded type.

               -> Q Exp

mkToJSONCommon = mkFunCommon (\jc _ -> consToValue Value jc)

-- | Generates a lambda expression which encodes the given data type or

-- data family instance constructor as a JSON string.

mkToEncoding :: Options -- ^ Encoding options.

             -> Name -- ^ Name of the type to encode.

             -> Q Exp

mkToEncoding = mkToEncodingCommon toJSONClass

-- | Generates a lambda expression which encodes the given data type or

-- data family instance constructor as a JSON string by using the given encoding

-- function on occurrences of the last type parameter.

mkLiftToEncoding :: Options -- ^ Encoding options.

                 -> Name -- ^ Name of the type to encode.

                 -> Q Exp

mkLiftToEncoding = mkToEncodingCommon toJSON1Class

-- | Generates a lambda expression which encodes the given data type or

-- data family instance constructor as a JSON string by using the given encoding

-- functions on occurrences of the last two type parameters.

mkLiftToEncoding2 :: Options -- ^ Encoding options.

                  -> Name -- ^ Name of the type to encode.

                  -> Q Exp

mkLiftToEncoding2 = mkToEncodingCommon toJSON2Class

mkToEncodingCommon :: JSONClass -- ^ Which class's method is being derived.

                   -> Options -- ^ Encoding options.

                   -> Name -- ^ Name of the encoded type.

                   -> Q Exp

mkToEncodingCommon = mkFunCommon (\jc _ -> consToValue Encoding jc)

-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates

-- code to generate a 'Value' or 'Encoding' of a number of constructors. All

-- constructors must be from the same type.

consToValue :: ToJSONFun

            -- ^ The method ('toJSON' or 'toEncoding') being derived.

            -> JSONClass

            -- ^ The ToJSON variant being derived.

            -> Options

            -- ^ Encoding options.

            -> [Type]

            -- ^ The types from the data type/data family instance declaration

            -> [ConstructorInfo]

            -- ^ Constructors for which to generate JSON generating code.

            -> Q Exp

consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "

                             ++ "Not a single constructor given!"

consToValue target jc opts vars cons = do

    value <- newName "value"

    tjs   <- newNameList "_tj"  $ arityInt jc

    tjls  <- newNameList "_tjl" $ arityInt jc

    let zippedTJs      = zip tjs tjls

        interleavedTJs = interleave tjs tjls

        lastTyVars     = map varTToName $ drop (length vars - arityInt jc) vars

        tvMap          = M.fromList $ zip lastTyVars zippedTJs

    lamE (map varP $ interleavedTJs ++ [value]) $

        caseE (varE value) (matches tvMap)

  where

    matches tvMap = case cons of

      -- A single constructor is directly encoded. The constructor itself may be

      -- forgotten.

      [con] | not (tagSingleConstructors opts) -> [argsToValue target jc tvMap opts False con]

      _ | allNullaryToStringTag opts && all isNullary cons ->

              [ match (conP conName []) (normalB $ conStr target opts conName) []

              | con <- cons

              , let conName = constructorName con

              ]

        | otherwise -> [argsToValue target jc tvMap opts True con | con <- cons]

-- | Name of the constructor as a quoted 'Value' or 'Encoding'.

conStr :: ToJSONFun -> Options -> Name -> Q Exp

conStr Value opts = appE [|String|] . conTxt opts

conStr Encoding opts = appE [|E.text|] . conTxt opts

-- | Name of the constructor as a quoted 'Text'.

conTxt :: Options -> Name -> Q Exp

conTxt opts = appE [|T.pack|] . stringE . conString opts

-- | Name of the constructor.

conString :: Options -> Name -> String

conString opts = constructorTagModifier opts . nameBase

-- | If constructor is nullary.

isNullary :: ConstructorInfo -> Bool

isNullary ConstructorInfo { constructorVariant = NormalConstructor

                          , constructorFields  = tys } = null tys

isNullary _ = False

-- | Wrap fields of a non-record constructor. See 'sumToValue'.

opaqueSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ

opaqueSumToValue target opts multiCons nullary conName value =

  sumToValue target opts multiCons nullary conName

    value

    pairs

  where

    pairs contentsFieldName = listE [toPair target contentsFieldName value]

-- | Wrap fields of a record constructor. See 'sumToValue'.

recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ

recordSumToValue target opts multiCons nullary conName pairs =

  sumToValue target opts multiCons nullary conName

    (objectExp target pairs)

    (const pairs)

-- | Wrap fields of a constructor.

sumToValue

  :: ToJSONFun

  -- ^ The method being derived.

  -> Options

  -- ^ Deriving options.

  -> Bool

  -- ^ Does this type have multiple constructors.

  -> Bool

  -- ^ Is this constructor nullary.

  -> Name

  -- ^ Constructor name.

  -> ExpQ

  -- ^ Fields of the constructor as a 'Value' or 'Encoding'.

  -> (String -> ExpQ)

  -- ^ Representation of an 'Object' fragment used for the 'TaggedObject'

  -- variant; of type @[(Text,Value)]@ or @[Encoding]@, depending on the method

  -- being derived.

  --

  -- - For non-records, produces a pair @"contentsFieldName":value@,

  --   given a @contentsFieldName@ as an argument. See 'opaqueSumToValue'.

  -- - For records, produces the list of pairs corresponding to fields of the

  --   encoded value (ignores the argument). See 'recordSumToValue'.

  -> ExpQ

sumToValue target opts multiCons nullary conName value pairs

    | multiCons =

        case sumEncoding opts of

          TwoElemArray ->

            array target [conStr target opts conName, value]

          TaggedObject{tagFieldName, contentsFieldName} ->

            -- TODO: Maybe throw an error in case

            -- tagFieldName overwrites a field in pairs.

            let tag = toPair target tagFieldName (conStr target opts conName)

                content = pairs contentsFieldName

            in objectExp target $

              if nullary then listE [tag] else infixApp tag [|(:)|] content

          ObjectWithSingleField ->

            object target [(conString opts conName, value)]

          UntaggedValue | nullary -> conStr target opts conName

          UntaggedValue -> value

    | otherwise = value

-- | Generates code to generate the JSON encoding of a single constructor.

argsToValue :: ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match

-- Polyadic constructors with special case for unary constructors.

argsToValue target jc tvMap opts multiCons

  ConstructorInfo { constructorName    = conName

                  , constructorVariant = NormalConstructor

                  , constructorFields  = argTys } = do

    argTys' <- mapM resolveTypeSynonyms argTys

    let len = length argTys'

    args <- newNameList "arg" len

    let js = case [ dispatchToJSON target jc conName tvMap argTy

                      `appE` varE arg

                  | (arg, argTy) <- zip args argTys'

                  ] of

               -- Single argument is directly converted.

               [e] -> e

               -- Zero and multiple arguments are converted to a JSON array.

               es -> array target es

    match (conP conName $ map varP args)

          (normalB $ opaqueSumToValue target opts multiCons (null argTys') conName js)

          []

-- Records.

argsToValue target jc tvMap opts multiCons

  info@ConstructorInfo { constructorName    = conName

                       , constructorVariant = RecordConstructor fields

                       , constructorFields  = argTys } =

    case (unwrapUnaryRecords opts, not multiCons, argTys) of

      (True,True,[_]) -> argsToValue target jc tvMap opts multiCons

                                     (info{constructorVariant = NormalConstructor})

      _ -> do

        argTys' <- mapM resolveTypeSynonyms argTys

        args <- newNameList "arg" $ length argTys'

        let pairs | omitNothingFields opts = infixApp maybeFields

                                                      [|(++)|]

                                                      restFields

                  | otherwise = listE $ map pureToPair argCons

            argCons = zip3 (map varE args) argTys' fields

            maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)

            restFields = listE $ map pureToPair rest

            (maybes0, rest0) = partition isMaybe argCons

            (options, rest) = partition isOption rest0

            maybes = maybes0 ++ map optionToMaybe options

            maybeToPair = toPairLifted True

            pureToPair = toPairLifted False

            toPairLifted lifted (arg, argTy, field) =

              let toValue = dispatchToJSON target jc conName tvMap argTy

                  fieldName = fieldLabel opts field

                  e arg' = toPair target fieldName (toValue `appE` arg')

              in if lifted

                then do

                  x <- newName "x"

                  infixApp (lam1E (varP x) (e (varE x))) [|(<$>)|] arg

                else e arg

        match (conP conName $ map varP args)

              (normalB $ recordSumToValue target opts multiCons (null argTys) conName pairs)

              []

-- Infix constructors.

argsToValue target jc tvMap opts multiCons

  ConstructorInfo { constructorName    = conName

                  , constructorVariant = InfixConstructor

                  , constructorFields  = argTys } = do

    [alTy, arTy] <- mapM resolveTypeSynonyms argTys

    al <- newName "argL"

    ar <- newName "argR"

    match (infixP (varP al) conName (varP ar))

          ( normalB

          $ opaqueSumToValue target opts multiCons False conName

          $ array target

              [ dispatchToJSON target jc conName tvMap aTy

                  `appE` varE a

              | (a, aTy) <- [(al,alTy), (ar,arTy)]

              ]

          )

          []

isMaybe :: (a, Type, b) -> Bool

isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe

isMaybe _                       = False

isOption :: (a, Type, b) -> Bool

isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option

isOption _                       = False

optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c)

optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)

(<^>) :: ExpQ -> ExpQ -> ExpQ

(<^>) a b = infixApp a [|(E.><)|] b

infixr 6 <^>

(<:>) :: ExpQ -> ExpQ -> ExpQ

(<:>) a b = a <^> [|E.colon|] <^> b

infixr 5 <:>

(<%>) :: ExpQ -> ExpQ -> ExpQ

(<%>) a b = a <^> [|E.comma|] <^> b

infixr 4 <%>

-- | Wrap a list of quoted 'Value's in a quoted 'Array' (of type 'Value').

array :: ToJSONFun -> [ExpQ] -> ExpQ

array Encoding [] = [|E.emptyArray_|]

array Value [] = [|Array V.empty|]

array Encoding es = [|E.wrapArray|] `appE` foldr1 (<%>) es

array Value es = do

  mv <- newName "mv"

  let newMV = bindS (varP mv)

                    ([|VM.unsafeNew|] `appE`

                      litE (integerL $ fromIntegral (length es)))

      stmts = [ noBindS $

                  [|VM.unsafeWrite|] `appE`

                    varE mv `appE`

                      litE (integerL ix) `appE`

                        e

              | (ix, e) <- zip [(0::Integer)..] es

              ]

      ret = noBindS $ [|return|] `appE` varE mv

  [|Array|] `appE`

             (varE 'V.create `appE`

               doE (newMV:stmts++[ret]))

-- | Wrap an associative list of keys and quoted values in a quoted 'Object'.

object :: ToJSONFun -> [(String, ExpQ)] -> ExpQ

object target = wrapObject target . catPairs target . fmap (uncurry (toPair target))

-- |

-- - When deriving 'ToJSON', map a list of quoted key-value pairs to an

--   expression of the list of pairs.

-- - When deriving 'ToEncoding', map a list of quoted 'Encoding's representing

--   key-value pairs to a comma-separated 'Encoding' of them.

--

-- > catPairs Value [ [|(k0,v0)|], [|(k1,v1)|] ] = [| [(k0,v0), (k1,v1)] |]

-- > catPairs Encoding [ [|"\"k0\":v0"|], [|"\"k1\":v1"|] ] = [| "\"k0\":v0,\"k1\":v1" |]

catPairs :: ToJSONFun -> [ExpQ] -> ExpQ

catPairs Value = listE

catPairs Encoding = foldr1 (<%>)

-- |

-- - When deriving 'ToJSON', wrap a quoted list of key-value pairs in an 'Object'.

-- - When deriving 'ToEncoding', wrap a quoted list of encoded key-value pairs

--   in an encoded 'Object'.

--

-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]

-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "{\"k0\":v0,\"k1\":v1}" |]

objectExp :: ToJSONFun -> ExpQ -> ExpQ

objectExp target = wrapObject target . catPairsExp target

-- | Counterpart of 'catPairsExp' when the list of pairs is already quoted.

--

-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| [(k0,v0), (k1,v1)] |]

-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "\"k0\":v0,\"k1\":v1" |]

catPairsExp :: ToJSONFun -> ExpQ -> ExpQ

catPairsExp Value e = e

catPairsExp Encoding e = [|commaSep|] `appE` e

-- | Create (an encoding of) a key-value pair.

--

-- > toPair Value "k" [|v|] = [|("k",v)|]  -- The quoted string is actually Text.

-- > toPair Encoding "k" [|"v"|] = [|"\"k\":v"|]

toPair :: ToJSONFun -> String -> ExpQ -> ExpQ

toPair Value k v = infixApp [|T.pack k|] [|(.=)|] v

toPair Encoding k v = [|E.string k|] <:> v

-- | Map an associative list in an 'Object'.

--

-- > wrapObject Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]

-- > wrapObject Encoding [| "\"k0\":v0,\"k1\":v1" |] = [| "{\"k0\":v0,\"k1\":v1}" |]

wrapObject :: ToJSONFun -> ExpQ -> ExpQ

wrapObject Value e = [|A.object|] `appE` e

wrapObject Encoding e = [|E.wrapObject|] `appE` e

-- | Separate 'Encoding's by commas.

--

-- > commaSep ["a","b","c"] = "a,b,c"

commaSep :: [E.Encoding] -> E.Encoding

commaSep [] = E.empty

commaSep [x] = x

commaSep (x : xs) = x E.>< E.comma E.>< commaSep xs

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

-- FromJSON

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

-- | Generates a 'FromJSON' instance declaration for the given data type or

-- data family instance constructor.

deriveFromJSON :: Options

               -- ^ Encoding options.

               -> Name

               -- ^ Name of the type for which to generate a 'FromJSON' instance

               -- declaration.

               -> Q [Dec]

deriveFromJSON = deriveFromJSONCommon fromJSONClass

-- | Generates a 'FromJSON1' instance declaration for the given data type or

-- data family instance constructor.

deriveFromJSON1 :: Options

                -- ^ Encoding options.

                -> Name

                -- ^ Name of the type for which to generate a 'FromJSON1' instance

                -- declaration.

                -> Q [Dec]

deriveFromJSON1 = deriveFromJSONCommon fromJSON1Class

-- | Generates a 'FromJSON2' instance declaration for the given data type or

-- data family instance constructor.

deriveFromJSON2 :: Options

                -- ^ Encoding options.

                -> Name

                -- ^ Name of the type for which to generate a 'FromJSON3' instance

                -- declaration.

                -> Q [Dec]

deriveFromJSON2 = deriveFromJSONCommon fromJSON2Class

deriveFromJSONCommon :: JSONClass

                     -- ^ The FromJSON variant being derived.

                     -> Options

                     -- ^ Encoding options.

                     -> Name

                     -- ^ Name of the type for which to generate an instance.

                     -- declaration.

                     -> Q [Dec]

deriveFromJSONCommon = deriveJSONClass [(ParseJSON, consFromJSON)]

-- | Generates a lambda expression which parses the JSON encoding of the given

-- data type or data family instance constructor.

mkParseJSON :: Options -- ^ Encoding options.

            -> Name -- ^ Name of the encoded type.

            -> Q Exp

mkParseJSON = mkParseJSONCommon fromJSONClass

-- | Generates a lambda expression which parses the JSON encoding of the given

-- data type or data family instance constructor by using the given parsing

-- function on occurrences of the last type parameter.

mkLiftParseJSON :: Options -- ^ Encoding options.

                -> Name -- ^ Name of the encoded type.

                -> Q Exp

mkLiftParseJSON = mkParseJSONCommon fromJSON1Class

-- | Generates a lambda expression which parses the JSON encoding of the given

-- data type or data family instance constructor by using the given parsing

-- functions on occurrences of the last two type parameters.

mkLiftParseJSON2 :: Options -- ^ Encoding options.

                 -> Name -- ^ Name of the encoded type.

                 -> Q Exp

mkLiftParseJSON2 = mkParseJSONCommon fromJSON2Class

mkParseJSONCommon :: JSONClass -- ^ Which class's method is being derived.

                  -> Options -- ^ Encoding options.

                  -> Name -- ^ Name of the encoded type.

                  -> Q Exp

mkParseJSONCommon = mkFunCommon consFromJSON

-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates

-- code to parse the JSON encoding of a number of constructors. All constructors

-- must be from the same type.

consFromJSON :: JSONClass

             -- ^ The FromJSON variant being derived.

             -> Name

             -- ^ Name of the type to which the constructors belong.

             -> Options

             -- ^ Encoding options

             -> [Type]

             -- ^ The types from the data type/data family instance declaration

             -> [ConstructorInfo]

             -- ^ Constructors for which to generate JSON parsing code.

             -> Q Exp

consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "

                                ++ "Not a single constructor given!"

consFromJSON jc tName opts vars cons = do

  value <- newName "value"

  pjs   <- newNameList "_pj"  $ arityInt jc

  pjls  <- newNameList "_pjl" $ arityInt jc

  let zippedPJs      = zip pjs pjls

      interleavedPJs = interleave pjs pjls

      lastTyVars     = map varTToName $ drop (length vars - arityInt jc) vars

      tvMap          = M.fromList $ zip lastTyVars zippedPJs

  lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap

  where

    checkExi tvMap con = checkExistentialContext jc tvMap

                                                 (constructorContext con)

                                                 (constructorName con)

    lamExpr value tvMap = case cons of

      [con]

        | not (tagSingleConstructors opts)

            -> checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right value)

      _ | sumEncoding opts == UntaggedValue

            -> parseUntaggedValue tvMap cons value

        | otherwise

            -> caseE (varE value) $

                   if allNullaryToStringTag opts && all isNullary cons

                   then allNullaryMatches

                   else mixedMatches tvMap

    allNullaryMatches =

      [ do txt <- newName "txt"

           match (conP 'String [varP txt])

                 (guardedB $

                  [ liftM2 (,) (normalG $

                                  infixApp (varE txt)

                                           [|(==)|]

                                           (conTxt opts conName)

                               )

                               ([|pure|] `appE` conE conName)

                  | con <- cons

                  , let conName = constructorName con

                  ]

                  ++

                  [ liftM2 (,)

                      (normalG [|otherwise|])

                      ( [|noMatchFail|]

                        `appE` litE (stringL $ show tName)

                        `appE` ([|T.unpack|] `appE` varE txt)

                      )

                  ]

                 )

                 []

      , do other <- newName "other"

           match (varP other)

                 (normalB $ [|noStringFail|]

                    `appE` litE (stringL $ show tName)

                    `appE` ([|valueConName|] `appE` varE other)

                 )

                 []

      ]

    mixedMatches tvMap =

        case sumEncoding opts of

          TaggedObject {tagFieldName, contentsFieldName} ->

            parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName

          UntaggedValue -> error "UntaggedValue: Should be handled already"

          ObjectWithSingleField ->

            parseObject $ parseObjectWithSingleField tvMap

          TwoElemArray ->

            [ do arr <- newName "array"

                 match (conP 'Array [varP arr])

                       (guardedB

                        [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)

                                                         [|(==)|]

                                                         (litE $ integerL 2))

                                     (parse2ElemArray tvMap arr)

                        , liftM2 (,) (normalG [|otherwise|])

                                     ([|not2ElemArray|]

                                       `appE` litE (stringL $ show tName)

                                       `appE` ([|V.length|] `appE` varE arr))

                        ]

                       )

                       []

            , do other <- newName "other"

                 match (varP other)

                       ( normalB

                         $ [|noArrayFail|]

                             `appE` litE (stringL $ show tName)

                             `appE` ([|valueConName|] `appE` varE other)

                       )

                       []

            ]

    parseObject f =

        [ do obj <- newName "obj"

             match (conP 'Object [varP obj]) (normalB $ f obj) []

        , do other <- newName "other"

             match (varP other)

                   ( normalB

                     $ [|noObjectFail|]

                         `appE` litE (stringL $ show tName)

                         `appE` ([|valueConName|] `appE` varE other)

                   )

                   []

        ]

    parseTaggedObject tvMap typFieldName valFieldName obj = do

      conKey <- newName "conKey"

      doE [ bindS (varP conKey)

                  (infixApp (varE obj)

                            [|(.:)|]

                            ([|T.pack|] `appE` stringE typFieldName))

          , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject

          ]

    parseUntaggedValue tvMap cons' conVal =

        foldr1 (\e e' -> infixApp e [|(<|>)|] e')

               (map (\x -> parseValue tvMap x conVal) cons')

    parseValue _tvMap

        ConstructorInfo { constructorName    = conName

                        , constructorVariant = NormalConstructor

                        , constructorFields  = [] }

        conVal = do

      str <- newName "str"

      caseE (varE conVal)

        [ match (conP 'String [varP str])

                (guardedB

                  [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] (conTxt opts conName)

                               )

                               ([|pure|] `appE` conE conName)

                  ]

                )

                []

        , matchFailed tName conName "String"

        ]

    parseValue tvMap con conVal =

      checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right conVal)

    parse2ElemArray tvMap arr = do

      conKey <- newName "conKey"

      conVal <- newName "conVal"

      let letIx n ix =

              valD (varP n)

                   (normalB ([|V.unsafeIndex|] `appE`

                               varE arr `appE`

                               litE (integerL ix)))

                   []

      letE [ letIx conKey 0

           , letIx conVal 1

           ]

           (caseE (varE conKey)

                  [ do txt <- newName "txt"

                       match (conP 'String [varP txt])

                             (normalB $ parseContents tvMap

                                                      txt

                                                      (Right conVal)

                                                      'conNotFoundFail2ElemArray

                             )

                             []

                  , do other <- newName "other"

                       match (varP other)

                             ( normalB

                               $ [|firstElemNoStringFail|]

                                     `appE` litE (stringL $ show tName)

                                     `appE` ([|valueConName|] `appE` varE other)