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

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

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

Note: this is an internal module, and as such, the API presented here is not
guaranteed to be stable, even between minor releases of this library.
-}
module Data.Functor.Deriving.Internal (
      -- * 'Foldable'

      deriveFoldable
    , deriveFoldableOptions
    , makeFoldMap
    , makeFoldMapOptions
    , makeFoldr
    , makeFoldrOptions
    , makeFold
    , makeFoldOptions
    , makeFoldl
    , makeFoldlOptions
    , makeNull
    , makeNullOptions
      -- * 'Functor'

    , deriveFunctor
    , deriveFunctorOptions
    , makeFmap
    , makeFmapOptions
    , makeReplace
    , makeReplaceOptions
      -- * 'Traversable'

    , deriveTraversable
    , deriveTraversableOptions
    , makeTraverse
    , makeTraverseOptions
    , makeSequenceA
    , makeSequenceAOptions
    , makeMapM
    , makeMapMOptions
    , makeSequence
    , makeSequenceOptions
      -- * 'FFTOptions'

    , FFTOptions(..)
    , defaultFFTOptions
    ) where

import           Control.Monad (guard)

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

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

-- | Options that further configure how the functions in "Data.Functor.Deriving"

-- should behave. (@FFT@ stands for 'Functor'/'Foldable'/'Traversable'.)

newtype FFTOptions = FFTOptions
  { 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
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
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
Ord, ReadPrec [FFTOptions]
ReadPrec FFTOptions
Int -> ReadS FFTOptions
ReadS [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
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 { 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 'null' (without requiring a

-- 'Foldable' instance).

makeNull :: Name -> Q Exp
makeNull :: Name -> Q Exp
makeNull = FFTOptions -> Name -> Q Exp
makeNullOptions FFTOptions
defaultFFTOptions

-- | Like 'makeNull', but takes an 'FFTOptions' argument.

makeNullOptions :: FFTOptions -> Name -> Q Exp
makeNullOptions :: FFTOptions -> Name -> Q Exp
makeNullOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
makeFunctorFun FunctorFun
Null

-- | 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 FFTOptions
opts Name
name = FFTOptions -> Name -> Q Exp
makeFoldMapOptions FFTOptions
opts Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m 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 FFTOptions
opts Name
name = do
  Name
f <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
  Name
z <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
  Name
t <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
  forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
z, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t] forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
appEndoValName
          , forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
getDualValName
                  , forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ FFTOptions -> Name -> Q Exp
makeFoldMapOptions FFTOptions
opts Name
name, Name -> Q Exp
foldFun Name
f, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t]
                  ]
          , forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z
          ]
  where
    foldFun :: Name -> Q Exp
    foldFun :: Name -> Q Exp
foldFun Name
n = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
dualDataName)
                         (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
                         (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
endoDataName)
                                   (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
                                   (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
flipValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m 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 lambda expression which behaves like ('<$') (without requiring a

-- 'Functor' instance).

makeReplace :: Name -> Q Exp
makeReplace :: Name -> Q Exp
makeReplace = FFTOptions -> Name -> Q Exp
makeReplaceOptions FFTOptions
defaultFFTOptions

-- | Like 'makeReplace', but takes an 'FFTOptions' argument.

makeReplaceOptions :: FFTOptions -> Name -> Q Exp
makeReplaceOptions :: FFTOptions -> Name -> Q Exp
makeReplaceOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
makeFunctorFun FunctorFun
Replace

-- | 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 FFTOptions
opts Name
name = FFTOptions -> Name -> Q Exp
makeTraverseOptions FFTOptions
opts Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m 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 FFTOptions
opts Name
name = do
  Name
f <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
  forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unwrapMonadValName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName) forall a b. (a -> b) -> a -> b
$
                   FFTOptions -> Name -> Q Exp
makeTraverseOptions FFTOptions
opts Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
wrapMonadExp Name
f
  where
    wrapMonadExp :: Name -> Q Exp
    wrapMonadExp :: Name -> Q Exp
wrapMonadExp Name
n = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
wrapMonadDataName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName) (forall (m :: * -> *). Quote m => Name -> m 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 FFTOptions
opts Name
name = FFTOptions -> Name -> Q Exp
makeMapMOptions FFTOptions
opts Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m 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 FunctorClass
fc FFTOptions
opts 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
      (Cxt
instanceCxt, Type
instanceType)
          <- forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance FunctorClass
fc Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
      (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
                             (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 FunctorClass
fc FFTOptions
opts Name
parentName Cxt
instTypes [ConstructorInfo]
cons =
  forall a b. (a -> b) -> [a] -> [b]
map FunctorFun -> Q Dec
makeFunD forall a b. (a -> b) -> a -> b
$ FunctorClass -> [FunctorFun]
functorClassToFuns FunctorClass
fc
  where
    makeFunD :: FunctorFun -> Q Dec
    makeFunD :: FunctorFun -> Q Dec
makeFunD FunctorFun
ff =
      forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (FunctorFun -> Name
functorFunName FunctorFun
ff)
           [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
                    (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB 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 FunctorFun
ff FFTOptions
opts 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.

      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
        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 FunctorFun
ff FFTOptions
opts Name
_parentName Cxt
instTypes [ConstructorInfo]
cons = do
  Name
mapFun <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
  Name
z      <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"z" -- Only used for deriving foldr

  Name
value  <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"value"
  let argNames :: [Name]
argNames  = forall a. [Maybe a] -> [a]
catMaybes [ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FunctorFun
ff forall a. Eq a => a -> a -> Bool
/= FunctorFun
Null)  forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. a -> Maybe a
Just Name
mapFun
                            , forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FunctorFun
ff forall a. Eq a => a -> a -> Bool
== FunctorFun
Foldr) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. a -> Maybe a
Just Name
z
                            , forall a. a -> Maybe a
Just Name
value
                            ]
      lastTyVar :: Name
lastTyVar = Type -> Name
varTToName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last Cxt
instTypes
      tvMap :: Map Name (OneOrTwoNames One)
tvMap     = forall k a. k -> a -> Map k a
Map.singleton Name
lastTyVar forall a b. (a -> b) -> a -> b
$ Name -> OneOrTwoNames One
OneName Name
mapFun
  forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
argNames)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
      forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => Name -> m Exp
varE 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
        ] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
argNames
  where
    makeFun :: Name -> Name -> TyVarMap1 -> Q Exp
    makeFun :: Name -> Name -> Map Name (OneOrTwoNames One) -> Q Exp
makeFun Name
z Name
value 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 ([Role]
_, Role
PhantomR) <- forall a. [a] -> Maybe ([a], a)
unsnoc [Role]
roles
         -> Name -> Name -> Q Exp
functorFunPhantom Name
z Name
value
#endif

          | 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

          | 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
         -> forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value)
                  (forall a b. (a -> b) -> [a] -> [b]
map (FunctorFun
-> Name
-> Map Name (OneOrTwoNames One)
-> ConstructorInfo
-> Q Match
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 Name
z Name
value =
        Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
functorFunTrivial Q Exp
coerce
                          (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
coerce)
                          FunctorFun
ff Name
z
      where
        coerce :: Q Exp
        coerce :: Q Exp
coerce = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
coerceValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value
#endif

-- | Generates a match for a single constructor.

makeFunctorFunForCon :: FunctorFun -> Name -> TyVarMap1 -> ConstructorInfo -> Q Match
makeFunctorFunForCon :: FunctorFun
-> Name
-> Map Name (OneOrTwoNames One)
-> ConstructorInfo
-> Q Match
makeFunctorFunForCon FunctorFun
ff Name
z Map Name (OneOrTwoNames One)
tvMap
  con :: ConstructorInfo
con@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                       , constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt }) = do
    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 forall a b. (a -> b) -> a -> b
$
      case FunctorFun
ff of
        FunctorFun
Fmap     -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeFmapMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
        FunctorFun
Replace  -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeReplaceMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
        FunctorFun
Foldr    -> Name -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeFoldrMatch Name
z Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
        FunctorFun
FoldMap  -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeFoldMapMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
        FunctorFun
Null     -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeNullMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
        FunctorFun
Traverse -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeTraverseMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con

-- | Generates a match whose right-hand side implements @fmap@.

makeFmapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeFmapMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeFmapMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Exp -> Q Exp]
parts <- forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType (Exp -> Q Exp)
ft_fmap ConstructorInfo
con
  Name -> [Exp -> Q Exp] -> Q Match
match_for_con_functor Name
conName [Exp -> Q Exp]
parts
  where
    ft_fmap :: FFoldType (Exp -> Q Exp)
    ft_fmap :: FFoldType (Exp -> Q Exp)
ft_fmap = FT { ft_triv :: Exp -> Q Exp
ft_triv = forall (m :: * -> *) a. Monad m => a -> m a
return
                 , ft_var :: Name -> Exp -> Q Exp
ft_var  = \Name
v Exp
x -> case Map Name (OneOrTwoNames One)
tvMap forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
                                       OneName Name
f -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
f 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 forall a b. (a -> b) -> a -> b
$ \Exp
b -> do
                     Exp
gg <- Exp -> Q Exp
g Exp
b
                     Exp -> Q Exp
h 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  = forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [Exp -> Q Exp] -> Q Match
match_for_con_functor
                 , ft_ty_app :: Type -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_ty_app = \Type
argTy Exp -> Q Exp
g Exp
x -> do
                     case Type -> Maybe Name
varTToName_maybe Type
argTy of
                       -- If the argument type is a bare occurrence of the

                       -- data type's last type variable, then we can

                       -- generate more efficient code.

                       -- This was inspired by GHC#17880.

                       Just Name
argVar
                         |  Just (OneName Name
f) <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
argVar Map Name (OneOrTwoNames One)
tvMap
                         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
f Exp -> Exp -> Exp
`AppE` Exp
x
                       Maybe Name
_ -> do Exp
gg <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
g
                               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Exp
gg Exp -> Exp -> Exp
`AppE` 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
_ -> forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
Functor Name
conName
                 , ft_co_var :: Name -> Exp -> Q Exp
ft_co_var  = \Name
_ Exp
_ -> forall a. Name -> Q a
contravarianceError Name
conName
                 }

-- | Generates a match whose right-hand side implements @(<$)@.

makeReplaceMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeReplaceMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeReplaceMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Exp -> Q Exp]
parts <- forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType (Exp -> Q Exp)
ft_replace ConstructorInfo
con
  Name -> [Exp -> Q Exp] -> Q Match
match_for_con_functor Name
conName [Exp -> Q Exp]
parts
  where
    ft_replace :: FFoldType (Exp -> Q Exp)
    ft_replace :: FFoldType (Exp -> Q Exp)
ft_replace = FT { ft_triv :: Exp -> Q Exp
ft_triv = forall (m :: * -> *) a. Monad m => a -> m a
return
                    , ft_var :: Name -> Exp -> Q Exp
ft_var  = \Name
v Exp
_ -> case Map Name (OneOrTwoNames One)
tvMap forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
                                          OneName Name
z -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
z
                    , 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 forall a b. (a -> b) -> a -> b
$ \Exp
b -> do
                        Exp
gg <- Exp -> Q Exp
g Exp
b
                        Exp -> Q Exp
h 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  = forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [Exp -> Q Exp] -> Q Match
match_for_con_functor
                    , ft_ty_app :: Type -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_ty_app = \Type
argTy Exp -> Q Exp
g Exp
x -> do
                        case Type -> Maybe Name
varTToName_maybe Type
argTy of
                          -- If the argument type is a bare occurrence of the

                          -- data type's last type variable, then we can

                          -- generate more efficient code.

                          -- This was inspired by GHC#17880.

                          Just Name
argVar
                            |  Just (OneName Name
z) <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
argVar Map Name (OneOrTwoNames One)
tvMap
                            -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
replaceValName Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
z Exp -> Exp -> Exp
`AppE` Exp
x
                          Maybe Name
_ -> do Exp
gg <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
g
                                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Exp
gg Exp -> Exp -> Exp
`AppE` 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
_ -> forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
Functor Name
conName
                    , ft_co_var :: Name -> Exp -> Q Exp
ft_co_var  = \Name
_ Exp
_ -> forall a. Name -> Q a
contravarianceError Name
conName
                    }

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


-- | Generates a match whose right-hand side implements @foldr@.

makeFoldrMatch :: Name -> TyVarMap1 -> ConstructorInfo -> Q Match
makeFoldrMatch :: Name -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeFoldrMatch Name
z Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Q (Bool, Exp)]
parts  <- forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType (Q (Bool, Exp))
ft_foldr ConstructorInfo
con
  [(Bool, Exp)]
parts' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t 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 the last type parameter, False

    -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out

    -- expressions that do not mention the last parameter by checking for False.

    ft_foldr :: FFoldType (Q (Bool, Exp))
    ft_foldr :: FFoldType (Q (Bool, Exp))
ft_foldr = FT { ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 forall a b. (a -> b) -> a -> b
$ \Exp
_ Exp
z' -> forall (m :: * -> *) a. Monad m => a -> m a
return Exp
z'
                                 forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Exp
lam)
                  , ft_var :: Name -> Q (Bool, Exp)
ft_var  = \Name
v -> case Map Name (OneOrTwoNames One)
tvMap forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
                                      OneName Name
f -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE Name
f)
                  , ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
ft_tup  = \TupleSort
t [Q (Bool, Exp)]
gs -> do
                      [(Bool, Exp)]
gg  <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
gs
                      Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 forall a b. (a -> b) -> a -> b
$ \Exp
x Exp
z' ->
                        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
                      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)
g -> do
                      (Bool
b, Exp
gg) <- Q (Bool, Exp)
g
                      Exp
e <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 forall a b. (a -> b) -> a -> b
$ \Exp
x Exp
z' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                           Name -> Exp
VarE Name
foldrValName Exp -> Exp -> Exp
`AppE` Exp
gg Exp -> Exp -> Exp
`AppE` Exp
z' Exp -> Exp -> Exp
`AppE` Exp
x
                      forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
b, 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
_ -> 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)
_ -> forall a. Name -> Q a
noFunctionsError Name
conName
                  , ft_bad_app :: Q (Bool, Exp)
ft_bad_app = forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
Foldable 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 forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkFoldr [Exp]
xs
      where
        -- g1 v1 (g2 v2 (.. z))

        mkFoldr :: [Exp] -> Exp
        mkFoldr :: [Exp] -> Exp
mkFoldr = 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 @foldMap@.

makeFoldMapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeFoldMapMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeFoldMapMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Q (Bool, Exp)]
parts  <- forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType (Q (Bool, Exp))
ft_foldMap ConstructorInfo
con
  [(Bool, Exp)]
parts' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t 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 the last type parameter, False

    -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out

    -- expressions that do not mention the last parameter by checking for False.

    ft_foldMap :: FFoldType (Q (Bool, Exp))
    ft_foldMap :: FFoldType (Q (Bool, Exp))
ft_foldMap = FT { ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam forall a b. (a -> b) -> a -> b
$ \Exp
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
memptyValName
                                   forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Exp
lam)
                    , ft_var :: Name -> Q (Bool, Exp)
ft_var  = \Name
v -> case Map Name (OneOrTwoNames One)
tvMap forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
                                        OneName Name
f -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE Name
f)
                    , ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
ft_tup  = \TupleSort
t [Q (Bool, Exp)]
gs -> do
                        [(Bool, Exp)]
gg  <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
gs
                        Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam forall a b. (a -> b) -> a -> b
$ 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
                        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)
g -> do
                        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Bool
b, Exp
e) -> (Bool
b, Name -> Exp
VarE Name
foldMapValName Exp -> Exp -> Exp
`AppE` Exp
e)) Q (Bool, Exp)
g
                    , 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
_ -> 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)
_ -> forall a. Name -> Q a
noFunctionsError Name
conName
                    , ft_bad_app :: Q (Bool, Exp)
ft_bad_app = forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
Foldable 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 forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkFoldMap [Exp]
xs
      where
        -- mappend v1 (mappend v2 ..)

        mkFoldMap :: [Exp] -> Exp
        mkFoldMap :: [Exp] -> Exp
mkFoldMap [] = Name -> Exp
VarE Name
memptyValName
        mkFoldMap [Exp]
es = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (Exp -> Exp -> Exp
AppE 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 @null@.

makeNullMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeNullMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeNullMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Q (NullM Exp)]
parts  <- forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType (Q (NullM Exp))
ft_null ConstructorInfo
con
  [NullM Exp]
parts' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (NullM Exp)]
parts
  case forall a. [NullM a] -> Maybe [(Bool, a)]
convert [NullM Exp]
parts' of
    Maybe [(Bool, Exp)]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match (ConstructorInfo -> Pat
conWildPat ConstructorInfo
con) (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
falseDataName) []
    Just [(Bool, Exp)]
cp -> Name -> [(Bool, Exp)] -> Q Match
match_for_con Name
conName [(Bool, Exp)]
cp
  where
    ft_null :: FFoldType (Q (NullM Exp))
    ft_null :: FFoldType (Q (NullM Exp))
ft_null = FT { ft_triv :: Q (NullM Exp)
ft_triv = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> NullM a
IsNull forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
trueDataName
                 , ft_var :: Name -> Q (NullM Exp)
ft_var  = \Name
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. NullM a
NotNull
                 , ft_tup :: TupleSort -> [Q (NullM Exp)] -> Q (NullM Exp)
ft_tup = \TupleSort
t [Q (NullM Exp)]
g -> do
                     [NullM Exp]
gg <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (NullM Exp)]
g
                     case forall a. [NullM a] -> Maybe [(Bool, a)]
convert [NullM Exp]
gg of
                       Maybe [(Bool, Exp)]
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. NullM a
NotNull
                       Just [(Bool, Exp)]
ggg ->
                         forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> NullM a
NullM forall a b. (a -> b) -> a -> b
$ (Exp -> Q Exp) -> Q Exp
mkSimpleLam
                                    forall a b. (a -> b) -> a -> b
$ forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> Q Match
match_for_con TupleSort
t [(Bool, Exp)]
ggg
                 , ft_ty_app :: Type -> Q (NullM Exp) -> Q (NullM Exp)
ft_ty_app = \Type
_ Q (NullM Exp)
g -> forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Q (NullM Exp)
g forall a b. (a -> b) -> a -> b
$ \NullM Exp
nestedResult ->
                     case NullM Exp
nestedResult of
                       -- If e definitely contains the parameter, then we can

                       -- test if (G e) contains it by simply checking if (G e)

                       -- is null

                       NullM Exp
NotNull -> forall a. a -> NullM a
NullM forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
nullValName
                       -- This case is unreachable--it will actually be caught

                       -- by ft_triv

                       r :: NullM Exp
r@IsNull{} -> NullM Exp
r
                       -- The general case uses (all null), (all (all null)),

                       -- etc.

                       NullM Exp
nestedTest -> forall a. a -> NullM a
NullM forall a b. (a -> b) -> a -> b
$
                                           Name -> Exp
VarE Name
allValName Exp -> Exp -> Exp
`AppE` Exp
nestedTest
                 , ft_forall :: [TyVarBndrSpec] -> Q (NullM Exp) -> Q (NullM Exp)
ft_forall = \[TyVarBndrSpec]
_ Q (NullM Exp)
g -> Q (NullM Exp)
g
                 , ft_co_var :: Name -> Q (NullM Exp)
ft_co_var  = \Name
_ -> forall a. Name -> Q a
contravarianceError Name
conName
                 , ft_fun :: Q (NullM Exp) -> Q (NullM Exp) -> Q (NullM Exp)
ft_fun     = \Q (NullM Exp)
_ Q (NullM Exp)
_ -> forall a. Name -> Q a
noFunctionsError Name
conName
                 , ft_bad_app :: Q (NullM Exp)
ft_bad_app = forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
Foldable 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 forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkNull [Exp]
xs
      where
        -- v1 && v2 && ..

        mkNull :: [Exp] -> Exp
        mkNull :: [Exp] -> Exp
mkNull [] = Name -> Exp
ConE Name
trueDataName
        mkNull [Exp]
xs = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Exp
x Exp
y -> Name -> Exp
VarE Name
andValName Exp -> Exp -> Exp
`AppE` Exp
x Exp -> Exp -> Exp
`AppE` Exp
y) [Exp]
xs

-- Given a list of NullM results, produce Nothing if any of them is NotNull,

-- and otherwise produce a list of (Bool, a) with True entries representing

-- unknowns and False entries representing things that are definitely null.

convert :: [NullM a] -> Maybe [(Bool, a)]
convert :: forall a. [NullM a] -> Maybe [(Bool, a)]
convert = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {b}. NullM b -> Maybe (Bool, b)
go where
  go :: NullM b -> Maybe (Bool, b)
go (IsNull b
a) = forall a. a -> Maybe a
Just (Bool
False, b
a)
  go NullM b
NotNull    = forall a. Maybe a
Nothing
  go (NullM b
a)  = forall a. a -> Maybe a
Just (Bool
True, b
a)

data NullM a =
    IsNull a -- Definitely null

  | NotNull  -- Definitely not null

  | NullM a  -- Unknown


-- | Generates a match whose right-hand side implements @traverse@.

makeTraverseMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeTraverseMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeTraverseMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Q (Bool, Exp)]
parts  <- forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType (Q (Bool, Exp))
ft_trav ConstructorInfo
con
  [(Bool, Exp)]
parts' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t 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 the last type parameter, False

    -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out

    -- expressions that do not mention the last parameter by checking for False.

    ft_trav :: FFoldType (Q (Bool, Exp))
    ft_trav :: FFoldType (Q (Bool, Exp))
ft_trav = FT { -- See Note [ft_triv for Bifoldable and Bitraversable]

                   ft_triv :: Q (Bool, Exp)
ft_triv = 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 -> case Map Name (OneOrTwoNames One)
tvMap forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
                                     OneName Name
f -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE Name
f)
                 , ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
ft_tup  = \TupleSort
t [Q (Bool, Exp)]
gs -> do
                     [(Bool, Exp)]
gg  <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
gs
                     Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam forall a b. (a -> b) -> a -> b
$ 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
                     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)
g ->
                     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Bool
b, Exp
e) -> (Bool
b, Name -> Exp
VarE Name
traverseValName Exp -> Exp -> Exp
`AppE` Exp
e)) Q (Bool, Exp)
g
                 , 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
_ -> 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)
_ -> forall a. Name -> Q a
noFunctionsError Name
conName
                 , ft_bad_app :: Q (Bool, Exp)
ft_bad_app = forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
Traversable 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 forall a b. (a -> b) -> a -> b
$ \Exp
conExp [Exp]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return 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) = 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 (forall a. a -> Maybe a
Just Exp
se1) (Name -> Exp
VarE Name
apValName) (forall a. a -> Maybe a
Just Exp
se2)

-------------------------------------------------------------------------------

-- Class-specific constants

-------------------------------------------------------------------------------


-- | A representation of which class is being derived.

data FunctorClass = Functor | Foldable | Traversable

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

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

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

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

-- | A representation of which function is being generated.

data FunctorFun
  = Fmap
  | Replace -- (<$)

  | Foldr
  | FoldMap
  | Null
  | Traverse
  deriving FunctorFun -> FunctorFun -> Bool
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 Int
_ FunctorFun
Fmap     = String -> ShowS
showString String
"fmap"
    showsPrec Int
_ FunctorFun
Replace  = String -> ShowS
showString String
"(<$)"
    showsPrec Int
_ FunctorFun
Foldr    = String -> ShowS
showString String
"foldr"
    showsPrec Int
_ FunctorFun
FoldMap  = String -> ShowS
showString String
"foldMap"
    showsPrec Int
_ FunctorFun
Null     = String -> ShowS
showString String
"null"
    showsPrec Int
_ FunctorFun
Traverse = String -> ShowS
showString String
"traverse"

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

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

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

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

-------------------------------------------------------------------------------

-- Assorted utilities

-------------------------------------------------------------------------------


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

functorFunNoCons :: FunctorFun -> Name -> Name -> Q Exp
functorFunNoCons :: FunctorFun -> Name -> Name -> Q Exp
functorFunNoCons FunctorFun
ff Name
z Name
value =
    Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
functorFunTrivial Q Exp
seqAndError
                      (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
seqAndError)
                      FunctorFun
ff Name
z
  where
    seqAndError :: Q Exp
    seqAndError :: Q Exp
seqAndError = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
seqValName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                  forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
errorValName)
                       (forall (m :: * -> *). Quote m => String -> m Exp
stringE forall a b. (a -> b) -> a -> b
$ String
"Void " 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 Q Exp
fmapE Q Exp
traverseE FunctorFun
ff Name
z = FunctorFun -> Q Exp
go FunctorFun
ff
  where
    go :: FunctorFun -> Q Exp
    go :: FunctorFun -> Q Exp
go FunctorFun
Fmap     = Q Exp
fmapE
    go FunctorFun
Replace  = Q Exp
fmapE
    go FunctorFun
Foldr    = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z
    go FunctorFun
FoldMap  = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
memptyValName
    go FunctorFun
Null     = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueDataName
    go FunctorFun
Traverse = Q Exp
traverseE

conWildPat :: ConstructorInfo -> Pat
conWildPat :: ConstructorInfo -> Pat
conWildPat (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
                            , constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
ts }) =
  Name -> [Pat] -> Pat
conPCompat Name
conName forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts) Pat
WildP

-------------------------------------------------------------------------------

-- Generic traversal for functor-like deriving

-------------------------------------------------------------------------------


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


data FFoldType a      -- Describes how to fold over a Type in a functor like way

   = FT { forall a. FFoldType a -> a
ft_triv    :: a
          -- ^ Does not contain variable

        , forall a. FFoldType a -> Name -> a
ft_var     :: Name -> a
          -- ^ The variable itself

        , forall a. FFoldType a -> Name -> a
ft_co_var  :: Name -> a
          -- ^ The variable itself, 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, variable only in last argument. The 'Type' is the

          --   @arg_ty@ in @fun_ty arg_ty@.

        , forall a. FFoldType a -> a
ft_bad_app :: a
          -- ^ Type app, variable other than in last argument

        , 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.
                       TyVarMap1   -- ^ Variable to look for

                    -> FFoldType a -- ^ How to fold

                    -> Type        -- ^ Type to process

                    -> Q a
functorLikeTraverse :: forall a.
Map Name (OneOrTwoNames One) -> FFoldType a -> Type -> Q a
functorLikeTraverse Map Name (OneOrTwoNames One)
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'
       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, Cxt)
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 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, Cxt
args) = Type -> (Type, Cxt)
unapplyTy Type
t
      (a
_,   Bool
fc)  <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
f
      ([a]
xrs, [Bool]
xcs) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Type -> Q (a, Bool)
go Bool
co) Cxt
args
      let tuple :: TupleSort -> Q (a, Bool)
          tuple :: TupleSort -> Q (a, Bool)
tuple TupleSort
tupSort = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseWrongArg, Bool
True)

      case () of
        ()
_ |  Bool -> Bool
not (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 forall a b. (a -> b) -> a -> b
$ Int -> TupleSort
Boxed Int
len
#if MIN_VERSION_template_haskell(2,6,0)
          |  UnboxedTupleT Int
len <- Type
f
          -> TupleSort -> Q (a, Bool)
tuple forall a b. (a -> b) -> a -> b
$ Int -> TupleSort
Unboxed Int
len
#endif
          |  Bool
fc Bool -> Bool -> Bool
|| forall (t :: * -> *). Foldable t => t Bool -> Bool
or (forall a. [a] -> [a]
init [Bool]
xcs)
          -> Q (a, Bool)
wrongArg                    -- T (..var..)    ty

          |  Bool
otherwise                   -- T (..no var..) ty

          -> do Bool
itf <- [Name] -> Type -> Cxt -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
f Cxt
args
                if Bool
itf -- We can't decompose type families, so

                       -- error if we encounter one here.

                   then Q (a, Bool)
wrongArg
                   else forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> a -> a
caseTyApp (forall a. [a] -> a
last Cxt
args) (forall a. [a] -> a
last [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 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)
      | forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
v Map Name (OneOrTwoNames One)
tvMap
      = 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 Cxt
_ Type
t) = do
      (a
tr, Bool
tc) <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
t
      let tvbNames :: [Name]
tvbNames = forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndrSpec]
tvbs
      if Bool -> Bool
not Bool
tc Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
tvbNames) [Name]
tyVarNames
         then Q (a, Bool)
trivial
         else 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)
#if MIN_VERSION_template_haskell(2,9,0)
    go_kind :: Bool -> Type -> Q (a, Bool)
go_kind = Bool -> Type -> Q (a, Bool)
go
#else
    go_kind _ _ = trivial
#endif

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

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

-- Fold over the arguments of a data constructor in a Functor-like way.

foldDataConArgs :: forall a. TyVarMap1 -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs :: forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType a
ft ConstructorInfo
con = do
  Cxt
fieldTys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Cxt
constructorFields ConstructorInfo
con
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q a
foldArg Cxt
fieldTys
  where
    foldArg :: Type -> Q a
    foldArg :: Type -> Q a
foldArg = forall a.
Map Name (OneOrTwoNames One) -> FFoldType a -> Type -> Q a
functorLikeTraverse Map Name (OneOrTwoNames One)
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
  Name
n <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"n"
  Exp
body <- Exp -> Q Exp
lam (Name -> Exp
VarE Name
n)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
n] Exp
body

-- 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
  Name
n1 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"n1"
  Name
n2 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"n2"
  Exp
body <- Exp -> Exp -> Q Exp
lam (Name -> Exp
VarE Name
n1) (Name -> Exp
VarE Name
n2)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
n1, Name -> Pat
VarP Name
n2] Exp
body

-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"

--

-- @mkSimpleConMatch fold conName insides@ produces a match clause in

-- which the LHS pattern-matches on @extraPats@, followed by a match on the

-- constructor @conName@ and its arguments. The RHS folds (with @fold@) over

-- @conName@ and its arguments, applying an expression (from @insides@) to each

-- of the respective arguments of @conName@.

mkSimpleConMatch :: (Name -> [a] -> Q Exp)
                 -> Name
                 -> [Exp -> a]
                 -> Q Match
mkSimpleConMatch :: 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" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp -> a]
insides
  let pat :: Pat
pat = Name -> [Pat] -> Pat
conPCompat Name
conName (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
  Exp
rhs <- Name -> [a] -> Q Exp
fold Name
conName (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Exp -> a
i Name
v -> Exp -> a
i forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
v) [Exp -> a]
insides [Name]
varsNeeded)
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
      -- Make sure to zip BEFORE invoking catMaybes. We want the variable

      -- indicies in each expression to match up with the argument indices

      -- in conExpr (defined below).

      exps :: [Exp]
exps = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Bool
m, Exp
i) Name
v -> if Bool
m then forall a. a -> Maybe a
Just (Exp
i Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
v)
                                                    else 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 = forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
m, Exp
_) -> Bool
m) [(Bool, Exp)]
insides
      ([Name]
asWithTyVar, [Name]
asWithoutTyVar) = forall a. [Bool] -> [a] -> ([a], [a])
partitionByList [Bool]
argTysTyVarInfo [Name]
varsNeeded

      conExpQ :: Q Exp
conExpQ
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
asWithTyVar = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conNameforall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map 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'  = forall a. [Bool] -> [a] -> [a]
filterByList  [Bool]
argTysTyVarInfo [Name]
bs
                vars :: [Q Exp]
vars = forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
argTysTyVarInfo
                                     (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
bs) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varsNeeded)
            forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
bs') (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conNameforall a. a -> [a] -> [a]
:[Q Exp]
vars))

  Exp
conExp <- Q Exp
conExpQ
  Exp
rhs <- Exp -> [Exp] -> Q Exp
fold Exp
conExp [Exp]
exps
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
rhs) []
  where
    lengthInsides :: Int
lengthInsides = 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
#if MIN_VERSION_template_haskell(2,6,0)
  | Unboxed Int
#endif

-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"

mkSimpleTupleCase :: (Name -> [a] -> Q Match)
                  -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase :: 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
#if MIN_VERSION_template_haskell(2,6,0)
                      Unboxed Int
len -> Int -> Name
unboxedTupleDataName Int
len
#endif
  Match
m <- Name -> [a] -> Q Match
matchForCon Name
tupDataName [a]
insides
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> Cxt -> [Pat] -> Pat
ConP Name
n
#if MIN_VERSION_template_haskell(2,18,0)
                         []
#endif
                         [Pat]
pats