{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingVia #-}
{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}
-- | @Functor@ \/ @Contravariant@ and @Foldable@ synthesizers over @Stock1@ (the variance walk).
module Stock.Functor where
-- Most names below (data-con/type builders, coercion builders, occ-name
-- helpers, …) are re-exported by 'GHC.Plugins', so we only import explicitly
-- the ones it does not provide.
import GHC.Plugins hiding (TcPlugin)
import GHC.Tc.Plugin
import GHC.Tc.Types
import GHC.Tc.Types.Constraint
#if MIN_VERSION_ghc(9,12,0)
import GHC.Tc.Types.CtLoc (CtLoc)
#else
import GHC.Tc.Types.Constraint (CtLoc)
#endif
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad (addErrTc)
import GHC.Tc.Errors.Types (mkTcRnUnknownMessage)
import GHC.Types.Error (mkPlainError, noHints)
import GHC.Core.Class (Class, className, classMethods, classOpItems, classTyCon)
import GHC.Core.Predicate (classifyPredType, Pred(ClassPred), mkClassPred)
import GHC.Builtin.Types.Prim (intPrimTy)
import GHC.Builtin.PrimOps (PrimOp(TagToEnumOp))
import GHC.Builtin.PrimOps.Ids (primOpId)
import GHC.Builtin.Names ( eqClassName, ordClassName, appendName
                         , enumClassName, mapName, numClassName
                         , enumFromToName, enumFromThenToName
                         , eqStringName
                         , genClassName, repTyConName, u1TyConName, k1TyConName
                         , prodTyConName, sumTyConName
                         , monoidClassName, foldableClassName, functorClassName
                         , semigroupClassName )
import Stock.Compat ( gHC_INTERNAL_SHOW, gHC_INTERNAL_READ
                    , gHC_INTERNAL_LIST, gHC_INTERNAL_GENERICS )
import GHC.Core.Reduction (mkReduction)
import GHC.Core.TyCo.Rep (UnivCoProvenance(PluginProv))
import GHC.Rename.Fixity (lookupFixityRn)
import GHC.Types.Fixity (Fixity(..), defaultFixity)
import GHC.Core.TyCo.Compare (eqType)
import GHC.Core.Multiplicity (scaledThing)
import GHC.Core.SimpleOpt (defaultSimpleOpts)
import GHC.Core.Unfold.Make (mkInlineUnfoldingWithArity)
import GHC.Core.InstEnv (classInstances, is_dfun, is_tys)
import GHC.Runtime.Loader (getValueSafely)
import Stock.Derive
import Data.Maybe (catMaybes, fromJust, isJust, fromMaybe)
import qualified Data.Monoid as Mon (Alt(..))  -- 'Alt' clashes with GHC.Core's case-alt 'Alt'
import Stock.Trans (MaybeT(..))
import Control.Monad (forM, zipWithM, unless, guard)
import Data.List (zipWith4)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef')
import Stock.Internal

synthFunctor :: GenEnv -> Class -> CtLoc -> Type -> Type
             -> TcPluginM (Maybe (EvTerm, [Ct]))
synthFunctor :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthFunctor = Variance
-> GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthMap1 Variance
Cov

-- | Synthesize @Contravariant (Stock1 F)@ — the contravariant instance of
-- @synthMap1@.
synthContravariant :: GenEnv -> Class -> CtLoc -> Type -> Type
                   -> TcPluginM (Maybe (EvTerm, [Ct]))
synthContravariant :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthContravariant = Variance
-> GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthMap1 Variance
Con

-- | The shared engine for the two single-parameter map-like classes over
-- @Stock1 F@.  @fmap@ and @contramap@ differ only in: the order of the two type
-- variables in the method (@forall a b@ vs @forall a' a@), the direction of the
-- supplied function (@a -> b@ vs @a' -> a@), and which 'varMap' base case it
-- feeds — so both are this one definition.  The non-overridden method (@(\<$)@
-- resp. @(>$)@, both at class-method index 1) comes from the class default; the
-- field walk is the full variance recursion in 'varMap'.
synthMap1 :: Variance -> GenEnv -> Class -> CtLoc -> Type -> Type
          -> TcPluginM (Maybe (EvTerm, [Ct]))
synthMap1 :: Variance
-> GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthMap1 Variance
dir GenEnv
gen Class
cls CtLoc
loc Type
wrappedTy Type
f =
  case GenEnv -> Maybe TyCon
geStock1 GenEnv
gen of
    Just TyCon
st1Tc
      -- peel an optional @Override1 cfg F@: @realF@ is the genuine constructor,
      -- @mMods@ the per-field functor modifiers (e.g. @[] -> ZipList@).
      | let (Type
realF, Maybe [Type]
mMods) = GenEnv -> Type -> (Type, Maybe [Type])
peelOverride1 GenEnv
gen Type
f
      , Just TyCon
fTc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realF -> do
      Class
functorCls <- Name -> TcPluginM Class
tcLookupClass Name
functorClassName
      let isCov :: Bool
isCov   = case Variance
dir of Variance
Cov -> Bool
True; Variance
Con -> Bool
False
          fixed :: [Type]
fixed   = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realF
          dcons :: [DataCon]
dcons   = TyCon -> [DataCon]
tyConDataCons TyCon
fTc
          coAt :: Type -> Coercion
coAt Type
t  = GenEnv -> TyCon -> Type -> Type -> Type -> Type -> Coercion
coDown1 GenEnv
gen TyCon
st1Tc Type
wrappedTy Type
f Type
realF Type
t   -- Stock1 (Override1? F) t ~R F t
      TyVar
svTv <- String -> TcPluginM TyVar
freshTyVar String
"a"                                 -- scrutinee param (input @f@ is at it)
      TyVar
rvTv <- String -> TcPluginM TyVar
freshTyVar (if Bool
isCov then String
"b" else String
"a'")       -- result param
      let svTy :: Type
svTy = TyVar -> Type
mkTyVarTy TyVar
svTv ; rvTy :: Type
rvTy = TyVar -> Type
mkTyVarTy TyVar
rvTv
          innerS :: Type
innerS = TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
svTy])
          gTy :: Type
gTy    = if Bool
isCov then HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
svTy Type
rvTy     -- fmap:      a  -> b
                            else HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
rvTy Type
svTy     -- contramap: a' -> a
      TyVar
gId  <- Type -> String -> TcPluginM TyVar
freshId Type
gTy String
"g"
      TyVar
sfId <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
svTy) String
"sf"
      TyVar
cb   <- Type -> String -> TcPluginM TyVar
freshId Type
innerS String
"cb"

      -- the only per-direction knobs: where the bare parameter maps, and whether
      -- contravariant subfields (@Pred a@) are allowed.  The variance walk then
      -- handles constants, covariant functor fields, and arbitrary arrow nesting.
      let (Maybe (Expr b)
covFwd, Maybe (Expr b)
conFwd, Maybe Class
mContra)
            | Bool
isCov     = (Expr b -> Maybe (Expr b)
forall a. a -> Maybe a
Just (TyVar -> Expr b
forall b. TyVar -> Expr b
Var TyVar
gId), Maybe (Expr b)
forall a. Maybe a
Nothing,          Maybe Class
forall a. Maybe a
Nothing)
            | Bool
otherwise = (Maybe (Expr b)
forall a. Maybe a
Nothing,        Expr b -> Maybe (Expr b)
forall a. a -> Maybe a
Just (TyVar -> Expr b
forall b. TyVar -> Expr b
Var TyVar
gId),   Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls)
          -- @i@/@rvFt@ let an @Override1@ modifier reshape this field's functor
          -- (@h a -> m a@), feeding @varMap@ the modifier type and bridging the
          -- field value with @realFt ~R m a@ coercions.
          mapField :: Int
-> TyVar -> Type -> Type -> TcPluginM (Maybe (Expr TyVar, [Ct]))
mapField Int
i TyVar
x Type
ftA Type
rvFt = case GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i of
            Maybe Type
Nothing -> do
              Maybe (Expr TyVar, [Ct])
m <- Class
-> Maybe Class
-> CtLoc
-> TyVar
-> Type
-> Maybe (Expr TyVar)
-> Maybe (Expr TyVar)
-> Variance
-> Type
-> TcPluginM (Maybe (Expr TyVar, [Ct]))
varMap Class
functorCls Maybe Class
mContra CtLoc
loc TyVar
svTv Type
rvTy Maybe (Expr TyVar)
forall {b}. Maybe (Expr b)
covFwd Maybe (Expr TyVar)
forall {b}. Maybe (Expr b)
conFwd Variance
Cov Type
ftA
              Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Expr TyVar, [Ct]) -> (Expr TyVar, [Ct]))
-> Maybe (Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Expr TyVar
e, [Ct]
ws) -> (Expr TyVar -> Expr TyVar -> Expr TyVar
forall b. Expr b -> Expr b -> Expr b
App Expr TyVar
e (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
x), [Ct]
ws)) Maybe (Expr TyVar, [Ct])
m)
            Just Type
modf -> do
              let effFt :: Type
effFt = Type -> Type -> Type
mkAppTy Type
modf Type
svTy                                     -- m a
                  coS :: Coercion
coS   = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkStockCo (String -> UnivCoProvenance
PluginProv String
"stock") Role
Representational Type
ftA  Type
effFt
                  coR :: Coercion
coR   = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkStockCo (String -> UnivCoProvenance
PluginProv String
"stock") Role
Representational Type
rvFt (Type -> Type -> Type
mkAppTy Type
modf Type
rvTy)
              Maybe (Expr TyVar, [Ct])
m <- Class
-> Maybe Class
-> CtLoc
-> TyVar
-> Type
-> Maybe (Expr TyVar)
-> Maybe (Expr TyVar)
-> Variance
-> Type
-> TcPluginM (Maybe (Expr TyVar, [Ct]))
varMap Class
functorCls Maybe Class
mContra CtLoc
loc TyVar
svTv Type
rvTy Maybe (Expr TyVar)
forall {b}. Maybe (Expr b)
covFwd Maybe (Expr TyVar)
forall {b}. Maybe (Expr b)
conFwd Variance
Cov Type
effFt
              Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Expr TyVar, [Ct]) -> (Expr TyVar, [Ct]))
-> Maybe (Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Expr TyVar
e, [Ct]
ws) -> (Expr TyVar -> Coercion -> Expr TyVar
forall b. Expr b -> Coercion -> Expr b
Cast (Expr TyVar -> Expr TyVar -> Expr TyVar
forall b. Expr b -> Expr b -> Expr b
App Expr TyVar
e (Expr TyVar -> Coercion -> Expr TyVar
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
x) Coercion
coS)) (Coercion -> Coercion
mkSymCo Coercion
coR), [Ct]
ws)) Maybe (Expr TyVar, [Ct])
m)
          binders :: [TyVar]
binders = if Bool
isCov then [TyVar
svTv, TyVar
rvTv] else [TyVar
rvTv, TyVar
svTv]

      [Maybe (Alt TyVar, [Ct])]
malts <- [DataCon]
-> (DataCon -> TcPluginM (Maybe (Alt TyVar, [Ct])))
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DataCon]
dcons \DataCon
dc -> do
        let fts :: [Type]
fts   = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
svTy]))
            rvFts :: [Type]
rvFts = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
rvTy]))
        [TyVar]
xs <- (Int -> Type -> TcPluginM TyVar)
-> [Int] -> [Type] -> TcPluginM [TyVar]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
n Type
ft -> Type -> String -> TcPluginM TyVar
freshId Type
ft (String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..] [Type]
fts
        [Maybe (Expr TyVar, [Ct])]
mfs <- [TcPluginM (Maybe (Expr TyVar, [Ct]))]
-> TcPluginM [Maybe (Expr TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((Int
 -> TyVar -> Type -> Type -> TcPluginM (Maybe (Expr TyVar, [Ct])))
-> [Int]
-> [TyVar]
-> [Type]
-> [Type]
-> [TcPluginM (Maybe (Expr TyVar, [Ct]))]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 Int
-> TyVar -> Type -> Type -> TcPluginM (Maybe (Expr TyVar, [Ct]))
mapField [Int
0 :: Int ..] [TyVar]
xs [Type]
fts [Type]
rvFts)
        case [Maybe (Expr TyVar, [Ct])] -> Maybe [(Expr TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Expr TyVar, [Ct])]
mfs of
          Maybe [(Expr TyVar, [Ct])]
Nothing    -> Maybe (Alt TyVar, [Ct]) -> TcPluginM (Maybe (Alt TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Alt TyVar, [Ct])
forall a. Maybe a
Nothing
          Just [(Expr TyVar, [Ct])]
pairs ->
            let ([Expr TyVar]
vals, [[Ct]]
wss) = [(Expr TyVar, [Ct])] -> ([Expr TyVar], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Expr TyVar, [Ct])]
pairs
                body :: Expr TyVar
body = Expr TyVar -> Coercion -> Expr TyVar
forall b. Expr b -> Coercion -> Expr b
Cast (DataCon -> [Expr TyVar] -> Expr TyVar
mkCoreConApps DataCon
dc ((Type -> Expr TyVar) -> [Type] -> [Expr TyVar]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Expr TyVar
forall b. Type -> Expr b
Type ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
rvTy]) [Expr TyVar] -> [Expr TyVar] -> [Expr TyVar]
forall a. [a] -> [a] -> [a]
++ [Expr TyVar]
vals))
                            (Coercion -> Coercion
mkSymCo (Type -> Coercion
coAt Type
rvTy))            -- F rv -> Stock1 F rv
            in Maybe (Alt TyVar, [Ct]) -> TcPluginM (Maybe (Alt TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Alt TyVar, [Ct]) -> Maybe (Alt TyVar, [Ct])
forall a. a -> Maybe a
Just (AltCon -> [TyVar] -> Expr TyVar -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [TyVar]
xs Expr TyVar
body, [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))

      case [Maybe (Alt TyVar, [Ct])] -> Maybe [(Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Alt TyVar, [Ct])]
malts of
        Maybe [(Alt TyVar, [Ct])]
Nothing     -> Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvTerm, [Ct])
forall a. Maybe a
Nothing
        Just [(Alt TyVar, [Ct])]
altWss -> do
          let ([Alt TyVar]
alts, [[Ct]]
wss) = [(Alt TyVar, [Ct])] -> ([Alt TyVar], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt TyVar, [Ct])]
altWss
              methodImpl :: Expr TyVar
methodImpl = [TyVar] -> Expr TyVar -> Expr TyVar
forall b. [b] -> Expr b -> Expr b
mkLams ([TyVar]
binders [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar
gId, TyVar
sfId])
                (TyCon
-> [Type]
-> Expr TyVar
-> TyVar
-> Type
-> [Alt TyVar]
-> Expr TyVar
destructInner TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
svTy]) (Expr TyVar -> Coercion -> Expr TyVar
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
sfId) (Type -> Coercion
coAt Type
svTy))
                               TyVar
cb (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
rvTy) [Alt TyVar]
alts)
          TyVar
dmExtra <- Class -> Int -> TcPluginM TyVar
defMethId Class
cls Int
1                         -- (<$) / (>$)
          Expr TyVar
dict <- Class
-> Type
-> (TyVar -> TcPluginM [Expr TyVar])
-> TcPluginM (Expr TyVar)
recClassDict Class
cls Type
wrappedTy \TyVar
dvar ->
                    [Expr TyVar] -> TcPluginM [Expr TyVar]
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Expr TyVar
methodImpl, Expr TyVar -> [Expr TyVar] -> Expr TyVar
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
dmExtra) [Type -> Expr TyVar
forall b. Type -> Expr b
Type Type
wrappedTy, TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
dvar] ]
          Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvTerm, [Ct]) -> Maybe (EvTerm, [Ct])
forall a. a -> Maybe a
Just (Expr TyVar -> EvTerm
EvExpr Expr TyVar
dict, [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))
    Maybe TyCon
_ -> Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvTerm, [Ct])
forall a. Maybe a
Nothing

-- | Synthesize @Foldable (Stock1 F)@.  @foldMap@ maps the parameter fields and
-- folds @H a@ fields with their own @foldMap@, combining contributions with
-- @(<>)@ (constant fields contribute nothing); all other @Foldable@ methods
-- come from the class defaults.  'Nothing' for unsupported field shapes.
synthFoldable :: GenEnv -> Class -> CtLoc -> Type -> Type
              -> TcPluginM (Maybe (EvTerm, [Ct]))
synthFoldable :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthFoldable GenEnv
gen Class
foldableCls CtLoc
loc Type
wrappedTy Type
f =
  case GenEnv -> Maybe TyCon
geStock1 GenEnv
gen of
    Just TyCon
st1Tc
      | let (Type
realF, Maybe [Type]
mMods) = GenEnv -> Type -> (Type, Maybe [Type])
peelOverride1 GenEnv
gen Type
f   -- @Override1@: reshape h-a fields
      , Just TyCon
fTc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realF -> do
      Class
monoidCls <- Name -> TcPluginM Class
tcLookupClass Name
monoidClassName
      let fixed :: [Type]
fixed      = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realF
          dcons :: [DataCon]
dcons      = TyCon -> [DataCon]
tyConDataCons TyCon
fTc
          foldMapSel :: TyVar
foldMapSel = String -> Class -> TyVar
classMethod String
"foldMap" Class
foldableCls
          memptySel :: TyVar
memptySel  = String -> Class -> TyVar
classMethod String
"mempty" Class
monoidCls
          mappendSel :: TyVar
mappendSel = String -> Class -> TyVar
classMethod String
"mappend" Class
monoidCls
          coAt :: Type -> Coercion
coAt Type
t     = GenEnv -> TyCon -> Type -> Type -> Type -> Type -> Coercion
coDown1 GenEnv
gen TyCon
st1Tc Type
wrappedTy Type
f Type
realF Type
t
      TyVar
atv <- String -> TcPluginM TyVar
freshTyVar String
"a" ; TyVar
mtv <- String -> TcPluginM TyVar
freshTyVar String
"m"
      let aTy :: Type
aTy = TyVar -> Type
mkTyVarTy TyVar
atv ; mTy :: Type
mTy = TyVar -> Type
mkTyVarTy TyVar
mtv
          innerA :: Type
innerA = TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy])
      TyVar
dM  <- Type -> String -> TcPluginM TyVar
freshId (Class -> [Type] -> Type
mkClassPred Class
monoidCls [Type
mTy]) String
"dM"
      TyVar
gId <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aTy Type
mTy) String
"g"
      TyVar
tId <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy) String
"t"
      TyVar
cb  <- Type -> String -> TcPluginM TyVar
freshId Type
innerA String
"cb"
      let memptyE :: Expr b
memptyE      = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> Expr b
forall b. TyVar -> Expr b
Var TyVar
memptySel) [Type -> Expr b
forall b. Type -> Expr b
Type Type
mTy, TyVar -> Expr b
forall b. TyVar -> Expr b
Var TyVar
dM]
          mappendE :: Arg b -> Arg b -> Arg b
mappendE Arg b
x Arg b
y = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
mappendSel) [Type -> Arg b
forall b. Type -> Expr b
Type Type
mTy, TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
dM, Arg b
x, Arg b
y]
          -- field contribution: Nothing = unsupported; Just Nothing = omitted
          -- foldMap :: forall m a. Monoid m => ...  (m is quantified first)
          foldMapOf :: Type -> Arg b -> Arg b -> Arg b
foldMapOf Type
h Arg b
ev Arg b
x = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
foldMapSel)
                               [Type -> Arg b
forall b. Type -> Expr b
Type Type
h, Arg b
ev, Type -> Arg b
forall b. Type -> Expr b
Type Type
mTy, Type -> Arg b
forall b. Type -> Expr b
Type Type
aTy, TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
dM, TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
gId, Arg b
x]
          -- GHC's @ft_*@ fold over a field's structure: a constant contributes
          -- nothing; the parameter contributes @g x@; a tuple folds every
          -- component and combines with @(<>)@; a covariant @H larg@ folds via
          -- @H@'s @foldMap@ (nested @[[a]]@ ⇒ @foldMap (foldMap g)@); a function
          -- field is rejected.  'Nothing' unsupported / @Just Nothing@ no
          -- contribution / @Just (Just (e,ws))@ contributes @e@.
          foldField :: Type -> Expr TyVar -> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
foldField Type
ft Expr TyVar
xe
            | Bool -> Bool
not (TyVar
atv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
ft) = Maybe (Maybe (Expr TyVar, [Ct]))
-> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Expr TyVar, [Ct]) -> Maybe (Maybe (Expr TyVar, [Ct]))
forall a. a -> Maybe a
Just Maybe (Expr TyVar, [Ct])
forall a. Maybe a
Nothing)
            | Type
ft Type -> Type -> Bool
`eqType` Type
aTy                          = Maybe (Maybe (Expr TyVar, [Ct]))
-> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Expr TyVar, [Ct]) -> Maybe (Maybe (Expr TyVar, [Ct]))
forall a. a -> Maybe a
Just ((Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a. a -> Maybe a
Just (Expr TyVar -> Expr TyVar -> Expr TyVar
forall b. Expr b -> Expr b -> Expr b
App (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
gId) Expr TyVar
xe, [])))
            | Just (FunTyFlag, Type, Type, Type)
_ <- Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
ft            = Maybe (Maybe (Expr TyVar, [Ct]))
-> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Maybe (Expr TyVar, [Ct]))
forall a. Maybe a
Nothing
            | Just (TyCon
tc, [Type]
args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ft
            , TyCon -> Bool
isTupleTyCon TyCon
tc, [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 = do
                [TyVar]
xs <- (Type -> TcPluginM TyVar) -> [Type] -> TcPluginM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Type -> String -> TcPluginM TyVar
`freshId` String
"u") [Type]
args
                [Maybe (Maybe (Expr TyVar, [Ct]))]
rs <- (Type
 -> Expr TyVar -> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct]))))
-> [Type]
-> [Expr TyVar]
-> TcPluginM [Maybe (Maybe (Expr TyVar, [Ct]))]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Type -> Expr TyVar -> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
foldField [Type]
args ((TyVar -> Expr TyVar) -> [TyVar] -> [Expr TyVar]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var [TyVar]
xs)
                case [Maybe (Maybe (Expr TyVar, [Ct]))]
-> Maybe [Maybe (Expr TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Maybe (Expr TyVar, [Ct]))]
rs of
                  Maybe [Maybe (Expr TyVar, [Ct])]
Nothing  -> Maybe (Maybe (Expr TyVar, [Ct]))
-> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Maybe (Expr TyVar, [Ct]))
forall a. Maybe a
Nothing
                  Just [Maybe (Expr TyVar, [Ct])]
mcs -> do
                    TyVar
cb <- Type -> String -> TcPluginM TyVar
freshId Type
ft String
"cb"
                    let ([Expr TyVar]
es, [[Ct]]
wss) = [(Expr TyVar, [Ct])] -> ([Expr TyVar], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([Maybe (Expr TyVar, [Ct])] -> [(Expr TyVar, [Ct])]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Expr TyVar, [Ct])]
mcs)
                        body :: Expr TyVar
body = if [Expr TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr TyVar]
es then Expr TyVar
forall {b}. Expr b
memptyE else (Expr TyVar -> Expr TyVar -> Expr TyVar)
-> [Expr TyVar] -> Expr TyVar
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Expr TyVar -> Expr TyVar -> Expr TyVar
forall b. Expr b -> Expr b -> Expr b
mappendE [Expr TyVar]
es
                    Maybe (Maybe (Expr TyVar, [Ct]))
-> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Expr TyVar, [Ct]) -> Maybe (Maybe (Expr TyVar, [Ct]))
forall a. a -> Maybe a
Just ((Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a. a -> Maybe a
Just ( Expr TyVar -> TyVar -> Type -> [Alt TyVar] -> Expr TyVar
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr TyVar
xe TyVar
cb Type
mTy
                           [AltCon -> [TyVar] -> Expr TyVar -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args))) [TyVar]
xs Expr TyVar
body]
                           , [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss )))
            | Just (Type
h, Type
larg) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ft
            , Bool -> Bool
not (TyVar
atv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
h) = do
                TyVar
y  <- Type -> String -> TcPluginM TyVar
freshId Type
larg String
"y"
                Maybe (Maybe (Expr TyVar, [Ct]))
mi <- Type -> Expr TyVar -> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
foldField Type
larg (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
y)
                case Maybe (Maybe (Expr TyVar, [Ct]))
mi of
                  Just (Just (Expr TyVar
e, [Ct]
w)) -> do
                    CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
foldableCls [Type
h])
                    Maybe (Maybe (Expr TyVar, [Ct]))
-> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Expr TyVar, [Ct]) -> Maybe (Maybe (Expr TyVar, [Ct]))
forall a. a -> Maybe a
Just ((Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a. a -> Maybe a
Just ( Expr TyVar -> [Expr TyVar] -> Expr TyVar
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
foldMapSel)
                           [Type -> Expr TyVar
forall b. Type -> Expr b
Type Type
h, HasDebugCallStack => CtEvidence -> Expr TyVar
CtEvidence -> Expr TyVar
ctEvExpr CtEvidence
ev, Type -> Expr TyVar
forall b. Type -> Expr b
Type Type
mTy, Type -> Expr TyVar
forall b. Type -> Expr b
Type Type
larg, TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
dM, TyVar -> Expr TyVar -> Expr TyVar
forall b. b -> Expr b -> Expr b
Lam TyVar
y Expr TyVar
e, Expr TyVar
xe]
                           , CtEvidence -> Ct
mkNonCanonical CtEvidence
ev Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
w )))
                  Maybe (Maybe (Expr TyVar, [Ct]))
_ -> Maybe (Maybe (Expr TyVar, [Ct]))
-> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Maybe (Expr TyVar, [Ct]))
forall a. Maybe a
Nothing
            | Bool
otherwise = Maybe (Maybe (Expr TyVar, [Ct]))
-> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Maybe (Expr TyVar, [Ct]))
forall a. Maybe a
Nothing
          contrib :: Int
-> TyVar -> Type -> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
contrib Int
i TyVar
x Type
ftA = case GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i of
            -- Override1 reshapes the field's (one-level) functor @h a -> m a@.
            Just Type
m  -> do CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
foldableCls [Type
m])
                          let co :: Coercion
co = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkStockCo (String -> UnivCoProvenance
PluginProv String
"stock") Role
Representational Type
ftA (Type -> Type -> Type
mkAppTy Type
m Type
aTy)
                          Maybe (Maybe (Expr TyVar, [Ct]))
-> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Expr TyVar, [Ct]) -> Maybe (Maybe (Expr TyVar, [Ct]))
forall a. a -> Maybe a
Just ((Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a. a -> Maybe a
Just (Type -> Expr TyVar -> Expr TyVar -> Expr TyVar
forall {b}. Type -> Arg b -> Arg b -> Arg b
foldMapOf Type
m (HasDebugCallStack => CtEvidence -> Expr TyVar
CtEvidence -> Expr TyVar
ctEvExpr CtEvidence
ev) (Expr TyVar -> Coercion -> Expr TyVar
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
x) Coercion
co), [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev])))
            Maybe Type
Nothing -> Type -> Expr TyVar -> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
foldField Type
ftA (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
x)
      [Maybe (Alt TyVar, [Ct])]
malts <- [DataCon]
-> (DataCon -> TcPluginM (Maybe (Alt TyVar, [Ct])))
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DataCon]
dcons \DataCon
dc -> do
        let ftsA :: [Type]
ftsA = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy]))
        [TyVar]
xs  <- (Int -> Type -> TcPluginM TyVar)
-> [Int] -> [Type] -> TcPluginM [TyVar]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
n Type
ft -> Type -> String -> TcPluginM TyVar
freshId Type
ft (String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..] [Type]
ftsA
        [Maybe (Maybe (Expr TyVar, [Ct]))]
mcs <- [TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))]
-> TcPluginM [Maybe (Maybe (Expr TyVar, [Ct]))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((Int
 -> TyVar -> Type -> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct]))))
-> [Int]
-> [TyVar]
-> [Type]
-> [TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int
-> TyVar -> Type -> TcPluginM (Maybe (Maybe (Expr TyVar, [Ct])))
contrib [Int
0 :: Int ..] [TyVar]
xs [Type]
ftsA)
        case [Maybe (Maybe (Expr TyVar, [Ct]))]
-> Maybe [Maybe (Expr TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Maybe (Expr TyVar, [Ct]))]
mcs of
          Maybe [Maybe (Expr TyVar, [Ct])]
Nothing       -> Maybe (Alt TyVar, [Ct]) -> TcPluginM (Maybe (Alt TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Alt TyVar, [Ct])
forall a. Maybe a
Nothing
          Just [Maybe (Expr TyVar, [Ct])]
contribs ->
            let ([Expr TyVar]
es, [[Ct]]
wss) = [(Expr TyVar, [Ct])] -> ([Expr TyVar], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([Maybe (Expr TyVar, [Ct])] -> [(Expr TyVar, [Ct])]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Expr TyVar, [Ct])]
contribs)
                body :: Expr TyVar
body = if [Expr TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr TyVar]
es then Expr TyVar
forall {b}. Expr b
memptyE else (Expr TyVar -> Expr TyVar -> Expr TyVar)
-> [Expr TyVar] -> Expr TyVar
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Expr TyVar -> Expr TyVar -> Expr TyVar
forall b. Expr b -> Expr b -> Expr b
mappendE [Expr TyVar]
es
            in Maybe (Alt TyVar, [Ct]) -> TcPluginM (Maybe (Alt TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Alt TyVar, [Ct]) -> Maybe (Alt TyVar, [Ct])
forall a. a -> Maybe a
Just (AltCon -> [TyVar] -> Expr TyVar -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [TyVar]
xs Expr TyVar
body, [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))
      -- @foldr@ (so @toList@\/@foldr@ do not fall back to the @Endo@-based
      -- default, which drags the @Stock1@ coercion along): synthesized to match
      -- GHC's stock derivation byte-for-byte.  @foldr f z (Con .. xi ..)@ nests
      -- a contribution per field around @z@: a constant passes the accumulator
      -- through; the parameter is @f xi rest@; a covariant @H a@ field is
      -- @(\\b1 b2 -> foldr (elemFn) b2 b1) xi rest@ (GHC's flip shape), where
      -- @elemFn@ recurses for nested structure.  Skipped under @Override1@
      -- (which reshapes fields and is handled only by @foldMap@).
      let foldrSel :: TyVar
foldrSel = String -> Class -> TyVar
classMethod String
"foldr" Class
foldableCls
      TyVar
faTv <- String -> TcPluginM TyVar
freshTyVar String
"a" ; TyVar
fbTv <- String -> TcPluginM TyVar
freshTyVar String
"b"
      let faTy :: Type
faTy = TyVar -> Type
mkTyVarTy TyVar
faTv ; fbTy :: Type
fbTy = TyVar -> Type
mkTyVarTy TyVar
fbTv
      TyVar
ffId <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
faTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
fbTy Type
fbTy)) String
"f"
      TyVar
fzId <- Type -> String -> TcPluginM TyVar
freshId Type
fbTy String
"z"
      TyVar
ftId <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
faTy) String
"t"
      TyVar
fcb  <- Type -> String -> TcPluginM TyVar
freshId (TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
faTy])) String
"cb"
      let -- element-combine function for values of type @t@ (leaves are @faTy@,
          -- folded by @ffId@): @t -> b -> b@.
          mkElemFn :: Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
          mkElemFn :: Type -> TcPluginM (Maybe (Expr TyVar, [Ct]))
mkElemFn Type
t
            | Type
t Type -> Type -> Bool
`eqType` Type
faTy = Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a. a -> Maybe a
Just (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
ffId, []))
            | Just (Type
h, Type
larg) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
t
            , Bool -> Bool
not (TyVar
faTv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
h) = do
                Maybe (Expr TyVar, [Ct])
mfn <- Type -> TcPluginM (Maybe (Expr TyVar, [Ct]))
mkElemFn Type
larg
                case Maybe (Expr TyVar, [Ct])
mfn of
                  Maybe (Expr TyVar, [Ct])
Nothing        -> Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Expr TyVar, [Ct])
forall a. Maybe a
Nothing
                  Just (Expr TyVar
efn, [Ct]
w0) -> do
                    CtEvidence
ev  <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
foldableCls [Type
h])
                    TyVar
p   <- Type -> String -> TcPluginM TyVar
freshId Type
t String
"p" ; TyVar
acc <- Type -> String -> TcPluginM TyVar
freshId Type
fbTy String
"acc"
                    let e :: Expr TyVar
e = [TyVar] -> Expr TyVar -> Expr TyVar
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
p, TyVar
acc] (Expr TyVar -> [Expr TyVar] -> Expr TyVar
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
foldrSel)
                              [Type -> Expr TyVar
forall b. Type -> Expr b
Type Type
h, HasDebugCallStack => CtEvidence -> Expr TyVar
CtEvidence -> Expr TyVar
ctEvExpr CtEvidence
ev, Type -> Expr TyVar
forall b. Type -> Expr b
Type Type
larg, Type -> Expr TyVar
forall b. Type -> Expr b
Type Type
fbTy, Expr TyVar
efn, TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
acc, TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
p])
                    Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a. a -> Maybe a
Just (Expr TyVar
e, CtEvidence -> Ct
mkNonCanonical CtEvidence
ev Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
w0))
            | Bool
otherwise = Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Expr TyVar, [Ct])
forall a. Maybe a
Nothing
          -- one field's contribution wrapped around continuation @k :: b@.
          contribR :: Type -> Id -> CoreExpr -> TcPluginM (Maybe (CoreExpr, [Ct]))
          contribR :: Type -> TyVar -> Expr TyVar -> TcPluginM (Maybe (Expr TyVar, [Ct]))
contribR Type
ft TyVar
x Expr TyVar
k
            | Bool -> Bool
not (TyVar
faTv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
ft) = Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a. a -> Maybe a
Just (Expr TyVar
k, []))
            | Type
ft Type -> Type -> Bool
`eqType` Type
faTy = Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a. a -> Maybe a
Just (Expr TyVar -> [Expr TyVar] -> Expr TyVar
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
ffId) [TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
x, Expr TyVar
k], []))
            | Just (FunTyFlag, Type, Type, Type)
_ <- Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
ft = Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Expr TyVar, [Ct])
forall a. Maybe a
Nothing
            | Just (TyCon
tc, [Type]
args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ft
            , TyCon -> Bool
isTupleTyCon TyCon
tc, [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 = do
                [TyVar]
us  <- (Type -> TcPluginM TyVar) -> [Type] -> TcPluginM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Type -> String -> TcPluginM TyVar
`freshId` String
"u") [Type]
args
                TyVar
cbt <- Type -> String -> TcPluginM TyVar
freshId Type
ft String
"ct"
                Maybe (Expr TyVar, [Ct])
mb  <- [(Type, TyVar)]
-> Expr TyVar -> TcPluginM (Maybe (Expr TyVar, [Ct]))
combineR ([Type] -> [TyVar] -> [(Type, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
args [TyVar]
us) Expr TyVar
k
                Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct])))
-> Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a b. (a -> b) -> a -> b
$ (((Expr TyVar, [Ct]) -> (Expr TyVar, [Ct]))
 -> Maybe (Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct]))
-> Maybe (Expr TyVar, [Ct])
-> ((Expr TyVar, [Ct]) -> (Expr TyVar, [Ct]))
-> Maybe (Expr TyVar, [Ct])
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Expr TyVar, [Ct]) -> (Expr TyVar, [Ct]))
-> Maybe (Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Expr TyVar, [Ct])
mb \(Expr TyVar
body, [Ct]
w) ->
                  ( Expr TyVar -> TyVar -> Type -> [Alt TyVar] -> Expr TyVar
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
x) TyVar
cbt Type
fbTy
                      [AltCon -> [TyVar] -> Expr TyVar -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args))) [TyVar]
us Expr TyVar
body], [Ct]
w )
            | Just (Type
h, Type
larg) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ft
            , Bool -> Bool
not (TyVar
faTv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
h) = do
                Maybe (Expr TyVar, [Ct])
mfn <- Type -> TcPluginM (Maybe (Expr TyVar, [Ct]))
mkElemFn Type
larg
                case Maybe (Expr TyVar, [Ct])
mfn of
                  Maybe (Expr TyVar, [Ct])
Nothing        -> Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Expr TyVar, [Ct])
forall a. Maybe a
Nothing
                  Just (Expr TyVar
efn, [Ct]
w0) -> do
                    CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
foldableCls [Type
h])
                    TyVar
b1 <- Type -> String -> TcPluginM TyVar
freshId Type
ft String
"b1" ; TyVar
b2 <- Type -> String -> TcPluginM TyVar
freshId Type
fbTy String
"b2"
                    let flipLam :: Expr TyVar
flipLam = [TyVar] -> Expr TyVar -> Expr TyVar
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
b1, TyVar
b2] (Expr TyVar -> [Expr TyVar] -> Expr TyVar
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
foldrSel)
                          [Type -> Expr TyVar
forall b. Type -> Expr b
Type Type
h, HasDebugCallStack => CtEvidence -> Expr TyVar
CtEvidence -> Expr TyVar
ctEvExpr CtEvidence
ev, Type -> Expr TyVar
forall b. Type -> Expr b
Type Type
larg, Type -> Expr TyVar
forall b. Type -> Expr b
Type Type
fbTy, Expr TyVar
efn, TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
b2, TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
b1])
                    Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a. a -> Maybe a
Just (Expr TyVar -> [Expr TyVar] -> Expr TyVar
forall b. Expr b -> [Expr b] -> Expr b
mkApps Expr TyVar
flipLam [TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
x, Expr TyVar
k], CtEvidence -> Ct
mkNonCanonical CtEvidence
ev Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
w0))
            | Bool
otherwise = Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Expr TyVar, [Ct])
forall a. Maybe a
Nothing
          -- nest contributions right-to-left around @z@ (= leftmost field outermost).
          combineR :: [(Type, Id)] -> CoreExpr -> TcPluginM (Maybe (CoreExpr, [Ct]))
          combineR :: [(Type, TyVar)]
-> Expr TyVar -> TcPluginM (Maybe (Expr TyVar, [Ct]))
combineR []            Expr TyVar
k = Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a. a -> Maybe a
Just (Expr TyVar
k, []))
          combineR ((Type
ft, TyVar
x) : [(Type, TyVar)]
r) Expr TyVar
k = do
            Maybe (Expr TyVar, [Ct])
mr <- [(Type, TyVar)]
-> Expr TyVar -> TcPluginM (Maybe (Expr TyVar, [Ct]))
combineR [(Type, TyVar)]
r Expr TyVar
k
            case Maybe (Expr TyVar, [Ct])
mr of
              Maybe (Expr TyVar, [Ct])
Nothing       -> Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Expr TyVar, [Ct])
forall a. Maybe a
Nothing
              Just (Expr TyVar
k', [Ct]
w') -> do Maybe (Expr TyVar, [Ct])
mc <- Type -> TyVar -> Expr TyVar -> TcPluginM (Maybe (Expr TyVar, [Ct]))
contribR Type
ft TyVar
x Expr TyVar
k'
                                  Maybe (Expr TyVar, [Ct]) -> TcPluginM (Maybe (Expr TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Expr TyVar, [Ct]) -> (Expr TyVar, [Ct]))
-> Maybe (Expr TyVar, [Ct]) -> Maybe (Expr TyVar, [Ct])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Expr TyVar
e, [Ct]
w) -> (Expr TyVar
e, [Ct]
w [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
w')) Maybe (Expr TyVar, [Ct])
mc)
      Maybe [(Alt TyVar, [Ct])]
mFoldrAlts <- if Maybe [Type] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Type]
mMods then Maybe [(Alt TyVar, [Ct])] -> TcPluginM (Maybe [(Alt TyVar, [Ct])])
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(Alt TyVar, [Ct])]
forall a. Maybe a
Nothing else ([Maybe (Alt TyVar, [Ct])] -> Maybe [(Alt TyVar, [Ct])])
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
-> TcPluginM (Maybe [(Alt TyVar, [Ct])])
forall a b. (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (Alt TyVar, [Ct])] -> Maybe [(Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (TcPluginM [Maybe (Alt TyVar, [Ct])]
 -> TcPluginM (Maybe [(Alt TyVar, [Ct])]))
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
-> TcPluginM (Maybe [(Alt TyVar, [Ct])])
forall a b. (a -> b) -> a -> b
$ [DataCon]
-> (DataCon -> TcPluginM (Maybe (Alt TyVar, [Ct])))
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DataCon]
dcons \DataCon
dc -> do
        let ftsA :: [Type]
ftsA = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
faTy]))
        [TyVar]
xs <- (Int -> Type -> TcPluginM TyVar)
-> [Int] -> [Type] -> TcPluginM [TyVar]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
n Type
ft -> Type -> String -> TcPluginM TyVar
freshId Type
ft (String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..] [Type]
ftsA
        Maybe (Expr TyVar, [Ct])
mb <- [(Type, TyVar)]
-> Expr TyVar -> TcPluginM (Maybe (Expr TyVar, [Ct]))
combineR ([Type] -> [TyVar] -> [(Type, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
ftsA [TyVar]
xs) (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
fzId)
        Maybe (Alt TyVar, [Ct]) -> TcPluginM (Maybe (Alt TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Expr TyVar, [Ct]) -> (Alt TyVar, [Ct]))
-> Maybe (Expr TyVar, [Ct]) -> Maybe (Alt TyVar, [Ct])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Expr TyVar
body, [Ct]
w) -> (AltCon -> [TyVar] -> Expr TyVar -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [TyVar]
xs Expr TyVar
body, [Ct]
w)) Maybe (Expr TyVar, [Ct])
mb)
      case [Maybe (Alt TyVar, [Ct])] -> Maybe [(Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Alt TyVar, [Ct])]
malts of
        Maybe [(Alt TyVar, [Ct])]
Nothing     -> Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvTerm, [Ct])
forall a. Maybe a
Nothing
        Just [(Alt TyVar, [Ct])]
altWss -> do
          let ([Alt TyVar]
alts, [[Ct]]
wss) = [(Alt TyVar, [Ct])] -> ([Alt TyVar], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt TyVar, [Ct])]
altWss
              foldMapImpl :: Expr TyVar
foldMapImpl = [TyVar] -> Expr TyVar -> Expr TyVar
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
mtv, TyVar
atv, TyVar
dM, TyVar
gId, TyVar
tId]   -- forall m a. Monoid m => ...
                (TyCon
-> [Type]
-> Expr TyVar
-> TyVar
-> Type
-> [Alt TyVar]
-> Expr TyVar
destructInner TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy]) (Expr TyVar -> Coercion -> Expr TyVar
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
tId) (Type -> Coercion
coAt Type
aTy))
                               TyVar
cb Type
mTy [Alt TyVar]
alts)
              idxOf :: String -> Int
idxOf String
nm = [Int] -> Int
forall a. HasCallStack => [a] -> a
head [ Int
i | (Int
i, TyVar
m) <- [Int] -> [TyVar] -> [(Int, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] (Class -> [TyVar]
classMethods Class
foldableCls)
                                  , OccName -> String
occNameString (TyVar -> OccName
forall name. HasOccName name => name -> OccName
occName TyVar
m) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
nm ]
              ([(Int, Expr TyVar)]
foldrMethods, [Ct]
foldrWs) = case Maybe [(Alt TyVar, [Ct])]
mFoldrAlts of
                Just [(Alt TyVar, [Ct])]
altWs ->
                  let ([Alt TyVar]
fAlts, [[Ct]]
fWss) = [(Alt TyVar, [Ct])] -> ([Alt TyVar], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt TyVar, [Ct])]
altWs
                      foldrImpl :: Expr TyVar
foldrImpl = [TyVar] -> Expr TyVar -> Expr TyVar
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
faTv, TyVar
fbTv, TyVar
ffId, TyVar
fzId, TyVar
ftId]
                        (TyCon
-> [Type]
-> Expr TyVar
-> TyVar
-> Type
-> [Alt TyVar]
-> Expr TyVar
destructInner TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
faTy]) (Expr TyVar -> Coercion -> Expr TyVar
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> Expr TyVar
forall b. TyVar -> Expr b
Var TyVar
ftId) (Type -> Coercion
coAt Type
faTy))
                                       TyVar
fcb Type
fbTy [Alt TyVar]
fAlts)
                  in ([(String -> Int
idxOf String
"foldr", Expr TyVar
foldrImpl)], [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
fWss)
                Maybe [(Alt TyVar, [Ct])]
Nothing -> ([], [])
          Expr TyVar
dict <- Class
-> Type
-> [Expr TyVar]
-> [(Int, Expr TyVar)]
-> TcPluginM (Expr TyVar)
recDictWith Class
foldableCls Type
wrappedTy []
                    ((String -> Int
idxOf String
"foldMap", Expr TyVar
foldMapImpl) (Int, Expr TyVar) -> [(Int, Expr TyVar)] -> [(Int, Expr TyVar)]
forall a. a -> [a] -> [a]
: [(Int, Expr TyVar)]
foldrMethods)
          Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvTerm, [Ct]) -> Maybe (EvTerm, [Ct])
forall a. a -> Maybe a
Just (Expr TyVar -> EvTerm
EvExpr Expr TyVar
dict, [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
foldrWs))
    Maybe TyCon
_ -> Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvTerm, [Ct])
forall a. Maybe a
Nothing

-- | Classify a field of a two-parameter type against the last two parameters
-- @a@ (first) and @b@ (second).