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

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

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

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

import           Control.Monad (guard)

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

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

-- | Options that further configure how the functions in "Data.Functor.Deriving"
-- should behave. (@FFT@ stands for 'Functor'/'Foldable'/'Traversable'.)
newtype FFTOptions = FFTOptions
  { 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 '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 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 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 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
mapFun <- String -> Q Name
newName "f"
  Name
z      <- String -> Q Name
newName "z" -- Only used for deriving foldr
  Name
value  <- String -> Q Name
newName "value"
  let argNames :: [Name]
argNames  = [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
catMaybes [ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FunctorFun
ff FunctorFun -> FunctorFun -> Bool
forall a. Eq a => a -> a -> Bool
/= FunctorFun
Null)  Maybe () -> Maybe Name -> Maybe Name
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
mapFun
                            , 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 Name -> Maybe Name
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
z
                            , Name -> Maybe Name
forall a. a -> Maybe a
Just Name
value
                            ]
      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 match 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
  con :: ConstructorInfo
con@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                       , constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt }) = do
    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
$
      case FunctorFun
ff of
        Fmap     -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeFmapMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
        Replace  -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeReplaceMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
        Foldr    -> Name -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeFoldrMatch Name
z Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
        FoldMap  -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeFoldMapMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
        Null     -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeNullMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
        Traverse -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
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 -> MatchQ
makeFmapMatch tvMap :: Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Exp -> Q Exp]
parts <- Map Name (OneOrTwoNames One)
-> FFoldType (Exp -> Q Exp) -> ConstructorInfo -> Q [Exp -> Q Exp]
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] -> MatchQ
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 :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> (Type -> a -> a)
-> a
-> ([TyVarBndr] -> a -> a)
-> FFoldType a
FT { ft_triv :: Exp -> Q Exp
ft_triv = Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return
                 , ft_var :: Name -> Exp -> Q Exp
ft_var  = \v :: Name
v x :: Exp
x -> case Map Name (OneOrTwoNames One)
tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
                                       OneName f :: Name
f -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
f Exp -> Exp -> Exp
`AppE` Exp
x
                 , ft_fun :: (Exp -> Q Exp) -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_fun  = \g :: Exp -> Q Exp
g h :: Exp -> Q Exp
h x :: Exp
x -> (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \b :: Exp
b -> do
                     Exp
gg <- Exp -> Q Exp
g Exp
b
                     Exp -> Q Exp
h (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
x Exp -> Exp -> Exp
`AppE` Exp
gg
                 , ft_tup :: TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
ft_tup  = (Name -> [Exp -> Q Exp] -> MatchQ)
-> TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [Exp -> Q Exp] -> MatchQ
match_for_con_functor
                 , ft_ty_app :: Type -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_ty_app = \argTy :: Type
argTy g :: Exp -> Q Exp
g x :: 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 argVar :: Name
argVar
                         |  Just (OneName f :: Name
f) <- Name -> Map Name (OneOrTwoNames One) -> Maybe (OneOrTwoNames One)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
argVar Map Name (OneOrTwoNames One)
tvMap
                         -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
f Exp -> Exp -> Exp
`AppE` Exp
x
                       _ -> do Exp
gg <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
g
                               Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Exp
gg Exp -> Exp -> Exp
`AppE` Exp
x
                 , ft_forall :: [TyVarBndr] -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_forall  = \_ g :: Exp -> Q Exp
g x :: Exp
x -> Exp -> Q Exp
g Exp
x
                 , ft_bad_app :: Exp -> Q Exp
ft_bad_app = \_ -> FunctorClass -> Name -> Q 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 -> Q 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 -> MatchQ
makeReplaceMatch tvMap :: Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Exp -> Q Exp]
parts <- Map Name (OneOrTwoNames One)
-> FFoldType (Exp -> Q Exp) -> ConstructorInfo -> Q [Exp -> Q Exp]
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] -> MatchQ
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 :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> (Type -> a -> a)
-> a
-> ([TyVarBndr] -> a -> a)
-> FFoldType a
FT { ft_triv :: Exp -> Q Exp
ft_triv = Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return
                    , ft_var :: Name -> Exp -> Q Exp
ft_var  = \v :: Name
v _ -> case Map Name (OneOrTwoNames One)
tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
                                          OneName z :: Name
z -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
z
                    , ft_fun :: (Exp -> Q Exp) -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_fun  = \g :: Exp -> Q Exp
g h :: Exp -> Q Exp
h x :: Exp
x -> (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \b :: Exp
b -> do
                        Exp
gg <- Exp -> Q Exp
g Exp
b
                        Exp -> Q Exp
h (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
x Exp -> Exp -> Exp
`AppE` Exp
gg
                    , ft_tup :: TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
ft_tup  = (Name -> [Exp -> Q Exp] -> MatchQ)
-> TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [Exp -> Q Exp] -> MatchQ
match_for_con_functor
                    , ft_ty_app :: Type -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_ty_app = \argTy :: Type
argTy g :: Exp -> Q Exp
g x :: 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 argVar :: Name
argVar
                            |  Just (OneName z :: Name
z) <- Name -> Map Name (OneOrTwoNames One) -> Maybe (OneOrTwoNames One)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
argVar Map Name (OneOrTwoNames One)
tvMap
                            -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
replaceValName Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
z Exp -> Exp -> Exp
`AppE` Exp
x
                          _ -> do Exp
gg <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
g
                                  Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Exp
gg Exp -> Exp -> Exp
`AppE` Exp
x
                    , ft_forall :: [TyVarBndr] -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_forall  = \_ g :: Exp -> Q Exp
g x :: Exp
x -> Exp -> Q Exp
g Exp
x
                    , ft_bad_app :: Exp -> Q Exp
ft_bad_app = \_ -> FunctorClass -> Name -> Q 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 -> Q 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] -> MatchQ
match_for_con_functor = (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> MatchQ
forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> MatchQ
mkSimpleConMatch ((Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> MatchQ)
-> (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \conName' :: Name
conName' xs :: [Q Exp]
xs ->
  [Q Exp] -> Q Exp
appsE (Name -> Q Exp
conE Name
conName'Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:[Q Exp]
xs) -- Con x1 x2 ..

-- | Generates a match whose right-hand side implements @foldr@.
makeFoldrMatch :: Name -> TyVarMap1 -> ConstructorInfo -> Q Match
makeFoldrMatch :: Name -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeFoldrMatch z :: Name
z tvMap :: Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Q (Bool, Exp)]
parts  <- Map Name (OneOrTwoNames One)
-> FFoldType (Q (Bool, Exp))
-> ConstructorInfo
-> Q [Q (Bool, Exp)]
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' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
  Exp -> Name -> [(Bool, Exp)] -> MatchQ
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 :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> (Type -> a -> a)
-> a
-> ([TyVarBndr] -> a -> a)
-> FFoldType a
FT { ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \_ z' :: Exp
z' -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
z'
                                 (Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Exp
lam)
                  , ft_var :: Name -> Q (Bool, Exp)
ft_var  = \v :: Name
v -> case Map Name (OneOrTwoNames One)
tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
                                      OneName f :: Name
f -> (Bool, Exp) -> Q (Bool, Exp)
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  = \t :: TupleSort
t gs :: [Q (Bool, Exp)]
gs -> do
                      [(Bool, Exp)]
gg  <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
gs
                      Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \x :: Exp
x z' :: Exp
z' ->
                        (Name -> [(Bool, Exp)] -> MatchQ)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase (Exp -> Name -> [(Bool, Exp)] -> MatchQ
match_for_con Exp
z') TupleSort
t [(Bool, Exp)]
gg Exp
x
                      (Bool, Exp) -> Q (Bool, Exp)
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 = \_ g :: Q (Bool, Exp)
g -> do
                      (b :: Bool
b, gg :: Exp
gg) <- Q (Bool, Exp)
g
                      Exp
e <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \x :: Exp
x z' :: Exp
z' -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
                           Name -> Exp
VarE Name
foldrValName Exp -> Exp -> Exp
`AppE` Exp
gg Exp -> Exp -> Exp
`AppE` Exp
z' Exp -> Exp -> Exp
`AppE` Exp
x
                      (Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
b, Exp
e)
                  , ft_forall :: [TyVarBndr] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall  = \_ g :: Q (Bool, Exp)
g -> Q (Bool, Exp)
g
                  , ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var  = \_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
contravarianceError Name
conName
                  , ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_fun     = \_ _ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
                  , ft_bad_app :: Q (Bool, Exp)
ft_bad_app = FunctorClass -> Name -> Q (Bool, Exp)
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)] -> MatchQ
match_for_con zExp :: Exp
zExp = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \_ xs :: [Exp]
xs -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
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 = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
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 -> MatchQ
makeFoldMapMatch tvMap :: Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Q (Bool, Exp)]
parts  <- Map Name (OneOrTwoNames One)
-> FFoldType (Q (Bool, Exp))
-> ConstructorInfo
-> Q [Q (Bool, Exp)]
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' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
  Name -> [(Bool, Exp)] -> MatchQ
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 :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> (Type -> a -> a)
-> a
-> ([TyVarBndr] -> a -> a)
-> FFoldType a
FT { ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \_ -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
memptyValName
                                   (Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Exp
lam)
                    , ft_var :: Name -> Q (Bool, Exp)
ft_var  = \v :: Name
v -> case Map Name (OneOrTwoNames One)
tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
                                        OneName f :: Name
f -> (Bool, Exp) -> Q (Bool, Exp)
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  = \t :: TupleSort
t gs :: [Q (Bool, Exp)]
gs -> do
                        [(Bool, Exp)]
gg  <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
gs
                        Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> [(Bool, Exp)] -> MatchQ)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> MatchQ
match_for_con TupleSort
t [(Bool, Exp)]
gg
                        (Bool, Exp) -> Q (Bool, Exp)
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 = \_ g :: Q (Bool, Exp)
g -> do
                        ((Bool, Exp) -> (Bool, Exp)) -> Q (Bool, Exp) -> Q (Bool, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(b :: Bool
b, e :: Exp
e) -> (Bool
b, Name -> Exp
VarE Name
foldMapValName Exp -> Exp -> Exp
`AppE` Exp
e)) Q (Bool, Exp)
g
                    , ft_forall :: [TyVarBndr] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall  = \_ g :: Q (Bool, Exp)
g -> Q (Bool, Exp)
g
                    , ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var  = \_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
contravarianceError Name
conName
                    , ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_fun     = \_ _ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
                    , ft_bad_app :: Q (Bool, Exp)
ft_bad_app = FunctorClass -> Name -> Q (Bool, Exp)
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)] -> MatchQ
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \_ xs :: [Exp]
xs -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
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 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

-- | Generates a match whose right-hand side implements @null@.
makeNullMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeNullMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeNullMatch tvMap :: Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Q (NullM Exp)]
parts  <- Map Name (OneOrTwoNames One)
-> FFoldType (Q (NullM Exp))
-> ConstructorInfo
-> Q [Q (NullM Exp)]
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' <- [Q (NullM Exp)] -> Q [NullM Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (NullM Exp)]
parts
  case [NullM Exp] -> Maybe [(Bool, Exp)]
forall a. [NullM a] -> Maybe [(Bool, a)]
convert [NullM Exp]
parts' of
    Nothing -> Match -> MatchQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> MatchQ) -> Match -> MatchQ
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match (ConstructorInfo -> Pat
conWildPat ConstructorInfo
con) (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
falseDataName) []
    Just cp :: [(Bool, Exp)]
cp -> Name -> [(Bool, Exp)] -> MatchQ
match_for_con Name
conName [(Bool, Exp)]
cp
  where
    ft_null :: FFoldType (Q (NullM Exp))
    ft_null :: FFoldType (Q (NullM Exp))
ft_null = FT :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> (Type -> a -> a)
-> a
-> ([TyVarBndr] -> a -> a)
-> FFoldType a
FT { ft_triv :: Q (NullM Exp)
ft_triv = NullM Exp -> Q (NullM Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (NullM Exp -> Q (NullM Exp)) -> NullM Exp -> Q (NullM Exp)
forall a b. (a -> b) -> a -> b
$ Exp -> NullM Exp
forall a. a -> NullM a
IsNull (Exp -> NullM Exp) -> Exp -> NullM Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
trueDataName
                 , ft_var :: Name -> Q (NullM Exp)
ft_var  = \_ -> NullM Exp -> Q (NullM Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return NullM Exp
forall a. NullM a
NotNull
                 , ft_tup :: TupleSort -> [Q (NullM Exp)] -> Q (NullM Exp)
ft_tup = \t :: TupleSort
t g :: [Q (NullM Exp)]
g -> do
                     [NullM Exp]
gg <- [Q (NullM Exp)] -> Q [NullM Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (NullM Exp)]
g
                     case [NullM Exp] -> Maybe [(Bool, Exp)]
forall a. [NullM a] -> Maybe [(Bool, a)]
convert [NullM Exp]
gg of
                       Nothing  -> NullM Exp -> Q (NullM Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return NullM Exp
forall a. NullM a
NotNull
                       Just ggg :: [(Bool, Exp)]
ggg ->
                         (Exp -> NullM Exp) -> Q Exp -> Q (NullM Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> NullM Exp
forall a. a -> NullM a
NullM (Q Exp -> Q (NullM Exp)) -> Q Exp -> Q (NullM Exp)
forall a b. (a -> b) -> a -> b
$ (Exp -> Q Exp) -> Q Exp
mkSimpleLam
                                    ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> [(Bool, Exp)] -> MatchQ)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> MatchQ
match_for_con TupleSort
t [(Bool, Exp)]
ggg
                 , ft_ty_app :: Type -> Q (NullM Exp) -> Q (NullM Exp)
ft_ty_app = \_ g :: Q (NullM Exp)
g -> ((NullM Exp -> NullM Exp) -> Q (NullM Exp) -> Q (NullM Exp))
-> Q (NullM Exp) -> (NullM Exp -> NullM Exp) -> Q (NullM Exp)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (NullM Exp -> NullM Exp) -> Q (NullM Exp) -> Q (NullM Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Q (NullM Exp)
g ((NullM Exp -> NullM Exp) -> Q (NullM Exp))
-> (NullM Exp -> NullM Exp) -> Q (NullM Exp)
forall a b. (a -> b) -> a -> b
$ \nestedResult :: 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
                       NotNull -> Exp -> NullM Exp
forall a. a -> NullM a
NullM (Exp -> NullM Exp) -> Exp -> NullM Exp
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 nestedTest :: Exp
nestedTest -> Exp -> NullM Exp
forall a. a -> NullM a
NullM (Exp -> NullM Exp) -> Exp -> NullM Exp
forall a b. (a -> b) -> a -> b
$
                                           Name -> Exp
VarE Name
allValName Exp -> Exp -> Exp
`AppE` Exp
nestedTest
                 , ft_forall :: [TyVarBndr] -> Q (NullM Exp) -> Q (NullM Exp)
ft_forall = \_ g :: Q (NullM Exp)
g -> Q (NullM Exp)
g
                 , ft_co_var :: Name -> Q (NullM Exp)
ft_co_var  = \_ -> Name -> Q (NullM Exp)
forall a. Name -> Q a
contravarianceError Name
conName
                 , ft_fun :: Q (NullM Exp) -> Q (NullM Exp) -> Q (NullM Exp)
ft_fun     = \_ _ -> Name -> Q (NullM Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
                 , ft_bad_app :: Q (NullM Exp)
ft_bad_app = FunctorClass -> Name -> Q (NullM Exp)
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)] -> MatchQ
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \_ xs :: [Exp]
xs -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
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 xs :: [Exp]
xs = (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\x :: Exp
x y :: 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 :: [NullM a] -> Maybe [(Bool, a)]
convert = (NullM a -> Maybe (Bool, a)) -> [NullM a] -> Maybe [(Bool, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NullM a -> Maybe (Bool, a)
forall b. NullM b -> Maybe (Bool, b)
go where
  go :: NullM b -> Maybe (Bool, b)
go (IsNull a :: b
a) = (Bool, b) -> Maybe (Bool, b)
forall a. a -> Maybe a
Just (Bool
False, b
a)
  go NotNull    = Maybe (Bool, b)
forall a. Maybe a
Nothing
  go (NullM a :: b
a)  = (Bool, b) -> Maybe (Bool, b)
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 -> MatchQ
makeTraverseMatch tvMap :: Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
  [Q (Bool, Exp)]
parts  <- Map Name (OneOrTwoNames One)
-> FFoldType (Q (Bool, Exp))
-> ConstructorInfo
-> Q [Q (Bool, Exp)]
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' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
  Name -> [(Bool, Exp)] -> MatchQ
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 :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> (Type -> a -> a)
-> a
-> ([TyVarBndr] -> a -> a)
-> FFoldType a
FT { -- See Note [ft_triv for Bifoldable and Bitraversable]
                   ft_triv :: Q (Bool, Exp)
ft_triv = (Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Name -> Exp
VarE Name
pureValName)
                 , ft_var :: Name -> Q (Bool, Exp)
ft_var  = \v :: Name
v -> case Map Name (OneOrTwoNames One)
tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
                                     OneName f :: Name
f -> (Bool, Exp) -> Q (Bool, Exp)
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  = \t :: TupleSort
t gs :: [Q (Bool, Exp)]
gs -> do
                     [(Bool, Exp)]
gg  <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
gs
                     Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> [(Bool, Exp)] -> MatchQ)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> MatchQ
match_for_con TupleSort
t [(Bool, Exp)]
gg
                     (Bool, Exp) -> Q (Bool, Exp)
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 = \_ g :: Q (Bool, Exp)
g ->
                     ((Bool, Exp) -> (Bool, Exp)) -> Q (Bool, Exp) -> Q (Bool, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(b :: Bool
b, e :: Exp
e) -> (Bool
b, Name -> Exp
VarE Name
traverseValName Exp -> Exp -> Exp
`AppE` Exp
e)) Q (Bool, Exp)
g
                 , ft_forall :: [TyVarBndr] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall  = \_ g :: Q (Bool, Exp)
g -> Q (Bool, Exp)
g
                 , ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var  = \_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
contravarianceError Name
conName
                 , ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_fun     = \_ _ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
                 , ft_bad_app :: Q (Bool, Exp)
ft_bad_app = FunctorClass -> Name -> Q (Bool, Exp)
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)] -> MatchQ
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \conExp :: Exp
conExp xs :: [Exp]
xs -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Exp] -> Exp
mkApCon Exp
conExp [Exp]
xs
      where
        -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
        mkApCon :: Exp -> [Exp] -> Exp
        mkApCon :: Exp -> [Exp] -> Exp
mkApCon conExp :: Exp
conExp []  = Name -> Exp
VarE Name
pureValName Exp -> Exp -> Exp
`AppE` Exp
conExp
        mkApCon conExp :: Exp
conExp [e :: Exp
e] = Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Exp
conExp Exp -> Exp -> Exp
`AppE` Exp
e
        mkApCon conExp :: Exp
conExp (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' 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 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)

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

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

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

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

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

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

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 Replace  = Q Exp
fmapE
    go Foldr    = Name -> Q Exp
varE Name
z
    go FoldMap  = Name -> Q Exp
varE Name
memptyValName
    go Null     = Name -> Q Exp
conE Name
trueDataName
    go 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
ConP Name
conName ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate (Cxt -> Int
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 { FFoldType a -> a
ft_triv    :: a
          -- ^ Does not contain variable
        , FFoldType a -> Name -> a
ft_var     :: Name -> a
          -- ^ The variable itself
        , FFoldType a -> Name -> a
ft_co_var  :: Name -> a
          -- ^ The variable itself, contravariantly
        , FFoldType a -> a -> a -> a
ft_fun     :: a -> a -> a
          -- ^ Function type
        , 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.
        , 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@.
        , FFoldType a -> a
ft_bad_app :: a
          -- ^ Type app, variable other than in last argument
        , FFoldType a -> [TyVarBndr] -> a -> a
ft_forall  :: [TyVarBndr] -> a -> a
          -- ^ Forall type
     }

-- Note that in GHC, this function is pure. It must be monadic here since we:
--
-- (1) Expand type synonyms
-- (2) Detect type family applications
--
-- Which require reification in Template Haskell, but are pure in Core.
functorLikeTraverse :: forall a.
                       TyVarMap1   -- ^ Variable to look for
                    -> FFoldType a -- ^ How to fold
                    -> Type        -- ^ Type to process
                    -> Q a
functorLikeTraverse :: Map Name (OneOrTwoNames One) -> FFoldType a -> Type -> Q a
functorLikeTraverse tvMap :: 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 -> [TyVarBndr] -> a -> a
ft_forall = [TyVarBndr] -> a -> a
caseForAll })
                    ty :: Type
ty
  = do Type
ty' <- Type -> TypeQ
resolveTypeSynonyms Type
ty
       (res :: a
res, _) <- Bool -> Type -> Q (a, Bool)
go Bool
False Type
ty'
       a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
  where
    go :: Bool        -- Covariant or contravariant context
       -> Type
       -> Q (a, Bool) -- (result of type a, does type contain var)
    go :: Bool -> Type -> Q (a, Bool)
go co :: Bool
co t :: Type
t@AppT{}
      | (ArrowT, [funArg :: Type
funArg, funRes :: Type
funRes]) <- Type -> (Type, Cxt)
unapplyTy Type
t
      = do (funArgR :: a
funArgR, funArgC :: Bool
funArgC) <- Bool -> Type -> Q (a, Bool)
go (Bool -> Bool
not Bool
co) Type
funArg
           (funResR :: a
funResR, funResC :: Bool
funResC) <- Bool -> Type -> Q (a, Bool)
go      Bool
co  Type
funRes
           if Bool
funArgC Bool -> Bool -> Bool
|| Bool
funResC
              then (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a -> a
caseFun a
funArgR a
funResR, Bool
True)
              else Q (a, Bool)
trivial
    go co :: Bool
co t :: Type
t@AppT{} = do
      let (f :: Type
f, args :: Cxt
args) = Type -> (Type, Cxt)
unapplyTy Type
t
      (_,   fc :: Bool
fc)  <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
f
      (xrs :: [a]
xrs, xcs :: [Bool]
xcs) <- ([(a, Bool)] -> ([a], [Bool])) -> Q [(a, Bool)] -> Q ([a], [Bool])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(a, Bool)] -> ([a], [Bool])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(a, Bool)] -> Q ([a], [Bool]))
-> Q [(a, Bool)] -> Q ([a], [Bool])
forall a b. (a -> b) -> a -> b
$ (Type -> Q (a, Bool)) -> Cxt -> Q [(a, Bool)]
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 tupSort :: TupleSort
tupSort = (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (TupleSort -> [a] -> a
caseTuple TupleSort
tupSort [a]
xrs, Bool
True)

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

      case () of
        _ |  Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
xcs)
          -> Q (a, Bool)
trivial -- Variable does not occur
          -- At this point we know that xrs, xcs is not empty,
          -- and at least one xr is True
          |  TupleT len :: Int
len <- Type
f
          -> TupleSort -> Q (a, Bool)
tuple (TupleSort -> Q (a, Bool)) -> TupleSort -> Q (a, Bool)
forall a b. (a -> b) -> a -> b
$ Int -> TupleSort
Boxed Int
len
#if MIN_VERSION_template_haskell(2,6,0)
          |  UnboxedTupleT len :: Int
len <- Type
f
          -> TupleSort -> Q (a, Bool)
tuple (TupleSort -> Q (a, Bool)) -> TupleSort -> Q (a, Bool)
forall a b. (a -> b) -> a -> b
$ Int -> TupleSort
Unboxed Int
len
#endif
          |  Bool
fc Bool -> Bool -> Bool
|| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> [Bool]
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 (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> a -> a
caseTyApp (Cxt -> Type
forall a. [a] -> a
last Cxt
args) ([a] -> a
forall a. [a] -> a
last [a]
xrs), Bool
True)
    go co :: Bool
co (SigT t :: Type
t k :: Type
k) = do
      (_, kc :: Bool
kc) <- Bool -> Type -> Q (a, Bool)
go_kind Bool
co Type
k
      if Bool
kc
         then (a, Bool) -> Q (a, Bool)
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 co :: Bool
co (VarT v :: Name
v)
      | Name -> Map Name (OneOrTwoNames One) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
v Map Name (OneOrTwoNames One)
tvMap
      = (a, Bool) -> Q (a, Bool)
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 co :: Bool
co (ForallT tvbs :: [TyVarBndr]
tvbs _ t :: Type
t) = do
      (tr :: a
tr, tc :: Bool
tc) <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
t
      let tvbNames :: [Name]
tvbNames = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tvName [TyVarBndr]
tvbs
      if Bool -> Bool
not Bool
tc Bool -> Bool -> Bool
|| (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
tvbNames) [Name]
tyVarNames
         then Q (a, Bool)
trivial
         else (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr] -> a -> a
caseForAll [TyVarBndr]
tvbs a
tr, Bool
True)
    go _ _ = 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 = (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseTrivial, Bool
False)

    tyVarNames :: [Name]
    tyVarNames :: [Name]
tyVarNames = Map Name (OneOrTwoNames One) -> [Name]
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 :: Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs tvMap :: Map Name (OneOrTwoNames One)
tvMap ft :: FFoldType a
ft con :: ConstructorInfo
con = do
  Cxt
fieldTys <- (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 -> CxtQ) -> Cxt -> CxtQ
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Cxt
constructorFields ConstructorInfo
con
  (Type -> Q a) -> Cxt -> Q [a]
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 = Map Name (OneOrTwoNames One) -> FFoldType a -> Type -> Q a
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 lam :: Exp -> Q Exp
lam = do
  Name
n <- String -> Q Name
newName "n"
  Exp
body <- Exp -> Q Exp
lam (Name -> Exp
VarE Name
n)
  Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
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 lam :: Exp -> Exp -> Q Exp
lam = do
  Name
n1 <- String -> Q Name
newName "n1"
  Name
n2 <- String -> Q Name
newName "n2"
  Exp
body <- Exp -> Exp -> Q Exp
lam (Name -> Exp
VarE Name
n1) (Name -> Exp
VarE Name
n2)
  Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
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 :: (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> MatchQ
mkSimpleConMatch fold :: Name -> [a] -> Q Exp
fold conName :: Name
conName insides :: [Exp -> a]
insides = do
  [Name]
varsNeeded <- String -> Int -> Q [Name]
newNameList "_arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Exp -> a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp -> a]
insides
  let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP Name
conName ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
  Exp
rhs <- Name -> [a] -> Q Exp
fold Name
conName (((Exp -> a) -> Name -> a) -> [Exp -> a] -> [Name] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\i :: Exp -> a
i v :: Name
v -> Exp -> a
i (Exp -> a) -> Exp -> a
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
v) [Exp -> a]
insides [Name]
varsNeeded)
  Match -> MatchQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> MatchQ) -> Match -> MatchQ
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)] -> MatchQ
mkSimpleConMatch2 fold :: Exp -> [Exp] -> Q Exp
fold conName :: Name
conName insides :: [(Bool, Exp)]
insides = do
  [Name]
varsNeeded <- String -> Int -> Q [Name]
newNameList "_arg" Int
lengthInsides
  let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP Name
conName ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
      -- Make sure to zip BEFORE invoking catMaybes. We want the variable
      -- indicies in each expression to match up with the argument indices
      -- in conExpr (defined below).
      exps :: [Exp]
exps = [Maybe Exp] -> [Exp]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Exp] -> [Exp]) -> [Maybe Exp] -> [Exp]
forall a b. (a -> b) -> a -> b
$ ((Bool, Exp) -> Name -> Maybe Exp)
-> [(Bool, Exp)] -> [Name] -> [Maybe Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(m :: Bool
m, i :: Exp
i) v :: Name
v -> if Bool
m then Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp
i Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
v)
                                                    else Maybe Exp
forall a. Maybe a
Nothing)
                                 [(Bool, Exp)]
insides [Name]
varsNeeded
      -- An element of argTysTyVarInfo is True if the constructor argument
      -- with the same index has a type which mentions the last type
      -- variable.
      argTysTyVarInfo :: [Bool]
argTysTyVarInfo = ((Bool, Exp) -> Bool) -> [(Bool, Exp)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (\(m :: Bool
m, _) -> Bool
m) [(Bool, Exp)]
insides
      (asWithTyVar :: [Name]
asWithTyVar, asWithoutTyVar :: [Name]
asWithoutTyVar) = [Bool] -> [Name] -> ([Name], [Name])
forall a. [Bool] -> [a] -> ([a], [a])
partitionByList [Bool]
argTysTyVarInfo [Name]
varsNeeded

      conExpQ :: Q Exp
conExpQ
        | [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
asWithTyVar = [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]
asWithoutTyVar)
        | Bool
otherwise = do
            [Name]
bs <- String -> Int -> Q [Name]
newNameList "b" Int
lengthInsides
            let bs' :: [Name]
bs'  = [Bool] -> [Name] -> [Name]
forall a. [Bool] -> [a] -> [a]
filterByList  [Bool]
argTysTyVarInfo [Name]
bs
                vars :: [Q Exp]
vars = [Bool] -> [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
argTysTyVarInfo
                                     ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
bs) ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
varsNeeded)
            [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
  Exp
rhs <- Exp -> [Exp] -> Q Exp
fold Exp
conExp [Exp]
exps
  Match -> MatchQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> MatchQ) -> Match -> MatchQ
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
rhs) []
  where
    lengthInsides :: Int
lengthInsides = [(Bool, Exp)] -> Int
forall (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 :: (Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase matchForCon :: Name -> [a] -> MatchQ
matchForCon tupSort :: TupleSort
tupSort insides :: [a]
insides x :: Exp
x = do
  let tupDataName :: Name
tupDataName = case TupleSort
tupSort of
                      Boxed   len :: Int
len -> Int -> Name
tupleDataName Int
len
#if MIN_VERSION_template_haskell(2,6,0)
                      Unboxed len :: Int
len -> Int -> Name
unboxedTupleDataName Int
len
#endif
  Match
m <- Name -> [a] -> MatchQ
matchForCon Name
tupDataName [a]
insides
  Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE Exp
x [Match
m]