{-# 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           Data.List
import qualified Data.Map as Map ((!), keys, lookup, member, singleton)
import           Data.Maybe

import           Language.Haskell.TH.Datatype
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) = 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 }) =
  ConP 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  :: [TyVarBndr] -> 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 = ConP 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 = ConP 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]