{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}

-- | Pointwise @Applicative@ via @Stock1@, for single-constructor (product)
-- types — a faster @Generically1@: @pure@ replicates into every field and
-- @(\<*\>)@ applies field-wise.  Each field must be the parameter (applied
-- directly), an @Applicative@ functor of it (delegating to that functor), or a
-- constant — which, Const-style (exactly as @Generically1@), is fine given a
-- @Monoid@: @pure@ fills it with @mempty@ and @(\<*\>)@\/@liftA2@ combine with
-- @(\<>)@.  (Any sum type is still rejected.)  The @Functor@ superclass
-- dictionary comes from 'synthFunctor'.
module Stock.Applicative where

import GHC.Plugins hiding (TcPlugin)
import GHC.Tc.Plugin
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.Core.Class (Class)
import GHC.Core.Predicate (mkClassPred)
import GHC.Core.Multiplicity (scaledThing)
import GHC.Core.TyCo.Rep (UnivCoProvenance(PluginProv))
import GHC.Builtin.Names (functorClassName, monoidClassName)
import Control.Monad (forM, zipWithM)
import Stock.Derive (classMethod)
import Stock.Internal
import Stock.Functor (synthFunctor)

-- | How one field of the product is handled by @pure@\/@(\<*\>)@\/@liftA2@: it
-- /is/ the parameter; an @Applicative@ functor @m@ of it (with @m@'s dict, and a
-- @Just@ @h t ~R m t@ coercion builder when reshaped by an @Override1@, else
-- @Nothing@); or a constant of type @ft@ handled Const-style via its @Monoid@.
data FldSpec = FsParam
             | FsApp Type CoreExpr (Maybe (Type -> Coercion))
             | FsConst Type CoreExpr

-- | Coerce a field value /into/ the modifier functor (@h t ~R m t@); identity
-- when the field is not reshaped.
castInOv :: Maybe (Type -> Coercion) -> Type -> CoreExpr -> CoreExpr
castInOv :: Maybe (Type -> Coercion) -> Type -> CoreExpr -> CoreExpr
castInOv Maybe (Type -> Coercion)
Nothing       Type
_ CoreExpr
e = CoreExpr
e
castInOv (Just Type -> Coercion
coFn)   Type
t CoreExpr
e = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
e (Type -> Coercion
coFn Type
t)

-- | Coerce a result /back/ from the modifier functor to the real field type.
castBackOv :: Maybe (Type -> Coercion) -> Type -> CoreExpr -> CoreExpr
castBackOv :: Maybe (Type -> Coercion) -> Type -> CoreExpr -> CoreExpr
castBackOv Maybe (Type -> Coercion)
Nothing     Type
_ CoreExpr
e = CoreExpr
e
castBackOv (Just Type -> Coercion
coFn) Type
t CoreExpr
e = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
e (Coercion -> Coercion
mkSymCo (Type -> Coercion
coFn Type
t))

synthApplicative :: GenEnv -> Class -> CtLoc -> Type -> Type
                 -> TcPluginM (Maybe (EvTerm, [Ct]))
synthApplicative :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthApplicative GenEnv
gen Class
applicativeCls CtLoc
loc Type
wrappedTy Type
f =
  case GenEnv -> Maybe TyCon
geStock1 GenEnv
gen of
    Just TyCon
st1Tc
      -- peel an optional @Override1 cfg F@ (functor reshape, 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
      , [DataCon
dc] <- TyCon -> [DataCon]
tyConDataCons TyCon
fTc -> do          -- products only: one constructor
          functorCls <- Name -> TcPluginM Class
tcLookupClass Name
functorClassName
          monoidCls  <- tcLookupClass monoidClassName
          let fixed     = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realF
              pureSel   = String -> Class -> Id
classMethod String
"pure"    Class
applicativeCls    -- index 0: pure
              apSel     = String -> Class -> Id
classMethod String
"<*>"     Class
applicativeCls    -- index 1: (<*>)
              laSel     = String -> Class -> Id
classMethod String
"liftA2"  Class
applicativeCls    -- index 2: liftA2
              memptySel = String -> Class -> Id
classMethod String
"mempty"  Class
monoidCls
              mappendSel= String -> Class -> Id
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   -- Stock1 (Override1? F) t ~R F t

          -- Classify each field once: parameter, an @Applicative@ functor of it,
          -- or a constant — which (Const-style, as @Generically1@ does) is fine
          -- given a @Monoid@: @pure@ uses @mempty@, @(\<*\>)@ uses @(\<>)@.
          ctv <- freshTyVar "p"
          let ctvTy  = Id -> Type
mkTyVarTy Id
ctv
              fldTys = (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
ctvTy]))
              kinds  = (Type -> Maybe FieldKind) -> [Type] -> [Maybe FieldKind]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> Type -> Type -> Maybe FieldKind
classifyField Id
ctv Type
ctvTy) [Type]
fldTys

          -- @FsParam@ | @FsApp h dApplicative@ | @FsConst ft dMonoid@; an arrow or
          -- other unsupported shape still bails with 'Nothing'.
          specsW <- forM (zip3 [0 :: Int ..] kinds fldTys) \(Int
i, Maybe FieldKind
k, Type
ft) ->
            -- Consult the @Override1@ modifier FIRST, regardless of the field's
            -- raw shape: that lets a modifier reshape an otherwise-unsupported
            -- field (e.g. a nested @[[a]]@ via @Compose [] []@) into a one-level
            -- applicative @m a@ — exactly as Functor\/Foldable\/Traversable do.
            -- The @field t ~R m t@ coercion is threaded through pure\/\<*\>.
            case GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i of
              Just Type
m  -> do ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
applicativeCls [Type
m])
                            -- validate at the closed type @()@ (see Stock.Functor)
                            -- so the evidence stays free of the method-local @ctv@.
                            vw <- newWanted loc (mkStockReprEq (substTyWith [ctv] [unitTy] ft)
                                                               (mkAppTy m unitTy))
                            let coFn Type
t = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkStockCo (String -> UnivCoProvenance
PluginProv String
"stock") Role
Representational
                                                   ([Id] -> [Type] -> Type -> Type
HasDebugCallStack => [Id] -> [Type] -> Type -> Type
substTyWith [Id
ctv] [Type
t] Type
ft) (Type -> Type -> Type
mkAppTy Type
m Type
t)
                            pure (Just (FsApp m (ctEvExpr ev) (Just coFn), [mkNonCanonical ev, mkNonCanonical vw]))
              Maybe Type
Nothing -> case Maybe FieldKind
k of
                Just FieldKind
FParam   -> Maybe (FldSpec, [Ct]) -> TcPluginM (Maybe (FldSpec, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FldSpec, [Ct]) -> Maybe (FldSpec, [Ct])
forall a. a -> Maybe a
Just (FldSpec
FsParam, []))
                Just (FApp Type
h) -> do ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
applicativeCls [Type
h])
                                    pure (Just (FsApp h (ctEvExpr ev) Nothing, [mkNonCanonical ev]))
                Just FieldKind
FConst   -> do ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
monoidCls [Type
ft])
                                    pure (Just (FsConst ft (ctEvExpr ev), [mkNonCanonical ev]))
                Maybe FieldKind
_             -> Maybe (FldSpec, [Ct]) -> TcPluginM (Maybe (FldSpec, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (FldSpec, [Ct])
forall a. Maybe a
Nothing

          case sequence specsW of
            Maybe [(FldSpec, [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 [(FldSpec, [Ct])]
sw  -> do
              let fieldSpec :: [FldSpec]
fieldSpec = ((FldSpec, [Ct]) -> FldSpec) -> [(FldSpec, [Ct])] -> [FldSpec]
forall a b. (a -> b) -> [a] -> [b]
map (FldSpec, [Ct]) -> FldSpec
forall a b. (a, b) -> a
fst [(FldSpec, [Ct])]
sw
                  appWs :: [Ct]
appWs     = ((FldSpec, [Ct]) -> [Ct]) -> [(FldSpec, [Ct])] -> [Ct]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FldSpec, [Ct]) -> [Ct]
forall a b. (a, b) -> b
snd [(FldSpec, [Ct])]
sw

              -- pure :: forall a. a -> Stock1 F a
              aP  <- String -> TcPluginM Id
freshTyVar String
"a"
              let aPt = Id -> Type
mkTyVarTy Id
aP
              xId <- freshId aPt "x"
              let pureVal FldSpec
FsParam          = Id -> CoreExpr
forall b. Id -> Expr b
Var Id
xId
                  pureVal (FsApp Type
m CoreExpr
d Maybe (Type -> Coercion)
mco)  = Maybe (Type -> Coercion) -> Type -> CoreExpr -> CoreExpr
castBackOv Maybe (Type -> Coercion)
mco Type
aPt (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
pureSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
m, CoreExpr
d, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aPt, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
xId])
                  pureVal (FsConst Type
ft CoreExpr
d)   = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
memptySel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ft, CoreExpr
d]
                  pureImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
aP, Id
xId] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                    CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
dc ((Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aPt]) [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ (FldSpec -> CoreExpr) -> [FldSpec] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map FldSpec -> CoreExpr
pureVal [FldSpec]
fieldSpec))
                         (Coercion -> Coercion
mkSymCo (Type -> Coercion
coAt Type
aPt))

              -- (<*>) :: forall a b. Stock1 F (a -> b) -> Stock1 F a -> Stock1 F b
              aS <- freshTyVar "a" ; bS <- freshTyVar "b"
              let aSt = Id -> Type
mkTyVarTy Id
aS ; bSt = Id -> Type
mkTyVarTy Id
bS ; fnTy = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aSt Type
bSt
              sffId <- freshId (mkAppTy wrappedTy fnTy) "sff"
              sfaId <- freshId (mkAppTy wrappedTy aSt)  "sfa"
              ffs <- zipWithM (\Int
n Type
t -> Type -> String -> TcPluginM Id
freshId Type
t (String
"ff" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [0 :: Int ..]
                       (map scaledThing (dataConInstOrigArgTys dc (fixed ++ [fnTy])))
              xas <- zipWithM (\Int
n Type
t -> Type -> String -> TcPluginM Id
freshId Type
t (String
"xa" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [0 :: Int ..]
                       (map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aSt])))
              cbF <- freshId (mkTyConApp fTc (fixed ++ [fnTy])) "cbf"
              cbA <- freshId (mkTyConApp fTc (fixed ++ [aSt]))  "cba"
              let apVal FldSpec
FsParam         Id
ff Id
xa = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ff) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
xa)
                  apVal (FsApp Type
m CoreExpr
d Maybe (Type -> Coercion)
mco) Id
ff Id
xa =
                    Maybe (Type -> Coercion) -> Type -> CoreExpr -> CoreExpr
castBackOv Maybe (Type -> Coercion)
mco Type
bSt (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
apSel)
                      [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
m, CoreExpr
d, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aSt, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
bSt
                      , Maybe (Type -> Coercion) -> Type -> CoreExpr -> CoreExpr
castInOv Maybe (Type -> Coercion)
mco Type
fnTy (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ff), Maybe (Type -> Coercion) -> Type -> CoreExpr -> CoreExpr
castInOv Maybe (Type -> Coercion)
mco Type
aSt (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
xa) ])
                  apVal (FsConst Type
ft CoreExpr
d) Id
ff Id
xa =        -- combine the constants with (<>)
                    CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
mappendSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ft, CoreExpr
d, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ff, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
xa]
                  apImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
aS, Id
bS, Id
sffId, Id
sfaId] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                    TyCon -> [Type] -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
destructInner TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
fnTy]) (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
sffId) (Type -> Coercion
coAt Type
fnTy))
                                  Id
cbF (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
bSt)
                      [ AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [Id]
ffs (CoreExpr -> CoreAlt) -> CoreExpr -> CoreAlt
forall a b. (a -> b) -> a -> b
$
                          TyCon -> [Type] -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
destructInner TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aSt]) (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
sfaId) (Type -> Coercion
coAt Type
aSt))
                                        Id
cbA (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
bSt)
                            [ AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [Id]
xas (CoreExpr -> CoreAlt) -> CoreExpr -> CoreAlt
forall a b. (a -> b) -> a -> b
$
                                CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
dc ((Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
bSt])
                                                         [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ (FldSpec -> Id -> Id -> CoreExpr)
-> [FldSpec] -> [Id] -> [Id] -> [CoreExpr]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 FldSpec -> Id -> Id -> CoreExpr
apVal [FldSpec]
fieldSpec [Id]
ffs [Id]
xas))
                                     (Coercion -> Coercion
mkSymCo (Type -> Coercion
coAt Type
bSt)) ] ]

              -- liftA2 :: forall a b c. (a -> b -> c) -> Stock1 F a -> Stock1 F b -> Stock1 F c
              -- Given DIRECTLY (one structural pass) rather than via the class
              -- default @liftA2 g x = (g \<$\> x) \<*\> y@, which would @fmap@ then
              -- @\<*\>@ (two passes).  Each field: @g p q@ for the parameter, or
              -- @liftA2 \@h g p q@ for an Applicative-functor field.
              laA <- freshTyVar "a" ; laB <- freshTyVar "b" ; laC <- freshTyVar "c"
              let laAt = Id -> Type
mkTyVarTy Id
laA ; laBt = Id -> Type
mkTyVarTy Id
laB ; laCt = Id -> Type
mkTyVarTy Id
laC
                  gTy  = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
laAt (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
laBt Type
laCt)
              gId  <- freshId gTy "g"
              ls1  <- freshId (mkAppTy wrappedTy laAt) "s1"
              ls2  <- freshId (mkAppTy wrappedTy laBt) "s2"
              ps   <- zipWithM (\Int
n Type
t -> Type -> String -> TcPluginM Id
freshId Type
t (String
"p" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [0 :: Int ..]
                        (map scaledThing (dataConInstOrigArgTys dc (fixed ++ [laAt])))
              qs   <- zipWithM (\Int
n Type
t -> Type -> String -> TcPluginM Id
freshId Type
t (String
"q" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [0 :: Int ..]
                        (map scaledThing (dataConInstOrigArgTys dc (fixed ++ [laBt])))
              cb1  <- freshId (mkTyConApp fTc (fixed ++ [laAt])) "cb1"
              cb2  <- freshId (mkTyConApp fTc (fixed ++ [laBt])) "cb2"
              let laVal FldSpec
FsParam         Id
p Id
q = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
gId) [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
p, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
q]
                  laVal (FsApp Type
m CoreExpr
d Maybe (Type -> Coercion)
mco) Id
p Id
q =
                    Maybe (Type -> Coercion) -> Type -> CoreExpr -> CoreExpr
castBackOv Maybe (Type -> Coercion)
mco Type
laCt (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
laSel)
                      [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
m, CoreExpr
d, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
laAt, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
laBt, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
laCt, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
gId
                      , Maybe (Type -> Coercion) -> Type -> CoreExpr -> CoreExpr
castInOv Maybe (Type -> Coercion)
mco Type
laAt (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
p), Maybe (Type -> Coercion) -> Type -> CoreExpr -> CoreExpr
castInOv Maybe (Type -> Coercion)
mco Type
laBt (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
q) ])
                  laVal (FsConst Type
ft CoreExpr
d) Id
p Id
q =          -- constants ignore g, combine with (<>)
                    CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
mappendSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ft, CoreExpr
d, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
p, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
q]
                  liftA2Impl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
laA, Id
laB, Id
laC, Id
gId, Id
ls1, Id
ls2] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                    TyCon -> [Type] -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
destructInner TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
laAt]) (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ls1) (Type -> Coercion
coAt Type
laAt))
                                  Id
cb1 (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
laCt)
                      [ AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [Id]
ps (CoreExpr -> CoreAlt) -> CoreExpr -> CoreAlt
forall a b. (a -> b) -> a -> b
$
                          TyCon -> [Type] -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
destructInner TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
laBt]) (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ls2) (Type -> Coercion
coAt Type
laBt))
                                        Id
cb2 (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
laCt)
                            [ AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [Id]
qs (CoreExpr -> CoreAlt) -> CoreExpr -> CoreAlt
forall a b. (a -> b) -> a -> b
$
                                CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
dc ((Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
laCt])
                                                         [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ (FldSpec -> Id -> Id -> CoreExpr)
-> [FldSpec] -> [Id] -> [Id] -> [CoreExpr]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 FldSpec -> Id -> Id -> CoreExpr
laVal [FldSpec]
fieldSpec [Id]
ps [Id]
qs))
                                     (Coercion -> Coercion
mkSymCo (Type -> Coercion
coAt Type
laCt)) ] ]

              -- the @Functor@ superclass dictionary is the first dict-con field
              synthFunctor gen functorCls loc wrappedTy f >>= \case
                Maybe (EvTerm, [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 (EvTerm
fEv, [Ct]
fWs) -> do
                  dict <- Class
-> Type -> [CoreExpr] -> [(Int, CoreExpr)] -> TcPluginM CoreExpr
recDictWith Class
applicativeCls Type
wrappedTy [EvTerm -> CoreExpr
unwrapEv EvTerm
fEv]
                                      [(Int
0, CoreExpr
pureImpl), (Int
1, CoreExpr
apImpl), (Int
2, CoreExpr
liftA2Impl)]
                  pure (Just (EvExpr dict, fWs ++ appWs))
    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