{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Unsafe #-}
-----------------------------------------------------------------------------
-- |
-- 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)

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

import           Language.Haskell.TH.Datatype as Datatype
import           Language.Haskell.TH.Datatype.TyVarBndr
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.
  } deriving (Options -> Options -> Bool
(Options -> Options -> Bool)
-> (Options -> Options -> Bool) -> Eq Options
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Options -> Options -> Bool
== :: Options -> Options -> Bool
$c/= :: Options -> Options -> Bool
/= :: 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
$ccompare :: Options -> Options -> Ordering
compare :: Options -> Options -> Ordering
$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
>= :: Options -> Options -> Bool
$cmax :: Options -> Options -> Options
max :: Options -> Options -> Options
$cmin :: Options -> Options -> Options
min :: Options -> Options -> 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
$creadsPrec :: Int -> ReadS Options
readsPrec :: Int -> ReadS Options
$creadList :: ReadS [Options]
readList :: ReadS [Options]
$creadPrec :: ReadPrec Options
readPrec :: ReadPrec Options
$creadListPrec :: ReadPrec [Options]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> Options -> ShowS
showsPrec :: Int -> Options -> ShowS
$cshow :: Options -> String
show :: Options -> String
$cshowList :: [Options] -> ShowS
showList :: [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 { 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 Options
opts Name
name = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ Options -> Name -> Q Exp
makeBifoldMapOptions Options
opts Name
name
                                    , Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
idValName
                                    , Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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 Options
opts Name
name = do
  Name
f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
  Name
g <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"g"
  Name
z <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
  Name
t <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
  [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
g, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
z, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
    [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
appEndoValName
          , [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
getDualValName
                  , [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m 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
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t]
                  ]
          , Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z
          ]
  where
    foldFun :: Name -> Q Exp
    foldFun :: Name -> Q Exp
foldFun Name
n = Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
dualDataName)
                         (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
                         (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
endoDataName)
                                   (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
                                   (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
flipValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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 Options
opts Name
name = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ Options -> Name -> Q Exp
makeBitraverseOptions Options
opts Name
name
                                         , Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
idValName
                                         , Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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 Options
opts Name
name = do
  Name
f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
  Name
g <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"g"
  [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unwrapMonadValName) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
                          [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m 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 Name
n = Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
wrapMonadDataName) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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 Options
opts Name
name = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ Options -> Name -> Q Exp
makeBimapMOptions Options
opts Name
name
                                        , Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
idValName
                                        , Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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 Options
opts Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case DatatypeInfo
info of
    DatatypeInfo { datatypeContext :: DatatypeInfo -> [Type]
datatypeContext   = [Type]
ctxt
                 , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
parentName
                 , datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTys
                 , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
                 , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                 } -> do
      ([Type]
instanceCxt, Type
instanceType)
          <- BiClass
-> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
buildTypeInstance BiClass
biClass Name
parentName [Type]
ctxt [Type]
instTys DatatypeVariant
variant
      (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
instanceCxt)
                             (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
                             (BiClass
-> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
biFunDecs BiClass
biClass Options
opts Name
parentName [Type]
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 -> [Type] -> [ConstructorInfo] -> [Q Dec]
biFunDecs BiClass
biClass Options
opts Name
parentName [Type]
instTys [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 =
      Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (BiFun -> Name
biFunName BiFun
biFun)
           [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
                    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
makeBiFunForCons BiFun
biFun Options
opts Name
parentName [Type]
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 Options
opts Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case DatatypeInfo
info of
    DatatypeInfo { datatypeContext :: DatatypeInfo -> [Type]
datatypeContext   = [Type]
ctxt
                 , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
parentName
                 , datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
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 -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
buildTypeInstance (BiFun -> BiClass
biFunToClass BiFun
biFun) Name
parentName [Type]
ctxt [Type]
instTys DatatypeVariant
variant
        Q ([Type], Type) -> Q Exp -> Q Exp
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
makeBiFunForCons BiFun
biFun Options
opts Name
parentName [Type]
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 -> [Type] -> [ConstructorInfo] -> Q Exp
makeBiFunForCons BiFun
biFun Options
opts Name
_parentName [Type]
instTys [ConstructorInfo]
cons = do
  Name
map1  <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
  Name
map2  <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"g"
  Name
z     <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"z" -- Only used for deriving bifoldr
  Name
value <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"value"
  let argNames :: [Name]
argNames   = [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
catMaybes [ Name -> Maybe Name
forall a. a -> Maybe a
Just Name
map1
                             , Name -> Maybe Name
forall a. a -> Maybe a
Just Name
map2
                             , 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 Name -> Maybe Name
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
z
                             , Name -> Maybe Name
forall a. a -> Maybe a
Just Name
value
                             ]
      lastTyVars :: [Name]
lastTyVars = (Type -> Name) -> [Type] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName ([Type] -> [Name]) -> [Type] -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
instTys Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) [Type]
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]
  [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
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
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
      ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
argNames
  where
    makeFun :: Name -> Name -> TyVarMap -> Q Exp
    makeFun :: Name -> Name -> Map Name Name -> Q Exp
makeFun Name
z Name
value Map Name Name
tvMap = do
      [Role]
roles <- Name -> Q [Role]
reifyRoles Name
_parentName
      case () of
        ()
_ | Just ([Role]
rs, Role
PhantomR) <- [Role] -> Maybe ([Role], Role)
forall a. [a] -> Maybe ([a], a)
unsnoc [Role]
roles
          , Just ([Role]
_,  Role
PhantomR) <- [Role] -> Maybe ([Role], Role)
forall a. [a] -> Maybe ([a], a)
unsnoc [Role]
rs
         -> Name -> Name -> Q Exp
biFunPhantom Name
z Name
value

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

          | [ConstructorInfo] -> Bool
forall a. [a] -> 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 -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value)
                  ((ConstructorInfo -> Q Match) -> [ConstructorInfo] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map (BiFun -> Name -> Map Name Name -> ConstructorInfo -> Q Match
makeBiFunForCon BiFun
biFun Name
z Map Name Name
tvMap) [ConstructorInfo]
cons)

    biFunPhantom :: Name -> Name -> Q Exp
    biFunPhantom :: Name -> Name -> Q Exp
biFunPhantom Name
z Name
value =
        Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial Q Exp
coerce
                     (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
coerce)
                     BiFun
biFun Name
z
      where
        coerce :: Q Exp
        coerce :: Q Exp
coerce = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
coerceValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value

-- | Generates a match for a single constructor.
makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match
makeBiFunForCon :: BiFun -> Name -> Map Name Name -> ConstructorInfo -> Q Match
makeBiFunForCon BiFun
biFun Name
z Map Name Name
tvMap
  con :: ConstructorInfo
con@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                       , constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
ctxt }) = do
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (((Type -> Bool) -> [Type] -> 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) [Type]
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
< Int
2)
             Bool -> Bool -> Bool
&& Bool -> Bool
not (BiClass -> Bool
allowExQuant (BiFun -> BiClass
biFunToClass BiFun
biFun))) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Name -> Q ()
forall a. Name -> Q a
existentialContextError Name
conName
    case BiFun
biFun of
      BiFun
Bimap      -> Map Name Name -> ConstructorInfo -> Q Match
makeBimapMatch Map Name Name
tvMap ConstructorInfo
con
      BiFun
Bifoldr    -> Name -> Map Name Name -> ConstructorInfo -> Q Match
makeBifoldrMatch Name
z Map Name Name
tvMap ConstructorInfo
con
      BiFun
BifoldMap  -> Map Name Name -> ConstructorInfo -> Q Match
makeBifoldMapMatch Map Name Name
tvMap ConstructorInfo
con
      BiFun
Bitraverse -> Map Name Name -> ConstructorInfo -> Q Match
makeBitraverseMatch Map Name Name
tvMap ConstructorInfo
con

-- | Generates a match whose right-hand side implements @bimap@.
makeBimapMatch :: TyVarMap -> ConstructorInfo -> Q Match
makeBimapMatch :: Map Name Name -> ConstructorInfo -> Q Match
makeBimapMatch Map Name Name
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Exp -> Q Exp]
parts <- Map Name Name
-> FFoldType (Exp -> Q Exp) -> ConstructorInfo -> Q [Exp -> Q Exp]
forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name Name
tvMap FFoldType (Exp -> Q Exp)
ft_bimap ConstructorInfo
con
  Name -> [Exp -> Q Exp] -> Q Match
match_for_con Name
conName [Exp -> Q Exp]
parts
  where
    ft_bimap :: FFoldType (Exp -> Q Exp)
    ft_bimap :: FFoldType (Exp -> Q Exp)
ft_bimap = FT { ft_triv :: Exp -> Q Exp
ft_triv = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
                  , ft_var :: Name -> Exp -> Q Exp
ft_var  = \Name
v Exp
x -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE (Map Name Name
tvMap Map Name Name -> Name -> Name
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v) Exp -> Exp -> Exp
`AppE` Exp
x
                  , ft_fun :: (Exp -> Q Exp) -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_fun  = \Exp -> Q Exp
g Exp -> Q Exp
h Exp
x -> (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
b -> do
                      Exp
gg <- Exp -> Q Exp
g Exp
b
                      Exp -> Q Exp
h (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
x Exp -> Exp -> Exp
`AppE` Exp
gg
                  , ft_tup :: TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
ft_tup  = (Name -> [Exp -> Q Exp] -> Q Match)
-> TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [Exp -> Q Exp] -> Q Match
match_for_con
                  , ft_ty_app :: [(Type, Exp -> Q Exp)] -> Exp -> Q Exp
ft_ty_app = \[(Type, Exp -> Q Exp)]
argGs Exp
x -> do
                      let inspect :: (Type, Exp -> Q Exp) -> Q Exp
                          inspect :: (Type, Exp -> Q Exp) -> Q Exp
inspect (Type
argTy, Exp -> Q Exp
g)
                            -- If the argument type is a bare occurrence of one
                            -- of the data type's last type variables, then we
                            -- can generate more efficient code.
                            -- This was inspired by GHC#17880.
                            | Just Name
argVar <- Type -> Maybe Name
varTToName_maybe Type
argTy
                            , Just Name
f <- Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
argVar Map Name Name
tvMap
                            = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
f
                            | Bool
otherwise
                            = (Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
g
                      [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Int -> Name
fmapArity ([(Type, Exp -> Q Exp)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Exp -> Q Exp)]
argGs))
                            Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Type, Exp -> Q Exp) -> Q Exp)
-> [(Type, Exp -> Q Exp)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Exp -> Q Exp) -> Q Exp
inspect [(Type, Exp -> Q Exp)]
argGs
                           [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ [Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x]
                  , ft_forall :: [TyVarBndrSpec] -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_forall  = \[TyVarBndrSpec]
_ Exp -> Q Exp
g Exp
x -> Exp -> Q Exp
g Exp
x
                  , ft_bad_app :: Exp -> Q Exp
ft_bad_app = \Exp
_ -> Name -> Q Exp
forall a. Name -> Q a
outOfPlaceTyVarError Name
conName
                  , ft_co_var :: Name -> Exp -> Q Exp
ft_co_var  = \Name
_ Exp
_ -> Name -> Q Exp
forall a. Name -> Q a
contravarianceError Name
conName
                  }

    -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
    match_for_con :: Name -> [Exp -> Q Exp] -> Q Match
    match_for_con :: Name -> [Exp -> Q Exp] -> Q Match
match_for_con = (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> Q Match
forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> Q Match
mkSimpleConMatch ((Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> Q Match)
-> (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> Q Match
forall a b. (a -> b) -> a -> b
$ \Name
conName' [Q Exp]
xs ->
       [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName'Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:[Q Exp]
xs) -- Con x1 x2 ..

-- | Generates a match whose right-hand side implements @bifoldr@.
makeBifoldrMatch :: Name -> TyVarMap -> ConstructorInfo -> Q Match
makeBifoldrMatch :: Name -> Map Name Name -> ConstructorInfo -> Q Match
makeBifoldrMatch Name
z Map Name Name
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Q (Bool, Exp)]
parts  <- Map Name Name
-> FFoldType (Q (Bool, Exp))
-> ConstructorInfo
-> Q [Q (Bool, Exp)]
forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name Name
tvMap FFoldType (Q (Bool, Exp))
ft_bifoldr ConstructorInfo
con
  [(Bool, Exp)]
parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q (Bool, Exp)]
parts
  Exp -> Name -> [(Bool, Exp)] -> Q Match
match_for_con (Name -> Exp
VarE Name
z) Name
conName [(Bool, Exp)]
parts'
  where
    -- The Bool is True if the type mentions of the last two type parameters,
    -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter
    -- out expressions that do not mention the last parameters by checking for
    -- False.
    ft_bifoldr :: FFoldType (Q (Bool, Exp))
    ft_bifoldr :: FFoldType (Q (Bool, Exp))
ft_bifoldr = FT { -- See Note [ft_triv for Bifoldable and Bitraversable]
                      ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
_ Exp
z' -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
z'
                                   (Bool, Exp) -> Q (Bool, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Exp
lam)
                    , ft_var :: Name -> Q (Bool, Exp)
ft_var  = \Name
v -> (Bool, Exp) -> Q (Bool, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Map Name Name
tvMap Map Name Name -> Name -> Name
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v)
                    , ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
ft_tup  = \TupleSort
t [Q (Bool, Exp)]
gs -> do
                        [(Bool, Exp)]
gg  <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q (Bool, Exp)]
gs
                        Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
x Exp
z' ->
                          (Name -> [(Bool, Exp)] -> Q Match)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase (Exp -> Name -> [(Bool, Exp)] -> Q Match
match_for_con Exp
z') TupleSort
t [(Bool, Exp)]
gg Exp
x
                        (Bool, Exp) -> Q (Bool, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
lam)
                    , ft_ty_app :: [(Type, Q (Bool, Exp))] -> Q (Bool, Exp)
ft_ty_app = \[(Type, Q (Bool, Exp))]
gs -> do
                        Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
x Exp
z' ->
                                 [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Int -> Name
foldrArity ([(Type, Q (Bool, Exp))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Q (Bool, Exp))]
gs))
                                       Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Type, Q (Bool, Exp)) -> Q Exp)
-> [(Type, Q (Bool, Exp))] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(Type
_, Q (Bool, Exp)
hs) -> ((Bool, Exp) -> Exp) -> Q (Bool, Exp) -> Q Exp
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, Exp) -> Exp
forall a b. (a, b) -> b
snd Q (Bool, Exp)
hs) [(Type, Q (Bool, Exp))]
gs
                                      [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Exp -> Q Exp) -> [Exp] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Exp
z', Exp
x]
                        (Bool, Exp) -> Q (Bool, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
lam)
                    , ft_forall :: [TyVarBndrSpec] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall  = \[TyVarBndrSpec]
_ Q (Bool, Exp)
g -> Q (Bool, Exp)
g
                    , ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var  = \Name
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
contravarianceError Name
conName
                    , ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_fun     = \Q (Bool, Exp)
_ Q (Bool, Exp)
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
                    , ft_bad_app :: Q (Bool, Exp)
ft_bad_app = Name -> Q (Bool, Exp)
forall a. Name -> Q a
outOfPlaceTyVarError Name
conName
                    }

    match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match
    match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match
match_for_con Exp
zExp = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkBifoldr [Exp]
xs
      where
        -- g1 v1 (g2 v2 (.. z))
        mkBifoldr :: [Exp] -> Exp
        mkBifoldr :: [Exp] -> Exp
mkBifoldr = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp -> Exp -> Exp
AppE Exp
zExp

-- | Generates a match whose right-hand side implements @bifoldMap@.
makeBifoldMapMatch :: TyVarMap -> ConstructorInfo -> Q Match
makeBifoldMapMatch :: Map Name Name -> ConstructorInfo -> Q Match
makeBifoldMapMatch Map Name Name
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Q (Bool, Exp)]
parts  <- Map Name Name
-> FFoldType (Q (Bool, Exp))
-> ConstructorInfo
-> Q [Q (Bool, Exp)]
forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name Name
tvMap FFoldType (Q (Bool, Exp))
ft_bifoldMap ConstructorInfo
con
  [(Bool, Exp)]
parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q (Bool, Exp)]
parts
  Name -> [(Bool, Exp)] -> Q Match
match_for_con Name
conName [(Bool, Exp)]
parts'
  where
    -- The Bool is True if the type mentions of the last two type parameters,
    -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter
    -- out expressions that do not mention the last parameters by checking for
    -- False.
    ft_bifoldMap :: FFoldType (Q (Bool, Exp))
    ft_bifoldMap :: FFoldType (Q (Bool, Exp))
ft_bifoldMap = FT { -- See Note [ft_triv for Bifoldable and Bitraversable]
                        ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
_ -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
memptyValName
                                     (Bool, Exp) -> Q (Bool, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Exp
lam)
                      , ft_var :: Name -> Q (Bool, Exp)
ft_var  = \Name
v -> (Bool, Exp) -> Q (Bool, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Map Name Name
tvMap Map Name Name -> Name -> Name
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v)
                      , ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
ft_tup  = \TupleSort
t [Q (Bool, Exp)]
gs -> do
                          [(Bool, Exp)]
gg  <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q (Bool, Exp)]
gs
                          Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> [(Bool, Exp)] -> Q Match)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> Q Match
match_for_con TupleSort
t [(Bool, Exp)]
gg
                          (Bool, Exp) -> Q (Bool, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
lam)
                      , ft_ty_app :: [(Type, Q (Bool, Exp))] -> Q (Bool, Exp)
ft_ty_app = \[(Type, Q (Bool, Exp))]
gs -> do
                          Exp
e <- [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Int -> Name
foldMapArity ([(Type, Q (Bool, Exp))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Q (Bool, Exp))]
gs))
                                     Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Type, Q (Bool, Exp)) -> Q Exp)
-> [(Type, Q (Bool, Exp))] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(Type
_, Q (Bool, Exp)
hs) -> ((Bool, Exp) -> Exp) -> Q (Bool, Exp) -> Q Exp
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, Exp) -> Exp
forall a b. (a, b) -> b
snd Q (Bool, Exp)
hs) [(Type, Q (Bool, Exp))]
gs
                          (Bool, Exp) -> Q (Bool, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
e)
                      , ft_forall :: [TyVarBndrSpec] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall  = \[TyVarBndrSpec]
_ Q (Bool, Exp)
g -> Q (Bool, Exp)
g
                      , ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var  = \Name
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
contravarianceError Name
conName
                      , ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_fun     = \Q (Bool, Exp)
_ Q (Bool, Exp)
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
                      , ft_bad_app :: Q (Bool, Exp)
ft_bad_app = Name -> Q (Bool, Exp)
forall a. Name -> Q a
outOfPlaceTyVarError Name
conName
                      }

    match_for_con :: Name -> [(Bool, Exp)] -> Q Match
    match_for_con :: Name -> [(Bool, Exp)] -> Q Match
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkBifoldMap [Exp]
xs
      where
        -- mappend v1 (mappend v2 ..)
        mkBifoldMap :: [Exp] -> Exp
        mkBifoldMap :: [Exp] -> Exp
mkBifoldMap [] = Name -> Exp
VarE Name
memptyValName
        mkBifoldMap [Exp]
es = (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall a. (a -> a -> a) -> [a] -> a
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

-- | Generates a match whose right-hand side implements @bitraverse@.
makeBitraverseMatch :: TyVarMap -> ConstructorInfo -> Q Match
makeBitraverseMatch :: Map Name Name -> ConstructorInfo -> Q Match
makeBitraverseMatch Map Name Name
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Q (Bool, Exp)]
parts  <- Map Name Name
-> FFoldType (Q (Bool, Exp))
-> ConstructorInfo
-> Q [Q (Bool, Exp)]
forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name Name
tvMap FFoldType (Q (Bool, Exp))
ft_bitrav ConstructorInfo
con
  [(Bool, Exp)]
parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q (Bool, Exp)]
parts
  Name -> [(Bool, Exp)] -> Q Match
match_for_con Name
conName [(Bool, Exp)]
parts'
  where
    -- The Bool is True if the type mentions of the last two type parameters,
    -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter
    -- out expressions that do not mention the last parameters by checking for
    -- False.
    ft_bitrav :: FFoldType (Q (Bool, Exp))
    ft_bitrav :: FFoldType (Q (Bool, Exp))
ft_bitrav = FT { -- See Note [ft_triv for Bifoldable and Bitraversable]
                     ft_triv :: Q (Bool, Exp)
ft_triv = (Bool, Exp) -> Q (Bool, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Name -> Exp
VarE Name
pureValName)
                   , ft_var :: Name -> Q (Bool, Exp)
ft_var  = \Name
v -> (Bool, Exp) -> Q (Bool, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Map Name Name
tvMap Map Name Name -> Name -> Name
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v)
                   , ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
ft_tup  = \TupleSort
t [Q (Bool, Exp)]
gs -> do
                       [(Bool, Exp)]
gg  <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q (Bool, Exp)]
gs
                       Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> [(Bool, Exp)] -> Q Match)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> Q Match
match_for_con TupleSort
t [(Bool, Exp)]
gg
                       (Bool, Exp) -> Q (Bool, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
lam)
                   , ft_ty_app :: [(Type, Q (Bool, Exp))] -> Q (Bool, Exp)
ft_ty_app = \[(Type, Q (Bool, Exp))]
gs -> do
                       Exp
e <- [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Int -> Name
traverseArity ([(Type, Q (Bool, Exp))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Q (Bool, Exp))]
gs))
                                  Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Type, Q (Bool, Exp)) -> Q Exp)
-> [(Type, Q (Bool, Exp))] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(Type
_, Q (Bool, Exp)
hs) -> ((Bool, Exp) -> Exp) -> Q (Bool, Exp) -> Q Exp
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, Exp) -> Exp
forall a b. (a, b) -> b
snd Q (Bool, Exp)
hs) [(Type, Q (Bool, Exp))]
gs
                       (Bool, Exp) -> Q (Bool, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
e)
                   , ft_forall :: [TyVarBndrSpec] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall  = \[TyVarBndrSpec]
_ Q (Bool, Exp)
g -> Q (Bool, Exp)
g
                   , ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var  = \Name
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
contravarianceError Name
conName
                   , ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_fun     = \Q (Bool, Exp)
_ Q (Bool, Exp)
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
                   , ft_bad_app :: Q (Bool, Exp)
ft_bad_app = Name -> Q (Bool, Exp)
forall a. Name -> Q a
outOfPlaceTyVarError Name
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 :: Name -> [(Bool, Exp)] -> Q Match
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
forall a b. (a -> b) -> a -> b
$ \Exp
conExp [Exp]
xs -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Exp] -> Exp
mkApCon Exp
conExp [Exp]
xs
      where
        -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
        mkApCon :: Exp -> [Exp] -> Exp
        mkApCon :: Exp -> [Exp] -> Exp
mkApCon Exp
conExp []  = Name -> Exp
VarE Name
pureValName Exp -> Exp -> Exp
`AppE` Exp
conExp
        mkApCon Exp
conExp [Exp
e] = Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Exp
conExp Exp -> Exp -> Exp
`AppE` Exp
e
        mkApCon Exp
conExp (Exp
e1:Exp
e2:[Exp]
es) = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Exp -> Exp -> Exp
appAp
          (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
          where appAp :: Exp -> Exp -> Exp
appAp Exp
se1 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)

-------------------------------------------------------------------------------
-- 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 -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
buildTypeInstance BiClass
biClass Name
tyConName [Type]
dataCxt [Type]
instTysOrig 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.)
    [Type]
varTysExp <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms [Type]
instTysOrig

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

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

        droppedStarKindStati :: [StarKindStatus]
        droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = (Type -> StarKindStatus) -> [Type] -> [StarKindStatus]
forall a b. (a -> b) -> [a] -> [b]
map Type -> StarKindStatus
canRealizeKindStar [Type]
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
< Int
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 -> Q 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 :: [Type]
varTysExpSubst = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
droppedKindVarNames) [Type]
varTysExp

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

        -- All of the type variables mentioned in the dropped types
        -- (post-synonym expansion)
        droppedTyVarNames :: [Name]
        droppedTyVarNames :: [Name]
droppedTyVarNames = [Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
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) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
hasKindStar [Type]
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      BiClass -> Name -> Q ()
forall a. BiClass -> Name -> Q 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)
        ([Maybe Type]
preds, [[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])) -> [Type] -> [(Maybe Type, [Name])]
forall a b. (a -> b) -> [a] -> [b]
map (BiClass -> Type -> (Maybe Type, [Name])
deriveConstraint BiClass
biClass) [Type]
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' :: [Type]
remainingTysExpSubst' =
          (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
kvNames') [Type]
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 :: [Type]
remainingTysOrigSubst =
          (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar ([Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
List.union [Name]
droppedKindVarNames [Name]
kvNames'))
            ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take Int
remainingLength [Type]
instTysOrig

    Bool
isDataFamily <-
      case DatatypeVariant
variant of
        DatatypeVariant
Datatype        -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        DatatypeVariant
Newtype         -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        DatatypeVariant
DataInstance    -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        DatatypeVariant
NewtypeInstance -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#if MIN_VERSION_th_abstraction(0,5,0)
        DatatypeVariant
Datatype.TypeData -> Name -> Q Bool
forall a. Name -> Q a
typeDataError Name
tyConName
#endif

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

        instanceCxt :: Cxt
        instanceCxt :: [Type]
instanceCxt = [Maybe Type] -> [Type]
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 -> [Type] -> Type
applyTyCon Name
tyConName [Type]
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) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` [Name]
droppedTyVarNames) [Type]
dataCxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Name -> Type -> Q ()
forall a. Name -> Type -> Q 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 ([Type] -> [Type] -> Bool
canEtaReduce [Type]
remainingTysExpSubst' [Type]
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Type -> Q ()
forall a. Type -> Q a
etaReductionError Type
instanceType
    ([Type], Type) -> Q ([Type], Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
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 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 Int
1 Type
t of
      Just [Name]
ns -> ((Name -> Name -> Type
`applyClass` Name
tName) (Name -> Type) -> Maybe Name -> Maybe Type
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` BiClass -> Int -> Maybe Name
biClassConstraint BiClass
biClass Int
1, [Name]
ns)
      Maybe [Name]
_ -> case Int -> Type -> Maybe [Name]
hasKindVarChain Int
2 Type
t of
                Just [Name]
ns -> ((Name -> Name -> Type
`applyClass` Name
tName) (Name -> Type) -> Maybe Name -> Maybe Type
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` BiClass -> Int -> Maybe Name
biClassConstraint BiClass
biClass Int
2, [Name]
ns)
                Maybe [Name]
_       -> (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 -> Q a
derivingKindError :: forall a. BiClass -> Name -> Q a
derivingKindError BiClass
biClass Name
tyConName = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"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 Char
' '
  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 String
" ..."
    )
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘\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 String
" expects an argument of kind * -> * -> *"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""
  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 appeared in a contravariant position
-- when deriving Bifoldable or Bitraversable.
contravarianceError :: Name -> Q a
contravarianceError :: forall a. Name -> Q a
contravarianceError Name
conName = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"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 String
"‘ must not use the last type variable(s) in a function argument"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-- | A constructor has a function argument in a derived Bifoldable or Bitraversable
-- instance.
noFunctionsError :: Name -> Q a
noFunctionsError :: forall a. Name -> Q a
noFunctionsError Name
conName = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"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 String
"‘ must not contain function types"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-- | The data type has a DatatypeContext which mentions one of the eta-reduced
-- type variables.
datatypeContextError :: Name -> Type -> Q a
datatypeContextError :: forall a. Name -> Type -> Q a
datatypeContextError Name
dataName Type
instanceType = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"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 String
"‘:\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 String
"‘ must not have a class context involving the last type argument(s)"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-- | The data type has an existential constraint which mentions one of the
-- eta-reduced type variables.
existentialContextError :: Name -> Q a
existentialContextError :: forall a. Name -> Q a
existentialContextError Name
conName = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"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 String
"‘ must be truly polymorphic in the last argument(s) of the data type"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-- | 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 -> Q a
outOfPlaceTyVarError :: forall a. Name -> Q a
outOfPlaceTyVarError Name
conName = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"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 String
"‘ 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 String
" the last two argument(s) of a data type"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce
-- function for the criteria it would have to meet).
etaReductionError :: Type -> Q a
etaReductionError :: forall a. Type -> Q a
etaReductionError Type
instanceType = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$
  String
"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

typeDataError :: Name -> Q a
typeDataError :: forall a. Name -> Q a
typeDataError Name
dataName = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> ShowS -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Cannot derive instance for ‘"
  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 String
"‘, which is a ‘type data‘ declaration"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-------------------------------------------------------------------------------
-- 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
$c== :: BiFun -> BiFun -> Bool
== :: BiFun -> BiFun -> Bool
$c/= :: BiFun -> BiFun -> Bool
/= :: BiFun -> BiFun -> Bool
Eq

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

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

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

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

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

biClassConstraint :: BiClass -> Int -> Maybe Name
biClassConstraint :: BiClass -> Int -> Maybe Name
biClassConstraint BiClass
Bifunctor     Int
1 = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
functorTypeName
biClassConstraint BiClass
Bifoldable    Int
1 = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
foldableTypeName
biClassConstraint BiClass
Bitraversable Int
1 = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
traversableTypeName
biClassConstraint BiClass
biClass       Int
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 BiClass
_             Int
_ = Maybe Name
forall a. Maybe a
Nothing

fmapArity :: Int -> Name
fmapArity :: Int -> Name
fmapArity Int
1 = Name
fmapValName
fmapArity Int
2 = Name
bimapValName
fmapArity Int
n = Int -> Name
forall a. Int -> a
arityErr Int
n

foldrArity :: Int -> Name
foldrArity :: Int -> Name
foldrArity Int
1 = Name
foldrValName
foldrArity Int
2 = Name
bifoldrValName
foldrArity Int
n = Int -> Name
forall a. Int -> a
arityErr Int
n

foldMapArity :: Int -> Name
foldMapArity :: Int -> Name
foldMapArity Int
1 = Name
foldMapValName
foldMapArity Int
2 = Name
bifoldMapValName
foldMapArity Int
n = Int -> Name
forall a. Int -> a
arityErr Int
n

traverseArity :: Int -> Name
traverseArity :: Int -> Name
traverseArity Int
1 = Name
traverseValName
traverseArity Int
2 = Name
bitraverseValName
traverseArity Int
n = Int -> Name
forall a. Int -> a
arityErr Int
n

arityErr :: Int -> a
arityErr :: forall a. Int -> a
arityErr Int
n = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Unsupported arity: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n

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

biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp
biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp
biFunEmptyCase BiFun
biFun Name
z Name
value =
    Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial Q Exp
emptyCase
                 (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
emptyCase)
                 BiFun
biFun Name
z
  where
    emptyCase :: Q Exp
    emptyCase :: Q Exp
emptyCase = Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) []

biFunNoCons :: BiFun -> Name -> Name -> Q Exp
biFunNoCons :: BiFun -> Name -> Name -> Q Exp
biFunNoCons BiFun
biFun Name
z Name
value =
    Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial Q Exp
seqAndError
                 (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
seqAndError)
                 BiFun
biFun Name
z
  where
    seqAndError :: Q Exp
    seqAndError :: Q Exp
seqAndError = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
seqValName) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                  Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
errorValName)
                        (String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"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 Q Exp
bimapE Q Exp
bitraverseE BiFun
biFun Name
z = BiFun -> Q Exp
go BiFun
biFun
  where
    go :: BiFun -> Q Exp
    go :: BiFun -> Q Exp
go BiFun
Bimap      = Q Exp
bimapE
    go BiFun
Bifoldr    = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z
    go BiFun
BifoldMap  = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
memptyValName
    go BiFun
Bitraverse = Q Exp
bitraverseE

{-
Note [ft_triv 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 ft_triv 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 bi_triv (\_ -> mempty) as the first argument to the recursive
call to bifoldMap, since that is how the algorithm handles polymorphic recursion.
-}

-------------------------------------------------------------------------------
-- 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 { forall a. FFoldType a -> a
ft_triv    :: a
          -- ^ Does not contain variables
        , forall a. FFoldType a -> Name -> a
ft_var     :: Name -> a
          -- ^ A bare variable
        , forall a. FFoldType a -> Name -> a
ft_co_var  :: Name -> a
          -- ^ A bare variable, contravariantly
        , forall a. FFoldType a -> a -> a -> a
ft_fun     :: a -> a -> a
          -- ^ Function type
        , forall a. FFoldType a -> TupleSort -> [a] -> a
ft_tup     :: TupleSort -> [a] -> a
          -- ^ Tuple type. The [a] is the result of folding over the
          --   arguments of the tuple.
        , forall a. FFoldType a -> [(Type, a)] -> a
ft_ty_app  :: [(Type, a)] -> a
          -- ^ Type app, variables only in last argument. The [(Type, a)]
          --   represents the last argument types. That is, they form the
          --   argument parts of @fun_ty arg_ty_1 ... arg_ty_n@.
        , forall a. FFoldType a -> a
ft_bad_app :: a
          -- ^ Type app, variable other than in last arguments
        , forall a. FFoldType a -> [TyVarBndrSpec] -> a -> a
ft_forall  :: [TyVarBndrSpec] -> a -> a
          -- ^ Forall type
     }

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

          tuple :: TupleSort -> Q (a, Bool)
          tuple :: TupleSort -> Q (a, Bool)
tuple TupleSort
tupSort = (a, Bool) -> Q (a, Bool)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (TupleSort -> [a] -> a
caseTuple TupleSort
tupSort [a]
xrs, Bool
True)

          wrongArg :: Q (a, Bool)
          wrongArg :: Q (a, Bool)
wrongArg = (a, Bool) -> Q (a, Bool)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseWrongArg, Bool
True)

      case () of
        ()
_ |  Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
xcs)
          -> Q (a, Bool)
trivial -- Variable does not occur
          -- At this point we know that xrs, xcs is not empty,
          -- and at least one xr is True
          |  TupleT Int
len <- Type
f
          -> TupleSort -> Q (a, Bool)
tuple (TupleSort -> Q (a, Bool)) -> TupleSort -> Q (a, Bool)
forall a b. (a -> b) -> a -> b
$ Int -> TupleSort
Boxed Int
len
          |  UnboxedTupleT Int
len <- Type
f
          -> TupleSort -> Q (a, Bool)
tuple (TupleSort -> Q (a, Bool)) -> TupleSort -> Q (a, Bool)
forall a b. (a -> b) -> a -> b
$ Int -> TupleSort
Unboxed Int
len
          |  Bool
fc Bool -> Bool -> Bool
|| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (Int -> [Bool] -> [Bool]
forall a. Int -> [a] -> [a]
take Int
numFirstArgs [Bool]
xcs)
          -> Q (a, Bool)
wrongArg                    -- T (..var..)    ty_1 ... ty_n
          |  Bool
otherwise                   -- T (..no var..) ty_1 ... ty_n
          -> do Bool
itf <- [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
f [Type]
args
                if Bool
itf -- We can't decompose type families, so
                       -- error if we encounter one here.
                   then Q (a, Bool)
wrongArg
                   else (a, Bool) -> Q (a, Bool)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [(Type, a)] -> a
caseTyApp ([(Type, a)] -> a) -> [(Type, a)] -> a
forall a b. (a -> b) -> a -> b
$ Int -> [(Type, a)] -> [(Type, a)]
forall a. Int -> [a] -> [a]
drop Int
numFirstArgs ([(Type, a)] -> [(Type, a)]) -> [(Type, a)] -> [(Type, a)]
forall a b. (a -> b) -> a -> b
$ [Type] -> [a] -> [(Type, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
args [a]
xrs
                               , Bool
True )
    go Bool
co (SigT Type
t Type
k) = do
      (a
_, Bool
kc) <- Bool -> Type -> Q (a, Bool)
go_kind Bool
co Type
k
      if Bool
kc
         then (a, Bool) -> Q (a, Bool)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseWrongArg, Bool
True)
         else Bool -> Type -> Q (a, Bool)
go Bool
co Type
t
    go Bool
co (VarT Name
v)
      | Name -> Map Name Name -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
v Map Name Name
tvMap
      = (a, Bool) -> Q (a, Bool)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
co then Name -> a
caseCoVar Name
v else Name -> a
caseVar Name
v, Bool
True)
      | Bool
otherwise
      = Q (a, Bool)
trivial
    go Bool
co (ForallT [TyVarBndrSpec]
tvbs [Type]
_ Type
t) = do
      (a
tr, Bool
tc) <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
t
      let tvbNames :: [Name]
tvbNames = (TyVarBndrSpec -> Name) -> [TyVarBndrSpec] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrSpec -> Name
forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndrSpec]
tvbs
      if Bool -> Bool
not Bool
tc Bool -> Bool -> Bool
|| (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
tvbNames) [Name]
tyVarNames
         then Q (a, Bool)
trivial
         else (a, Bool) -> Q (a, Bool)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndrSpec] -> a -> a
caseForAll [TyVarBndrSpec]
tvbs a
tr, Bool
True)
    go Bool
_ Type
_ = Q (a, Bool)
trivial

    go_kind :: Bool
            -> Kind
            -> Q (a, Bool)
    go_kind :: Bool -> Type -> Q (a, Bool)
go_kind = Bool -> Type -> Q (a, Bool)
go

    trivial :: Q (a, Bool)
    trivial :: Q (a, Bool)
trivial = (a, Bool) -> Q (a, Bool)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseTrivial, Bool
False)

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

-- Fold over the arguments of a data constructor in a Functor-like way.
foldDataConArgs :: forall a. TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs :: forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name Name
tvMap FFoldType a
ft ConstructorInfo
con = do
  [Type]
fieldTys <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms ([Type] -> Q [Type]) -> [Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con
  (Type -> Q a) -> [Type] -> Q [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q a
foldArg [Type]
fieldTys
  where
    foldArg :: Type -> Q a
    foldArg :: Type -> Q a
foldArg = Map Name Name -> FFoldType a -> Type -> Q a
forall a. Map Name Name -> FFoldType a -> Type -> Q a
functorLikeTraverse Map Name Name
tvMap FFoldType a
ft

-- Make a 'LamE' using a fresh variable.
mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
lam = do
  -- Use an underscore in front of the variable name, as it's possible for
  -- certain Bifoldable instances to generate code like this (see #89):
  --
  -- @
  -- bifoldMap (\\_n -> mempty) ...
  -- @
  --
  -- Without the underscore, that code would trigger -Wunused-matches warnings.
  Name
n <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_n"
  [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Q Exp
lam (Name -> Exp
VarE Name
n)

-- Make a 'LamE' using two fresh variables.
mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 Exp -> Exp -> Q Exp
lam = do
  -- Use an underscore in front of the variable name, as it's possible for
  -- certain Bifoldable instances to generate code like this (see #89):
  --
  -- @
  -- bifoldr (\\_n1 n2 -> n2) ...
  -- @
  --
  -- Without the underscore, that code would trigger -Wunused-matches warnings.
  Name
n1 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_n1"
  Name
n2 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"n2"
  [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n1, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n2] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Q Exp
lam (Name -> Exp
VarE Name
n1) (Name -> Exp
VarE Name
n2)

-- "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 :: forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> Q Match
mkSimpleConMatch Name -> [a] -> Q Exp
fold Name
conName [Exp -> a]
insides = do
  [Name]
varsNeeded <- String -> Int -> Q [Name]
newNameList String
"_arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Exp -> a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp -> a]
insides
  let pat :: Pat
pat = Name -> [Pat] -> Pat
conPCompat Name
conName ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
  Exp
rhs <- Name -> [a] -> Q Exp
fold Name
conName (((Exp -> a) -> Name -> a) -> [Exp -> a] -> [Name] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Exp -> a
i Name
v -> Exp -> a
i (Exp -> a) -> Exp -> a
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
v) [Exp -> a]
insides [Name]
varsNeeded)
  Match -> Q Match
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> Q Match) -> Match -> Q Match
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
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 :: (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
mkSimpleConMatch2 Exp -> [Exp] -> Q Exp
fold Name
conName [(Bool, Exp)]
insides = do
  [Name]
varsNeeded <- String -> Int -> Q [Name]
newNameList String
"_arg" Int
lengthInsides
  let pat :: Pat
pat = Name -> [Pat] -> Pat
conPCompat Name
conName ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
      -- Make sure to zip BEFORE invoking catMaybes. We want the variable
      -- indices in each expression to match up with the argument indices
      -- in conExpr (defined below).
      exps :: [Exp]
exps = [Maybe Exp] -> [Exp]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Exp] -> [Exp]) -> [Maybe Exp] -> [Exp]
forall a b. (a -> b) -> a -> b
$ ((Bool, Exp) -> Name -> Maybe Exp)
-> [(Bool, Exp)] -> [Name] -> [Maybe Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Bool
m, Exp
i) Name
v -> if Bool
m then Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp
i Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
v)
                                                    else Maybe Exp
forall a. Maybe a
Nothing)
                                 [(Bool, Exp)]
insides [Name]
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 :: [Bool]
argTysTyVarInfo = ((Bool, Exp) -> Bool) -> [(Bool, Exp)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
m, Exp
_) -> Bool
m) [(Bool, Exp)]
insides
      ([Name]
asWithTyVar, [Name]
asWithoutTyVar) = [Bool] -> [Name] -> ([Name], [Name])
forall a. [Bool] -> [a] -> ([a], [a])
partitionByList [Bool]
argTysTyVarInfo [Name]
varsNeeded

      conExpQ :: Q Exp
conExpQ
        | [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
asWithTyVar = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
asWithoutTyVar)
        | Bool
otherwise = do
            [Name]
bs <- String -> Int -> Q [Name]
newNameList String
"b" Int
lengthInsides
            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
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
bs) ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varsNeeded)
            [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
bs') ([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conNameQ Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:[Q Exp]
vars))

  Exp
conExp <- Q Exp
conExpQ
  Exp
rhs <- Exp -> [Exp] -> Q Exp
fold Exp
conExp [Exp]
exps
  Match -> Q Match
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> Q Match) -> Match -> Q Match
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
rhs) []
  where
    lengthInsides :: Int
lengthInsides = [(Bool, Exp)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Exp)]
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
  | Unboxed Int

-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
mkSimpleTupleCase :: (Name -> [a] -> Q Match)
                  -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase :: forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [a] -> Q Match
matchForCon TupleSort
tupSort [a]
insides Exp
x = do
  let tupDataName :: Name
tupDataName = case TupleSort
tupSort of
                      Boxed   Int
len -> Int -> Name
tupleDataName Int
len
                      Unboxed Int
len -> Int -> Name
unboxedTupleDataName Int
len
  Match
m <- Name -> [a] -> Q Match
matchForCon Name
tupDataName [a]
insides
  Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE Exp
x [Match
m]

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