{-# LANGUAGE
CPP,
FlexibleInstances,
NamedFieldPuns,
TemplateHaskell,
UndecidableInstances,
NoImplicitPrelude
  #-}

#include "overlapping-compat.h"

{-|
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 Json.Internal.TH
(
  deriveJson,

  deriveToJson,
  deriveFromJson,

  mkToJson,
  mkToEncoding,
  mkParseJson,
)
where
  
import BasePrelude

import Json.Internal.Types
import Json.Internal.Classes
import Json.Internal.Instances
import Json.Internal.ValueParser
import Data.Map (Map)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax ( VarStrictType )
#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))
import qualified Data.Map as M    (singleton)
import Language.Haskell.TH.Syntax (mkNameG_tc)
#endif
import qualified Data.ByteString.Builder as B
import qualified Json.Internal.Encode.ByteString as E
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as VM


--------------------------------------------------------------------------------
-- 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 opts name =
    liftM2 (++)
           (deriveToJson   opts name)
           (deriveFromJson opts name)


--------------------------------------------------------------------------------
-- 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 opts name =
    withType name $ \name' tvbs cons mbTys -> fmap (:[]) $ fromCons name' tvbs cons mbTys
  where
    fromCons :: Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec
    fromCons name' tvbs cons mbTys = do
        (instanceCxt, instanceType) <- buildTypeInstance name' ''ToJson tvbs mbTys
        instanceD (return instanceCxt)
                  (return instanceType)
                  [ funD 'toJson
                         [ clause []
                                  (normalB $ consToJson opts cons)
                                  []
                         ]
                  , funD 'toEncoding
                         [ clause []
                                  (normalB $ consToEncoding opts cons)
                                  []
                         ]
                  ]

-- | Generates a lambda expression which encodes the given data type or
-- data family instance constructor as 'Json'.
mkToJson :: Options -- ^ Encoding options.
         -> Name -- ^ Name of the type to encode.
         -> ExpQ
mkToJson opts name = withType name (\_ _ cons _ -> consToJson opts cons)

-- | 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.
             -> ExpQ
mkToEncoding opts name = withType name (\_ _ cons _ -> consToEncoding opts cons)

-- | Helper function used by both 'deriveToJson' and 'mkToJson'. Generates
-- code to generate a 'Json' value of a number of constructors. All
-- constructors must be from the same type.
consToJson :: Options
           -- ^ Encoding options.
           -> [Con]
           -- ^ Constructors for which to generate JSON generating code.
           -> ExpQ

-- TODO: change this error message
consToJson _ [] = error $ "Json.Internal.TH.consToJson: "
                          ++ "Not a single constructor given!"

-- A single constructor is directly encoded. The constructor itself may be
-- forgotten.
consToJson opts [con] = do
    value <- newName "value"
    lam1E (varP value) $ caseE (varE value) [argsToJson opts False con]

consToJson opts cons = do
    value <- newName "value"
    lam1E (varP value) $ caseE (varE value) matches
  where
    matches
        | allNullaryToStringTag opts && all isNullary cons =
              [ match (conP conName [])
                  (normalB [|String (T.pack $(conStringE opts conName))|]) []
              | con <- cons
              , let conName = getConName con
              ]
        | otherwise = [argsToJson opts True con | con <- cons]

-- | Turn a Haskell constructor name into the name we expect to see in JSON.
conStringE :: Options -> Name -> ExpQ
conStringE opts = stringE . constructorTagModifier opts . nameBase

-- | Turn a Haskell record field name into the name we expect to see in JSON.
fieldStringE :: Options -> Name -> ExpQ
fieldStringE opts = stringE . fieldLabelModifier opts . nameBase

-- | Helper function used by both 'deriveToJson' and 'mkToEncoding'. Generates
-- code to write out a value for a number of constructors. All constructors
-- must be from the same type.
consToEncoding
  :: Options -- ^ Encoding options
  -> [Con]   -- ^ Constructors for which to generate JSON-generating code
  -> ExpQ

-- TODO: change this error message
consToEncoding _ [] = error $ "Json.Internal.TH.consToEncoding: "
                      ++ "Not a single constructor given!"

-- A single constructor is directly encoded. The constructor itself may be
-- forgotten.
consToEncoding opts [con] = do
    value <- newName "value"
    lam1E (varP value) $ caseE (varE value) [argsToEncoding opts False con]

-- Encode just the name of the constructor of a sum type iff all the
-- constructors are nullary.
consToEncoding opts cons = do
    value <- newName "value"
    lam1E (varP value) $ caseE (varE value) matches
  where
    matches
        | allNullaryToStringTag opts && all isNullary cons =
              [ match (conP conName [])
                      (normalB [|Encoding $(encStr opts conName)|])
                      []
              | con <- cons
              , let conName = getConName con
              ]
        | otherwise = [argsToEncoding opts True con | con <- cons]

encStr :: Options -> Name -> ExpQ
encStr opts name = [|E.text (T.pack $(conStringE opts name))|]

-- | If constructor is nullary.
isNullary :: Con -> Bool
isNullary (NormalC _ []) = True
isNullary _ = False

sumToJson :: Options -> Bool -> Name -> ExpQ -> ExpQ
sumToJson opts multiCons conName contentsE
  | not multiCons = contentsE
  | otherwise = case sumEncoding opts of
      TwoElemArray ->
        [|Array (V.fromList [String (T.pack $(conStringE opts conName)),
                             $contentsE])|]
      TaggedObject{tagFieldName, contentsFieldName} ->
        [|object [
            T.pack tagFieldName .= String (T.pack $(conStringE opts conName)),
            T.pack contentsFieldName .= $contentsE]
         |]
      ObjectWithSingleField ->
        [|object [
            T.pack $(conStringE opts conName) .= $contentsE]
         |]

-- | Generates code to generate the JSON encoding of a single constructor.
argsToJson :: Options -> Bool -> Con -> Q Match
-- Nullary constructors. Generates code that explicitly matches against the
-- constructor even though it doesn't contain data. This is useful to prevent
-- type errors.
argsToJson opts multiCons (NormalC conName []) =
  match (conP conName [])
        (normalB (sumToJson opts multiCons conName [|toJson ([] :: [()])|]))
        []

-- Polyadic constructors with special case for unary constructors.
argsToJson opts multiCons (NormalC conName ts) = do
  let len = length ts
  args <- mapM newName ["arg" ++ show n | n <- [1..len]]
  js <- case [[|toJson $(varE arg)|] | arg <- args] of
          -- Single argument is directly converted.
          [e] -> return e
          -- Multiple arguments are converted to a JSON array.
          es -> do
            mv <- newName "mv"
            let newMV = bindS (varP mv)
                              ([|VM.unsafeNew|] `appE`
                                litE (integerL $ fromIntegral len))
                stmts = [ noBindS [|VM.unsafeWrite $(varE mv)
                                                   $(litE (integerL ix))
                                                   $e
                                   |]
                        | (ix, e) <- zip [(0::Integer)..] es
                        ]
                ret = noBindS [|return $(varE mv)|]
            return [|Array (V.create $(doE (newMV:stmts++[ret])))|]
  match (conP conName $ map varP args)
        (normalB $ sumToJson opts multiCons conName js)
        []

-- Records.
argsToJson opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of
  (True,True,[(_,st,ty)]) -> argsToJson opts multiCons (NormalC conName [(st,ty)])
  _ -> do
    args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
    let pairs | omitNothingFields opts = [|$maybeFields ++ $restFields|]
              | otherwise = listE $ map toPair argCons

        argCons = zip args ts

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

        restFields = listE $ map toPair rest

        (maybes, rest) = partition isMaybe argCons

        maybeToPair (arg, (fieldName, _, _)) =
          [|($(fieldTextE fieldName) .=) <$> $(varE arg)|]

        toPair (arg, (fieldName, _, _)) =
          [|$(fieldTextE fieldName) .= $(varE arg)|]

        fieldTextE fieldName = [|T.pack $(fieldStringE opts fieldName)|]

    match (conP conName $ map varP args)
          ( normalB
          $ if not multiCons
              then [|object $pairs|]
              else case sumEncoding opts of
                     TwoElemArray ->
                       [|toJson (String (T.pack $(conStringE opts conName)),
                                 object $pairs)
                        |]
                     TaggedObject{tagFieldName} -> do
                       -- TODO: Maybe throw an error in case
                       -- tagFieldName overwrites a field in pairs.
                       let tagPair =
                             [|T.pack tagFieldName .=
                                 String (T.pack $(conStringE opts conName))
                              |]
                       [|object ($tagPair : $pairs)|]
                     ObjectWithSingleField ->
                       [|object [
                           T.pack $(conStringE opts conName) .= object $pairs]
                        |]
          ) []

-- Infix constructors.
argsToJson opts multiCons (InfixC _ conName _) = do
  al <- newName "argL"
  ar <- newName "argR"
  match (infixP (varP al) conName (varP ar))
        ( normalB
        $ sumToJson opts multiCons conName
        $ [|toJson [toJson $(varE al), toJson $(varE ar)]|]
        )
        []
-- Existentially quantified constructors.
argsToJson opts multiCons (ForallC _ _ con) =
  argsToJson opts multiCons con

#if MIN_VERSION_template_haskell(2,11,0)
-- GADTs.
argsToValue opts multiCons (GadtC conNames ts _) =
  argsToValue opts multiCons $ NormalC (head conNames) ts

argsToValue opts multiCons (RecGadtC conNames ts _) =
  argsToValue opts multiCons $ RecC (head conNames) ts
#endif

isMaybe :: (a, (b, c, Type)) -> Bool
isMaybe (_, (_, _, AppT (ConT t) _)) = t == ''Maybe
isMaybe _                            = False

(<^>) :: ExpQ -> ExpQ -> ExpQ
(<^>) a b = [|$a <> $b|]
infixr 6 <^>

(<:>) :: ExpQ -> ExpQ -> ExpQ
(<:>) a b = a <^> [|B.char7 ':'|] <^> b
infixr 5 <:>

(<%>) :: ExpQ -> ExpQ -> ExpQ
(<%>) a b = a <^> [|B.char7 ','|] <^> b
infixr 4 <%>

-- like 'arrayE', but for expressions
-- 
-- arrayEncoding :: Builder -> Encoding
arrayEncoding :: ExpQ -> ExpQ
arrayEncoding e = [|Encoding|] `appE` ([|B.char7 '['|] <^> e <^> [|B.char7 ']'|])

-- TODO: benchmark whether replacing this with just “E.brackets” and
-- “E.braces” will make any difference

-- like 'objectE', but for expressions
-- 
-- objectEncoding :: Builder -> Encoding
objectEncoding :: ExpQ -> ExpQ
objectEncoding e = [|Encoding|] `appE` ([|B.char7 '{'|] <^> e <^> [|B.char7 '}'|])

sumToEncoding :: Options -> Bool -> Name -> ExpQ -> ExpQ
sumToEncoding opts multiCons conName contentsE
  | not multiCons = contentsE
  | otherwise = do
      let builderE = [|fromEncoding $contentsE|]
      case sumEncoding opts of
        TwoElemArray ->
          arrayEncoding (encStr opts conName <%> builderE)
        TaggedObject{tagFieldName, contentsFieldName} ->
          objectEncoding $
          ([|E.text (T.pack tagFieldName)|] <:> encStr opts conName) <%>
          ([|E.text (T.pack contentsFieldName)|] <:> builderE)
        ObjectWithSingleField ->
          objectEncoding (encStr opts conName <:> builderE)

-- | Generates code to generate the JSON encoding of a single constructor.
argsToEncoding :: Options -> Bool -> Con -> Q Match
-- Nullary constructors. Generates code that explicitly matches against the
-- constructor even though it doesn't contain data. This is useful to prevent
-- type errors.
argsToEncoding opts multiCons (NormalC conName []) =
  match (conP conName [])
        (normalB (sumToEncoding opts multiCons conName [|toEncoding ([] :: [()])|]))
        []

-- Polyadic constructors with special case for unary constructors.
argsToEncoding opts multiCons (NormalC conName ts) = do
    let len = length ts
    args <- mapM newName ["arg" ++ show n | n <- [1..len]]
    js <- case args of
            -- Single argument is directly converted.
            [e] -> return [|toEncoding $(varE e)|]
            -- Multiple arguments are converted to a Json array.
            es ->
              return (arrayEncoding (foldr1 (<%>) [[|builder $(varE x)|] | x <- es]))
    match (conP conName $ map varP args)
          (normalB $ sumToEncoding opts multiCons conName js)
          []

-- Records.
--
-- TODO: rewrite things here a bit once I understand the fixities of <^> etc
argsToEncoding opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of
  (True,True,[(_,st,ty)]) -> argsToEncoding opts multiCons (NormalC conName [(st,ty)])
  _ -> do
    args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]

    let objBody = [|mconcat (intersperse (B.char7 ',') $pairs)|]
        pairs | omitNothingFields opts = [|$maybeFields <> $restFields|]
              | otherwise = listE (map toPair argCons)

        argCons = zip args ts

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

        restFields = listE (map toPair rest)

        (maybes, rest) = partition isMaybe argCons

        maybeToPair (arg, (fieldName, _, _)) =
            infixApp
              (infixApp
                (infixE
                  (Just $ fieldEnc fieldName <^> [|B.char7 ':'|])
                  [|(<>)|]
                  Nothing)
                [|(.)|]
                [|builder|])
              [|(<$>)|]
              (varE arg)

        toPair (arg, (fieldName, _, _)) =
          fieldEnc fieldName <:> [|builder $(varE arg)|]

        fieldEnc fieldName = [|E.text (T.pack $(fieldStringE opts fieldName))|]

    match (conP conName $ map varP args)
          ( normalB
          $ if not multiCons
              then objectEncoding objBody
              else case sumEncoding opts of
                     TwoElemArray -> arrayEncoding $
                       encStr opts conName <%>
                       [|fromEncoding $(objectEncoding objBody)|]
                     TaggedObject{tagFieldName} -> objectEncoding $
                       ([|E.text (T.pack tagFieldName)|] <:>
                        encStr opts conName) <%>
                       objBody
                     ObjectWithSingleField -> objectEncoding $
                       encStr opts conName <:>
                       [|fromEncoding $(objectEncoding objBody)|]
          ) []

-- Infix constructors.
argsToEncoding opts multiCons (InfixC _ conName _) = do
    al <- newName "argL"
    ar <- newName "argR"
    match (infixP (varP al) conName (varP ar))
          ( normalB
          $ sumToEncoding opts multiCons conName
          $ [|toEncoding [toJson $(varE al), toJson $(varE ar)]|]
          )
          []
-- Existentially quantified constructors.
argsToEncoding opts multiCons (ForallC _ _ con) =
    argsToEncoding opts multiCons con

#if MIN_VERSION_template_haskell(2,11,0)
-- GADTs.
argsToEncoding opts multiCons (GadtC conNames ts _) =
    argsToEncoding opts multiCons $ NormalC (head conNames) ts

argsToEncoding opts multiCons (RecGadtC conNames ts _) =
    argsToEncoding opts multiCons $ RecC (head conNames) ts
#endif

--------------------------------------------------------------------------------
-- 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 opts name =
    withType name $ \name' tvbs cons mbTys -> fmap (:[]) $ fromCons name' tvbs cons mbTys
  where
    {-
    instance (<instanceCxt>) => FromJson <instanceType> where
      parseJson = $(consFromJson name' opts cons)
    -}
    fromCons :: Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec
    fromCons name' tvbs cons mbTys = do
      (instanceCxt, instanceType) <- buildTypeInstance name' ''FromJson tvbs mbTys
      instanceD (return instanceCxt)
                (return instanceType)
                [ funD 'parseJson
                       [ clause []
                                (normalB $ consFromJson name' opts cons)
                                []
                       ]
                ]

-- | 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.
            -> ExpQ
mkParseJson opts name =
  withType name (\name' _ cons _ -> consFromJson name' opts cons)

-- | Generate code to parse the JSON encoding of a number of constructors.
-- All constructors must be from the same type.
consFromJson
  :: Name       -- ^ Name of the type to which the constructors belong
  -> Options    -- ^ Encoding options
  -> [Con]      -- ^ Constructors for which to generate JSON parsing code
  -> ExpQ

-- TODO: change this error message (together with other ones in this module)
consFromJson _ _ [] = error $ "Json.Internal.TH.consFromJson: "
                              ++ "Not a single constructor given!"

consFromJson tName opts [con] =
  parseArgs tName opts con True

consFromJson tName opts cons =
  if allNullaryToStringTag opts && all isNullary cons
    then allNullaryMatches
    else mixedMatches

  where
    -- tName as a string literal that could be used in splices
    tNameExpr = stringE (show tName)

    {-
    do txt <- getString tName
       case () of
         _ | txt == T.pack <JSON name of Con1> = return Con1
           | txt == T.pack <JSON name of Con2> = return Con2
           ...
           | otherwise = noMatchFail tName (T.unpack txt)
    -}
    allNullaryMatches = do
      txt <- newName "txt"
      let makeGuard conName =
            normalGE [|$(varE txt) == T.pack $(conStringE opts conName)|]
                     [|return $(conE conName)|]
      let makeOtherwiseGuard =
            normalGE [|otherwise|]
                     [|noMatchFail $tNameExpr (T.unpack $(varE txt))|]
      let allGuards = [makeGuard (getConName con) | con <- cons]
                   ++ [makeOtherwiseGuard]
      doE [bindS (varP txt) [|getString $tNameExpr|],
           noBindS $ caseE [|()|] [match wildP (guardedB allGuards) []]]

    -- TODO: rename
    mixedMatches = case sumEncoding opts of
      TaggedObject {tagFieldName} ->
        [|do k <- withObject $tNameExpr $
                    field (T.pack $(stringE tagFieldName))
             -- parseArgs might want to look for data in the “contents”
             -- field, but it also might not (if the constructor is a
             -- record), so we let parseArgs decide whether it's needed or
             -- not
             $(chooseConstructor 'k 'conNotFoundFailTaggedObject)
         |]
      ObjectWithSingleField ->
        [|withSingleton $tNameExpr $ \k -> do
            $(chooseConstructor 'k 'conNotFoundFailObjectSingleField)
         |]
      TwoElemArray ->
        [|withArray $tNameExpr $ do
            checkLength 2
            k <- unsafeElementAt 0
            with (unsafeElementAt 1) $
              $(chooseConstructor 'k 'conNotFoundFail2ElemArray)
         |]

    {-
    case conKey of
      _ | conKey == T.pack <JSON name of Con1> =
            $parseArgs tName opts con1
        | conKey == T.pack <JSON name of Con2> =
            $parseArgs tName opts con2
        ...
        | otherwise = errorFun tName
                        [<JSON name of Con1>, <JSON name of Con2>, ...]
                        (T.unpack conKey)
    -}
    chooseConstructor conKey errorFun =
      caseE (varE conKey)
            [ match wildP
                    ( guardedB $
                      [ normalGE
                          [|$(varE conKey) == T.pack $(conStringE opts conName)|]
                          (parseArgs tName opts con False)
                      | con <- cons
                      , let conName = getConName con
                      ]
                      ++
                      [ normalGE
                          [|otherwise|]
                          [|$(varE errorFun) $tNameExpr
                              $(listE (map (conStringE opts . getConName) cons))
                              (T.unpack $(varE conKey))|]
                      ]
                    )
                    []
            ]

{-
result :: Parser Json <tName>
result = withArray tName $ do
  checkLength 0
  return Con
-}
parseNullaryConstructor :: Name -> Name -> ExpQ
parseNullaryConstructor tName conName =
  [|withArray $(stringE (show tName)) $ do
      checkLength 0
      return $(conE conName)
   |]

{-
result :: Parser Json <some type>
result = Con <$> parseJson
-}
parseUnaryConstructor :: Name -> ExpQ
parseUnaryConstructor conName = [|$(conE conName) <$> parseJson|]

{-
result :: Parser Json <tName>
result = withObject tName $
  Con <$> lookupField tName <JSON name of constructor>
                      (T.pack <JSON name of field 1>)
      <*> lookupField tName <JSON name of constructor>
                      (T.pack <JSON name of field 2>)
      ...
-}
parseRecord :: Options -> Name -> Name -> [VarStrictType] -> ExpQ
parseRecord opts tName conName ts =
    [|withObject $tNameExpr $(applicativeChain (conE conName) xs)|]
  where
    tNameExpr = stringE (show tName)
    xs = [ [|lookupField
               $(stringE $ show tName)
               $(conStringE opts conName)
               (T.pack $(fieldStringE opts recordField))
            |]
         | (recordField, _, _) <- ts
         ]

{- Generate code to parse the JSON encoding of a single constructor.

result :: Parser Json <some type>
-}
parseArgs :: Name    -- ^ Name of the type to which the constructor belongs
          -> Options -- ^ Encoding options
          -> Con     -- ^ Constructor for which to generate JSON parsing code
          -> Bool    -- ^ Whether the type is a single-constructor type
          -> ExpQ
parseArgs tName opts con isSingle = case con of
  -- Nullary constructors
  NormalC conName [] ->
    mbWithContents $ parseNullaryConstructor tName conName
  -- Unary constructors
  NormalC conName [_] ->
    mbWithContents $ parseUnaryConstructor conName
  -- Polyadic constructors
  NormalC conName ts ->
    mbWithContents $ parseProduct tName conName (genericLength ts)
  -- Records
  RecC conName ts ->
    case (unwrapUnaryRecords opts, ts) of
      (True, [(_,st,ty)]) ->
        parseArgs tName opts (NormalC conName [(st,ty)]) isSingle
      _ ->
        mbWithContents $ parseRecord opts tName conName ts
  -- Infix constructors (apart from syntax these are the same as polyadic
  -- constructors)
  InfixC _ conName _ ->
    mbWithContents $ parseProduct tName conName 2
  -- Existentially quantified constructors (we ignore the quantifiers and
  -- proceed with the contained constructor)
  ForallC _ _ con' ->
    parseArgs tName opts con' isSingle
#if MIN_VERSION_template_haskell(2,11,0)
  -- GADTs (we ignore the refined return type and proceed as if it were a
  -- NormalC or RecC)
  GadtC conNames ts _ ->
    parseArgs tName opts (NormalC (head conNames) ts) isSingle
  RecGadtC conNames ts _ ->
    parseArgs tName opts (RecC (head conNames) ts) isSingle
#endif
  where
    mbWithContents p = case (isSingle, sumEncoding opts, con) of
      (True, _, _) -> p
      (_, TaggedObject{}, RecC{}) -> p
      (_, TaggedObject{contentsFieldName}, _) ->
        [|withObject $(stringE (show tName)) $
            with (field (T.pack $(stringE contentsFieldName))) $p
         |]
      _otherwise -> p

{- Generate code to parse the JSON encoding of an n-ary constructor

result :: Parser Json <tName>
result = withArray tName $ do
  checkLength n
  Con <$> unsafeElementAt 0
      <*> unsafeElementAt 1
      <*> ...
-}
parseProduct :: Name -- ^ Name of the type to which the constructor belongs
             -> Name -- ^ Constructor name
             -> Integer -- ^ Constructor arity
             -> ExpQ
parseProduct tName conName numArgs = do
  let parsers = [ [|unsafeElementAt $(litE (integerL i))|]
                | i <- [0..numArgs-1]]
  [|withArray $(stringE (show tName)) $ do
      checkLength $(litE (integerL numArgs))
      $(applicativeChain (conE conName) parsers)
   |]

--------------------------------------------------------------------------------
-- Parsing errors
--------------------------------------------------------------------------------

-- TODO: this had a FromJson constraint, did we even need it?
class LookupField a where
  lookupField
    :: String             -- ^ Type name
    -> String             -- ^ Constructor name
    -> T.Text             -- ^ Key name
    -> Parser Object a

instance OVERLAPPABLE_ (FromJson a) => LookupField a where
  lookupField _tName _rec key = field key

instance FromJson a => LookupField (Maybe a) where
  lookupField _tName _rec key = optionalField key

-- TODO: previously, when lookups failed, the error messages were sort of
-- nice: “When parsing the record %s of type %s the key %s was not
-- present.”. Now they are probably less nice; what can be done about it?

noMatchFail :: String -> String -> Parser Json fail
noMatchFail t o =
  fail $ printf "When parsing %s expected a String with the tag of a constructor but got %s." t o

conNotFoundFail2ElemArray :: String -> [String] -> String -> Parser Json fail
conNotFoundFail2ElemArray t cs o =
  fail $ printf "When parsing %s expected a 2-element Array with a tag and contents element where the tag is one of [%s], but got %s."
                t (intercalate ", " cs) o

conNotFoundFailObjectSingleField :: String -> [String] -> String -> Parser Json fail
conNotFoundFailObjectSingleField t cs o =
  fail $ printf "When parsing %s expected an Object with a single tag/contents pair where the tag is one of [%s], but got %s."
                t (intercalate ", " cs) o

conNotFoundFailTaggedObject :: String -> [String] -> String -> Parser Json fail
conNotFoundFailTaggedObject t cs o =
  fail $ printf "When parsing %s expected an Object with a tag field where the value is one of [%s], but got %s."
                t (intercalate ", " cs) o

--------------------------------------------------------------------------------
-- Utility functions
--------------------------------------------------------------------------------

-- f <$> a <*> b <*> c <*> ...
applicativeChain :: ExpQ -> [ExpQ] -> ExpQ
applicativeChain f [] = f
applicativeChain f (x:xs) =
  foldl' (\a b -> [|$a <*> $b|]) [|$f <$> $x|] xs

-- | Boilerplate for top level splices.
--
-- The given 'Name' must meet one of two criteria:
--
-- 1. It must be the name of a type constructor of a plain data type or newtype.
-- 2. It must be the name of a data family instance or newtype instance constructor.

-- Any other value will result in an exception.
withType :: Name
         -> (Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)
         -- ^ Function that generates the actual code. Will be applied
         -- to the datatype/data family 'Name', type variable binders and
         -- constructors extracted from the given 'Name'. If the 'Name' is
         -- from a data family instance constructor, it will also have its
         -- instantiated types; otherwise, it will be 'Nothing'.
         -> Q a
         -- ^ Resulting value in the 'Q'uasi monad.
withType name f = do
    info <- reify name
    case info of
      TyConI dec ->
        case dec of
#if MIN_VERSION_template_haskell(2,11,0)
          DataD    _ _ tvbs _ cons _ -> f name tvbs cons Nothing
          NewtypeD _ _ tvbs _ con  _ -> f name tvbs [con] Nothing
#else
          DataD    _ _ tvbs   cons _ -> f name tvbs cons Nothing
          NewtypeD _ _ tvbs   con  _ -> f name tvbs [con] Nothing
#endif
          other -> error $ ns ++ "Unsupported type: " ++ show other
#if MIN_VERSION_template_haskell(2,11,0)
      DataConI _ _ parentName   -> do
#else
      DataConI _ _ parentName _ -> do
#endif
        parentInfo <- reify parentName
        case parentInfo of
#if MIN_VERSION_template_haskell(2,11,0)
          FamilyI (DataFamilyD _ tvbs _) decs ->
#else
          FamilyI (FamilyD DataFam _ tvbs _) decs ->
#endif
            let instDec = flip find decs $ \dec -> case dec of
#if MIN_VERSION_template_haskell(2,11,0)
                  DataInstD    _ _ _ _ cons _ -> any ((name ==) . getConName) cons
                  NewtypeInstD _ _ _ _ con  _ -> name == getConName con
#else
                  DataInstD    _ _ _   cons _ -> any ((name ==) . getConName) cons
                  NewtypeInstD _ _ _   con  _ -> name == getConName con
#endif
                  _ -> error $ ns ++ "Must be a data or newtype instance."
             in case instDec of
#if MIN_VERSION_template_haskell(2,11,0)
                  Just (DataInstD    _ _ instTys _ cons _) -> f parentName tvbs cons $ Just instTys
                  Just (NewtypeInstD _ _ instTys _ con  _) -> f parentName tvbs [con] $ Just instTys
#else
                  Just (DataInstD    _ _ instTys   cons _) -> f parentName tvbs cons $ Just instTys
                  Just (NewtypeInstD _ _ instTys   con  _) -> f parentName tvbs [con] $ Just instTys
#endif
                  _ -> error $ ns ++
                    "Could not find data or newtype instance constructor."
          _ -> error $ ns ++ "Data constructor " ++ show name ++
            " is not from a data family instance constructor."
#if MIN_VERSION_template_haskell(2,11,0)
      FamilyI DataFamilyD{} _ ->
#else
      FamilyI (FamilyD DataFam _ _ _) _ ->
#endif
        error $ ns ++
          "Cannot use a data family name. Use a data family instance constructor instead."
      _ -> error $ ns ++ "I need the name of a plain data type constructor, "
                      ++ "or a data family instance constructor."
  where
    ns :: String
    ns = "Json.Internal.TH.withType: "

-- | Infer the context and instance head needed for a FromJson or ToJson instance.
buildTypeInstance :: Name
                  -- ^ The type constructor or data family name
                  -> Name
                  -- ^ The typeclass name ('ToJson' or 'FromJson')
                  -> [TyVarBndr]
                  -- ^ The type variables from the data type/data family declaration
                  -> Maybe [Type]
                  -- ^ 'Just' the types used to instantiate a data family instance,
                  -- or 'Nothing' if it's a plain data type
                  -> Q (Cxt, Type)
                  -- ^ The resulting 'Cxt' and 'Type' to use in a class instance
-- Plain data type/newtype case
buildTypeInstance tyConName constraint tvbs Nothing =
    let varTys :: [Type]
        varTys = map tvbToType tvbs
    in buildTypeInstanceFromTys tyConName constraint varTys False
-- Data family instance case
--
-- The CPP is present to work around a couple of annoying old GHC bugs.
-- See Note [Polykinded data families in Template Haskell]
buildTypeInstance dataFamName constraint tvbs (Just instTysAndKinds) = do
#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)
    let instTys :: [Type]
        instTys = zipWith stealKindForType tvbs instTysAndKinds
#else
    let kindVarNames :: [Name]
        kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs

        -- Gets all of the type/kind variable names mentioned somewhere in a Type.
        tyVarNamesOfType :: Type -> [Name]
        tyVarNamesOfType = go
          where
            go :: Type -> [Name]
            go (AppT t1 t2) = go t1 ++ go t2
            go (SigT t k)   = go t  ++ go k
            go (VarT n)     = [n]
            go _            = []

        numKindVars :: Int
        numKindVars = length kindVarNames

        givenKinds, givenKinds' :: [Kind]
        givenTys                :: [Type]
        (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds
        givenKinds' = map sanitizeStars givenKinds

        -- A GHC 7.6-specific bug requires us to replace all occurrences of
        -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.
        -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.
        sanitizeStars :: Kind -> Kind
        sanitizeStars = go
          where
            go :: Kind -> Kind
            go (AppT t1 t2)                 = AppT (go t1) (go t2)
            go (SigT t k)                   = SigT (go t) (go k)
            go (ConT n) | n == starKindName = StarT
            go t                            = t

            -- It's quite awkward to import * from GHC.Prim, so we'll just
            -- hack our way around it.
            starKindName :: Name
            starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"

        -- Generate a list of fresh names with a common prefix, and numbered suffixes.
        newNameList :: String -> Int -> Q [Name]
        newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]

    -- If we run this code with GHC 7.8, we might have to generate extra type
    -- variables to compensate for any type variables that Template Haskell
    -- eta-reduced away.
    -- See Note [Polykinded data families in Template Haskell]
    xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys)

    let xTys :: [Type]
        xTys = map VarT xTypeNames
        -- ^ Because these type variables were eta-reduced away, we can only
        --   determine their kind by using stealKindForType. Therefore, we mark
        --   them as VarT to ensure they will be given an explicit kind annotation
        --   (and so the kind inference machinery has the right information).

        substNameWithKind :: Name -> Kind -> Type -> Type
        substNameWithKind n k = substType (M.singleton n k)

        substNamesWithKinds :: [(Name, Kind)] -> Type -> Type
        substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks

        -- The types from the data family instance might not have explicit kind
        -- annotations, which the kind machinery needs to work correctly. To
        -- compensate, we use stealKindForType to explicitly annotate any
        -- types without kind annotations.
        instTys :: [Type]
        instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))
                  -- Note that due to a GHC 7.8-specific bug
                  -- (see Note [Polykinded data families in Template Haskell]),
                  -- there may be more kind variable names than there are kinds
                  -- to substitute. But this is OK! If a kind is eta-reduced, it
                  -- means that is was not instantiated to something more specific,
                  -- so we need not substitute it. Using stealKindForType will
                  -- grab the correct kind.
                $ zipWith stealKindForType tvbs (givenTys ++ xTys)
#endif
    buildTypeInstanceFromTys dataFamName constraint instTys True

-- For the given Types, generate an instance context and head.
buildTypeInstanceFromTys :: Name
                         -- ^ The type constructor or data family name
                         -> Name
                         -- ^ The typeclass name ('ToJson' or 'FromJson')
                         -> [Type]
                         -- ^ The types to instantiate the instance with
                         -> Bool
                         -- ^ True if it's a data family, False otherwise
                         -> Q (Cxt, Type)
buildTypeInstanceFromTys tyConName constraint varTysOrig isDataFamily = do
    -- Make sure to expand through type/kind synonyms! Otherwise, we won't
    -- be able to infer constraints as accurately.
    varTysExp <- mapM expandSyn varTysOrig

    let preds    :: [Maybe Pred]
        -- Derive instance constraints for type variables of kind *
        preds = map (deriveConstraint constraint) varTysExp

        varTys :: [Type]
        -- See Note [Kind signatures in derived instances] for an explanation
        -- of the isDataFamily check.
        varTys =
          if isDataFamily
             then varTysOrig
             else map unSigT varTysOrig

        instanceCxt :: Cxt
        instanceCxt = catMaybes preds

        instanceType :: Type
        instanceType = AppT (ConT constraint)
                     $ applyTyCon tyConName varTys

    return (instanceCxt, instanceType)

-- | Attempt to derive a constraint on a Type. If it's of kind *,
-- we give it Just a ToJson/FromJson constraint. Otherwise, return Nothing.
deriveConstraint :: Name -> Type -> Maybe Pred
deriveConstraint constraint t
  | isTyVar t && hasKindStar t = Just $ applyCon constraint $ varTToName t
  | otherwise                  = Nothing

{-
Note [Polykinded data families in Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

In order to come up with the correct instance context and head for an instance, e.g.,

  instance C a => C (Data a) where ...

We need to know the exact types and kinds used to instantiate the instance. For
plain old datatypes, this is simple: every type must be a type variable, and
Template Haskell reliably tells us the type variables and their kinds.

Doing the same for data families proves to be much harder for three reasons:

1. On any version of Template Haskell, it may not tell you what an instantiated
   type's kind is. For instance, in the following data family instance:

     data family Fam (f :: * -> *) (a :: *)
     data instance Fam f a

   Then if we use TH's reify function, it would tell us the TyVarBndrs of the
   data family declaration are:

     [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]

   and the instantiated types of the data family instance are:

     [VarT f1,VarT a1]

   We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we
   have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the
   kind is in case an instantiated type isn't a SigT, so we use the stealKindForType
   function to ensure all of the instantiated types are SigTs before passing them
   to buildTypeInstanceFromTys.
2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of
   the specified kinds of a data family instance efore any of the instantiated
   types. Fortunately, this is easy to deal with: you simply count the number of
   distinct kind variables in the data family declaration, take that many elements
   from the front of the  Types list of the data family instance, substitute the
   kind variables with their respective instantiated kinds (which you took earlier),
   and proceed as normal.
3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template
   Haskell might not even list all of the Types of a data family instance, since
   they are eta-reduced away! And yes, kinds can be eta-reduced too.

   The simplest workaround is to count how many instantiated types are missing from
   the list and generate extra type variables to use in their place. Luckily, we
   needn't worry much if its kind was eta-reduced away, since using stealKindForType
   will get it back.

Note [Kind signatures in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

It is possible to put explicit kind signatures into the derived instances, e.g.,

  instance C a => C (Data (f :: * -> *)) where ...

But it is preferable to avoid this if possible. If we come up with an incorrect
kind signature (which is entirely possible, since Template Haskell doesn't always
have the best track record with reifying kind signatures), then GHC will flat-out
reject the instance, which is quite unfortunate.

Plain old datatypes have the advantage that you can avoid using any kind signatures
at all in their instances. This is because a datatype declaration uses all type
variables, so the types that we use in a derived instance uniquely determine their
kinds. As long as we plug in the right types, the kind inferencer can do the rest
of the work. For this reason, we use unSigT to remove all kind signatures before
splicing in the instance context and head.

Data family instances are trickier, since a data family can have two instances that
are distinguished by kind alone, e.g.,

  data family Fam (a :: k)
  data instance Fam (a :: * -> *)
  data instance Fam (a :: *)

If we dropped the kind signatures for C (Fam a), then GHC will have no way of
knowing which instance we are talking about. To avoid this scenario, we always
include explicit kind signatures in data family instances. There is a chance that
the inferred kind signatures will be incorrect, but if so, we can always fall back
on the mk- functions.
-}

-- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.
stealKindForType :: TyVarBndr -> Type -> Type
stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)
stealKindForType _   t        = t

-- | Extracts the kind from a type variable binder.
tvbKind :: TyVarBndr -> Kind
#if MIN_VERSION_template_haskell(2,8,0)
tvbKind (PlainTV  _  ) = StarT
#else
tvbKind (PlainTV  _  ) = StarK
#endif
tvbKind (KindedTV _ k) = k

tvbToType :: TyVarBndr -> Type
tvbToType (PlainTV n)    = VarT n
tvbToType (KindedTV n k) = SigT (VarT n) k

-- | Returns True if a Type has kind *.
hasKindStar :: Type -> Bool
hasKindStar VarT{}         = True
#if MIN_VERSION_template_haskell(2,8,0)
hasKindStar (SigT _ StarT) = True
#else
hasKindStar (SigT _ StarK) = True
#endif
hasKindStar _              = False

-- | Extract the Name from a type variable. If the argument Type is not a
-- type variable, throw an error.
varTToName :: Type -> Name
varTToName (VarT n)   = n
varTToName (SigT t _) = varTToName t
varTToName _          = error "Not a type variable!"

-- | Extracts the name from a constructor.
getConName :: Con -> Name
getConName (NormalC name _)  = name
getConName (RecC name _)     = name
getConName (InfixC _ name _) = name
getConName (ForallC _ _ con) = getConName con
#if MIN_VERSION_template_haskell(2,11,0)
getConName (GadtC    names _ _) = head names
getConName (RecGadtC names _ _) = head names
#endif

-- | Fully applies a type constructor to its type variables.
applyTyCon :: Name -> [Type] -> Type
applyTyCon = foldl' AppT . ConT

-- | Is the given type a variable?
isTyVar :: Type -> Bool
isTyVar (VarT _)   = True
isTyVar (SigT t _) = isTyVar t
isTyVar _          = False

-- | Peel off a kind signature from a Type (if it has one).
unSigT :: Type -> Type
unSigT (SigT t _) = t
unSigT t          = t

applyCon :: Name -> Name -> Pred
applyCon con t =
#if MIN_VERSION_template_haskell(2,10,0)
          AppT (ConT con) (VarT t)
#else
          ClassP con [VarT t]
#endif

-------------------------------------------------------------------------------
-- Expanding type synonyms
-------------------------------------------------------------------------------

-- | Expands all type synonyms in a type. Written by Dan Rosén in the
-- @genifunctors@ package (licensed under BSD3).
expandSyn :: Type -> Q Type
expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t
expandSyn t@AppT{}            = expandSynApp t []
expandSyn t@ConT{}            = expandSynApp t []
expandSyn (SigT t k)          = do t' <- expandSyn t
                                   k' <- expandSynKind k
                                   return (SigT t' k')
expandSyn t                   = return t

expandSynKind :: Kind -> Q Kind
#if MIN_VERSION_template_haskell(2,8,0)
expandSynKind = expandSyn
#else
expandSynKind = return -- There are no kind synonyms to deal with
#endif

expandSynApp :: Type -> [Type] -> Q Type
expandSynApp (AppT t1 t2) ts = do
    t2' <- expandSyn t2
    expandSynApp t1 (t2':ts)
expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts
expandSynApp t@(ConT n) ts = do
    info <- reify n
    case info of
        TyConI (TySynD _ tvs rhs) ->
            let (ts', ts'') = splitAt (length tvs) ts
                subs = mkSubst tvs ts'
                rhs' = substType subs rhs
             in expandSynApp rhs' ts''
        _ -> return $ foldl' AppT t ts
expandSynApp t ts = do
    t' <- expandSyn t
    return $ foldl' AppT t' ts

type TypeSubst = Map Name Type

mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst
mkSubst vs ts =
   let vs' = map un vs
       un (PlainTV v)    = v
       un (KindedTV v _) = v
   in M.fromList $ zip vs' ts

substType :: TypeSubst -> Type -> Type
substType subs (ForallT v c t) = ForallT v c $ substType subs t
substType subs t@(VarT n)      = M.findWithDefault t n subs
substType subs (AppT t1 t2)    = AppT (substType subs t1) (substType subs t2)
substType subs (SigT t k)      = SigT (substType subs t)
#if MIN_VERSION_template_haskell(2,8,0)
                                      (substType subs k)
#else
                                      k
#endif
substType _ t                  = t

builder :: ToJson a => a -> B.Builder
builder = fromEncoding . toEncoding
