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

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

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

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

import           Control.Monad (guard, zipWithM)

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

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

-- | Options that further configure how the functions in "Data.Functor.Deriving"
-- should behave. (@FFT@ stands for 'Functor'/'Foldable'/'Traversable'.)
newtype FFTOptions = FFTOptions
  { FFTOptions -> Bool
fftEmptyCaseBehavior :: Bool
    -- ^ If 'True', derived instances for empty data types (i.e., ones with
    --   no data constructors) will use the @EmptyCase@ language extension.
    --   If 'False', derived instances will simply use 'seq' instead.
    --   (This has no effect on GHCs before 7.8, since @EmptyCase@ is only
    --   available in 7.8 or later.)
  } deriving (FFTOptions -> FFTOptions -> Bool
(FFTOptions -> FFTOptions -> Bool)
-> (FFTOptions -> FFTOptions -> Bool) -> Eq FFTOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FFTOptions -> FFTOptions -> Bool
$c/= :: FFTOptions -> FFTOptions -> Bool
== :: FFTOptions -> FFTOptions -> Bool
$c== :: FFTOptions -> FFTOptions -> Bool
Eq, Eq FFTOptions
Eq FFTOptions =>
(FFTOptions -> FFTOptions -> Ordering)
-> (FFTOptions -> FFTOptions -> Bool)
-> (FFTOptions -> FFTOptions -> Bool)
-> (FFTOptions -> FFTOptions -> Bool)
-> (FFTOptions -> FFTOptions -> Bool)
-> (FFTOptions -> FFTOptions -> FFTOptions)
-> (FFTOptions -> FFTOptions -> FFTOptions)
-> Ord FFTOptions
FFTOptions -> FFTOptions -> Bool
FFTOptions -> FFTOptions -> Ordering
FFTOptions -> FFTOptions -> FFTOptions
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FFTOptions -> FFTOptions -> FFTOptions
$cmin :: FFTOptions -> FFTOptions -> FFTOptions
max :: FFTOptions -> FFTOptions -> FFTOptions
$cmax :: FFTOptions -> FFTOptions -> FFTOptions
>= :: FFTOptions -> FFTOptions -> Bool
$c>= :: FFTOptions -> FFTOptions -> Bool
> :: FFTOptions -> FFTOptions -> Bool
$c> :: FFTOptions -> FFTOptions -> Bool
<= :: FFTOptions -> FFTOptions -> Bool
$c<= :: FFTOptions -> FFTOptions -> Bool
< :: FFTOptions -> FFTOptions -> Bool
$c< :: FFTOptions -> FFTOptions -> Bool
compare :: FFTOptions -> FFTOptions -> Ordering
$ccompare :: FFTOptions -> FFTOptions -> Ordering
$cp1Ord :: Eq FFTOptions
Ord, ReadPrec [FFTOptions]
ReadPrec FFTOptions
Int -> ReadS FFTOptions
ReadS [FFTOptions]
(Int -> ReadS FFTOptions)
-> ReadS [FFTOptions]
-> ReadPrec FFTOptions
-> ReadPrec [FFTOptions]
-> Read FFTOptions
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FFTOptions]
$creadListPrec :: ReadPrec [FFTOptions]
readPrec :: ReadPrec FFTOptions
$creadPrec :: ReadPrec FFTOptions
readList :: ReadS [FFTOptions]
$creadList :: ReadS [FFTOptions]
readsPrec :: Int -> ReadS FFTOptions
$creadsPrec :: Int -> ReadS FFTOptions
Read, Int -> FFTOptions -> ShowS
[FFTOptions] -> ShowS
FFTOptions -> String
(Int -> FFTOptions -> ShowS)
-> (FFTOptions -> String)
-> ([FFTOptions] -> ShowS)
-> Show FFTOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FFTOptions] -> ShowS
$cshowList :: [FFTOptions] -> ShowS
show :: FFTOptions -> String
$cshow :: FFTOptions -> String
showsPrec :: Int -> FFTOptions -> ShowS
$cshowsPrec :: Int -> FFTOptions -> ShowS
Show)

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

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

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

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

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

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

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

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

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

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

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

-- | Generates a 'Functor' instance declaration for the given data type or data
-- family instance.
deriveFunctor :: Name -> Q [Dec]
deriveFunctor :: Name -> Q [Dec]
deriveFunctor = FFTOptions -> Name -> Q [Dec]
deriveFunctorOptions FFTOptions
defaultFFTOptions

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Generates a lambda expression for the given constructors.
-- All constructors must be from the same type.
makeFunctorFunForCons
  :: FunctorFun -> FFTOptions -> Name -> [Type] -> [ConstructorInfo]
  -> Q Exp
makeFunctorFunForCons :: FunctorFun
-> FFTOptions -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeFunctorFunForCons ff :: FunctorFun
ff opts :: FFTOptions
opts _parentName :: Name
_parentName instTypes :: Cxt
instTypes cons :: [ConstructorInfo]
cons = do
  [Name]
argNames <- (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Q Name
newName ([String] -> Q [Name]) -> [String] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [ String -> Maybe String
forall a. a -> Maybe a
Just "f"
                                       , Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FunctorFun
ff FunctorFun -> FunctorFun -> Bool
forall a. Eq a => a -> a -> Bool
== FunctorFun
Foldr) Maybe () -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Maybe String
forall a. a -> Maybe a
Just "z"
                                       , String -> Maybe String
forall a. a -> Maybe a
Just "value"
                                       ]
  let mapFun :: Name
mapFun:others :: [Name]
others = [Name]
argNames
      z :: Name
z         = [Name] -> Name
forall a. [a] -> a
head [Name]
others -- If we're deriving foldr, this will be well defined
                              -- and useful. Otherwise, it'll be ignored.
      value :: Name
value     = [Name] -> Name
forall a. [a] -> a
last [Name]
others
      lastTyVar :: Name
lastTyVar = Type -> Name
varTToName (Type -> Name) -> Type -> Name
forall a b. (a -> b) -> a -> b
$ Cxt -> Type
forall a. [a] -> a
last Cxt
instTypes
      tvMap :: Map Name (OneOrTwoNames One)
tvMap     = Name -> OneOrTwoNames One -> Map Name (OneOrTwoNames One)
forall k a. k -> a -> Map k a
Map.singleton Name
lastTyVar (OneOrTwoNames One -> Map Name (OneOrTwoNames One))
-> OneOrTwoNames One -> Map Name (OneOrTwoNames One)
forall a b. (a -> b) -> a -> b
$ Name -> OneOrTwoNames One
OneName Name
mapFun
  [PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
argNames)
      (Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE
      ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ FunctorFun -> Name
functorFunConstName FunctorFun
ff
        , Name -> Name -> Map Name (OneOrTwoNames One) -> Q Exp
makeFun Name
z Name
value Map Name (OneOrTwoNames One)
tvMap
        ] [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
argNames
  where
    makeFun :: Name -> Name -> TyVarMap1 -> Q Exp
    makeFun :: Name -> Name -> Map Name (OneOrTwoNames One) -> Q Exp
makeFun z :: Name
z value :: Name
value tvMap :: Map Name (OneOrTwoNames One)
tvMap = do
#if MIN_VERSION_template_haskell(2,9,0)
      [Role]
roles <- Name -> Q [Role]
reifyRoles Name
_parentName
#endif
      case () of
        _

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

          | [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons Bool -> Bool -> Bool
&& FFTOptions -> Bool
fftEmptyCaseBehavior FFTOptions
opts Bool -> Bool -> Bool
&& Bool
ghc7'8OrLater
         -> FunctorFun -> Name -> Name -> Q Exp
functorFunEmptyCase FunctorFun
ff Name
z Name
value

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

          | Bool
otherwise
         -> Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value)
                  ((ConstructorInfo -> MatchQ) -> [ConstructorInfo] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (FunctorFun
-> Name
-> Map Name (OneOrTwoNames One)
-> ConstructorInfo
-> MatchQ
makeFunctorFunForCon FunctorFun
ff Name
z Map Name (OneOrTwoNames One)
tvMap) [ConstructorInfo]
cons)

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

-- | Generates a lambda expression for a single constructor.
makeFunctorFunForCon :: FunctorFun -> Name -> TyVarMap1 -> ConstructorInfo -> Q Match
makeFunctorFunForCon :: FunctorFun
-> Name
-> Map Name (OneOrTwoNames One)
-> ConstructorInfo
-> MatchQ
makeFunctorFunForCon ff :: FunctorFun
ff z :: Name
z tvMap :: Map Name (OneOrTwoNames One)
tvMap
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                   , constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt
                   , constructorFields :: ConstructorInfo -> Cxt
constructorFields  = Cxt
ts }) = do
    Cxt
ts'      <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
ts
    [Name]
argNames <- String -> Int -> Q [Name]
newNameList "_arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts'
    FunctorClass
-> Map Name (OneOrTwoNames One) -> Cxt -> Name -> MatchQ -> MatchQ
forall a b c.
ClassRep a =>
a -> TyVarMap b -> Cxt -> Name -> Q c -> Q c
checkExistentialContext (FunctorFun -> FunctorClass
functorFunToClass FunctorFun
ff) Map Name (OneOrTwoNames One)
tvMap Cxt
ctxt Name
conName (MatchQ -> MatchQ) -> MatchQ -> MatchQ
forall a b. (a -> b) -> a -> b
$
      FunctorFun
-> Name
-> Map Name (OneOrTwoNames One)
-> Name
-> Cxt
-> [Name]
-> MatchQ
makeFunctorFunForArgs FunctorFun
ff Name
z Map Name (OneOrTwoNames One)
tvMap Name
conName Cxt
ts' [Name]
argNames

-- | Generates a lambda expression for a single constructor's arguments.
makeFunctorFunForArgs :: FunctorFun
                      -> Name
                      -> TyVarMap1
                      -> Name
                      -> [Type]
                      -> [Name]
                      -> Q Match
makeFunctorFunForArgs :: FunctorFun
-> Name
-> Map Name (OneOrTwoNames One)
-> Name
-> Cxt
-> [Name]
-> MatchQ
makeFunctorFunForArgs ff :: FunctorFun
ff z :: Name
z tvMap :: Map Name (OneOrTwoNames One)
tvMap conName :: Name
conName tys :: Cxt
tys args :: [Name]
args =
  PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
        (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ FunctorFun -> Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
functorFunCombine FunctorFun
ff Name
conName Name
z [Name]
args Q [Either Exp Exp]
mappedArgs)
        []
  where
    mappedArgs :: Q [Either Exp Exp]
    mappedArgs :: Q [Either Exp Exp]
mappedArgs = (Type -> Name -> Q (Either Exp Exp))
-> Cxt -> [Name] -> Q [Either Exp Exp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Type
-> Name
-> Q (Either Exp Exp)
makeFunctorFunForArg FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName) Cxt
tys [Name]
args

-- | Generates a lambda expression for a single argument of a constructor.
--  The returned value is 'Right' if its type mentions the last type
-- parameter. Otherwise, it is 'Left'.
makeFunctorFunForArg :: FunctorFun
                     -> TyVarMap1
                     -> Name
                     -> Type
                     -> Name
                     -> Q (Either Exp Exp)
makeFunctorFunForArg :: FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Type
-> Name
-> Q (Either Exp Exp)
makeFunctorFunForArg ff :: FunctorFun
ff tvMap :: Map Name (OneOrTwoNames One)
tvMap conName :: Name
conName ty :: Type
ty tyExpName :: Name
tyExpName =
  FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName Bool
True Type
ty Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
`appEitherE` Name -> Q Exp
varE Name
tyExpName

-- | Generates a lambda expression for a specific type. The returned value is
-- 'Right' if its type mentions the last type parameter. Otherwise,
-- it is 'Left'.
makeFunctorFunForType :: FunctorFun
                      -> TyVarMap1
                      -> Name
                      -> Bool
                      -> Type
                      -> Q (Either Exp Exp)
makeFunctorFunForType :: FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType ff :: FunctorFun
ff tvMap :: Map Name (OneOrTwoNames One)
tvMap conName :: Name
conName covariant :: Bool
covariant (VarT tyName :: Name
tyName) =
  case Name -> Map Name (OneOrTwoNames One) -> Maybe (OneOrTwoNames One)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name (OneOrTwoNames One)
tvMap of
    Just (OneName mapName :: Name
mapName) ->
      (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. b -> Either a b
Right (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$ if Bool
covariant
                      then Name -> Q Exp
varE Name
mapName
                      else Name -> Q Exp
forall a. Name -> Q a
contravarianceError Name
conName
    -- Invariant: this should only happen when deriving fmap
    Nothing -> (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. a -> Either a b
Left (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$ FunctorFun -> Q Exp
functorFunTriv FunctorFun
ff
makeFunctorFunForType ff :: FunctorFun
ff tvMap :: Map Name (OneOrTwoNames One)
tvMap conName :: Name
conName covariant :: Bool
covariant (SigT ty :: Type
ty _) =
  FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName Bool
covariant Type
ty
makeFunctorFunForType ff :: FunctorFun
ff tvMap :: Map Name (OneOrTwoNames One)
tvMap conName :: Name
conName covariant :: Bool
covariant (ForallT _ _ ty :: Type
ty) =
  FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName Bool
covariant Type
ty
makeFunctorFunForType ff :: FunctorFun
ff tvMap :: Map Name (OneOrTwoNames One)
tvMap conName :: Name
conName covariant :: Bool
covariant ty :: Type
ty =
  let tyCon  :: Type
      tyArgs :: [Type]
      tyCon :: Type
tyCon:tyArgs :: Cxt
tyArgs = Type -> Cxt
unapplyTy Type
ty

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

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

      tyVarNames :: [Name]
      tyVarNames :: [Name]
tyVarNames = Map Name (OneOrTwoNames One) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (OneOrTwoNames One)
tvMap

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

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

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

      makeFunctorFunTupleField :: Type -> Name -> Q (Either Exp Exp)
      makeFunctorFunTupleField :: Type -> Name -> Q (Either Exp Exp)
makeFunctorFunTupleField fieldTy :: Type
fieldTy fieldName :: Name
fieldName =
        FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName Bool
covariant Type
fieldTy
          Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
`appEitherE` Name -> Q Exp
varE Name
fieldName

      fc :: FunctorClass
      fc :: FunctorClass
fc = FunctorFun -> FunctorClass
functorFunToClass FunctorFun
ff

   in case Type
tyCon of
     ArrowT
       | Bool -> Bool
not (FunctorClass -> Bool
allowFunTys FunctorClass
fc) -> Name -> Q (Either Exp Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
       | Bool
mentionsTyArgs, [argTy :: Type
argTy, resTy :: Type
resTy] <- Cxt
tyArgs ->
         do Name
x <- String -> Q Name
newName "x"
            Name
b <- String -> Q Name
newName "b"
            (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. b -> Either a b
Right (Q Exp -> Q (Either Exp Exp))
-> (Q Exp -> Q Exp) -> Q Exp -> Q (Either Exp Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x, Name -> PatQ
varP Name
b] (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$
              Bool -> Type -> Q Exp
covFunctorFun Bool
covariant Type
resTy Q Exp -> Q Exp -> Q Exp
`appE` (Name -> Q Exp
varE Name
x Q Exp -> Q Exp -> Q Exp
`appE`
                (Bool -> Type -> Q Exp
covFunctorFun (Bool -> Bool
not Bool
covariant) Type
argTy Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
b))
         where
           covFunctorFun :: Bool -> Type -> Q Exp
           covFunctorFun :: Bool -> Type -> Q Exp
covFunctorFun cov :: Bool
cov = (Either Exp Exp -> Exp) -> Q (Either Exp Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Exp Exp -> Exp
forall a. Either a a -> a
fromEither (Q (Either Exp Exp) -> Q Exp)
-> (Type -> Q (Either Exp Exp)) -> Type -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName Bool
cov
#if MIN_VERSION_template_haskell(2,6,0)
     UnboxedTupleT n :: Int
n
       | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Bool
mentionsTyArgs -> ([PatQ] -> PatQ) -> (Int -> Name) -> Int -> Q (Either Exp Exp)
makeFunctorFunTuple [PatQ] -> PatQ
unboxedTupP Int -> Name
unboxedTupleDataName Int
n
#endif
     TupleT n :: Int
n
       | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Bool
mentionsTyArgs -> ([PatQ] -> PatQ) -> (Int -> Name) -> Int -> Q (Either Exp Exp)
makeFunctorFunTuple [PatQ] -> PatQ
tupP Int -> Name
tupleDataName Int
n
     _ -> do
         Bool
itf <- Type -> Q Bool
isTyFamily Type
tyCon
         if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
lhsArgs Bool -> Bool -> Bool
|| (Bool
itf Bool -> Bool -> Bool
&& Bool
mentionsTyArgs)
           then FunctorClass -> Name -> Q (Either Exp Exp)
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
fc Name
conName
           else if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
                  then (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. b -> Either a b
Right (Q Exp -> Q (Either Exp Exp))
-> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q (Either Exp Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunctorFun -> Q Exp -> Q Exp
functorFunApp FunctorFun
ff (Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q (Either Exp Exp)) -> [Q Exp] -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$
                         ( Name -> Q Exp
varE (FunctorFun -> Name
functorFunName FunctorFun
ff)
                         Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Type -> Q Exp) -> Cxt -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ((Either Exp Exp -> Exp) -> Q (Either Exp Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Exp Exp -> Exp
forall a. Either a a -> a
fromEither (Q (Either Exp Exp) -> Q Exp)
-> (Type -> Q (Either Exp Exp)) -> Type -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName Bool
covariant)
                                Cxt
rhsArgs
                         )
                  else (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. a -> Either a b
Left (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$ FunctorFun -> Q Exp
functorFunTriv FunctorFun
ff

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

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

instance ClassRep FunctorClass where
    arity :: FunctorClass -> Int
arity _ = 1

    allowExQuant :: FunctorClass -> Bool
allowExQuant Foldable = Bool
True
    allowExQuant _        = Bool
False

    fullClassName :: FunctorClass -> Name
fullClassName Functor     = Name
functorTypeName
    fullClassName Foldable    = Name
foldableTypeName
    fullClassName Traversable = Name
traversableTypeName

    classConstraint :: FunctorClass -> Int -> Maybe Name
classConstraint fClass :: FunctorClass
fClass 1 = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ FunctorClass -> Name
forall a. ClassRep a => a -> Name
fullClassName FunctorClass
fClass
    classConstraint  _      _ = Maybe Name
forall a. Maybe a
Nothing

-- | A representation of which function is being generated.
data FunctorFun = Fmap | Foldr | FoldMap | Traverse
  deriving FunctorFun -> FunctorFun -> Bool
(FunctorFun -> FunctorFun -> Bool)
-> (FunctorFun -> FunctorFun -> Bool) -> Eq FunctorFun
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FunctorFun -> FunctorFun -> Bool
$c/= :: FunctorFun -> FunctorFun -> Bool
== :: FunctorFun -> FunctorFun -> Bool
$c== :: FunctorFun -> FunctorFun -> Bool
Eq

instance Show FunctorFun where
    showsPrec :: Int -> FunctorFun -> ShowS
showsPrec _ Fmap     = String -> ShowS
showString "fmap"
    showsPrec _ Foldr    = String -> ShowS
showString "foldr"
    showsPrec _ FoldMap  = String -> ShowS
showString "foldMap"
    showsPrec _ Traverse = String -> ShowS
showString "traverse"

functorFunConstName :: FunctorFun -> Name
functorFunConstName :: FunctorFun -> Name
functorFunConstName Fmap     = Name
fmapConstValName
functorFunConstName Foldr    = Name
foldrConstValName
functorFunConstName FoldMap  = Name
foldMapConstValName
functorFunConstName Traverse = Name
traverseConstValName

functorFunName :: FunctorFun -> Name
functorFunName :: FunctorFun -> Name
functorFunName Fmap     = Name
fmapValName
functorFunName Foldr    = Name
foldrValName
functorFunName FoldMap  = Name
foldMapValName
functorFunName Traverse = Name
traverseValName

functorClassToFuns :: FunctorClass -> [FunctorFun]
functorClassToFuns :: FunctorClass -> [FunctorFun]
functorClassToFuns Functor     = [FunctorFun
Fmap]
functorClassToFuns Foldable    = [FunctorFun
Foldr, FunctorFun
FoldMap]
functorClassToFuns Traversable = [FunctorFun
Traverse]

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

allowFunTys :: FunctorClass -> Bool
allowFunTys :: FunctorClass -> Bool
allowFunTys Functor = Bool
True
allowFunTys _       = Bool
False

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

-- See Trac #7436 for why explicit lambdas are used
functorFunTriv :: FunctorFun -> Q Exp
functorFunTriv :: FunctorFun -> Q Exp
functorFunTriv Fmap = do
  Name
x <- String -> Q Name
newName "x"
  PatQ -> Q Exp -> Q Exp
lam1E (Name -> PatQ
varP Name
x) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
x
-- We filter out trivial expressions from derived foldr, foldMap, and traverse
-- implementations, so if we attempt to call functorFunTriv on one of those
-- methods, we've done something wrong.
functorFunTriv ff :: FunctorFun
ff = Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> (String -> Exp) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "functorFunTriv: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FunctorFun -> String
forall a. Show a => a -> String
show FunctorFun
ff

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

functorFunCombine :: FunctorFun
                  -> Name
                  -> Name
                  -> [Name]
                  -> Q [Either Exp Exp]
                  -> Q Exp
functorFunCombine :: FunctorFun -> Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
functorFunCombine Fmap     = Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
fmapCombine
functorFunCombine Foldr    = Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
foldrCombine
functorFunCombine FoldMap  = Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
foldMapCombine
functorFunCombine Traverse = Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
traverseCombine

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

-- foldr, foldMap, and traverse are handled differently from fmap, since
-- they filter out subexpressions whose types do not mention the last
-- type parameter. See
-- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor#AlternativestrategyforderivingFoldableandTraversable
-- for further discussion.

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

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

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

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

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

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

    Exp
conExp <- Q Exp
conExpQ

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

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

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

functorFunNoCons :: FunctorFun -> Name -> Name -> Q Exp
functorFunNoCons :: FunctorFun -> Name -> Name -> Q Exp
functorFunNoCons ff :: FunctorFun
ff z :: Name
z value :: Name
value =
    Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
functorFunTrivial Q Exp
seqAndError
                      (Name -> Q Exp
varE Name
pureValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
seqAndError)
                      FunctorFun
ff Name
z
  where
    seqAndError :: Q Exp
    seqAndError :: Q Exp
seqAndError = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
seqValName) (Name -> Q Exp
varE Name
value) Q Exp -> Q Exp -> Q Exp
`appE`
                  Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
errorValName)
                       (String -> Q Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "Void " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (FunctorFun -> Name
functorFunName FunctorFun
ff))

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