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

#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Unsafe #-}
#endif

#ifndef MIN_VERSION_template_haskell
#define MIN_VERSION_template_haskell(x,y,z) 1
#endif
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2008-2016 Edward Kmett, (C) 2015-2016 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
  , deriveBifunctorOptions
  , makeBimap
  , makeBimapOptions
    -- * 'Bifoldable'
  , deriveBifoldable
  , deriveBifoldableOptions
  , makeBifold
  , makeBifoldOptions
  , makeBifoldMap
  , makeBifoldMapOptions
  , makeBifoldr
  , makeBifoldrOptions
  , makeBifoldl
  , makeBifoldlOptions
    -- * 'Bitraversable'
  , deriveBitraversable
  , deriveBitraversableOptions
  , makeBitraverse
  , makeBitraverseOptions
  , makeBisequenceA
  , makeBisequenceAOptions
  , makeBimapM
  , makeBimapMOptions
  , makeBisequence
  , makeBisequenceOptions
    -- * 'Options'
  , Options(..)
  , defaultOptions
  ) where

import           Control.Monad (guard, unless, when, zipWithM)

import           Data.Bifunctor.TH.Internal
import           Data.Either (rights)
import           Data.List
import qualified Data.Map as Map (fromList, keys, lookup, size)
import           Data.Maybe

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

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

-- | Options that further configure how the functions in "Data.Bifunctor.TH"
-- should behave.
newtype Options = Options
  { Options -> Bool
emptyCaseBehavior :: 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 (Options -> Options -> Bool
(Options -> Options -> Bool)
-> (Options -> Options -> Bool) -> Eq Options
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Options -> Options -> Bool
$c/= :: Options -> Options -> Bool
== :: Options -> Options -> Bool
$c== :: Options -> Options -> Bool
Eq, Eq Options
Eq Options =>
(Options -> Options -> Ordering)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Options)
-> (Options -> Options -> Options)
-> Ord Options
Options -> Options -> Bool
Options -> Options -> Ordering
Options -> Options -> Options
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Options -> Options -> Options
$cmin :: Options -> Options -> Options
max :: Options -> Options -> Options
$cmax :: Options -> Options -> Options
>= :: Options -> Options -> Bool
$c>= :: Options -> Options -> Bool
> :: Options -> Options -> Bool
$c> :: Options -> Options -> Bool
<= :: Options -> Options -> Bool
$c<= :: Options -> Options -> Bool
< :: Options -> Options -> Bool
$c< :: Options -> Options -> Bool
compare :: Options -> Options -> Ordering
$ccompare :: Options -> Options -> Ordering
$cp1Ord :: Eq Options
Ord, ReadPrec [Options]
ReadPrec Options
Int -> ReadS Options
ReadS [Options]
(Int -> ReadS Options)
-> ReadS [Options]
-> ReadPrec Options
-> ReadPrec [Options]
-> Read Options
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Options]
$creadListPrec :: ReadPrec [Options]
readPrec :: ReadPrec Options
$creadPrec :: ReadPrec Options
readList :: ReadS [Options]
$creadList :: ReadS [Options]
readsPrec :: Int -> ReadS Options
$creadsPrec :: Int -> ReadS Options
Read, Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show)

-- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to
-- prevent users from having to enable that extension at use sites.)
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options :: Bool -> Options
Options { emptyCaseBehavior :: Bool
emptyCaseBehavior = Bool
False }

{- $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@.

-}

{- $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 :: Name -> Q [Dec]
deriveBifunctor = Options -> Name -> Q [Dec]
deriveBifunctorOptions Options
defaultOptions

-- | Like 'deriveBifunctor', but takes an 'Options' argument.
deriveBifunctorOptions :: Options -> Name -> Q [Dec]
deriveBifunctorOptions :: Options -> Name -> Q [Dec]
deriveBifunctorOptions = BiClass -> Options -> Name -> Q [Dec]
deriveBiClass BiClass
Bifunctor

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

-- | Like 'makeBimap', but takes an 'Options' argument.
makeBimapOptions :: Options -> Name -> Q Exp
makeBimapOptions :: Options -> Name -> Q Exp
makeBimapOptions = BiFun -> Options -> Name -> Q Exp
makeBiFun BiFun
Bimap

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

-- | Like 'deriveBifoldable', but takes an 'Options' argument.
deriveBifoldableOptions :: Options -> Name -> Q [Dec]
deriveBifoldableOptions :: Options -> Name -> Q [Dec]
deriveBifoldableOptions = BiClass -> Options -> Name -> Q [Dec]
deriveBiClass BiClass
Bifoldable

--- | Generates a lambda expression which behaves like 'bifold' (without requiring a
-- 'Bifoldable' instance).
makeBifold :: Name -> Q Exp
makeBifold :: Name -> Q Exp
makeBifold = Options -> Name -> Q Exp
makeBifoldOptions Options
defaultOptions

-- | Like 'makeBifold', but takes an 'Options' argument.
makeBifoldOptions :: Options -> Name -> Q Exp
makeBifoldOptions :: Options -> Name -> Q Exp
makeBifoldOptions opts :: Options
opts name :: Name
name = [Q Exp] -> Q Exp
appsE [ Options -> Name -> Q Exp
makeBifoldMapOptions Options
opts Name
name
                                    , Name -> Q Exp
varE Name
idValName
                                    , Name -> Q Exp
varE Name
idValName
                                    ]

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

-- | Like 'makeBifoldMap', but takes an 'Options' argument.
makeBifoldMapOptions :: Options -> Name -> Q Exp
makeBifoldMapOptions :: Options -> Name -> Q Exp
makeBifoldMapOptions = BiFun -> Options -> Name -> Q Exp
makeBiFun BiFun
BifoldMap

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

-- | Like 'makeBifoldr', but takes an 'Options' argument.
makeBifoldrOptions :: Options -> Name -> Q Exp
makeBifoldrOptions :: Options -> Name -> Q Exp
makeBifoldrOptions = BiFun -> Options -> Name -> Q Exp
makeBiFun BiFun
Bifoldr

-- | Generates a lambda expression which behaves like 'bifoldl' (without requiring a
-- 'Bifoldable' instance).
makeBifoldl :: Name -> Q Exp
makeBifoldl :: Name -> Q Exp
makeBifoldl = Options -> Name -> Q Exp
makeBifoldlOptions Options
defaultOptions

-- | Like 'makeBifoldl', but takes an 'Options' argument.
makeBifoldlOptions :: Options -> Name -> Q Exp
makeBifoldlOptions :: Options -> Name -> Q Exp
makeBifoldlOptions opts :: Options
opts name :: Name
name = do
  Name
f <- String -> Q Name
newName "f"
  Name
g <- String -> Q Name
newName "g"
  Name
z <- String -> Q Name
newName "z"
  Name
t <- String -> Q Name
newName "t"
  [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
f, Name -> PatQ
varP Name
g, Name -> PatQ
varP Name
z, Name -> PatQ
varP Name
t] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
    [Q Exp] -> Q Exp
appsE [ Name -> Q Exp
varE Name
appEndoValName
          , [Q Exp] -> Q Exp
appsE [ Name -> Q Exp
varE Name
getDualValName
                  , [Q Exp] -> Q Exp
appsE [ Options -> Name -> Q Exp
makeBifoldMapOptions Options
opts Name
name
                          , Name -> Q Exp
foldFun Name
f
                          , Name -> Q Exp
foldFun Name
g
                          , Name -> Q Exp
varE Name
t]
                  ]
          , Name -> Q Exp
varE Name
z
          ]
  where
    foldFun :: Name -> Q Exp
    foldFun :: Name -> Q Exp
foldFun n :: Name
n = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
conE Name
dualDataName)
                         (Name -> Q Exp
varE Name
composeValName)
                         (Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
conE Name
endoDataName)
                                   (Name -> Q Exp
varE Name
composeValName)
                                   (Name -> Q Exp
varE Name
flipValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
n)
                         )

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

-- | Like 'deriveBitraversable', but takes an 'Options' argument.
deriveBitraversableOptions :: Options -> Name -> Q [Dec]
deriveBitraversableOptions :: Options -> Name -> Q [Dec]
deriveBitraversableOptions = BiClass -> Options -> Name -> Q [Dec]
deriveBiClass BiClass
Bitraversable

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

-- | Like 'makeBitraverse', but takes an 'Options' argument.
makeBitraverseOptions :: Options -> Name -> Q Exp
makeBitraverseOptions :: Options -> Name -> Q Exp
makeBitraverseOptions = BiFun -> Options -> Name -> Q Exp
makeBiFun BiFun
Bitraverse

-- | Generates a lambda expression which behaves like 'bisequenceA' (without
-- requiring a 'Bitraversable' instance).
makeBisequenceA :: Name -> Q Exp
makeBisequenceA :: Name -> Q Exp
makeBisequenceA = Options -> Name -> Q Exp
makeBisequenceAOptions Options
defaultOptions

-- | Like 'makeBitraverseA', but takes an 'Options' argument.
makeBisequenceAOptions :: Options -> Name -> Q Exp
makeBisequenceAOptions :: Options -> Name -> Q Exp
makeBisequenceAOptions opts :: Options
opts name :: Name
name = [Q Exp] -> Q Exp
appsE [ Options -> Name -> Q Exp
makeBitraverseOptions Options
opts Name
name
                                         , Name -> Q Exp
varE Name
idValName
                                         , Name -> Q Exp
varE Name
idValName
                                         ]

-- | Generates a lambda expression which behaves like 'bimapM' (without
-- requiring a 'Bitraversable' instance).
makeBimapM :: Name -> Q Exp
makeBimapM :: Name -> Q Exp
makeBimapM = Options -> Name -> Q Exp
makeBimapMOptions Options
defaultOptions

-- | Like 'makeBimapM', but takes an 'Options' argument.
makeBimapMOptions :: Options -> Name -> Q Exp
makeBimapMOptions :: Options -> Name -> Q Exp
makeBimapMOptions opts :: Options
opts name :: Name
name = do
  Name
f <- String -> Q Name
newName "f"
  Name
g <- String -> Q Name
newName "g"
  [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
f, Name -> PatQ
varP Name
g] (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
unwrapMonadValName) (Name -> Q Exp
varE Name
composeValName) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
                          [Q Exp] -> Q Exp
appsE [ Options -> Name -> Q Exp
makeBitraverseOptions Options
opts Name
name
                                , Name -> Q Exp
wrapMonadExp Name
f
                                , Name -> Q Exp
wrapMonadExp Name
g
                                ]
  where
    wrapMonadExp :: Name -> Q Exp
    wrapMonadExp :: Name -> Q Exp
wrapMonadExp n :: Name
n = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
conE Name
wrapMonadDataName) (Name -> Q Exp
varE Name
composeValName) (Name -> Q Exp
varE Name
n)

-- | Generates a lambda expression which behaves like 'bisequence' (without
-- requiring a 'Bitraversable' instance).
makeBisequence :: Name -> Q Exp
makeBisequence :: Name -> Q Exp
makeBisequence = Options -> Name -> Q Exp
makeBisequenceOptions Options
defaultOptions

-- | Like 'makeBisequence', but takes an 'Options' argument.
makeBisequenceOptions :: Options -> Name -> Q Exp
makeBisequenceOptions :: Options -> Name -> Q Exp
makeBisequenceOptions opts :: Options
opts name :: Name
name = [Q Exp] -> Q Exp
appsE [ Options -> Name -> Q Exp
makeBimapMOptions Options
opts Name
name
                                        , Name -> Q Exp
varE Name
idValName
                                        , Name -> Q Exp
varE Name
idValName
                                        ]

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

-- | Derive a class instance declaration (depending on the BiClass argument's value).
deriveBiClass :: BiClass -> Options -> Name -> Q [Dec]
deriveBiClass :: BiClass -> Options -> Name -> Q [Dec]
deriveBiClass biClass :: BiClass
biClass opts :: Options
opts name :: Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case DatatypeInfo
info of
    DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext   = Cxt
ctxt
                 , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
parentName
                 , datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTys
                 , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
                 , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                 } -> do
      (instanceCxt :: Cxt
instanceCxt, instanceType :: Type
instanceType)
          <- BiClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance BiClass
biClass Name
parentName Cxt
ctxt Cxt
instTys DatatypeVariant
variant
      (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
                             (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
                             (BiClass -> Options -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
biFunDecs BiClass
biClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons)

-- | 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 -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
biFunDecs :: BiClass -> Options -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
biFunDecs biClass :: BiClass
biClass opts :: Options
opts parentName :: Name
parentName instTys :: Cxt
instTys cons :: [ConstructorInfo]
cons =
  (BiFun -> Q Dec) -> [BiFun] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map BiFun -> Q Dec
makeFunD ([BiFun] -> [Q Dec]) -> [BiFun] -> [Q Dec]
forall a b. (a -> b) -> a -> b
$ BiClass -> [BiFun]
biClassToFuns BiClass
biClass
  where
    makeFunD :: BiFun -> Q Dec
    makeFunD :: BiFun -> Q Dec
makeFunD biFun :: BiFun
biFun =
      Name -> [ClauseQ] -> Q Dec
funD (BiFun -> Name
biFunName BiFun
biFun)
           [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                    (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ BiFun -> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeBiFunForCons BiFun
biFun Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons)
                    []
           ]

-- | Generates a lambda expression which behaves like the BiFun argument.
makeBiFun :: BiFun -> Options -> Name -> Q Exp
makeBiFun :: BiFun -> Options -> Name -> Q Exp
makeBiFun biFun :: BiFun
biFun opts :: Options
opts name :: Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case DatatypeInfo
info of
    DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext   = Cxt
ctxt
                 , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
parentName
                 , datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTys
                 , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
                 , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                 } ->
      -- We force buildTypeInstance here since it performs some checks for whether
      -- or not the provided datatype can actually have bimap/bifoldr/bitraverse/etc.
      -- implemented for it, and produces errors if it can't.
      BiClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance (BiFun -> BiClass
biFunToClass BiFun
biFun) Name
parentName Cxt
ctxt Cxt
instTys DatatypeVariant
variant
        Q (Cxt, Type) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BiFun -> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeBiFunForCons BiFun
biFun Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons

-- | Generates a lambda expression for the given constructors.
-- All constructors must be from the same type.
makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
makeBiFunForCons :: BiFun -> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeBiFunForCons biFun :: BiFun
biFun opts :: Options
opts _parentName :: Name
_parentName instTys :: Cxt
instTys cons :: [ConstructorInfo]
cons = do
  [Name]
argNames <- (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Q Name
newName ([String] -> Q [Name]) -> [String] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [ String -> Maybe String
forall a. a -> Maybe a
Just "f"
                                       , String -> Maybe String
forall a. a -> Maybe a
Just "g"
                                       , Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BiFun
biFun BiFun -> BiFun -> Bool
forall a. Eq a => a -> a -> Bool
== BiFun
Bifoldr) Maybe () -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Maybe String
forall a. a -> Maybe a
Just "z"
                                       , String -> Maybe String
forall a. a -> Maybe a
Just "value"
                                       ]
  let ([map1 :: Name
map1, map2 :: Name
map2], others :: [Name]
others) = Int -> [Name] -> ([Name], [Name])
forall a. Int -> [a] -> ([a], [a])
splitAt 2 [Name]
argNames
      z :: Name
z          = [Name] -> Name
forall a. [a] -> a
head [Name]
others -- If we're deriving bifoldr, this will be well defined
                               -- and useful. Otherwise, it'll be ignored.
      value :: Name
value      = [Name] -> Name
forall a. [a] -> a
last [Name]
others
      lastTyVars :: [Name]
lastTyVars = (Type -> Name) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName (Cxt -> [Name]) -> Cxt -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTys Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2) Cxt
instTys
      tvMap :: Map Name Name
tvMap      = [(Name, Name)] -> Map Name Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Name)] -> Map Name Name)
-> [(Name, Name)] -> Map Name Name
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
lastTyVars [Name
map1, Name
map2]
  [PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
argNames)
      (Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE
      ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ BiFun -> Name
biFunConstName BiFun
biFun
        , Name -> Name -> Map Name Name -> Q Exp
makeFun Name
z Name
value Map Name Name
tvMap
        ] [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
argNames
  where
    makeFun :: Name -> Name -> TyVarMap -> Q Exp
    makeFun :: Name -> Name -> Map Name Name -> Q Exp
makeFun z :: Name
z value :: Name
value tvMap :: Map Name Name
tvMap = do
#if MIN_VERSION_template_haskell(2,9,0)
      [Role]
roles <- Name -> Q [Role]
reifyRoles Name
_parentName
#endif
      case () of
        _

#if MIN_VERSION_template_haskell(2,9,0)
          | Just (rs :: [Role]
rs, PhantomR) <- [Role] -> Maybe ([Role], Role)
forall a. [a] -> Maybe ([a], a)
unsnoc [Role]
roles
          , Just (_,  PhantomR) <- [Role] -> Maybe ([Role], Role)
forall a. [a] -> Maybe ([a], a)
unsnoc [Role]
rs
         -> Name -> Name -> Q Exp
biFunPhantom Name
z Name
value
#endif

          | [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons Bool -> Bool -> Bool
&& Options -> Bool
emptyCaseBehavior Options
opts Bool -> Bool -> Bool
&& Bool
ghc7'8OrLater
         -> BiFun -> Name -> Name -> Q Exp
biFunEmptyCase BiFun
biFun Name
z Name
value

          | [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
         -> BiFun -> Name -> Name -> Q Exp
biFunNoCons BiFun
biFun Name
z Name
value

          | Bool
otherwise
         -> Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value)
                  ((ConstructorInfo -> MatchQ) -> [ConstructorInfo] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (BiFun -> Name -> Map Name Name -> ConstructorInfo -> MatchQ
makeBiFunForCon BiFun
biFun Name
z Map Name Name
tvMap) [ConstructorInfo]
cons)

    ghc7'8OrLater :: Bool
#if __GLASGOW_HASKELL__ >= 708
    ghc7'8OrLater :: Bool
ghc7'8OrLater = Bool
True
#else
    ghc7'8OrLater = False
#endif

#if MIN_VERSION_template_haskell(2,9,0)
    biFunPhantom :: Name -> Name -> Q Exp
    biFunPhantom :: Name -> Name -> Q Exp
biFunPhantom z :: Name
z value :: Name
value =
        Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial Q Exp
coerce
                     (Name -> Q Exp
varE Name
pureValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
coerce)
                     BiFun
biFun Name
z
      where
        coerce :: Q Exp
        coerce :: Q Exp
coerce = Name -> Q Exp
varE Name
coerceValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
value
#endif

-- | Generates a lambda expression for a single constructor.
makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match
makeBiFunForCon :: BiFun -> Name -> Map Name Name -> ConstructorInfo -> MatchQ
makeBiFunForCon biFun :: BiFun
biFun z :: Name
z tvMap :: Map Name Name
tvMap
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                   , constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt
                   , constructorFields :: ConstructorInfo -> Cxt
constructorFields  = Cxt
ts }) = do
    Cxt
ts'      <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
ts
    [Name]
argNames <- String -> Int -> Q [Name]
newNameList "_arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts'
    if ((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` Map Name Name -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name Name
tvMap) Cxt
ctxt
          Bool -> Bool -> Bool
|| Map Name Name -> Int
forall k a. Map k a -> Int
Map.size Map Name Name
tvMap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2)
          Bool -> Bool -> Bool
&& Bool -> Bool
not (BiClass -> Bool
allowExQuant (BiFun -> BiClass
biFunToClass BiFun
biFun))
       then Name -> MatchQ
forall a. Name -> a
existentialContextError Name
conName
       else BiFun -> Name -> Map Name Name -> Name -> Cxt -> [Name] -> MatchQ
makeBiFunForArgs BiFun
biFun Name
z Map Name Name
tvMap Name
conName Cxt
ts' [Name]
argNames

-- | Generates a lambda expression for a single constructor's arguments.
makeBiFunForArgs :: BiFun
                 -> Name
                 -> TyVarMap
                 -> Name
                 -> [Type]
                 -> [Name]
                 -> Q Match
makeBiFunForArgs :: BiFun -> Name -> Map Name Name -> Name -> Cxt -> [Name] -> MatchQ
makeBiFunForArgs biFun :: BiFun
biFun z :: Name
z tvMap :: Map Name Name
tvMap conName :: Name
conName tys :: Cxt
tys args :: [Name]
args =
  PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
        (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ BiFun -> Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
biFunCombine BiFun
biFun Name
conName Name
z [Name]
args Q [Either Exp Exp]
mappedArgs)
        []
  where
    mappedArgs :: Q [Either Exp Exp]
    mappedArgs :: Q [Either Exp Exp]
mappedArgs = (Type -> Name -> Q (Either Exp Exp))
-> Cxt -> [Name] -> Q [Either Exp Exp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (BiFun
-> Map Name Name -> Name -> Type -> Name -> Q (Either Exp Exp)
makeBiFunForArg BiFun
biFun Map Name Name
tvMap Name
conName) Cxt
tys [Name]
args

-- | Generates a lambda expression for a single argument of a constructor.
--  The returned value is 'Right' if its type mentions one of the last two type
-- parameters. Otherwise, it is 'Left'.
makeBiFunForArg :: BiFun
                -> TyVarMap
                -> Name
                -> Type
                -> Name
                -> Q (Either Exp Exp)
makeBiFunForArg :: BiFun
-> Map Name Name -> Name -> Type -> Name -> Q (Either Exp Exp)
makeBiFunForArg biFun :: BiFun
biFun tvMap :: Map Name Name
tvMap conName :: Name
conName ty :: Type
ty tyExpName :: Name
tyExpName =
  BiFun
-> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
makeBiFunForType BiFun
biFun Map Name Name
tvMap Name
conName Bool
True Type
ty Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
`appEitherE` Name -> Q Exp
varE Name
tyExpName

-- | Generates a lambda expression for a specific type. The returned value is
-- 'Right' if its type mentions one of the last two type parameters. Otherwise,
-- it is 'Left'.
makeBiFunForType :: BiFun
                 -> TyVarMap
                 -> Name
                 -> Bool
                 -> Type
                 -> Q (Either Exp Exp)
makeBiFunForType :: BiFun
-> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
makeBiFunForType biFun :: BiFun
biFun tvMap :: Map Name Name
tvMap conName :: Name
conName covariant :: Bool
covariant (VarT tyName :: Name
tyName) =
  case Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name Name
tvMap of
    Just mapName :: Name
mapName -> (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. b -> Either a b
Right (Q Exp -> Q (Either Exp Exp))
-> (Name -> Q Exp) -> Name -> Q (Either Exp Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
varE (Name -> Q (Either Exp Exp)) -> Name -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$
                        if Bool
covariant
                           then Name
mapName
                           else Name -> Name
forall a. Name -> a
contravarianceError Name
conName
    Nothing -> (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. a -> Either a b
Left (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$ BiFun -> Q Exp
biFunTriv BiFun
biFun
makeBiFunForType biFun :: BiFun
biFun tvMap :: Map Name Name
tvMap conName :: Name
conName covariant :: Bool
covariant (SigT ty :: Type
ty _) =
  BiFun
-> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
makeBiFunForType BiFun
biFun Map Name Name
tvMap Name
conName Bool
covariant Type
ty
makeBiFunForType biFun :: BiFun
biFun tvMap :: Map Name Name
tvMap conName :: Name
conName covariant :: Bool
covariant (ForallT _ _ ty :: Type
ty) =
  BiFun
-> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
makeBiFunForType BiFun
biFun Map Name Name
tvMap Name
conName Bool
covariant Type
ty
makeBiFunForType biFun :: BiFun
biFun tvMap :: Map Name Name
tvMap conName :: Name
conName covariant :: Bool
covariant ty :: Type
ty =
  let tyCon  :: Type
      tyArgs :: [Type]
      tyCon :: Type
tyCon:tyArgs :: Cxt
tyArgs = Type -> Cxt
unapplyTy Type
ty

      numLastArgs :: Int
      numLastArgs :: Int
numLastArgs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min 2 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs

      lhsArgs, rhsArgs :: [Type]
      (lhsArgs :: Cxt
lhsArgs, rhsArgs :: Cxt
rhsArgs) = Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) Cxt
tyArgs

      tyVarNames :: [Name]
      tyVarNames :: [Name]
tyVarNames = Map Name Name -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name Name
tvMap

      mentionsTyArgs :: Bool
      mentionsTyArgs :: Bool
mentionsTyArgs = (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs

      makeBiFunTuple :: ([Q Pat] -> Q Pat) -> (Int -> Name) -> Int
                     -> Q (Either Exp Exp)
      makeBiFunTuple :: ([PatQ] -> PatQ) -> (Int -> Name) -> Int -> Q (Either Exp Exp)
makeBiFunTuple mkTupP :: [PatQ] -> PatQ
mkTupP mkTupleDataName :: Int -> Name
mkTupleDataName n :: Int
n = do
        [Name]
args <- (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Q Name
newName ([String] -> Q [Name]) -> [String] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [ String -> Maybe String
forall a. a -> Maybe a
Just "x"
                                         , Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BiFun
biFun BiFun -> BiFun -> Bool
forall a. Eq a => a -> a -> Bool
== BiFun
Bifoldr) Maybe () -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Maybe String
forall a. a -> Maybe a
Just "z"
                                         ]
        [Name]
xs <- String -> Int -> Q [Name]
newNameList "_tup" Int
n

        let x :: Name
x = [Name] -> Name
forall a. [a] -> a
head [Name]
args
            z :: Name
z = [Name] -> Name
forall a. [a] -> a
last [Name]
args
        (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. b -> Either a b
Right (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$ [PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
x)
             [ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match ([PatQ] -> PatQ
mkTupP ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs)
                     (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ BiFun -> Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
biFunCombine BiFun
biFun
                                             (Int -> Name
mkTupleDataName Int
n)
                                             Name
z
                                             [Name]
xs
                                             ((Type -> Name -> Q (Either Exp Exp))
-> Cxt -> [Name] -> Q [Either Exp Exp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Type -> Name -> Q (Either Exp Exp)
makeBiFunTupleField Cxt
tyArgs [Name]
xs)
                     )
                     []
             ]

      makeBiFunTupleField :: Type -> Name -> Q (Either Exp Exp)
      makeBiFunTupleField :: Type -> Name -> Q (Either Exp Exp)
makeBiFunTupleField fieldTy :: Type
fieldTy fieldName :: Name
fieldName =
        BiFun
-> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
makeBiFunForType BiFun
biFun Map Name Name
tvMap Name
conName Bool
covariant Type
fieldTy
          Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
`appEitherE` Name -> Q Exp
varE Name
fieldName

   in case Type
tyCon of
     ArrowT
       | Bool -> Bool
not (BiClass -> Bool
allowFunTys (BiFun -> BiClass
biFunToClass BiFun
biFun)) -> Name -> Q (Either Exp Exp)
forall a. Name -> a
noFunctionsError Name
conName
       | Bool
mentionsTyArgs, [argTy :: Type
argTy, resTy :: Type
resTy] <- Cxt
tyArgs ->
         do Name
x <- String -> Q Name
newName "x"
            Name
b <- String -> Q Name
newName "b"
            (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. b -> Either a b
Right (Q Exp -> Q (Either Exp Exp))
-> (Q Exp -> Q Exp) -> Q Exp -> Q (Either Exp Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x, Name -> PatQ
varP Name
b] (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$
              Bool -> Type -> Q Exp
covBiFun Bool
covariant Type
resTy Q Exp -> Q Exp -> Q Exp
`appE` (Name -> Q Exp
varE Name
x Q Exp -> Q Exp -> Q Exp
`appE`
                (Bool -> Type -> Q Exp
covBiFun (Bool -> Bool
not Bool
covariant) Type
argTy Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
b))
         where
           covBiFun :: Bool -> Type -> Q Exp
           covBiFun :: Bool -> Type -> Q Exp
covBiFun cov :: Bool
cov = (Either Exp Exp -> Exp) -> Q (Either Exp Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Exp Exp -> Exp
forall a. Either a a -> a
fromEither (Q (Either Exp Exp) -> Q Exp)
-> (Type -> Q (Either Exp Exp)) -> Type -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BiFun
-> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
makeBiFunForType BiFun
biFun Map Name Name
tvMap Name
conName Bool
cov
#if MIN_VERSION_template_haskell(2,6,0)
     UnboxedTupleT n :: Int
n
       | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Bool
mentionsTyArgs -> ([PatQ] -> PatQ) -> (Int -> Name) -> Int -> Q (Either Exp Exp)
makeBiFunTuple [PatQ] -> PatQ
unboxedTupP Int -> Name
unboxedTupleDataName Int
n
#endif
     TupleT n :: Int
n
       | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Bool
mentionsTyArgs -> ([PatQ] -> PatQ) -> (Int -> Name) -> Int -> Q (Either Exp Exp)
makeBiFunTuple [PatQ] -> PatQ
tupP Int -> Name
tupleDataName Int
n
     _ -> do
         Bool
itf <- Type -> Q Bool
isTyFamily Type
tyCon
         if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
lhsArgs Bool -> Bool -> Bool
|| (Bool
itf Bool -> Bool -> Bool
&& Bool
mentionsTyArgs)
           then Name -> Q (Either Exp Exp)
forall a. Name -> a
outOfPlaceTyVarError Name
conName
           else if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
                  then (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. b -> Either a b
Right (Q Exp -> Q (Either Exp Exp))
-> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q (Either Exp Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BiFun -> Q Exp -> Q Exp
biFunApp BiFun
biFun (Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q (Either Exp Exp)) -> [Q Exp] -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$
                         ( Name -> Q Exp
varE (Maybe Name -> Name
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Name -> Name) -> Maybe Name -> Name
forall a b. (a -> b) -> a -> b
$ BiFun -> Int -> Maybe Name
biFunArity BiFun
biFun Int
numLastArgs)
                         Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Type -> Q Exp) -> Cxt -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ((Either Exp Exp -> Exp) -> Q (Either Exp Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Exp Exp -> Exp
forall a. Either a a -> a
fromEither (Q (Either Exp Exp) -> Q Exp)
-> (Type -> Q (Either Exp Exp)) -> Type -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BiFun
-> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
makeBiFunForType BiFun
biFun Map Name Name
tvMap Name
conName Bool
covariant)
                                Cxt
rhsArgs
                         )
                  else (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. a -> Either a b
Left (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$ BiFun -> Q Exp
biFunTriv BiFun
biFun

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

-- For the given Types, generate an instance context and head. Coming up with
-- the instance type isn't as simple as dropping the last types, as you need to
-- be wary of kinds being instantiated with *.
-- See Note [Type inference in derived instances]
buildTypeInstance :: BiClass
                  -- ^ Bifunctor, Bifoldable, or Bitraversable
                  -> Name
                  -- ^ The type constructor or data family name
                  -> Cxt
                  -- ^ The datatype context
                  -> [Type]
                  -- ^ The types to instantiate the instance with
                  -> DatatypeVariant
                  -- ^ Are we dealing with a data family instance or not
                  -> Q (Cxt, Type)
buildTypeInstance :: BiClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance biClass :: BiClass
biClass tyConName :: Name
tyConName dataCxt :: Cxt
dataCxt instTysOrig :: Cxt
instTysOrig variant :: DatatypeVariant
variant = do
    -- Make sure to expand through type/kind synonyms! Otherwise, the
    -- eta-reduction check might get tripped up over type variables in a
    -- synonym that are actually dropped.
    -- (See GHC Trac #11416 for a scenario where this actually happened.)
    Cxt
varTysExp <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
instTysOrig

    let remainingLength :: Int
        remainingLength :: Int
remainingLength = Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTysOrig Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2

        droppedTysExp :: [Type]
        droppedTysExp :: Cxt
droppedTysExp = Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop Int
remainingLength Cxt
varTysExp

        droppedStarKindStati :: [StarKindStatus]
        droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = (Type -> StarKindStatus) -> Cxt -> [StarKindStatus]
forall a b. (a -> b) -> [a] -> [b]
map Type -> StarKindStatus
canRealizeKindStar Cxt
droppedTysExp

    -- Check there are enough types to drop and that all of them are either of
    -- kind * or kind k (for some kind variable k). If not, throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
remainingLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 Bool -> Bool -> Bool
|| (StarKindStatus -> Bool) -> [StarKindStatus] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (StarKindStatus -> StarKindStatus -> Bool
forall a. Eq a => a -> a -> Bool
== StarKindStatus
NotKindStar) [StarKindStatus]
droppedStarKindStati) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      BiClass -> Name -> Q ()
forall a. BiClass -> Name -> a
derivingKindError BiClass
biClass Name
tyConName

    let droppedKindVarNames :: [Name]
        droppedKindVarNames :: [Name]
droppedKindVarNames = [StarKindStatus] -> [Name]
catKindVarNames [StarKindStatus]
droppedStarKindStati

        -- Substitute kind * for any dropped kind variables
        varTysExpSubst :: [Type]
        varTysExpSubst :: Cxt
varTysExpSubst = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
droppedKindVarNames) Cxt
varTysExp

        remainingTysExpSubst, droppedTysExpSubst :: [Type]
        (remainingTysExpSubst :: Cxt
remainingTysExpSubst, droppedTysExpSubst :: Cxt
droppedTysExpSubst) =
          Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength Cxt
varTysExpSubst

        -- All of the type variables mentioned in the dropped types
        -- (post-synonym expansion)
        droppedTyVarNames :: [Name]
        droppedTyVarNames :: [Name]
droppedTyVarNames = Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Cxt
droppedTysExpSubst

    -- If any of the dropped types were polykinded, ensure that they are of kind *
    -- after substituting * for the dropped kind variables. If not, throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
hasKindStar Cxt
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      BiClass -> Name -> Q ()
forall a. BiClass -> Name -> a
derivingKindError BiClass
biClass Name
tyConName

    let preds    :: [Maybe Pred]
        kvNames  :: [[Name]]
        kvNames' :: [Name]
        -- Derive instance constraints (and any kind variables which are specialized
        -- to * in those constraints)
        (preds :: [Maybe Type]
preds, kvNames :: [[Name]]
kvNames) = [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe Type, [Name])] -> ([Maybe Type], [[Name]]))
-> [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
forall a b. (a -> b) -> a -> b
$ (Type -> (Maybe Type, [Name])) -> Cxt -> [(Maybe Type, [Name])]
forall a b. (a -> b) -> [a] -> [b]
map (BiClass -> Type -> (Maybe Type, [Name])
deriveConstraint BiClass
biClass) Cxt
remainingTysExpSubst
        kvNames' :: [Name]
kvNames' = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
kvNames

        -- Substitute the kind variables specialized in the constraints with *
        remainingTysExpSubst' :: [Type]
        remainingTysExpSubst' :: Cxt
remainingTysExpSubst' =
          (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
kvNames') Cxt
remainingTysExpSubst

        -- We now substitute all of the specialized-to-* kind variable names with
        -- *, but in the original types, not the synonym-expanded types. The reason
        -- we do this is a superficial one: we want the derived instance to resemble
        -- the datatype written in source code as closely as possible. For example,
        -- for the following data family instance:
        --
        --   data family Fam a
        --   newtype instance Fam String = Fam String
        --
        -- We'd want to generate the instance:
        --
        --   instance C (Fam String)
        --
        -- Not:
        --
        --   instance C (Fam [Char])
        remainingTysOrigSubst :: [Type]
        remainingTysOrigSubst :: Cxt
remainingTysOrigSubst =
          (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar ([Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
union [Name]
droppedKindVarNames [Name]
kvNames'))
            (Cxt -> Cxt) -> Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
take Int
remainingLength Cxt
instTysOrig

        isDataFamily :: Bool
        isDataFamily :: Bool
isDataFamily = case DatatypeVariant
variant of
                         Datatype        -> Bool
False
                         Newtype         -> Bool
False
                         DataInstance    -> Bool
True
                         NewtypeInstance -> Bool
True

        remainingTysOrigSubst' :: [Type]
        -- See Note [Kind signatures in derived instances] for an explanation
        -- of the isDataFamily check.
        remainingTysOrigSubst' :: Cxt
remainingTysOrigSubst' =
          if Bool
isDataFamily
             then Cxt
remainingTysOrigSubst
             else (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
unSigT Cxt
remainingTysOrigSubst

        instanceCxt :: Cxt
        instanceCxt :: Cxt
instanceCxt = [Maybe Type] -> Cxt
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
preds

        instanceType :: Type
        instanceType :: Type
instanceType = Type -> Type -> Type
AppT (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ BiClass -> Name
biClassName BiClass
biClass)
                     (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Type
applyTyCon Name
tyConName Cxt
remainingTysOrigSubst'

    -- If the datatype context mentions any of the dropped type variables,
    -- we can't derive an instance, so throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` [Name]
droppedTyVarNames) Cxt
dataCxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Name -> Type -> Q ()
forall a. Name -> Type -> a
datatypeContextError Name
tyConName Type
instanceType
    -- Also ensure the dropped types can be safely eta-reduced. Otherwise,
    -- throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Cxt -> Cxt -> Bool
canEtaReduce Cxt
remainingTysExpSubst' Cxt
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Type -> Q ()
forall a. Type -> a
etaReductionError Type
instanceType
    (Cxt, Type) -> Q (Cxt, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt
instanceCxt, Type
instanceType)

-- | Attempt to derive a constraint on a Type. If successful, return
-- Just the constraint and any kind variable names constrained to *.
-- Otherwise, return Nothing and the empty list.
--
-- See Note [Type inference in derived instances] for the heuristics used to
-- come up with constraints.
deriveConstraint :: BiClass -> Type -> (Maybe Pred, [Name])
deriveConstraint :: BiClass -> Type -> (Maybe Type, [Name])
deriveConstraint biClass :: BiClass
biClass t :: Type
t
  | Bool -> Bool
not (Type -> Bool
isTyVar Type
t) = (Maybe Type
forall a. Maybe a
Nothing, [])
  | Bool
otherwise = case Int -> Type -> Maybe [Name]
hasKindVarChain 1 Type
t of
      Just ns :: [Name]
ns -> ((Name -> Name -> Type
`applyClass` Name
tName) (Name -> Type) -> Maybe Name -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` BiClass -> Int -> Maybe Name
biClassConstraint BiClass
biClass 1, [Name]
ns)
      _ -> case Int -> Type -> Maybe [Name]
hasKindVarChain 2 Type
t of
                Just ns :: [Name]
ns -> ((Name -> Name -> Type
`applyClass` Name
tName) (Name -> Type) -> Maybe Name -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` BiClass -> Int -> Maybe Name
biClassConstraint BiClass
biClass 2, [Name]
ns)
                _       -> (Maybe Type
forall a. Maybe a
Nothing, [])
  where
    tName :: Name
    tName :: Name
tName = Type -> Name
varTToName Type
t

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

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

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

But it is preferable to avoid this if possible. If we come up with an incorrect
kind signature (which is entirely possible, since our type inferencer is pretty
unsophisticated - see Note [Type inference in derived instances]), then GHC will
flat-out reject the instance, which is quite unfortunate.

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

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

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

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

Note [Type inference in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Type inference is can be tricky to get right, and we want to avoid recreating the
entirety of GHC's type inferencer in Template Haskell. For this reason, we will
probably never come up with derived instance contexts that are as accurate as
GHC's. But that doesn't mean we can't do anything! There are a couple of simple
things we can do to make instance contexts that work for 80% of use cases:

1. If one of the last type parameters is polykinded, then its kind will be
   specialized to * in the derived instance. We note what kind variable the type
   parameter had and substitute it with * in the other types as well. For example,
   imagine you had

     data Data (a :: k) (b :: k) (c :: k)

   Then you'd want to derived instance to be:

     instance C (Data (a :: *))

   Not:

     instance C (Data (a :: k))

2. We naïvely come up with instance constraints using the following criteria:

   (i)  If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind
        variables), then generate a Functor n constraint, and if k1/k2 are kind
        variables, then substitute k1/k2 with * elsewhere in the types. We must
        consider the case where they are kind variables because you might have a
        scenario like this:

          newtype Compose (f :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2)
            = Compose (f (g a b))

        Which would have a derived Bifunctor instance of:

          instance (Functor f, Bifunctor g) => Bifunctor (Compose f g) where ...
   (ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are
        * or kind variables), then generate a Bifunctor n constraint and perform
        kind substitution as in the other case.
-}

{-
Note [Matching functions with GADT type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When deriving Bifoldable, there is a tricky corner case to consider:

  data Both a b where
    BothCon :: x -> x -> Both x x

Which fold functions should be applied to which arguments of BothCon? We have a
choice, since both the function of type (a -> m) and of type (b -> m) can be
applied to either argument. In such a scenario, the second fold function takes
precedence over the first fold function, so the derived Bifoldable instance would be:

  instance Bifoldable Both where
    bifoldMap _ g (BothCon x1 x2) = g x1 <> g x2

This is not an arbitrary choice, as this definition ensures that
bifoldMap id = Foldable.foldMap for a derived Bifoldable instance for Both.
-}

-------------------------------------------------------------------------------
-- 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 -> Name -> a
derivingKindError biClass :: BiClass
biClass tyConName :: Name
tyConName = String -> a
forall a. HasCallStack => String -> a
error
  (String -> a) -> ShowS -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "Cannot derive well-kinded instance of form ‘"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
className
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar ' '
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowS -> ShowS
showParen Bool
True
    ( String -> ShowS
showString (Name -> String
nameBase Name
tyConName)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " ..."
    )
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "‘\n\tClass "
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
className
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " expects an argument of kind * -> * -> *"
  (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ ""
  where
    className :: String
    className :: String
className = Name -> String
nameBase (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ BiClass -> Name
biClassName BiClass
biClass

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

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

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

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

-- | 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 -> a
outOfPlaceTyVarError :: Name -> a
outOfPlaceTyVarError conName :: Name
conName = String -> a
forall a. HasCallStack => String -> a
error
  (String -> a) -> ShowS -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "Constructor ‘"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "‘ must only use its last two type variable(s) within"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " the last two argument(s) of a data type"
  (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ ""

-- | 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 :: Type -> a
etaReductionError instanceType :: Type
instanceType = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
  "Cannot eta-reduce to an instance of form \n\tinstance (...) => "
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
instanceType

-------------------------------------------------------------------------------
-- 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 BiFun -> BiFun -> Bool
(BiFun -> BiFun -> Bool) -> (BiFun -> BiFun -> Bool) -> Eq BiFun
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BiFun -> BiFun -> Bool
$c/= :: BiFun -> BiFun -> Bool
== :: BiFun -> BiFun -> Bool
$c== :: BiFun -> BiFun -> Bool
Eq

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

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

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

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

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

biClassConstraint :: BiClass -> Int -> Maybe Name
biClassConstraint :: BiClass -> Int -> Maybe Name
biClassConstraint Bifunctor     1 = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
functorTypeName
biClassConstraint Bifoldable    1 = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
foldableTypeName
biClassConstraint Bitraversable 1 = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
traversableTypeName
biClassConstraint biClass :: BiClass
biClass       2 = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ BiClass -> Name
biClassName BiClass
biClass
biClassConstraint _             _ = Maybe Name
forall a. Maybe a
Nothing

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

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

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

-- See Trac #7436 for why explicit lambdas are used
biFunTriv :: BiFun -> Q Exp
biFunTriv :: BiFun -> Q Exp
biFunTriv Bimap = do
  Name
x <- String -> Q Name
newName "x"
  [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
x
-- The biFunTriv definitions for bifoldr, bifoldMap, and bitraverse might seem
-- useless, but they do serve a purpose.
-- See Note [biFunTriv for Bifoldable and Bitraversable]
biFunTriv Bifoldr = do
  Name
z <- String -> Q Name
newName "z"
  [PatQ] -> Q Exp -> Q Exp
lamE [PatQ
wildP, Name -> PatQ
varP Name
z] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
z
biFunTriv BifoldMap = [PatQ] -> Q Exp -> Q Exp
lamE [PatQ
wildP] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
memptyValName
biFunTriv Bitraverse = Name -> Q Exp
varE Name
pureValName

biFunApp :: BiFun -> Q Exp -> Q Exp
biFunApp :: BiFun -> Q Exp -> Q Exp
biFunApp Bifoldr e :: Q Exp
e = do
  Name
x <- String -> Q Name
newName "x"
  Name
z <- String -> Q Name
newName "z"
  [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x, Name -> PatQ
varP Name
z] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
appsE [Q Exp
e, Name -> Q Exp
varE Name
z, Name -> Q Exp
varE Name
x]
biFunApp _ e :: Q Exp
e = Q Exp
e

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

bimapCombine :: Name
             -> Name
             -> [Name]
             -> Q [Either Exp Exp]
             -> Q Exp
bimapCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
bimapCombine conName :: Name
conName _ _ = ([Either Exp Exp] -> Exp) -> Q [Either Exp Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
conName) ([Exp] -> Exp)
-> ([Either Exp Exp] -> [Exp]) -> [Either Exp Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Exp Exp -> Exp) -> [Either Exp Exp] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Exp Exp -> Exp
forall a. Either a a -> a
fromEither)

-- bifoldr, bifoldMap, and bitraverse are handled differently from bimap, since
-- they filter out subexpressions whose types do not mention one of the last two
-- type parameters. See
-- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor#AlternativestrategyforderivingFoldableandTraversable
-- for further discussion.

bifoldrCombine :: Name
               -> Name
               -> [Name]
               -> Q [Either Exp Exp]
               -> Q Exp
bifoldrCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
bifoldrCombine _ zName :: Name
zName _ = ([Either Exp Exp] -> Exp) -> Q [Either Exp Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
zName) ([Exp] -> Exp)
-> ([Either Exp Exp] -> [Exp]) -> [Either Exp Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Exp Exp] -> [Exp]
forall a b. [Either a b] -> [b]
rights)

bifoldMapCombine :: Name
                 -> Name
                 -> [Name]
                 -> Q [Either Exp Exp]
                 -> Q Exp
bifoldMapCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
bifoldMapCombine _ _ _ = ([Either Exp Exp] -> Exp) -> Q [Either Exp Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Exp] -> Exp
go ([Exp] -> Exp)
-> ([Either Exp Exp] -> [Exp]) -> [Either Exp Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Exp Exp] -> [Exp]
forall a b. [Either a b] -> [b]
rights)
  where
    go :: [Exp] -> Exp
    go :: [Exp] -> Exp
go [] = Name -> Exp
VarE Name
memptyValName
    go es :: [Exp]
es = (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
mappendValName)) [Exp]
es

bitraverseCombine :: Name
                  -> Name
                  -> [Name]
                  -> Q [Either Exp Exp]
                  -> Q Exp
bitraverseCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
bitraverseCombine conName :: Name
conName _ args :: [Name]
args essQ :: Q [Either Exp Exp]
essQ = do
    [Either Exp Exp]
ess <- Q [Either Exp Exp]
essQ

    let argTysTyVarInfo :: [Bool]
        argTysTyVarInfo :: [Bool]
argTysTyVarInfo = (Either Exp Exp -> Bool) -> [Either Exp Exp] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Either Exp Exp -> Bool
forall l r. Either l r -> Bool
isRight [Either Exp Exp]
ess

        argsWithTyVar, argsWithoutTyVar :: [Name]
        (argsWithTyVar :: [Name]
argsWithTyVar, argsWithoutTyVar :: [Name]
argsWithoutTyVar) = [Bool] -> [Name] -> ([Name], [Name])
forall a. [Bool] -> [a] -> ([a], [a])
partitionByList [Bool]
argTysTyVarInfo [Name]
args

        conExpQ :: Q Exp
        conExpQ :: Q Exp
conExpQ
          | [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
argsWithTyVar
          = [Q Exp] -> Q Exp
appsE (Name -> Q Exp
conE Name
conNameQ Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:(Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
argsWithoutTyVar)
          | Bool
otherwise = do
              [Name]
bs <- String -> Int -> Q [Name]
newNameList "b" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
args
              let bs' :: [Name]
bs'  = [Bool] -> [Name] -> [Name]
forall a. [Bool] -> [a] -> [a]
filterByList  [Bool]
argTysTyVarInfo [Name]
bs
                  vars :: [Q Exp]
vars = [Bool] -> [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
argTysTyVarInfo
                                       ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
bs) ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
args)
              [PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
bs') ([Q Exp] -> Q Exp
appsE (Name -> Q Exp
conE Name
conNameQ Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:[Q Exp]
vars))

    Exp
conExp <- Q Exp
conExpQ

    let go :: [Exp] -> Exp
        go :: [Exp] -> Exp
go []  = Name -> Exp
VarE Name
pureValName Exp -> Exp -> Exp
`AppE` Exp
conExp
        go [e :: Exp
e] = Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Exp
conExp Exp -> Exp -> Exp
`AppE` Exp
e
        go (e1 :: Exp
e1:e2 :: Exp
e2:es :: [Exp]
es) = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\se1 :: Exp
se1 se2 :: Exp
se2 -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
se1) (Name -> Exp
VarE Name
apValName) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
se2))
          (Name -> Exp
VarE Name
liftA2ValName Exp -> Exp -> Exp
`AppE` Exp
conExp Exp -> Exp -> Exp
`AppE` Exp
e1 Exp -> Exp -> Exp
`AppE` Exp
e2) [Exp]
es

    Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp)
-> ([Either Exp Exp] -> Exp) -> [Either Exp Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
go ([Exp] -> Exp)
-> ([Either Exp Exp] -> [Exp]) -> [Either Exp Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Exp Exp] -> [Exp]
forall a b. [Either a b] -> [b]
rights ([Either Exp Exp] -> Q Exp) -> [Either Exp Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Either Exp Exp]
ess

biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp
biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp
biFunEmptyCase biFun :: BiFun
biFun z :: Name
z value :: Name
value =
    Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial Q Exp
emptyCase
                 (Name -> Q Exp
varE Name
pureValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
emptyCase)
                 BiFun
biFun Name
z
  where
    emptyCase :: Q Exp
    emptyCase :: Q Exp
emptyCase = Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value) []

biFunNoCons :: BiFun -> Name -> Name -> Q Exp
biFunNoCons :: BiFun -> Name -> Name -> Q Exp
biFunNoCons biFun :: BiFun
biFun z :: Name
z value :: Name
value =
    Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial Q Exp
seqAndError
                 (Name -> Q Exp
varE Name
pureValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
seqAndError)
                 BiFun
biFun Name
z
  where
    seqAndError :: Q Exp
    seqAndError :: Q Exp
seqAndError = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
seqValName) (Name -> Q Exp
varE Name
value) Q Exp -> Q Exp -> Q Exp
`appE`
                  Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
errorValName)
                        (String -> Q Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "Void " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (BiFun -> Name
biFunName BiFun
biFun))

biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial bimapE :: Q Exp
bimapE bitraverseE :: Q Exp
bitraverseE biFun :: BiFun
biFun z :: Name
z = BiFun -> Q Exp
go BiFun
biFun
  where
    go :: BiFun -> Q Exp
    go :: BiFun -> Q Exp
go Bimap      = Q Exp
bimapE
    go Bifoldr    = Name -> Q Exp
varE Name
z
    go BifoldMap  = Name -> Q Exp
varE Name
memptyValName
    go Bitraverse = Q Exp
bitraverseE

{-
Note [biFunTriv for Bifoldable and Bitraversable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When deriving Bifoldable and Bitraversable, we filter out any subexpressions whose
type does not mention one of the last two type parameters. From this, you might
think that we don't need to implement biFunTriv for bifoldr, bifoldMap, or
bitraverse at all, but in fact we do need to. Imagine the following data type:

    data T a b = MkT a (T Int b)

In a derived Bifoldable T instance, you would generate the following bifoldMap
definition:

    bifoldMap f g (MkT a1 a2) = f a1 <> bifoldMap (\_ -> mempty) g arg2

You need to fill in biFunTriv (\_ -> mempty) as the first argument to the recursive
call to bifoldMap, since that is how the algorithm handles polymorphic recursion.
-}