{-# 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
      functorCls <- Name -> TcPluginM Class
tcLookupClass Name
functorClassName
      let isCov   = case Variance
dir of Variance
Cov -> Bool
True; Variance
Con -> Bool
False
          fixed   = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realF
          dcons   = TyCon -> [DataCon]
tyConDataCons TyCon
fTc
          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
      svTv <- freshTyVar "a"                                 -- scrutinee param (input @f@ is at it)
      rvTv <- freshTyVar (if isCov then "b" else "a'")       -- result param
      let svTy = TyVar -> Type
mkTyVarTy TyVar
svTv ; rvTy = TyVar -> Type
mkTyVarTy TyVar
rvTv
          innerS = TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
svTy])
          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
      gId  <- freshId gTy "g"
      sfId <- freshId (mkAppTy wrappedTy svTy) "sf"
      cb   <- freshId innerS "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 (covFwd, conFwd, mContra)
            | isCov     = (Just (Var gId), Nothing,          Nothing)
            | otherwise = (Nothing,        Just (Var gId),   Just 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
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
              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
              pure (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)) 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)
              -- validate the reshape: GHC must agree @field a ~R m a@, else the
              -- unchecked @coS@\/@coR@ axioms would be unsound (reject bad overrides).
              -- We check it at the CLOSED type @()@ rather than the method binder
              -- @svTv@: the reshape is parametric in the element, so this still
              -- rejects bad overrides, while keeping the (possibly dictionary-shaped,
              -- e.g. via @Representational1@) evidence free of the method-local
              -- @svTv@ — otherwise GHC binds that evidence at instance level, where
              -- @svTv@ is out of scope, and emits ill-scoped Core (a nested-abstract
              -- @Compose@ reshape did exactly this).
              vw <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Type -> Type -> Type
mkStockReprEq ([TyVar] -> [Type] -> Type -> Type
HasDebugCallStack => [TyVar] -> [Type] -> Type -> Type
substTyWith [TyVar
svTv] [Type
unitTy] Type
ftA)
                                                 (Type -> Type -> Type
mkAppTy Type
modf Type
unitTy))
              m <- varMap functorCls mContra loc svTv rvTy covFwd conFwd Cov effFt
              pure (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), CtEvidence -> Ct
mkNonCanonical CtEvidence
vw Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
ws)) m)
          binders = if Bool
isCov then [TyVar
svTv, TyVar
rvTv] else [TyVar
rvTv, TyVar
svTv]

      malts <- forM 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]))
        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
        mfs <- sequence (zipWith4 mapField [0 :: Int ..] xs fts rvFts)
        case sequence 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 sequence 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)
          dmExtra <- Class -> Int -> TcPluginM TyVar
defMethId Class
cls Int
1                         -- (<$) / (>$)
          dict <- recClassDict cls 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] ]
          pure (Just (EvExpr dict, concat 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
      monoidCls <- Name -> TcPluginM Class
tcLookupClass Name
monoidClassName
      let fixed      = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realF
          dcons      = TyCon -> [DataCon]
tyConDataCons TyCon
fTc
          foldMapSel = String -> Class -> TyVar
classMethod String
"foldMap" Class
foldableCls
          memptySel  = String -> Class -> TyVar
classMethod String
"mempty" Class
monoidCls
          mappendSel = String -> Class -> TyVar
classMethod String
"mappend" Class
monoidCls
          coAt Type
t     = GenEnv -> TyCon -> Type -> Type -> Type -> Type -> Coercion
coDown1 GenEnv
gen TyCon
st1Tc Type
wrappedTy Type
f Type
realF Type
t
      atv <- freshTyVar "a" ; mtv <- freshTyVar "m"
      let aTy = TyVar -> Type
mkTyVarTy TyVar
atv ; mTy = TyVar -> Type
mkTyVarTy TyVar
mtv
          innerA = TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy])
      dM  <- freshId (mkClassPred monoidCls [mTy]) "dM"
      gId <- freshId (mkVisFunTyMany aTy mTy) "g"
      tId <- freshId (mkAppTy wrappedTy aTy) "t"
      cb  <- freshId innerA "cb"
      let 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
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
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
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
                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
                rs <- zipWithM foldField args (map Var xs)
                case sequence 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
                    cb <- Type -> String -> TcPluginM TyVar
freshId Type
ft String
"cb"
                    let (es, wss) = unzip (catMaybes mcs)
                        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
                    pure (Just (Just ( Case xe cb mTy
                           [Alt (DataAlt (tupleDataCon Boxed (length args))) xs body]
                           , concat 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
                y  <- Type -> String -> TcPluginM TyVar
freshId Type
larg String
"y"
                mi <- foldField larg (Var y)
                case mi of
                  Just (Just (Expr TyVar
e, [Ct]
w)) -> do
                    ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
foldableCls [Type
h])
                    pure (Just (Just ( mkApps (Var foldMapSel)
                           [Type h, ctEvExpr ev, Type mTy, Type larg, Var dM, Lam y e, xe]
                           , mkNonCanonical ev : 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
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 ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
foldableCls [Type
m])
                          -- validate at the closed type @()@ (see synthMap1) so the
                          -- evidence stays free of the method-local @atv@.
                          vw <- newWanted loc (mkStockReprEq (substTyWith [atv] [unitTy] ftA)
                                                             (mkAppTy m unitTy))
                          let co = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkStockCo (String -> UnivCoProvenance
PluginProv String
"stock") Role
Representational Type
ftA (Type -> Type -> Type
mkAppTy Type
m Type
aTy)
                          pure (Just (Just (foldMapOf m (ctEvExpr ev) (Cast (Var x) co), [mkNonCanonical ev, mkNonCanonical vw])))
            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)
      malts <- forM 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]))
        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
        mcs <- sequence (zipWith3 contrib [0 :: Int ..] xs ftsA)
        case sequence 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 = String -> Class -> TyVar
classMethod String
"foldr" Class
foldableCls
      faTv <- freshTyVar "a" ; fbTv <- freshTyVar "b"
      let faTy = TyVar -> Type
mkTyVarTy TyVar
faTv ; fbTy = TyVar -> Type
mkTyVarTy TyVar
fbTv
      ffId <- freshId (mkVisFunTyMany faTy (mkVisFunTyMany fbTy fbTy)) "f"
      fzId <- freshId fbTy "z"
      ftId <- freshId (mkAppTy wrappedTy faTy) "t"
      fcb  <- freshId (mkTyConApp fTc (fixed ++ [faTy])) "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
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
                mfn <- Type -> TcPluginM (Maybe (Expr TyVar, [Ct]))
mkElemFn Type
larg
                case 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
                    ev  <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
foldableCls [Type
h])
                    p   <- freshId t "p" ; acc <- freshId fbTy "acc"
                    let 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])
                    pure (Just (e, mkNonCanonical ev : 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
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
                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
                cbt <- freshId ft "ct"
                mb  <- combineR (zip args us) k
                pure $ flip fmap 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
                mfn <- Type -> TcPluginM (Maybe (Expr TyVar, [Ct]))
mkElemFn Type
larg
                case 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
                    ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
foldableCls [Type
h])
                    b1 <- freshId ft "b1" ; b2 <- freshId fbTy "b2"
                    let 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])
                    pure (Just (mkApps flipLam [Var x, k], mkNonCanonical ev : 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 []            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
            mr <- [(Type, TyVar)]
-> Expr TyVar -> TcPluginM (Maybe (Expr TyVar, [Ct]))
combineR [(Type, TyVar)]
r Expr TyVar
k
            case 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 mc <- Type -> TyVar -> Expr TyVar -> TcPluginM (Maybe (Expr TyVar, [Ct]))
contribR Type
ft TyVar
x Expr TyVar
k'
                                  pure (fmap (\(Expr TyVar
e, [Ct]
w) -> (Expr TyVar
e, [Ct]
w [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
w')) mc)
      mFoldrAlts <- if isJust mMods then pure Nothing else fmap sequence $ forM 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]))
        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
        mb <- combineR (zip ftsA xs) (Var fzId)
        pure (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)) mb)
      case sequence 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 -> ([], [])
          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)
          pure (Just (EvExpr dict, concat wss ++ 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).