{-# 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
          Class
functorCls <- Name -> TcPluginM Class
tcLookupClass Name
functorClassName
          Class
monoidCls  <- Name -> TcPluginM Class
tcLookupClass Name
monoidClassName
          let fixed :: [Type]
fixed     = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realF
              pureSel :: Id
pureSel   = String -> Class -> Id
classMethod String
"pure"    Class
applicativeCls    -- index 0: pure
              apSel :: Id
apSel     = String -> Class -> Id
classMethod String
"<*>"     Class
applicativeCls    -- index 1: (<*>)
              laSel :: Id
laSel     = String -> Class -> Id
classMethod String
"liftA2"  Class
applicativeCls    -- index 2: liftA2
              memptySel :: Id
memptySel = String -> Class -> Id
classMethod String
"mempty"  Class
monoidCls
              mappendSel :: Id
mappendSel= String -> Class -> Id
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   -- 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 @(\<>)@.
          Id
ctv <- String -> TcPluginM Id
freshTyVar String
"p"
          let ctvTy :: Type
ctvTy  = Id -> Type
mkTyVarTy Id
ctv
              fldTys :: [Type]
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 :: [Maybe FieldKind]
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'.
          [Maybe (FldSpec, [Ct])]
specsW <- [(Int, Maybe FieldKind, Type)]
-> ((Int, Maybe FieldKind, Type)
    -> TcPluginM (Maybe (FldSpec, [Ct])))
-> TcPluginM [Maybe (FldSpec, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Int]
-> [Maybe FieldKind] -> [Type] -> [(Int, Maybe FieldKind, Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
0 :: Int ..] [Maybe FieldKind]
kinds [Type]
fldTys) \(Int
i, Maybe FieldKind
k, Type
ft) -> 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) -> case GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i of
              -- Override1: reshape the field functor @h a -> m a@ (e.g. ZipList),
              -- with a @h t ~R m t@ coercion threaded through pure/<*>/liftA2.
              Just Type
m  -> do CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
applicativeCls [Type
m])
                            let coFn :: Type -> Coercion
coFn Type
t = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkStockCo (String -> UnivCoProvenance
PluginProv String
"stock") Role
Representational
                                                   (Type -> Type -> Type
mkAppTy Type
h Type
t) (Type -> Type -> Type
mkAppTy Type
m Type
t)
                            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 (Type -> CoreExpr -> Maybe (Type -> Coercion) -> FldSpec
FsApp Type
m (HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev) ((Type -> Coercion) -> Maybe (Type -> Coercion)
forall a. a -> Maybe a
Just Type -> Coercion
coFn), [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
              Maybe Type
Nothing -> do CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
applicativeCls [Type
h])
                            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 (Type -> CoreExpr -> Maybe (Type -> Coercion) -> FldSpec
FsApp Type
h (HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev) Maybe (Type -> Coercion)
forall a. Maybe a
Nothing, [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
            Just FieldKind
FConst   -> do CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
monoidCls [Type
ft])
                                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 (Type -> CoreExpr -> FldSpec
FsConst Type
ft (HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev), [CtEvidence -> Ct
mkNonCanonical CtEvidence
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 [Maybe (FldSpec, [Ct])] -> Maybe [(FldSpec, [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 (FldSpec, [Ct])]
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
              Id
aP  <- String -> TcPluginM Id
freshTyVar String
"a"
              let aPt :: Type
aPt = Id -> Type
mkTyVarTy Id
aP
              Id
xId <- Type -> String -> TcPluginM Id
freshId Type
aPt String
"x"
              let pureVal :: FldSpec -> CoreExpr
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 :: CoreExpr
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
              Id
aS <- String -> TcPluginM Id
freshTyVar String
"a" ; Id
bS <- String -> TcPluginM Id
freshTyVar String
"b"
              let aSt :: Type
aSt = Id -> Type
mkTyVarTy Id
aS ; bSt :: Type
bSt = Id -> Type
mkTyVarTy Id
bS ; fnTy :: Type
fnTy = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aSt Type
bSt
              Id
sffId <- Type -> String -> TcPluginM Id
freshId (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
fnTy) String
"sff"
              Id
sfaId <- Type -> String -> TcPluginM Id
freshId (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aSt)  String
"sfa"
              [Id]
ffs <- (Int -> Type -> TcPluginM Id) -> [Int] -> [Type] -> TcPluginM [Id]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
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)) [Int
0 :: Int ..]
                       ((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
fnTy])))
              [Id]
xas <- (Int -> Type -> TcPluginM Id) -> [Int] -> [Type] -> TcPluginM [Id]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
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)) [Int
0 :: Int ..]
                       ((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
aSt])))
              Id
cbF <- Type -> String -> TcPluginM Id
freshId (TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
fnTy])) String
"cbf"
              Id
cbA <- Type -> String -> TcPluginM Id
freshId (TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aSt]))  String
"cba"
              let apVal :: FldSpec -> Id -> Id -> CoreExpr
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 :: CoreExpr
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.
              Id
laA <- String -> TcPluginM Id
freshTyVar String
"a" ; Id
laB <- String -> TcPluginM Id
freshTyVar String
"b" ; Id
laC <- String -> TcPluginM Id
freshTyVar String
"c"
              let laAt :: Type
laAt = Id -> Type
mkTyVarTy Id
laA ; laBt :: Type
laBt = Id -> Type
mkTyVarTy Id
laB ; laCt :: Type
laCt = Id -> Type
mkTyVarTy Id
laC
                  gTy :: Type
gTy  = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
laAt (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
laBt Type
laCt)
              Id
gId  <- Type -> String -> TcPluginM Id
freshId Type
gTy String
"g"
              Id
ls1  <- Type -> String -> TcPluginM Id
freshId (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
laAt) String
"s1"
              Id
ls2  <- Type -> String -> TcPluginM Id
freshId (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
laBt) String
"s2"
              [Id]
ps   <- (Int -> Type -> TcPluginM Id) -> [Int] -> [Type] -> TcPluginM [Id]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
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)) [Int
0 :: Int ..]
                        ((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
laAt])))
              [Id]
qs   <- (Int -> Type -> TcPluginM Id) -> [Int] -> [Type] -> TcPluginM [Id]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
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)) [Int
0 :: Int ..]
                        ((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
laBt])))
              Id
cb1  <- Type -> String -> TcPluginM Id
freshId (TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
laAt])) String
"cb1"
              Id
cb2  <- Type -> String -> TcPluginM Id
freshId (TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
laBt])) String
"cb2"
              let laVal :: FldSpec -> Id -> Id -> CoreExpr
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 :: CoreExpr
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
              GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthFunctor GenEnv
gen Class
functorCls CtLoc
loc Type
wrappedTy Type
f TcPluginM (Maybe (EvTerm, [Ct]))
-> (Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM (Maybe (EvTerm, [Ct]))
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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
                  CoreExpr
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)]
                  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 (CoreExpr -> EvTerm
EvExpr CoreExpr
dict, [Ct]
fWs [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
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