{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module:      Data.Functor.Deriving.Internal
Copyright:   (C) 2015-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Portability: Template Haskell

The machinery needed to derive 'Foldable', 'Functor', and 'Traversable' instances.

For more info on how deriving @Functor@ works, see
<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>.

Note: this is an internal module, and as such, the API presented here is not
guaranteed to be stable, even between minor releases of this library.
-}
module Data.Functor.Deriving.Internal (
      -- * 'Foldable'
      deriveFoldable
    , deriveFoldableOptions
    , makeFoldMap
    , makeFoldMapOptions
    , makeFoldr
    , makeFoldrOptions
    , makeFold
    , makeFoldOptions
    , makeFoldl
    , makeFoldlOptions
    , makeNull
    , makeNullOptions
      -- * 'Functor'
    , deriveFunctor
    , deriveFunctorOptions
    , makeFmap
    , makeFmapOptions
    , makeReplace
    , makeReplaceOptions
      -- * 'Traversable'
    , deriveTraversable
    , deriveTraversableOptions
    , makeTraverse
    , makeTraverseOptions
    , makeSequenceA
    , makeSequenceAOptions
    , makeMapM
    , makeMapMOptions
    , makeSequence
    , makeSequenceOptions
      -- * 'FFTOptions'
    , FFTOptions(..)
    , defaultFFTOptions
    ) where

import           Control.Monad (guard)

import           Data.Deriving.Internal
import qualified Data.List as List
import qualified Data.Map as Map ((!), keys, lookup, member, singleton)
import           Data.Maybe

import           Language.Haskell.TH.Datatype
import           Language.Haskell.TH.Datatype.TyVarBndr
import           Language.Haskell.TH.Lib
import           Language.Haskell.TH.Syntax

-- | Options that further configure how the functions in "Data.Functor.Deriving"
-- should behave. (@FFT@ stands for 'Functor'/'Foldable'/'Traversable'.)
newtype FFTOptions = FFTOptions
  { fftEmptyCaseBehavior :: Bool
    -- ^ If 'True', derived instances for empty data types (i.e., ones with
    --   no data constructors) will use the @EmptyCase@ language extension.
    --   If 'False', derived instances will simply use 'seq' instead.
    --   (This has no effect on GHCs before 7.8, since @EmptyCase@ is only
    --   available in 7.8 or later.)
  } deriving (Eq, Ord, Read, Show)

-- | Conservative 'FFTOptions' that doesn't attempt to use @EmptyCase@ (to
-- prevent users from having to enable that extension at use sites.)
defaultFFTOptions :: FFTOptions
defaultFFTOptions = FFTOptions { fftEmptyCaseBehavior = False }

-- | Generates a 'Foldable' instance declaration for the given data type or data
-- family instance.
deriveFoldable :: Name -> Q [Dec]
deriveFoldable = deriveFoldableOptions defaultFFTOptions

-- | Like 'deriveFoldable', but takes an 'FFTOptions' argument.
deriveFoldableOptions :: FFTOptions -> Name -> Q [Dec]
deriveFoldableOptions = deriveFunctorClass Foldable

-- | Generates a lambda expression which behaves like 'foldMap' (without requiring a
-- 'Foldable' instance).
makeFoldMap :: Name -> Q Exp
makeFoldMap = makeFoldMapOptions defaultFFTOptions

-- | Like 'makeFoldMap', but takes an 'FFTOptions' argument.
makeFoldMapOptions :: FFTOptions -> Name -> Q Exp
makeFoldMapOptions = makeFunctorFun FoldMap

-- | Generates a lambda expression which behaves like 'null' (without requiring a
-- 'Foldable' instance).
makeNull :: Name -> Q Exp
makeNull = makeNullOptions defaultFFTOptions

-- | Like 'makeNull', but takes an 'FFTOptions' argument.
makeNullOptions :: FFTOptions -> Name -> Q Exp
makeNullOptions = makeFunctorFun Null

-- | Generates a lambda expression which behaves like 'foldr' (without requiring a
-- 'Foldable' instance).
makeFoldr :: Name -> Q Exp
makeFoldr = makeFoldrOptions defaultFFTOptions

-- | Like 'makeFoldr', but takes an 'FFTOptions' argument.
makeFoldrOptions :: FFTOptions -> Name -> Q Exp
makeFoldrOptions = makeFunctorFun Foldr

-- | Generates a lambda expression which behaves like 'fold' (without requiring a
-- 'Foldable' instance).
makeFold :: Name -> Q Exp
makeFold = makeFoldOptions defaultFFTOptions

-- | Like 'makeFold', but takes an 'FFTOptions' argument.
makeFoldOptions :: FFTOptions -> Name -> Q Exp
makeFoldOptions opts name = makeFoldMapOptions opts name `appE` varE idValName

-- | Generates a lambda expression which behaves like 'foldl' (without requiring a
-- 'Foldable' instance).
makeFoldl :: Name -> Q Exp
makeFoldl = makeFoldlOptions defaultFFTOptions

-- | Like 'makeFoldl', but takes an 'FFTOptions' argument.
makeFoldlOptions :: FFTOptions -> Name -> Q Exp
makeFoldlOptions opts name = do
  f <- newName "f"
  z <- newName "z"
  t <- newName "t"
  lamE [varP f, varP z, varP t] $
    appsE [ varE appEndoValName
          , appsE [ varE getDualValName
                  , appsE [ makeFoldMapOptions opts name, foldFun f, 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 'Functor' instance declaration for the given data type or data
-- family instance.
deriveFunctor :: Name -> Q [Dec]
deriveFunctor = deriveFunctorOptions defaultFFTOptions

-- | Like 'deriveFunctor', but takes an 'FFTOptions' argument.
deriveFunctorOptions :: FFTOptions -> Name -> Q [Dec]
deriveFunctorOptions = deriveFunctorClass Functor

-- | Generates a lambda expression which behaves like 'fmap' (without requiring a
-- 'Functor' instance).
makeFmap :: Name -> Q Exp
makeFmap = makeFmapOptions defaultFFTOptions

-- | Like 'makeFmap', but takes an 'FFTOptions' argument.
makeFmapOptions :: FFTOptions -> Name -> Q Exp
makeFmapOptions = makeFunctorFun Fmap

-- | Generates a lambda expression which behaves like ('<$') (without requiring a
-- 'Functor' instance).
makeReplace :: Name -> Q Exp
makeReplace = makeReplaceOptions defaultFFTOptions

-- | Like 'makeReplace', but takes an 'FFTOptions' argument.
makeReplaceOptions :: FFTOptions -> Name -> Q Exp
makeReplaceOptions = makeFunctorFun Replace

-- | Generates a 'Traversable' instance declaration for the given data type or data
-- family instance.
deriveTraversable :: Name -> Q [Dec]
deriveTraversable = deriveTraversableOptions defaultFFTOptions

-- | Like 'deriveTraverse', but takes an 'FFTOptions' argument.
deriveTraversableOptions :: FFTOptions -> Name -> Q [Dec]
deriveTraversableOptions = deriveFunctorClass Traversable

-- | Generates a lambda expression which behaves like 'traverse' (without requiring a
-- 'Traversable' instance).
makeTraverse :: Name -> Q Exp
makeTraverse = makeTraverseOptions defaultFFTOptions

-- | Like 'makeTraverse', but takes an 'FFTOptions' argument.
makeTraverseOptions :: FFTOptions -> Name -> Q Exp
makeTraverseOptions = makeFunctorFun Traverse

-- | Generates a lambda expression which behaves like 'sequenceA' (without requiring a
-- 'Traversable' instance).
makeSequenceA :: Name -> Q Exp
makeSequenceA = makeSequenceAOptions defaultFFTOptions

-- | Like 'makeSequenceA', but takes an 'FFTOptions' argument.
makeSequenceAOptions :: FFTOptions -> Name -> Q Exp
makeSequenceAOptions opts name = makeTraverseOptions opts name `appE` varE idValName

-- | Generates a lambda expression which behaves like 'mapM' (without requiring a
-- 'Traversable' instance).
makeMapM :: Name -> Q Exp
makeMapM = makeMapMOptions defaultFFTOptions

-- | Like 'makeMapM', but takes an 'FFTOptions' argument.
makeMapMOptions :: FFTOptions -> Name -> Q Exp
makeMapMOptions opts name = do
  f <- newName "f"
  lam1E (varP f) . infixApp (varE unwrapMonadValName) (varE composeValName) $
                   makeTraverseOptions opts name `appE` wrapMonadExp f
  where
    wrapMonadExp :: Name -> Q Exp
    wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n)

-- | Generates a lambda expression which behaves like 'sequence' (without requiring a
-- 'Traversable' instance).
makeSequence :: Name -> Q Exp
makeSequence = makeSequenceOptions defaultFFTOptions

-- | Like 'makeSequence', but takes an 'FFTOptions' argument.
makeSequenceOptions :: FFTOptions -> Name -> Q Exp
makeSequenceOptions opts name = makeMapMOptions opts name `appE` varE idValName

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

-- | Derive a class instance declaration (depending on the FunctorClass argument's value).
deriveFunctorClass :: FunctorClass -> FFTOptions -> Name -> Q [Dec]
deriveFunctorClass fc opts name = do
  info <- reifyDatatype name
  case info of
    DatatypeInfo { datatypeContext   = ctxt
                 , datatypeName      = parentName
                 , datatypeInstTypes = instTypes
                 , datatypeVariant   = variant
                 , datatypeCons      = cons
                 } -> do
      (instanceCxt, instanceType)
          <- buildTypeInstance fc parentName ctxt instTypes variant
      (:[]) `fmap` instanceD (return instanceCxt)
                             (return instanceType)
                             (functorFunDecs fc opts parentName instTypes cons)

-- | Generates a declaration defining the primary function(s) corresponding to a
-- particular class (fmap for Functor, foldr and foldMap for Foldable, and
-- traverse for Traversable).
--
-- For why both foldr and foldMap are derived for Foldable, see Trac #7436.
functorFunDecs
  :: FunctorClass -> FFTOptions -> Name -> [Type] -> [ConstructorInfo]
  -> [Q Dec]
functorFunDecs fc opts parentName instTypes cons =
  map makeFunD $ functorClassToFuns fc
  where
    makeFunD :: FunctorFun -> Q Dec
    makeFunD ff =
      funD (functorFunName ff)
           [ clause []
                    (normalB $ makeFunctorFunForCons ff opts parentName instTypes cons)
                    []
           ]

-- | Generates a lambda expression which behaves like the FunctorFun argument.
makeFunctorFun :: FunctorFun -> FFTOptions -> Name -> Q Exp
makeFunctorFun ff opts name = do
  info <- reifyDatatype name
  case info of
    DatatypeInfo { datatypeContext   = ctxt
                 , datatypeName      = parentName
                 , datatypeInstTypes = instTypes
                 , datatypeVariant   = variant
                 , datatypeCons      = cons
                 } -> do
      -- We force buildTypeInstance here since it performs some checks for whether
      -- or not the provided datatype can actually have fmap/foldr/traverse/etc.
      -- implemented for it, and produces errors if it can't.
      buildTypeInstance (functorFunToClass ff) parentName ctxt instTypes variant
        >> makeFunctorFunForCons ff opts parentName instTypes cons

-- | Generates a lambda expression for the given constructors.
-- All constructors must be from the same type.
makeFunctorFunForCons
  :: FunctorFun -> FFTOptions -> Name -> [Type] -> [ConstructorInfo]
  -> Q Exp
makeFunctorFunForCons ff opts _parentName instTypes cons = do
  mapFun <- newName "f"
  z      <- newName "z" -- Only used for deriving foldr
  value  <- newName "value"
  let argNames  = catMaybes [ guard (ff /= Null)  >> Just mapFun
                            , guard (ff == Foldr) >> Just z
                            , Just value
                            ]
      lastTyVar = varTToName $ last instTypes
      tvMap     = Map.singleton lastTyVar $ OneName mapFun
  lamE (map varP argNames)
      . appsE
      $ [ varE $ functorFunConstName ff
        , makeFun z value tvMap
        ] ++ map varE argNames
  where
    makeFun :: Name -> Name -> TyVarMap1 -> Q Exp
    makeFun z value tvMap = do
#if MIN_VERSION_template_haskell(2,9,0)
      roles <- reifyRoles _parentName
#endif
      case () of
        _

#if MIN_VERSION_template_haskell(2,9,0)
          | Just (_, PhantomR) <- unsnoc roles
         -> functorFunPhantom z value
#endif

          | null cons && fftEmptyCaseBehavior opts && ghc7'8OrLater
         -> functorFunEmptyCase ff z value

          | null cons
         -> functorFunNoCons ff z value

          | otherwise
         -> caseE (varE value)
                  (map (makeFunctorFunForCon ff z tvMap) cons)

#if MIN_VERSION_template_haskell(2,9,0)
    functorFunPhantom :: Name -> Name -> Q Exp
    functorFunPhantom z value =
        functorFunTrivial coerce
                          (varE pureValName `appE` coerce)
                          ff z
      where
        coerce :: Q Exp
        coerce = varE coerceValName `appE` varE value
#endif

-- | Generates a match for a single constructor.
makeFunctorFunForCon :: FunctorFun -> Name -> TyVarMap1 -> ConstructorInfo -> Q Match
makeFunctorFunForCon ff z tvMap
  con@(ConstructorInfo { constructorName    = conName
                       , constructorContext = ctxt }) = do
    checkExistentialContext (functorFunToClass ff) tvMap ctxt conName $
      case ff of
        Fmap     -> makeFmapMatch tvMap con
        Replace  -> makeReplaceMatch tvMap con
        Foldr    -> makeFoldrMatch z tvMap con
        FoldMap  -> makeFoldMapMatch tvMap con
        Null     -> makeNullMatch tvMap con
        Traverse -> makeTraverseMatch tvMap con

-- | Generates a match whose right-hand side implements @fmap@.
makeFmapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeFmapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do
  parts <- foldDataConArgs tvMap ft_fmap con
  match_for_con_functor conName parts
  where
    ft_fmap :: FFoldType (Exp -> Q Exp)
    ft_fmap = FT { ft_triv = return
                 , ft_var  = \v x -> case tvMap Map.! v of
                                       OneName f -> return $ VarE f `AppE` x
                 , ft_fun  = \g h x -> mkSimpleLam $ \b -> do
                     gg <- g b
                     h $ x `AppE` gg
                 , ft_tup  = mkSimpleTupleCase match_for_con_functor
                 , ft_ty_app = \argTy g x -> do
                     case varTToName_maybe argTy of
                       -- If the argument type is a bare occurrence of the
                       -- data type's last type variable, then we can
                       -- generate more efficient code.
                       -- This was inspired by GHC#17880.
                       Just argVar
                         |  Just (OneName f) <- Map.lookup argVar tvMap
                         -> return $ VarE fmapValName `AppE` VarE f `AppE` x
                       _ -> do gg <- mkSimpleLam g
                               return $ VarE fmapValName `AppE` gg `AppE` x
                 , ft_forall  = \_ g x -> g x
                 , ft_bad_app = \_ -> outOfPlaceTyVarError Functor conName
                 , ft_co_var  = \_ _ -> contravarianceError conName
                 }

-- | Generates a match whose right-hand side implements @(<$)@.
makeReplaceMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeReplaceMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do
  parts <- foldDataConArgs tvMap ft_replace con
  match_for_con_functor conName parts
  where
    ft_replace :: FFoldType (Exp -> Q Exp)
    ft_replace = FT { ft_triv = return
                    , ft_var  = \v _ -> case tvMap Map.! v of
                                          OneName z -> return $ VarE z
                    , ft_fun  = \g h x -> mkSimpleLam $ \b -> do
                        gg <- g b
                        h $ x `AppE` gg
                    , ft_tup  = mkSimpleTupleCase match_for_con_functor
                    , ft_ty_app = \argTy g x -> do
                        case varTToName_maybe argTy of
                          -- If the argument type is a bare occurrence of the
                          -- data type's last type variable, then we can
                          -- generate more efficient code.
                          -- This was inspired by GHC#17880.
                          Just argVar
                            |  Just (OneName z) <- Map.lookup argVar tvMap
                            -> return $ VarE replaceValName `AppE` VarE z `AppE` x
                          _ -> do gg <- mkSimpleLam g
                                  return $ VarE fmapValName `AppE` gg `AppE` x
                    , ft_forall  = \_ g x -> g x
                    , ft_bad_app = \_ -> outOfPlaceTyVarError Functor conName
                    , ft_co_var  = \_ _ -> contravarianceError conName
                    }

match_for_con_functor :: Name -> [Exp -> Q Exp] -> Q Match
match_for_con_functor = mkSimpleConMatch $ \conName' xs ->
  appsE (conE conName':xs) -- Con x1 x2 ..

-- | Generates a match whose right-hand side implements @foldr@.
makeFoldrMatch :: Name -> TyVarMap1 -> ConstructorInfo -> Q Match
makeFoldrMatch z tvMap con@(ConstructorInfo{constructorName = conName}) = do
  parts  <- foldDataConArgs tvMap ft_foldr con
  parts' <- sequence parts
  match_for_con (VarE z) conName parts'
  where
    -- The Bool is True if the type mentions the last type parameter, False
    -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out
    -- expressions that do not mention the last parameter by checking for False.
    ft_foldr :: FFoldType (Q (Bool, Exp))
    ft_foldr = FT { ft_triv = do lam <- mkSimpleLam2 $ \_ z' -> return z'
                                 return (False, lam)
                  , ft_var  = \v -> case tvMap Map.! v of
                                      OneName f -> return (True, VarE f)
                  , ft_tup  = \t gs -> do
                      gg  <- sequence gs
                      lam <- mkSimpleLam2 $ \x z' ->
                        mkSimpleTupleCase (match_for_con z') t gg x
                      return (True, lam)
                  , ft_ty_app = \_ g -> do
                      (b, gg) <- g
                      e <- mkSimpleLam2 $ \x z' -> return $
                           VarE foldrValName `AppE` gg `AppE` z' `AppE` x
                      return (b, e)
                  , ft_forall  = \_ g -> g
                  , ft_co_var  = \_ -> contravarianceError conName
                  , ft_fun     = \_ _ -> noFunctionsError conName
                  , ft_bad_app = outOfPlaceTyVarError Foldable conName
                  }

    match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match
    match_for_con zExp = mkSimpleConMatch2 $ \_ xs -> return $ mkFoldr xs
      where
        -- g1 v1 (g2 v2 (.. z))
        mkFoldr :: [Exp] -> Exp
        mkFoldr = foldr AppE zExp

-- | Generates a match whose right-hand side implements @foldMap@.
makeFoldMapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeFoldMapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do
  parts  <- foldDataConArgs tvMap ft_foldMap con
  parts' <- sequence parts
  match_for_con conName parts'
  where
    -- The Bool is True if the type mentions the last type parameter, False
    -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out
    -- expressions that do not mention the last parameter by checking for False.
    ft_foldMap :: FFoldType (Q (Bool, Exp))
    ft_foldMap = FT { ft_triv = do lam <- mkSimpleLam $ \_ -> return $ VarE memptyValName
                                   return (False, lam)
                    , ft_var  = \v -> case tvMap Map.! v of
                                        OneName f -> return (True, VarE f)
                    , ft_tup  = \t gs -> do
                        gg  <- sequence gs
                        lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
                        return (True, lam)
                    , ft_ty_app = \_ g -> do
                        fmap (\(b, e) -> (b, VarE foldMapValName `AppE` e)) g
                    , ft_forall  = \_ g -> g
                    , ft_co_var  = \_ -> contravarianceError conName
                    , ft_fun     = \_ _ -> noFunctionsError conName
                    , ft_bad_app = outOfPlaceTyVarError Foldable conName
                    }

    match_for_con :: Name -> [(Bool, Exp)] -> Q Match
    match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkFoldMap xs
      where
        -- mappend v1 (mappend v2 ..)
        mkFoldMap :: [Exp] -> Exp
        mkFoldMap [] = VarE memptyValName
        mkFoldMap es = foldr1 (AppE . AppE (VarE mappendValName)) es

-- | Generates a match whose right-hand side implements @null@.
makeNullMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeNullMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do
  parts  <- foldDataConArgs tvMap ft_null con
  parts' <- sequence parts
  case convert parts' of
    Nothing -> return $ Match (conWildPat con) (NormalB $ ConE falseDataName) []
    Just cp -> match_for_con conName cp
  where
    ft_null :: FFoldType (Q (NullM Exp))
    ft_null = FT { ft_triv = return $ IsNull $ ConE trueDataName
                 , ft_var  = \_ -> return NotNull
                 , ft_tup = \t g -> do
                     gg <- sequence g
                     case convert gg of
                       Nothing  -> return NotNull
                       Just ggg ->
                         fmap NullM $ mkSimpleLam
                                    $ mkSimpleTupleCase match_for_con t ggg
                 , ft_ty_app = \_ g -> flip fmap g $ \nestedResult ->
                     case nestedResult of
                       -- If e definitely contains the parameter, then we can
                       -- test if (G e) contains it by simply checking if (G e)
                       -- is null
                       NotNull -> NullM $ VarE nullValName
                       -- This case is unreachable--it will actually be caught
                       -- by ft_triv
                       r@IsNull{} -> r
                       -- The general case uses (all null), (all (all null)),
                       -- etc.
                       NullM nestedTest -> NullM $
                                           VarE allValName `AppE` nestedTest
                 , ft_forall = \_ g -> g
                 , ft_co_var  = \_ -> contravarianceError conName
                 , ft_fun     = \_ _ -> noFunctionsError conName
                 , ft_bad_app = outOfPlaceTyVarError Foldable conName
                 }

    match_for_con :: Name -> [(Bool, Exp)] -> Q Match
    match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkNull xs
      where
        -- v1 && v2 && ..
        mkNull :: [Exp] -> Exp
        mkNull [] = ConE trueDataName
        mkNull xs = foldr1 (\x y -> VarE andValName `AppE` x `AppE` y) xs

-- Given a list of NullM results, produce Nothing if any of them is NotNull,
-- and otherwise produce a list of (Bool, a) with True entries representing
-- unknowns and False entries representing things that are definitely null.
convert :: [NullM a] -> Maybe [(Bool, a)]
convert = mapM go where
  go (IsNull a) = Just (False, a)
  go NotNull    = Nothing
  go (NullM a)  = Just (True, a)

data NullM a =
    IsNull a -- Definitely null
  | NotNull  -- Definitely not null
  | NullM a  -- Unknown

-- | Generates a match whose right-hand side implements @traverse@.
makeTraverseMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeTraverseMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do
  parts  <- foldDataConArgs tvMap ft_trav con
  parts' <- sequence parts
  match_for_con conName parts'
  where
    -- The Bool is True if the type mentions the last type parameter, False
    -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out
    -- expressions that do not mention the last parameter by checking for False.
    ft_trav :: FFoldType (Q (Bool, Exp))
    ft_trav = FT { -- See Note [ft_triv for Bifoldable and Bitraversable]
                   ft_triv = return (False, VarE pureValName)
                 , ft_var  = \v -> case tvMap Map.! v of
                                     OneName f -> return (True, VarE f)
                 , ft_tup  = \t gs -> do
                     gg  <- sequence gs
                     lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
                     return (True, lam)
                 , ft_ty_app = \_ g ->
                     fmap (\(b, e) -> (b, VarE traverseValName `AppE` e)) g
                 , ft_forall  = \_ g -> g
                 , ft_co_var  = \_ -> contravarianceError conName
                 , ft_fun     = \_ _ -> noFunctionsError conName
                 , ft_bad_app = outOfPlaceTyVarError Traversable conName
                 }

    -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
    --                    (g2 a2) <*> ...
    match_for_con :: Name -> [(Bool, Exp)] -> Q Match
    match_for_con = mkSimpleConMatch2 $ \conExp xs -> return $ mkApCon conExp xs
      where
        -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
        mkApCon :: Exp -> [Exp] -> Exp
        mkApCon conExp []  = VarE pureValName `AppE` conExp
        mkApCon conExp [e] = VarE fmapValName `AppE` conExp `AppE` e
        mkApCon conExp (e1:e2:es) = List.foldl' appAp
          (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es
          where appAp se1 se2 = InfixE (Just se1) (VarE apValName) (Just se2)

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

-- | A representation of which class is being derived.
data FunctorClass = Functor | Foldable | Traversable

instance ClassRep FunctorClass where
    arity _ = 1

    allowExQuant Foldable = True
    allowExQuant _        = False

    fullClassName Functor     = functorTypeName
    fullClassName Foldable    = foldableTypeName
    fullClassName Traversable = traversableTypeName

    classConstraint fClass 1 = Just $ fullClassName fClass
    classConstraint  _      _ = Nothing

-- | A representation of which function is being generated.
data FunctorFun
  = Fmap
  | Replace -- (<$)
  | Foldr
  | FoldMap
  | Null
  | Traverse
  deriving Eq

instance Show FunctorFun where
    showsPrec _ Fmap     = showString "fmap"
    showsPrec _ Replace  = showString "(<$)"
    showsPrec _ Foldr    = showString "foldr"
    showsPrec _ FoldMap  = showString "foldMap"
    showsPrec _ Null     = showString "null"
    showsPrec _ Traverse = showString "traverse"

functorFunConstName :: FunctorFun -> Name
functorFunConstName Fmap     = fmapConstValName
functorFunConstName Replace  = replaceConstValName
functorFunConstName Foldr    = foldrConstValName
functorFunConstName FoldMap  = foldMapConstValName
functorFunConstName Null     = nullConstValName
functorFunConstName Traverse = traverseConstValName

functorFunName :: FunctorFun -> Name
functorFunName Fmap     = fmapValName
functorFunName Replace  = replaceValName
functorFunName Foldr    = foldrValName
functorFunName FoldMap  = foldMapValName
functorFunName Null     = nullValName
functorFunName Traverse = traverseValName

functorClassToFuns :: FunctorClass -> [FunctorFun]
functorClassToFuns Functor     = [ Fmap, Replace ]
functorClassToFuns Foldable    = [ Foldr, FoldMap
#if MIN_VERSION_base(4,8,0)
                                 , Null
#endif
                                 ]
functorClassToFuns Traversable = [ Traverse ]

functorFunToClass :: FunctorFun -> FunctorClass
functorFunToClass Fmap     = Functor
functorFunToClass Replace  = Functor
functorFunToClass Foldr    = Foldable
functorFunToClass FoldMap  = Foldable
functorFunToClass Null     = Foldable
functorFunToClass Traverse = Traversable

-------------------------------------------------------------------------------
-- Assorted utilities
-------------------------------------------------------------------------------

functorFunEmptyCase :: FunctorFun -> Name -> Name -> Q Exp
functorFunEmptyCase ff z value =
    functorFunTrivial emptyCase
                      (varE pureValName `appE` emptyCase)
                      ff z
  where
    emptyCase :: Q Exp
    emptyCase = caseE (varE value) []

functorFunNoCons :: FunctorFun -> Name -> Name -> Q Exp
functorFunNoCons ff z value =
    functorFunTrivial seqAndError
                      (varE pureValName `appE` seqAndError)
                      ff z
  where
    seqAndError :: Q Exp
    seqAndError = appE (varE seqValName) (varE value) `appE`
                  appE (varE errorValName)
                       (stringE $ "Void " ++ nameBase (functorFunName ff))

functorFunTrivial :: Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
functorFunTrivial fmapE traverseE ff z = go ff
  where
    go :: FunctorFun -> Q Exp
    go Fmap     = fmapE
    go Replace  = fmapE
    go Foldr    = varE z
    go FoldMap  = varE memptyValName
    go Null     = conE trueDataName
    go Traverse = traverseE

conWildPat :: ConstructorInfo -> Pat
conWildPat (ConstructorInfo { constructorName = conName
                            , constructorFields = ts }) =
  conPCompat conName $ replicate (length ts) WildP

-------------------------------------------------------------------------------
-- Generic traversal for functor-like deriving
-------------------------------------------------------------------------------

-- Much of the code below is cargo-culted from the TcGenFunctor module in GHC.

data FFoldType a      -- Describes how to fold over a Type in a functor like way
   = FT { ft_triv    :: a
          -- ^ Does not contain variable
        , ft_var     :: Name -> a
          -- ^ The variable itself
        , ft_co_var  :: Name -> a
          -- ^ The variable itself, contravariantly
        , ft_fun     :: a -> a -> a
          -- ^ Function type
        , ft_tup     :: TupleSort -> [a] -> a
          -- ^ Tuple type. The @[a]@ is the result of folding over the
          --   arguments of the tuple.
        , ft_ty_app  :: Type -> a -> a
          -- ^ Type app, variable only in last argument. The 'Type' is the
          --   @arg_ty@ in @fun_ty arg_ty@.
        , ft_bad_app :: a
          -- ^ Type app, variable other than in last argument
        , ft_forall  :: [TyVarBndrSpec] -> a -> a
          -- ^ Forall type
     }

-- Note that in GHC, this function is pure. It must be monadic here since we:
--
-- (1) Expand type synonyms
-- (2) Detect type family applications
--
-- Which require reification in Template Haskell, but are pure in Core.
functorLikeTraverse :: forall a.
                       TyVarMap1   -- ^ Variable to look for
                    -> FFoldType a -- ^ How to fold
                    -> Type        -- ^ Type to process
                    -> Q a
functorLikeTraverse tvMap (FT { ft_triv = caseTrivial,     ft_var = caseVar
                              , ft_co_var = caseCoVar,     ft_fun = caseFun
                              , ft_tup = caseTuple,        ft_ty_app = caseTyApp
                              , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
                    ty
  = do ty' <- resolveTypeSynonyms ty
       (res, _) <- go False ty'
       return res
  where
    go :: Bool        -- Covariant or contravariant context
       -> Type
       -> Q (a, Bool) -- (result of type a, does type contain var)
    go co t@AppT{}
      | (ArrowT, [funArg, funRes]) <- unapplyTy t
      = do (funArgR, funArgC) <- go (not co) funArg
           (funResR, funResC) <- go      co  funRes
           if funArgC || funResC
              then return (caseFun funArgR funResR, True)
              else trivial
    go co t@AppT{} = do
      let (f, args) = unapplyTy t
      (_,   fc)  <- go co f
      (xrs, xcs) <- fmap unzip $ mapM (go co) args
      let tuple :: TupleSort -> Q (a, Bool)
          tuple tupSort = return (caseTuple tupSort xrs, True)

          wrongArg :: Q (a, Bool)
          wrongArg = return (caseWrongArg, True)

      case () of
        _ |  not (or xcs)
          -> trivial -- Variable does not occur
          -- At this point we know that xrs, xcs is not empty,
          -- and at least one xr is True
          |  TupleT len <- f
          -> tuple $ Boxed len
#if MIN_VERSION_template_haskell(2,6,0)
          |  UnboxedTupleT len <- f
          -> tuple $ Unboxed len
#endif
          |  fc || or (init xcs)
          -> wrongArg                    -- T (..var..)    ty
          |  otherwise                   -- T (..no var..) ty
          -> do itf <- isInTypeFamilyApp tyVarNames f args
                if itf -- We can't decompose type families, so
                       -- error if we encounter one here.
                   then wrongArg
                   else return (caseTyApp (last args) (last xrs), True)
    go co (SigT t k) = do
      (_, kc) <- go_kind co k
      if kc
         then return (caseWrongArg, True)
         else go co t
    go co (VarT v)
      | Map.member v tvMap
      = return (if co then caseCoVar v else caseVar v, True)
      | otherwise
      = trivial
    go co (ForallT tvbs _ t) = do
      (tr, tc) <- go co t
      let tvbNames = map tvName tvbs
      if not tc || any (`elem` tvbNames) tyVarNames
         then trivial
         else return (caseForAll tvbs tr, True)
    go _ _ = trivial

    go_kind :: Bool
            -> Kind
            -> Q (a, Bool)
#if MIN_VERSION_template_haskell(2,9,0)
    go_kind = go
#else
    go_kind _ _ = trivial
#endif

    trivial :: Q (a, Bool)
    trivial = return (caseTrivial, False)

    tyVarNames :: [Name]
    tyVarNames = Map.keys tvMap

-- Fold over the arguments of a data constructor in a Functor-like way.
foldDataConArgs :: forall a. TyVarMap1 -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs tvMap ft con = do
  fieldTys <- mapM resolveTypeSynonyms $ constructorFields con
  mapM foldArg fieldTys
  where
    foldArg :: Type -> Q a
    foldArg = functorLikeTraverse tvMap ft

-- Make a 'LamE' using a fresh variable.
mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
mkSimpleLam lam = do
  n <- newName "n"
  body <- lam (VarE n)
  return $ LamE [VarP n] body

-- Make a 'LamE' using two fresh variables.
mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 lam = do
  n1 <- newName "n1"
  n2 <- newName "n2"
  body <- lam (VarE n1) (VarE n2)
  return $ LamE [VarP n1, VarP n2] body

-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
--
-- @mkSimpleConMatch fold conName insides@ produces a match clause in
-- which the LHS pattern-matches on @extraPats@, followed by a match on the
-- constructor @conName@ and its arguments. The RHS folds (with @fold@) over
-- @conName@ and its arguments, applying an expression (from @insides@) to each
-- of the respective arguments of @conName@.
mkSimpleConMatch :: (Name -> [a] -> Q Exp)
                 -> Name
                 -> [Exp -> a]
                 -> Q Match
mkSimpleConMatch fold conName insides = do
  varsNeeded <- newNameList "_arg" $ length insides
  let pat = conPCompat conName (map VarP varsNeeded)
  rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded)
  return $ Match pat (NormalB rhs) []

-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
--
-- @mkSimpleConMatch2 fold conName insides@ behaves very similarly to
-- 'mkSimpleConMatch', with two key differences:
--
-- 1. @insides@ is a @[(Bool, Exp)]@ instead of a @[Exp]@. This is because it
--    filters out the expressions corresponding to arguments whose types do not
--    mention the last type variable in a derived 'Foldable' or 'Traversable'
--    instance (i.e., those elements of @insides@ containing @False@).
--
-- 2. @fold@ takes an expression as its first argument instead of a
--    constructor name. This is because it uses a specialized
--    constructor function expression that only takes as many parameters as
--    there are argument types that mention the last type variable.
mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp)
                  -> Name
                  -> [(Bool, Exp)]
                  -> Q Match
mkSimpleConMatch2 fold conName insides = do
  varsNeeded <- newNameList "_arg" lengthInsides
  let pat = conPCompat conName (map VarP varsNeeded)
      -- Make sure to zip BEFORE invoking catMaybes. We want the variable
      -- indicies in each expression to match up with the argument indices
      -- in conExpr (defined below).
      exps = catMaybes $ zipWith (\(m, i) v -> if m then Just (i `AppE` VarE v)
                                                    else Nothing)
                                 insides varsNeeded
      -- An element of argTysTyVarInfo is True if the constructor argument
      -- with the same index has a type which mentions the last type
      -- variable.
      argTysTyVarInfo = map (\(m, _) -> m) insides
      (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo varsNeeded

      conExpQ
        | null asWithTyVar = appsE (conE conName:map varE asWithoutTyVar)
        | otherwise = do
            bs <- newNameList "b" lengthInsides
            let bs'  = filterByList  argTysTyVarInfo bs
                vars = filterByLists argTysTyVarInfo
                                     (map varE bs) (map varE varsNeeded)
            lamE (map varP bs') (appsE (conE conName:vars))

  conExp <- conExpQ
  rhs <- fold conExp exps
  return $ Match pat (NormalB rhs) []
  where
    lengthInsides = length insides

-- Indicates whether a tuple is boxed or unboxed, as well as its number of
-- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #)
-- corresponds to @Unboxed 3@.
data TupleSort
  = Boxed   Int
#if MIN_VERSION_template_haskell(2,6,0)
  | Unboxed Int
#endif

-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
mkSimpleTupleCase :: (Name -> [a] -> Q Match)
                  -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase matchForCon tupSort insides x = do
  let tupDataName = case tupSort of
                      Boxed   len -> tupleDataName len
#if MIN_VERSION_template_haskell(2,6,0)
                      Unboxed len -> unboxedTupleDataName len
#endif
  m <- matchForCon tupDataName insides
  return $ CaseE x [m]

-- Adapt to the type of ConP changing in template-haskell-2.18.0.0.
conPCompat :: Name -> [Pat] -> Pat
conPCompat n pats = ConP n
#if MIN_VERSION_template_haskell(2,18,0)
                         []
#endif
                         pats