{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE BangPatterns #-}

#ifndef MIN_VERSION_template_haskell
#define MIN_VERSION_template_haskell(x,y,z) 1
#endif
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2008-2015 Edward Kmett, (C) 2015 Ryan Scott
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- Functions to mechanically derive 'Bifunctor', 'Bifoldable',
-- or 'Bitraversable' instances, or to splice their functions directly into
-- source code. You need to enable the @TemplateHaskell@ language extension
-- in order to use this module.
----------------------------------------------------------------------------

module Data.Bifunctor.TH (
    -- * @derive@- functions
    -- $derive
    -- * @make@- functions
    -- $make
    -- * 'Bifunctor'
    deriveBifunctor
  , makeBimap
    -- * 'Bifoldable'
  , deriveBifoldable
  , makeBifold
  , makeBifoldMap
  , makeBifoldr
  , makeBifoldl
    -- * 'Bitraversable'
  , deriveBitraversable
  , makeBitraverse
  , makeBisequenceA
  , makeBimapM
  , makeBisequence
  ) where

import Control.Monad (guard)

import Data.Bifunctor.TH.Internal
import Data.List
import Data.Maybe
#if __GLASGOW_HASKELL__ < 710 && MIN_VERSION_template_haskell(2,8,0)
import qualified Data.Set as Set
#endif

import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Syntax

-------------------------------------------------------------------------------
-- User-facing API
-------------------------------------------------------------------------------

{- $derive

'deriveBifunctor', 'deriveBifoldable', and 'deriveBitraversable' automatically
generate their respective class instances for a given data type, newtype, or data
family instance that has at least two type variable. Examples:

@
&#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;
import Data.Bifunctor.TH

data Pair a b = Pair a b
$('deriveBifunctor' ''Pair) -- instance Bifunctor Pair where ...

data WrapLeftPair f g a b = WrapLeftPair (f a) (g a b)
$('deriveBifoldable' ''WrapLeftPair)
-- instance (Foldable f, Bifoldable g) => Bifoldable (WrapLeftPair f g) where ...
@

If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later),
the @derive@ functions can be used data family instances (which requires the
@-XTypeFamilies@ extension). To do so, pass the name of a data or newtype instance
constructor (NOT a data family name!) to a @derive@ function.  Note that the
generated code may require the @-XFlexibleInstances@ extension. Example:

@
&#123;-&#35; LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies &#35;-&#125;
import Data.Bifunctor.TH

class AssocClass a b c where
    data AssocData a b c
instance AssocClass Int b c where
    data AssocData Int b c = AssocDataInt1 Int | AssocDataInt2 b c
$('deriveBitraversable' 'AssocDataInt1) -- instance Bitraversable (AssocData Int) where ...
-- Alternatively, one could use $(deriveBitraversable 'AssocDataInt2)
@

Note that there are some limitations:

* The 'Name' argument to a @derive@ function must not be a type synonym.

* With a @derive@ function, the last two type variables must both be of kind @*@.
  Other type variables of kind @* -> *@ are assumed to require a 'Functor',
  'Foldable', or 'Traversable' constraint (depending on which @derive@ function is
  used), and other type variables of kind @* -> * -> *@ are assumed to require an
  'Bifunctor', 'Bifoldable', or 'Bitraversable' constraint. If your data type
  doesn't meet these assumptions, use a @make@ function.

* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@
  extensions, a constraint cannot mention either of the last two type variables. For
  example, @data Illegal2 a b where I2 :: Ord a => a -> b -> Illegal2 a b@ cannot
  have a derived 'Bifunctor' instance.

* If either of the last two type variables is used within a constructor argument's
  type, it must only be used in the last two type arguments. For example,
  @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'Bifunctor' instance,
  but @data Illegal a b = Illegal (a, b, a, b)@ cannot.

* Data family instances must be able to eta-reduce the last two type variables. In other
  words, if you have a instance of the form:

  @
  data family Family a1 ... an t1 t2
  data instance Family e1 ... e2 v1 v2 = ...
  @

  Then the following conditions must hold:

  1. @v1@ and @v2@ must be distinct type variables.
  2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@.

* In GHC 7.8, a bug exists that can cause problems when a data family declaration and
  one of its data instances use different type variables, e.g.,

  @
  data family Foo a b c
  data instance Foo Int y z = Foo Int y z
  $(deriveBifunctor 'Foo)
  @

  To avoid this issue, it is recommened that you use the same type variables in the
  same positions in which they appeared in the data family declaration:

  @
  data family Foo a b c
  data instance Foo Int b c = Foo Int b c
  $(deriveBifunctor 'Foo)
  @

-}

{- $make

There may be scenarios in which you want to, say, 'bimap' over an arbitrary data type
or data family instance without having to make the type an instance of 'Bifunctor'. For
these cases, this module provides several functions (all prefixed with @make@-) that
splice the appropriate lambda expression into your source code.

This is particularly useful for creating instances for sophisticated data types. For
example, 'deriveBifunctor' cannot infer the correct type context for
@newtype HigherKinded f a b c = HigherKinded (f a b c)@, since @f@ is of kind
@* -> * -> * -> *@. However, it is still possible to create a 'Bifunctor' instance for
@HigherKinded@ without too much trouble using 'makeBimap':

@
&#123;-&#35; LANGUAGE FlexibleContexts, TemplateHaskell &#35;-&#125;
import Data.Bifunctor
import Data.Bifunctor.TH

newtype HigherKinded f a b c = HigherKinded (f a b c)

instance Bifunctor (f a) => Bifunctor (HigherKinded f a) where
    bimap = $(makeBimap ''HigherKinded)
@

-}

-- | Generates a 'Bifunctor' instance declaration for the given data type or data
-- family instance.
deriveBifunctor :: Name -> Q [Dec]
deriveBifunctor = deriveBiClass Bifunctor

-- | Generates a lambda expression which behaves like 'bimap' (without requiring a
-- 'Bifunctor' instance).
makeBimap :: Name -> Q Exp
makeBimap = makeBiFun Bimap

-- | Generates a 'Bifoldable' instance declaration for the given data type or data
-- family instance.
deriveBifoldable :: Name -> Q [Dec]
deriveBifoldable = deriveBiClass Bifoldable

-- | Generates a lambda expression which behaves like 'bifold' (without requiring a
-- 'Bifoldable' instance).
makeBifold :: Name -> Q Exp
makeBifold name = appsE [ makeBifoldMap name
                        , varE idValName
                        , varE idValName
                        ]

-- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring a
-- 'Bifoldable' instance).
makeBifoldMap :: Name -> Q Exp
makeBifoldMap = makeBiFun BifoldMap

-- | Generates a lambda expression which behaves like 'bifoldr' (without requiring a
-- 'Bifoldable' instance).
makeBifoldr :: Name -> Q Exp
makeBifoldr = makeBiFun Bifoldr

-- | Generates a lambda expression which behaves like 'bifoldl' (without requiring a
-- 'Bifoldable' instance).
makeBifoldl :: Name -> Q Exp
makeBifoldl name = do
  f <- newName "f"
  g <- newName "g"
  z <- newName "z"
  t <- newName "t"
  lamE [varP f, varP g, varP z, varP t] $
    appsE [ varE appEndoValName
          , appsE [ varE getDualValName
                  , appsE [ makeBifoldMap name, foldFun f, foldFun g, varE t]
                  ]
          , varE z
          ]
  where
    foldFun :: Name -> Q Exp
    foldFun n = infixApp (conE dualDataName)
                         (varE composeValName)
                         (infixApp (conE endoDataName)
                                   (varE composeValName)
                                   (varE flipValName `appE` varE n)
                         )

-- | Generates a 'Bitraversable' instance declaration for the given data type or data
-- family instance.
deriveBitraversable :: Name -> Q [Dec]
deriveBitraversable = deriveBiClass Bitraversable

-- | Generates a lambda expression which behaves like 'bitraverse' (without requiring a
-- 'Bitraversable' instance).
makeBitraverse :: Name -> Q Exp
makeBitraverse = makeBiFun Bitraverse

-- | Generates a lambda expression which behaves like 'bisequenceA' (without requiring a
-- 'Bitraversable' instance).
makeBisequenceA :: Name -> Q Exp
makeBisequenceA name = appsE [ makeBitraverse name
                             , varE idValName
                             , varE idValName
                             ]

-- | Generates a lambda expression which behaves like 'bimapM' (without requiring a
-- 'Bitraversable' instance).
makeBimapM :: Name -> Q Exp
makeBimapM name = do
  f <- newName "f"
  g <- newName "g"
  lamE [varP f, varP g] . infixApp (varE unwrapMonadValName) (varE composeValName) $
                          appsE [makeBitraverse name, wrapMonadExp f, wrapMonadExp g]
  where
    wrapMonadExp :: Name -> Q Exp
    wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n)

-- | Generates a lambda expression which behaves like 'bisequence' (without requiring a
-- 'Bitraversable' instance).
makeBisequence :: Name -> Q Exp
makeBisequence name = appsE [ makeBimapM name
                            , varE idValName
                            , varE idValName
                            ]

-------------------------------------------------------------------------------
-- Code generation
-------------------------------------------------------------------------------

-- | Derive a class instance declaration (depending on the BiClass argument's value).
deriveBiClass :: BiClass -> Name -> Q [Dec]
deriveBiClass biClass tyConName = do
  info <- reify tyConName
  case info of
    TyConI{} -> deriveBiClassPlainTy biClass tyConName
#if MIN_VERSION_template_haskell(2,7,0)
    DataConI{} -> deriveBiClassDataFamInst biClass tyConName
    FamilyI (FamilyD DataFam _ _ _) _ ->
      error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead."
    FamilyI (FamilyD TypeFam _ _ _) _ ->
      error $ ns ++ "Cannot use a type family name."
    _ -> error $ ns ++ "The name must be of a plain type constructor or data family instance constructor."
#else
      DataConI{} -> dataConIError
      _          -> error $ ns ++ "The name must be of a plain type constructor."
#endif
  where
    ns :: String
    ns = "Data.Bifunctor.TH.deriveBiClass: "

-- | Generates a class instance declaration for a plain type constructor.
deriveBiClassPlainTy :: BiClass -> Name -> Q [Dec]
deriveBiClassPlainTy biClass tyConName = withTyCon tyConName fromCons where
  className :: Name
  className = biClassName biClass

  fromCons :: Cxt -> [TyVarBndr] -> [Con] -> Q [Dec]
  fromCons ctxt tvbs cons = (:[]) `fmap`
    instanceD (return instanceCxt)
              (return $ AppT (ConT className) instanceType)
              (biFunDecs biClass droppedNbs cons)
    where
      (instanceCxt, instanceType, droppedNbs) =
        cxtAndTypePlainTy biClass tyConName ctxt tvbs

#if MIN_VERSION_template_haskell(2,7,0)
-- | Generates a class instance declaration for a data family instance constructor.
deriveBiClassDataFamInst :: BiClass -> Name -> Q [Dec]
deriveBiClassDataFamInst biClass dataFamInstName = withDataFamInstCon dataFamInstName fromDec where
  className :: Name
  className = biClassName biClass

  fromDec :: [TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q [Dec]
  fromDec famTvbs ctxt parentName instTys cons = (:[]) `fmap`
    instanceD (return instanceCxt)
              (return $ AppT (ConT className) instanceType)
              (biFunDecs biClass droppedNbs cons)
    where
      (instanceCxt, instanceType, droppedNbs) =
          cxtAndTypeDataFamInstCon biClass parentName ctxt famTvbs instTys
#endif

-- | Generates a declaration defining the primary function(s) corresponding to a
-- particular class (bimap for Bifunctor, bifoldr and bifoldMap for Bifoldable, and
-- bitraverse for Bitraversable).
--
-- For why both bifoldr and bifoldMap are derived for Bifoldable, see Trac #7436.
biFunDecs :: BiClass -> [NameBase] -> [Con] -> [Q Dec]
biFunDecs biClass nbs cons = map makeFunD $ biClassToFuns biClass where
  makeFunD :: BiFun -> Q Dec
  makeFunD biFun =
    funD (biFunName biFun)
         [ clause []
                  (normalB $ makeBiFunForCons biFun nbs cons)
                  []
         ]

-- | Generates a lambda expression which behaves like the BiFun argument.
makeBiFun :: BiFun -> Name -> Q Exp
makeBiFun biFun tyConName = do
  info <- reify tyConName
  case info of
    TyConI{} -> withTyCon tyConName $ \ctxt tvbs decs ->
      let !nbs = thd3 $ cxtAndTypePlainTy (biFunToClass biFun) tyConName ctxt tvbs
      in makeBiFunForCons biFun nbs decs
#if MIN_VERSION_template_haskell(2,7,0)
    DataConI{} -> withDataFamInstCon tyConName $ \famTvbs ctxt parentName instTys cons ->
      let !nbs = thd3 $ cxtAndTypeDataFamInstCon (biFunToClass biFun) parentName ctxt famTvbs instTys
      in makeBiFunForCons biFun nbs cons
    FamilyI (FamilyD DataFam _ _ _) _ ->
      error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead."
    FamilyI (FamilyD TypeFam _ _ _) _ ->
      error $ ns ++ "Cannot use a type family name."
    _ -> error $ ns ++ "The name must be of a plain type constructor or data family instance constructor."
#else
    DataConI{} -> dataConIError
    _          -> error $ ns ++ "The name must be of a plain type constructor."
#endif
  where
    ns :: String
    ns = "Data.Bifunctor.TH.makeBiFun: "

-- | Generates a lambda expression for the given constructors.
-- All constructors must be from the same type.
makeBiFunForCons :: BiFun -> [NameBase] -> [Con] -> Q Exp
makeBiFunForCons biFun nbs cons = do
  argNames <- mapM newName $ catMaybes [ Just "f"
                                       , Just "g"
                                       , guard (biFun == Bifoldr) >> Just "z"
                                       , Just "value"
                                       ]
  let (maps,others) = splitAt 2 argNames
      z             = head others -- If we're deriving bifoldr, this will be well defined
                                  -- and useful. Otherwise, it'll be ignored.
      value         = last others
      tvis          = zip nbs maps
  lamE (map varP argNames)
      . appsE
      $ [ varE $ biFunConstName biFun
        , if null cons
             then appE (varE errorValName)
                       (stringE $ "Void " ++ nameBase (biFunName biFun))
             else caseE (varE value)
                        (map (makeBiFunForCon biFun z tvis) cons)
        ] ++ map varE argNames

-- | Generates a lambda expression for a single constructor.
makeBiFunForCon :: BiFun -> Name -> [TyVarInfo] -> Con -> Q Match
makeBiFunForCon biFun z tvis (NormalC conName tys) = do
  args <- newNameList "arg" $ length tys
  let argTys = map snd tys
  makeBiFunForArgs biFun z tvis conName argTys args
makeBiFunForCon biFun z tvis (RecC conName tys) = do
  args <- newNameList "arg" $ length tys
  let argTys = map thd3 tys
  makeBiFunForArgs biFun z tvis conName argTys args
makeBiFunForCon biFun z tvis (InfixC (_, argTyL) conName (_, argTyR)) = do
  argL <- newName "argL"
  argR <- newName "argR"
  makeBiFunForArgs biFun z tvis conName [argTyL, argTyR] [argL, argR]
makeBiFunForCon biFun z tvis (ForallC tvbs faCxt con)
  | any (`predMentionsNameBase` map fst tvis) faCxt && not (allowExQuant (biFunToClass biFun))
  = existentialContextError (constructorName con)
  | otherwise = makeBiFunForCon biFun z (removeForalled tvbs tvis) con

-- | Generates a lambda expression for a single constructor's arguments.
makeBiFunForArgs :: BiFun
                 -> Name
                 -> [TyVarInfo]
                 -> Name
                 -> [Type]
                 -> [Name]
                 ->  Q Match
makeBiFunForArgs biFun z tvis conName tys args =
  match (conP conName $ map varP args)
        (normalB $ biFunCombine biFun conName z mappedArgs)
        []
  where
    mappedArgs :: [Q Exp]
    mappedArgs = zipWith (makeBiFunForArg biFun tvis conName) tys args

-- | Generates a lambda expression for a single argument of a constructor.
makeBiFunForArg :: BiFun
                -> [TyVarInfo]
                -> Name
                -> Type
                -> Name
                -> Q Exp
makeBiFunForArg biFun tvis conName ty tyExpName = do
  ty' <- expandSyn ty
  makeBiFunForArg' biFun tvis conName ty' tyExpName

-- | Generates a lambda expression for a single argument of a constructor, after
-- expanding all type synonyms.
makeBiFunForArg' :: BiFun
                 -> [TyVarInfo]
                 -> Name
                 -> Type
                 -> Name
                 -> Q Exp
makeBiFunForArg' biFun tvis conName ty tyExpName =
  makeBiFunForType biFun tvis conName True ty `appE` varE tyExpName

-- | Generates a lambda expression for a specific type.
makeBiFunForType :: BiFun
                 -> [TyVarInfo]
                 -> Name
                 -> Bool
                 -> Type
                 -> Q Exp
makeBiFunForType biFun tvis conName covariant (VarT tyName) =
  case lookup (NameBase tyName) tvis of
    Just mapName -> varE $ if covariant
                           then mapName
                           else contravarianceError conName
    Nothing -> biFunTriv biFun
makeBiFunForType biFun tvis conName covariant (SigT ty _) =
  makeBiFunForType biFun tvis conName covariant ty
makeBiFunForType biFun tvis conName covariant (ForallT tvbs _ ty) =
  makeBiFunForType biFun (removeForalled tvbs tvis) conName covariant ty
makeBiFunForType biFun tvis conName covariant ty =
  let tyCon  :: Type
      tyArgs :: [Type]
      tyCon:tyArgs = unapplyTy ty

      numLastArgs :: Int
      numLastArgs = min 2 $ length tyArgs

      lhsArgs, rhsArgs :: [Type]
      (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs

      tyVarNameBases :: [NameBase]
      tyVarNameBases = map fst tvis

      mentionsTyArgs :: Bool
      mentionsTyArgs = any (`mentionsNameBase` tyVarNameBases) tyArgs

      makeBiFunTuple :: Type -> Name -> Q Exp
      makeBiFunTuple fieldTy fieldName =
        makeBiFunForType biFun tvis conName covariant fieldTy `appE` varE fieldName

   in case tyCon of
     ArrowT
       | not (allowFunTys (biFunToClass biFun)) -> noFunctionsError conName
       | mentionsTyArgs, [argTy, resTy] <- tyArgs ->
         do x <- newName "x"
            b <- newName "b"
            lamE [varP x, varP b] $
              covBiFun covariant resTy `appE` (varE x `appE`
                (covBiFun (not covariant) argTy `appE` varE b))
         where
           covBiFun :: Bool -> Type -> Q Exp
           covBiFun = makeBiFunForType biFun tvis conName
     TupleT n
       | n > 0 && mentionsTyArgs -> do
         args <- mapM newName $ catMaybes [ Just "x"
                                          , guard (biFun == Bifoldr) >> Just "z"
                                          ]
         xs <- newNameList "tup" n

         let x = head args
             z = last args
         lamE (map varP args) $ caseE (varE x)
              [ match (tupP $ map varP xs)
                      (normalB $ biFunCombine biFun
                                              (tupleDataName n)
                                              z
                                              (zipWith makeBiFunTuple tyArgs xs)
                      )
                      []
              ]
     _ -> do
         itf <- isTyFamily tyCon
         if any (`mentionsNameBase` tyVarNameBases) lhsArgs || (itf && mentionsTyArgs)
           then outOfPlaceTyVarError conName tyVarNameBases
           else if any (`mentionsNameBase` tyVarNameBases) rhsArgs
                  then biFunApp biFun . appsE $
                         ( varE (fromJust $ biFunArity biFun numLastArgs)
                         : map (makeBiFunForType biFun tvis conName covariant) rhsArgs
                         )
                  else biFunTriv biFun

-------------------------------------------------------------------------------
-- Template Haskell reifying and AST manipulation
-------------------------------------------------------------------------------

-- | Extracts a plain type constructor's information.
withTyCon :: Name
          -> (Cxt -> [TyVarBndr] -> [Con] -> Q a)
          -> Q a
withTyCon name f = do
  info <- reify name
  case info of
    TyConI dec ->
      case dec of
        DataD    ctxt _ tvbs cons _ -> f ctxt tvbs cons
        NewtypeD ctxt _ tvbs con  _ -> f ctxt tvbs [con]
        _ -> error $ ns ++ "Unsupported type " ++ show dec ++ ". Must be a data type or newtype."
    _ -> error $ ns ++ "The name must be of a plain type constructor."
  where
    ns :: String
    ns = "Data.Bifunctor.TH.withTyCon: "

#if MIN_VERSION_template_haskell(2,7,0)
-- | Extracts a data family name's information.
withDataFam :: Name
            -> ([TyVarBndr] -> [Dec] -> Q a)
            -> Q a
withDataFam name f = do
  info <- reify name
  case info of
    FamilyI (FamilyD DataFam _ tvbs _) decs -> f tvbs decs
    FamilyI (FamilyD TypeFam _ _    _) _    -> error $ ns ++ "Cannot use a type family name."
    _ -> error $ ns ++ "Unsupported type " ++ show info ++ ". Must be a data family name."
  where
    ns :: String
    ns = "Data.Bifunctor.TH.withDataFam: "

-- | Extracts a data family instance constructor's information.
withDataFamInstCon :: Name
                   -> ([TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q a)
                   -> Q a
withDataFamInstCon dficName f = do
  dficInfo <- reify dficName
  case dficInfo of
    DataConI _ _ parentName _ -> do
      parentInfo <- reify parentName
      case parentInfo of
        FamilyI (FamilyD DataFam _ _ _) _ -> withDataFam parentName $ \famTvbs decs ->
          let sameDefDec = flip find decs $ \dec ->
                case dec of
                  DataInstD    _ _ _ cons' _ -> any ((dficName ==) . constructorName) cons'
                  NewtypeInstD _ _ _ con   _ -> dficName == constructorName con
                  _ -> error $ ns ++ "Must be a data or newtype instance."

              (ctxt, instTys, cons) = case sameDefDec of
                Just (DataInstD    ctxt' _ instTys' cons' _) -> (ctxt', instTys', cons')
                Just (NewtypeInstD ctxt' _ instTys' con   _) -> (ctxt', instTys', [con])
                _ -> error $ ns ++ "Could not find data or newtype instance constructor."

          in f famTvbs ctxt parentName instTys cons
        _ -> error $ ns ++ "Data constructor " ++ show dficName ++ " is not from a data family instance."
    _ -> error $ ns ++ "Unsupported type " ++ show dficInfo ++ ". Must be a data family instance constructor."
  where
    ns :: String
    ns = "Data.Bifunctor.TH.withDataFamInstCon: "
#endif

-- | Deduces the instance context, instance head, and eta-reduced type variables
-- for a plain data type constructor.
cxtAndTypePlainTy :: BiClass     -- Bifunctor, Bifoldable, or Bitraversable
                  -> Name        -- The datatype's name
                  -> Cxt         -- The datatype context
                  -> [TyVarBndr] -- The type variables
                  -> (Cxt, Type, [NameBase])
cxtAndTypePlainTy biClass tyConName dataCxt tvbs
  | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables
  = derivingKindError biClass tyConName
  | any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context
  = datatypeContextError tyConName instanceType
  | otherwise = (instanceCxt, instanceType, droppedNbs)
  where
    instanceCxt :: Cxt
    instanceCxt = mapMaybe (applyConstraint biClass) remaining

    instanceType :: Type
    instanceType = applyTyCon tyConName $ map (VarT . tvbName) remaining

    remainingLength :: Int
    remainingLength = length tvbs - 2

    remaining, dropped :: [TyVarBndr]
    (remaining, dropped) = splitAt remainingLength tvbs

    droppedKinds :: [Kind]
    droppedKinds = map tvbKind dropped

    droppedNbs :: [NameBase]
    droppedNbs = map (NameBase . tvbName) dropped

#if MIN_VERSION_template_haskell(2,7,0)
-- | Deduces the instance context, instance head, and eta-reduced type variables
-- for a data family instance constructor.
cxtAndTypeDataFamInstCon :: BiClass     -- Bifunctor, Bifoldable, or Bitraversable
                         -> Name        -- The data family name
                         -> Cxt         -- The datatype context
                         -> [TyVarBndr] -- The data family declaration's type variables
                         -> [Type]      -- The data family instance types
                         -> (Cxt, Type, [NameBase])
cxtAndTypeDataFamInstCon biClass parentName dataCxt famTvbs instTysAndKinds
  | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables
  = derivingKindError biClass parentName
  | any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context
  = datatypeContextError parentName instanceType
  | canEtaReduce remaining dropped -- If it is safe to drop the type variables
  = (instanceCxt, instanceType, droppedNbs)
  | otherwise = etaReductionError instanceType
  where
    instanceCxt :: Cxt
    instanceCxt = mapMaybe (applyConstraint biClass) lhsTvbs

    -- We need to make sure that type variables in the instance head which have
    -- constraints aren't poly-kinded, e.g.,
    --
    -- @
    -- instance Bifunctor f => Bifunctor (Foo (f :: k)) where
    -- @
    --
    -- To do this, we remove every kind ascription (i.e., strip off every 'SigT').
    instanceType :: Type
    instanceType = applyTyCon parentName
                 $ map unSigT remaining

    remainingLength :: Int
    remainingLength = length famTvbs - 2

    remaining, dropped :: [Type]
    (remaining, dropped) = splitAt remainingLength rhsTypes

    droppedKinds :: [Kind]
    droppedKinds = map tvbKind . snd $ splitAt remainingLength famTvbs

    droppedNbs :: [NameBase]
    droppedNbs = map varTToNameBase dropped

    -- We need to be mindful of an old GHC bug which causes kind variables to appear in
    -- @instTysAndKinds@ (as the name suggests) if
    --
    --   (1) @PolyKinds@ is enabled
    --   (2) either GHC 7.6 or 7.8 is being used (for more info, see Trac #9692).
    --
    -- Since Template Haskell doesn't seem to have a mechanism for detecting which
    -- language extensions are enabled, we do the next-best thing by counting
    -- the number of distinct kind variables in the data family declaration, and
    -- then dropping that number of entries from @instTysAndKinds@.
    instTypes :: [Type]
    instTypes =
# if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))
      instTysAndKinds
# else
      drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) famTvbs)
        instTysAndKinds
# endif

    lhsTvbs :: [TyVarBndr]
    lhsTvbs = map (uncurry replaceTyVarName)
            . filter (isTyVar . snd)
            . take remainingLength
            $ zip famTvbs rhsTypes

    -- In GHC 7.8, only the @Type@s up to the rightmost non-eta-reduced type variable
    -- in @instTypes@ are provided (as a result of a bug reported in Trac #9692). This
    -- is pretty inconvenient, as it makes it impossible to come up with the correct
    -- instance types in some cases. For example, consider the following code:
    --
    -- @
    -- data family Foo a b c
    -- data instance Foo Int y z = Foo Int y z
    -- $(deriveBifunctor 'Foo)
    -- @
    --
    -- Due to the aformentioned bug, Template Haskell doesn't tell us the names of
    -- either of type variables in the data instance (@y@ and @z@). As a result, we
    -- won't know to which fields of the 'Foo' constructor to apply the map functions,
    -- which will result in an incorrect instance. Urgh.
    --
    -- A workaround is to ensure that you use the exact same type variables, in the
    -- exact same order, in the data family declaration and any data or newtype
    -- instances:
    --
    -- @
    -- data family Foo a b c
    -- data instance Foo Int b c = Foo Int b c
    -- $(deriveBifunctor 'Foo)
    -- @
    --
    -- Thankfully, other versions of GHC don't seem to have this bug.
    rhsTypes :: [Type]
    rhsTypes =
# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
      instTypes ++ map tvbToType (drop (length instTypes) famTvbs)
# else
      instTypes
# endif
#endif

-- | Given a TyVarBndr, apply a certain constraint to it, depending on its kind.
applyConstraint :: BiClass -> TyVarBndr -> Maybe Pred
applyConstraint _       (PlainTV  _)         = Nothing
applyConstraint biClass (KindedTV name kind) = do
  constraint <- biClassConstraint biClass $ numKindArrows kind
  if canRealizeKindStarChain kind
    then Just $ applyClass constraint name
    else Nothing

-------------------------------------------------------------------------------
-- Error messages
-------------------------------------------------------------------------------

-- | Either the given data type doesn't have enough type variables, or one of
-- the type variables to be eta-reduced cannot realize kind *.
derivingKindError :: BiClass -> Name -> a
derivingKindError biClass tyConName = error
  . showString "Cannot derive well-kinded instance of form ‘"
  . showString className
  . showChar ' '
  . showParen True
    ( showString (nameBase tyConName)
    . showString " ..."
    )
  . showString "‘\n\tClass "
  . showString className
  . showString " expects an argument of kind * -> * -> *"
  $ ""
  where
    className :: String
    className = nameBase $ biClassName biClass

-- | One of the last two type variables appeard in a contravariant position
-- when deriving Bifoldable or Bitraversable.
contravarianceError :: Name -> a
contravarianceError conName = error
  . showString "Constructor ‘"
  . showString (nameBase conName)
  . showString "‘ must not use the last type variable(s) in a function argument"
  $ ""

-- | A constructor has a function argument in a derived Bifoldable or Bitraversable
-- instance.
noFunctionsError :: Name -> a
noFunctionsError conName = error
  . showString "Constructor ‘"
  . showString (nameBase conName)
  . showString "‘ must not contain function types"
  $ ""

-- | The data type has a DatatypeContext which mentions one of the eta-reduced
-- type variables.
datatypeContextError :: Name -> Type -> a
datatypeContextError dataName instanceType = error
  . showString "Can't make a derived instance of ‘"
  . showString (pprint instanceType)
  . showString "‘:\n\tData type ‘"
  . showString (nameBase dataName)
  . showString "‘ must not have a class context involving the last type argument(s)"
  $ ""

-- | The data type has an existential constraint which mentions one of the
-- eta-reduced type variables.
existentialContextError :: Name -> a
existentialContextError conName = error
  . showString "Constructor ‘"
  . showString (nameBase conName)
  . showString "‘ must be truly polymorphic in the last argument(s) of the data type"
  $ ""

-- | The data type mentions one of the n eta-reduced type variables in a place other
-- than the last nth positions of a data type in a constructor's field.
outOfPlaceTyVarError :: Name -> [NameBase] -> a
outOfPlaceTyVarError conName tyVarNames = error
  . showString "Constructor ‘"
  . showString (nameBase conName)
  . showString "‘ must use the type variable(s) "
  . shows tyVarNames
  . showString " only in the last argument(s) of a data type"
  $ ""

#if MIN_VERSION_template_haskell(2,7,0)
-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce
-- function for the criteria it would have to meet).
etaReductionError :: Type -> a
etaReductionError instanceType = error $
  "Cannot eta-reduce to an instance of form \n\tinstance (...) => "
  ++ pprint instanceType
#else
-- | Template Haskell didn't list all of a data family's instances upon reification
-- until template-haskell-2.7.0.0, which is necessary for a derived instance to work.
dataConIError :: a
dataConIError = error
  . showString "Cannot use a data constructor."
  . showString "\n\t(Note: if you are trying to derive for a data family instance,"
  . showString "\n\tuse GHC >= 7.4 instead.)"
  $ ""
#endif

-------------------------------------------------------------------------------
-- Class-specific constants
-------------------------------------------------------------------------------

-- | A representation of which class is being derived.
data BiClass = Bifunctor | Bifoldable | Bitraversable

-- | A representation of which function is being generated.
data BiFun = Bimap | Bifoldr | BifoldMap | Bitraverse
  deriving Eq

biFunConstName :: BiFun -> Name
biFunConstName Bimap      = bimapConstValName
biFunConstName Bifoldr    = bifoldrConstValName
biFunConstName BifoldMap  = bifoldMapConstValName
biFunConstName Bitraverse = bitraverseConstValName

biClassName :: BiClass -> Name
biClassName Bifunctor     = bifunctorTypeName
biClassName Bifoldable    = bifoldableTypeName
biClassName Bitraversable = bitraversableTypeName

biFunName :: BiFun -> Name
biFunName Bimap      = bimapValName
biFunName Bifoldr    = bifoldrValName
biFunName BifoldMap  = bifoldMapValName
biFunName Bitraverse = bitraverseValName

biClassToFuns :: BiClass -> [BiFun]
biClassToFuns Bifunctor     = [Bimap]
biClassToFuns Bifoldable    = [Bifoldr, BifoldMap]
biClassToFuns Bitraversable = [Bitraverse]

biFunToClass :: BiFun -> BiClass
biFunToClass Bimap      = Bifunctor
biFunToClass Bifoldr    = Bifoldable
biFunToClass BifoldMap  = Bifoldable
biFunToClass Bitraverse = Bitraversable

biClassConstraint :: BiClass -> Int -> Maybe Name
biClassConstraint Bifunctor     1 = Just functorTypeName
biClassConstraint Bifoldable    1 = Just foldableTypeName
biClassConstraint Bitraversable 1 = Just traversableTypeName
biClassConstraint biClass       2 = Just $ biClassName biClass
biClassConstraint _             _ = Nothing

biFunArity :: BiFun -> Int -> Maybe Name
biFunArity Bimap      1 = Just fmapValName
biFunArity Bifoldr    1 = Just foldrValName
biFunArity BifoldMap  1 = Just foldMapValName
biFunArity Bitraverse 1 = Just traverseValName
biFunArity biFun      2 = Just $ biFunName biFun
biFunArity _          _ = Nothing

allowFunTys :: BiClass -> Bool
allowFunTys Bifunctor = True
allowFunTys _         = False

allowExQuant :: BiClass -> Bool
allowExQuant Bifoldable = True
allowExQuant _          = False

-- See Trac #7436 for why explicit lambdas are used
biFunTriv :: BiFun -> Q Exp
biFunTriv Bimap = do
  x <- newName "x"
  lamE [varP x] $ varE x
biFunTriv Bifoldr = do
  z <- newName "z"
  lamE [wildP, varP z] $ varE z
biFunTriv BifoldMap = lamE [wildP] $ varE memptyValName
biFunTriv Bitraverse = varE pureValName

biFunApp :: BiFun -> Q Exp -> Q Exp
biFunApp Bifoldr e = do
  x <- newName "x"
  z <- newName "z"
  lamE [varP x, varP z] $ appsE [e, varE z, varE x]
biFunApp _ e = e

biFunCombine :: BiFun -> Name -> Name -> [Q Exp] -> Q Exp
biFunCombine Bimap      = bimapCombine
biFunCombine Bifoldr    = bifoldrCombine
biFunCombine BifoldMap  = bifoldMapCombine
biFunCombine Bitraverse = bitraverseCombine

bimapCombine :: Name -> Name -> [Q Exp] -> Q Exp
bimapCombine conName _ = foldl' appE (conE conName)

bifoldrCombine :: Name -> Name -> [Q Exp] -> Q Exp
bifoldrCombine _ zName = foldr appE (varE zName)

bifoldMapCombine :: Name -> Name -> [Q Exp] -> Q Exp
bifoldMapCombine _ _ [] = varE memptyValName
bifoldMapCombine _ _ es = foldr1 (appE . appE (varE mappendValName)) es

bitraverseCombine :: Name -> Name -> [Q Exp] -> Q Exp
bitraverseCombine conName _ [] = varE pureValName `appE` conE conName
bitraverseCombine conName _ (e:es) =
  foldl' (flip infixApp $ varE apValName)
    (appsE [varE fmapValName, conE conName, e]) es