{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingVia #-}
{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}
-- | All @Stock2@ synthesizers (classes over a two-parameter type @P@):
--
--   * @Bifunctor@ \/ @Bifoldable@ — map\/fold the last two parameters.
--   * @Eq2@ \/ @Ord2@ \/ @Show2@ \/ @Read2@ — the lifted "two-parameter"
--     'Data.Functor.Classes' (mirroring "Stock.Classes1" one level up).
--   * @Bitraversable@ — synthesized directly (usable at the wrapper \/ via the
--     one-liner; a bare @deriving via@ can't, abstract-applicative role).
--   * @Category@ — pointwise @id@\/@(.)@ for a single-constructor product
--     whose fields are each a 'Control.Category.Category' in the two params.
--
-- Field shapes: each of the two parameters, constants, or a (covariant) functor
-- applied to one (the flat 'classifyBiField'); @Bifunctor@ also goes through the
-- n-ary variance engine for nested\/self-applied fields like @Either a b@.
module Stock.Bifunctor 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, classTyVars, classSCTheta)
import GHC.Core.Predicate (classifyPredType, Pred(ClassPred), mkClassPred)
import GHC.Core.TyCo.Subst (substTy, emptySubst)
import GHC.Builtin.Types (orderingTyCon)
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, applicativeClassName, traversableClassName )
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.IORef (IORef, newIORef, readIORef, modifyIORef')
import Control.Monad (zipWithM)
import Data.List (zip4, zip5, zipWith4)
import Data.Maybe (listToMaybe)
import Stock.Internal
-- field reshape: 'reshapeCo' (@h t ~R m t@) + 'castReshape' live in "Stock.Internal".

data BiField
  = BFA | BFB                 -- ^ the field /is/ @a@ resp. @b@
  | BFConst                   -- ^ mentions neither
  | BFFoldA Type | BFFoldB Type   -- ^ @h a@ / @h b@ (covariant, @h@ over one param)

classifyBiField :: TyVar -> TyVar -> Type -> Type -> Type -> Maybe BiField
classifyBiField :: TyVar -> TyVar -> Type -> Type -> Type -> Maybe BiField
classifyBiField TyVar
atv TyVar
btv Type
aTy Type
bTy Type
ft
  | Type
ft Type -> Type -> Bool
`eqType` Type
aTy                            = BiField -> Maybe BiField
forall a. a -> Maybe a
Just BiField
BFA
  | Type
ft Type -> Type -> Bool
`eqType` Type
bTy                            = BiField -> Maybe BiField
forall a. a -> Maybe a
Just BiField
BFB
  | Bool -> Bool
not (TyVar -> Bool
inFt TyVar
atv) Bool -> Bool -> Bool
&& Bool -> Bool
not (TyVar -> Bool
inFt TyVar
btv)           = BiField -> Maybe BiField
forall a. a -> Maybe a
Just BiField
BFConst
  | Just (Type
h, Type
larg) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ft
  , Type
larg Type -> Type -> Bool
`eqType` Type
bTy, Type -> Bool
clean Type
h                 = BiField -> Maybe BiField
forall a. a -> Maybe a
Just (Type -> BiField
BFFoldB Type
h)
  | Just (Type
h, Type
larg) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ft
  , Type
larg Type -> Type -> Bool
`eqType` Type
aTy, Type -> Bool
clean Type
h                 = BiField -> Maybe BiField
forall a. a -> Maybe a
Just (Type -> BiField
BFFoldA Type
h)
  | Bool
otherwise                                  = Maybe BiField
forall a. Maybe a
Nothing
  where inFt :: TyVar -> Bool
inFt TyVar
v = TyVar
v TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
ft
        clean :: Type -> Bool
clean Type
h = Bool -> Bool
not (TyVar
atv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
h)
               Bool -> Bool -> Bool
&& Bool -> Bool
not (TyVar
btv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
h)

-- | For @Category@: a field must be exactly @h a b@ — a (poly-kinded)
-- two-parameter constructor @h@ applied to /both/ datatype parameters, in
-- order.  @h@ is the per-field @Category@ (e.g. @(->)@, @(:~:)@, @Kleisli m@,
-- or a @Basic m@ from an @Override@).  Returns @h@ (which must not mention the
-- parameters).  Constants and one-parameter shapes have no @id@\/@(.)@, so they
-- yield 'Nothing' and the whole synthesis bails.
classifyCatField :: TyVar -> TyVar -> Type -> Maybe Type
classifyCatField :: TyVar -> TyVar -> Type -> Maybe Type
classifyCatField TyVar
atv TyVar
btv Type
ft
  | Just (Type
hp, Type
qarg) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ft
  , Type
qarg Type -> Type -> Bool
`eqType` TyVar -> Type
mkTyVarTy TyVar
btv
  , Just (Type
h, Type
parg)  <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
hp
  , Type
parg Type -> Type -> Bool
`eqType` TyVar -> Type
mkTyVarTy TyVar
atv
  , Bool -> Bool
not (TyVar
atv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
h)
  , Bool -> Bool
not (TyVar
btv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
h)  = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
h
  | Bool
otherwise                                = Maybe Type
forall a. Maybe a
Nothing

-- | How one field of a @Category@ product is handled: it is a @Category@ @h@
-- (with a @realFt(t1,t2) ~R h t1 t2@ coercion builder — 'Refl' unless reshaped
-- by an @Override2@), or a /constant/ @m@ handled Const-style via its @Monoid@
-- (@id = mempty@, @(.) = (\<>)@) — the automatic, @Basic@-free version.
data CatFld = CatF Type (Type -> Type -> Coercion) | MonF Type

-- | Synthesize @Category (Stock2 P)@ for a single-constructor product whose
-- every field is a @Category@ in the two parameters (shape @h a b@).  @id@ and
-- @(.)@ are pointwise — @id = P id .. id@, @P g.. . P h.. = P (g.h)..@ — exactly
-- the @Semigroup@ pattern lifted to two parameters.  @Category@ is poly-kinded
-- (@cat :: k -> k -> Type@), so the kind @k@ (here always @Type@) is threaded
-- through the dictionary and through every @id@\/@(.)@ at the field categories.
--
-- @P@ may be wrapped in @Override2 cfg P@: then each positional modifier @m@
-- reshapes its field to @m a b@ (the modifier applied to both parameters), with
-- a per-field @realFt ~R m a b@ coercion, so fields that are not yet categories
-- (an @Int@, an @a -> Maybe b@) become ones (@Basic (Sum Int)@, @Kleisli Maybe@).
synthCategory :: GenEnv -> Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))
synthCategory :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthCategory GenEnv
gen Class
catCls CtLoc
loc Type
wrappedTy Type
p0 =
  case GenEnv -> Maybe TyCon
geStock2 GenEnv
gen of
    Just TyCon
st2Tc
      -- peel an optional @Override2 cfg P@: @realP@ is the genuine constructor,
      -- @mMods@ the per-field positional modifiers (single inner list — one ctor).
      | let (Type
realP, Maybe [Type]
mMods) = case GenEnv -> Maybe TyCon
geOverride2 GenEnv
gen of
              Just TyCon
ov2Tc
                | Just (TyCon
tc, [Type
_, Type
rp, Type
cfg]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
p0, TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ov2Tc
                -> (Type
rp, [[Type]] -> Maybe [Type]
forall a. [a] -> Maybe a
listToMaybe ([[Type]] -> Maybe [Type]) -> Maybe [[Type]] -> Maybe [Type]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Maybe [[Type]]
decodePositional Type
cfg)
              Maybe TyCon
_ -> (Type
p0, Maybe [Type]
forall a. Maybe a
Nothing)
      , Just TyCon
pTc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realP
      , [DataCon
dc] <- TyCon -> [DataCon]
tyConDataCons TyCon
pTc, Bool -> Bool
not (TyCon -> Bool
isNewTyCon TyCon
pTc) -> do
          Class
monoidCls <- Name -> TcPluginM Class
tcLookupClass Name
monoidClassName
          let fixed :: [Type]
fixed   = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
              idSel :: TyVar
idSel   = String -> Class -> TyVar
classMethod String
"id" Class
catCls
              compSel :: TyVar
compSel = String -> Class -> TyVar
classMethod String
"." Class
catCls
              memptySel :: TyVar
memptySel  = String -> Class -> TyVar
classMethod String
"mempty"  Class
monoidCls
              mappendSel :: TyVar
mappendSel = String -> Class -> TyVar
classMethod String
"mappend" Class
monoidCls
              wargs :: [Type]
wargs   = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
wrappedTy          -- [k, k, P]  (P may be Override2 …)
              kTy :: Type
kTy     = [Type] -> Type
forall a. HasCallStack => [a] -> a
head [Type]
wargs                      -- the kind k (Type here)
              dictCon :: TyVar
dictCon = DataCon -> TyVar
dataConWorkId (Class -> DataCon
classDataCon Class
catCls)
              app2 :: Type -> Type -> Type -> Type
app2 Type
m Type
t1 Type
t2 = Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
m Type
t1) Type
t2
              instAt :: Type -> Type -> [Type]
instAt Type
t1 Type
t2 = (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
t1, Type
t2]))
              isKeep :: Type -> Bool
isKeep Type
m = Bool -> (TyCon -> Bool) -> Maybe TyCon -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\TyCon
k -> Type -> Maybe TyCon
tyConAppTyCon_maybe Type
m Maybe TyCon -> Maybe TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
k) (GenEnv -> Maybe TyCon
geKeep GenEnv
gen)
              -- @Stock2 P a b ~R P a b@, then (if present) @Override2 cfg rp a b ~R rp a b@
              coDown :: Type -> Type -> Coercion
coDown Type
t1 Type
t2 = Coercion -> Coercion -> Coercion
mkTransCo
                (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
st2Tc) ([Type]
wargs [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
t1, Type
t2]) [])
                (case GenEnv -> Maybe TyCon
geOverride2 GenEnv
gen of
                   Just TyCon
ov2Tc | Type -> Maybe TyCon
tyConAppTyCon_maybe Type
p0 Maybe TyCon -> Maybe TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
ov2Tc ->
                     Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
ov2Tc)
                                          (HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
p0 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
t1, Type
t2]) []
                   Maybe TyCon
_ -> Type -> Coercion
mkRepReflCo (Type -> Type -> Type -> Type
app2 Type
realP Type
t1 Type
t2))
              cast' :: Expr b -> Coercion -> Expr b
cast' Expr b
e Coercion
co = if Coercion -> Bool
isReflCo Coercion
co then Expr b
e else Expr b -> Coercion -> Expr b
forall b. Expr b -> Coercion -> Expr b
Cast Expr b
e Coercion
co
          TyVar
pTv <- String -> TcPluginM TyVar
freshTyVar String
"p" ; TyVar
qTv <- String -> TcPluginM TyVar
freshTyVar String
"q"
          let realFtsPQ :: [Type]
realFtsPQ = Type -> Type -> [Type]
instAt (TyVar -> Type
mkTyVarTy TyVar
pTv) (TyVar -> Type
mkTyVarTy TyVar
qTv)
              inPQ :: Type -> Bool
inPQ Type
t = TyVar
pTv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
t Bool -> Bool -> Bool
|| TyVar
qTv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
t
              -- per field: a Category @h@ (+ coercion), or a constant @m@ handled
              -- Const-style via its Monoid (the automatic, @Basic@-free path).
              resolve :: Int -> Type -> Maybe CatFld
resolve Int
i Type
ftPQ = case Maybe [Type]
mMods of
                Just [Type]
mods | Just Type
m <- [Type] -> Int -> Maybe Type
forall a. [a] -> Int -> Maybe a
safeIdx [Type]
mods Int
i, Bool -> Bool
not (Type -> Bool
isKeep Type
m) ->
                  CatFld -> Maybe CatFld
forall a. a -> Maybe a
Just (Type -> (Type -> Type -> Coercion) -> CatFld
CatF Type
m (\Type
t1 Type
t2 -> UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkStockCo (String -> UnivCoProvenance
PluginProv String
"stock") Role
Representational
                                                    (Type -> Type -> [Type]
instAt Type
t1 Type
t2 [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) (Type -> Type -> Type -> Type
app2 Type
m Type
t1 Type
t2)))
                Maybe [Type]
_ -> case TyVar -> TyVar -> Type -> Maybe Type
classifyCatField TyVar
pTv TyVar
qTv Type
ftPQ of
                       Just Type
h                    -> CatFld -> Maybe CatFld
forall a. a -> Maybe a
Just (Type -> (Type -> Type -> Coercion) -> CatFld
CatF Type
h (\Type
t1 Type
t2 -> Type -> Coercion
mkRepReflCo (Type -> Type -> [Type]
instAt Type
t1 Type
t2 [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)))
                       Maybe Type
Nothing | Bool -> Bool
not (Type -> Bool
inPQ Type
ftPQ) -> CatFld -> Maybe CatFld
forall a. a -> Maybe a
Just (Type -> CatFld
MonF Type
ftPQ)   -- constant ⇒ Monoid
                               | Bool
otherwise        -> Maybe CatFld
forall a. Maybe a
Nothing           -- mentions a/b but not @h a b@
              badLen :: Bool
badLen = Bool -> ([Type] -> Bool) -> Maybe [Type] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
realFtsPQ) (Int -> Bool) -> ([Type] -> Int) -> [Type] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) Maybe [Type]
mMods
          case if Bool
badLen then Maybe [CatFld]
forall a. Maybe a
Nothing
               else ((Int, Type) -> Maybe CatFld) -> [(Int, Type)] -> Maybe [CatFld]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Int -> Type -> Maybe CatFld) -> (Int, Type) -> Maybe CatFld
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Type -> Maybe CatFld
resolve) ([Int] -> [Type] -> [(Int, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [Type]
realFtsPQ) of
            Maybe [CatFld]
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 [CatFld]
flds -> do
              -- per-field dictionary: @Category h@, or @Monoid m@ for a constant
              [(EvExpr, Ct)]
dws <- (CatFld -> TcPluginM (EvExpr, Ct))
-> [CatFld] -> TcPluginM [(EvExpr, Ct)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\CatFld
fld -> case CatFld
fld of
                       CatF Type
h Type -> Type -> Coercion
_ -> do CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
catCls [Type
kTy, Type
h])
                                      (EvExpr, Ct) -> TcPluginM (EvExpr, Ct)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, CtEvidence -> Ct
mkNonCanonical CtEvidence
ev)
                       MonF Type
m   -> do CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
monoidCls [Type
m])
                                      (EvExpr, Ct) -> TcPluginM (EvExpr, Ct)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, CtEvidence -> Ct
mkNonCanonical CtEvidence
ev)) [CatFld]
flds
              let ([EvExpr]
dEs, [Ct]
dWs) = [(EvExpr, Ct)] -> ([EvExpr], [Ct])
forall a b. [(a, b)] -> ([a], [b])
unzip [(EvExpr, Ct)]
dws
              -- id = /\a. (P <id of each field>..) |> sym (Stock2(..) a a ~ P a a)
              TyVar
aTv <- String -> TcPluginM TyVar
freshTyVar String
"a"
              let aTy :: Type
aTy = TyVar -> Type
mkTyVarTy TyVar
aTv
                  idVal :: CatFld -> Arg b -> Arg b
idVal (CatF Type
h Type -> Type -> Coercion
coFn) Arg b
dE = Arg b -> Coercion -> Arg b
forall b. Expr b -> Coercion -> Expr b
cast' (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
idSel) [Type -> Arg b
forall b. Type -> Expr b
Type Type
kTy, Type -> Arg b
forall b. Type -> Expr b
Type Type
h, Arg b
dE, Type -> Arg b
forall b. Type -> Expr b
Type Type
aTy])
                                                 (Coercion -> Coercion
mkSymCo (Type -> Type -> Coercion
coFn Type
aTy Type
aTy))
                  idVal (MonF Type
m)      Arg b
dE = 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
memptySel) [Type -> Arg b
forall b. Type -> Expr b
Type Type
m, Arg b
dE]   -- id = mempty
                  idImpl :: EvExpr
idImpl = TyVar -> EvExpr -> EvExpr
forall b. b -> Expr b -> Expr b
Lam TyVar
aTv (EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (DataCon -> [EvExpr] -> EvExpr
mkCoreConApps DataCon
dc ((Type -> EvExpr) -> [Type] -> [EvExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> EvExpr
forall b. Type -> Expr b
Type ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
aTy])
                                                            [EvExpr] -> [EvExpr] -> [EvExpr]
forall a. [a] -> [a] -> [a]
++ (CatFld -> EvExpr -> EvExpr) -> [CatFld] -> [EvExpr] -> [EvExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith CatFld -> EvExpr -> EvExpr
forall {b}. CatFld -> Arg b -> Arg b
idVal [CatFld]
flds [EvExpr]
dEs))
                                         (Coercion -> Coercion
mkSymCo (Type -> Type -> Coercion
coDown Type
aTy Type
aTy)))
              -- (.) = /\b c a. \g h. case g|>co of P g.. -> case h|>co of P h.. -> (P (g.h)..)|>sym
              TyVar
bTv <- String -> TcPluginM TyVar
freshTyVar String
"b" ; TyVar
cTv <- String -> TcPluginM TyVar
freshTyVar String
"c" ; TyVar
a2Tv <- String -> TcPluginM TyVar
freshTyVar String
"a"
              let bTy :: Type
bTy = TyVar -> Type
mkTyVarTy TyVar
bTv ; cTy :: Type
cTy = TyVar -> Type
mkTyVarTy TyVar
cTv ; a2Ty :: Type
a2Ty = TyVar -> Type
mkTyVarTy TyVar
a2Tv
                  resTy :: Type
resTy = Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
a2Ty) Type
cTy   -- Stock2(..) a c
              TyVar
gId <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
bTy) Type
cTy) String
"g"
              TyVar
hId <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
a2Ty) Type
bTy) String
"h"
              [TyVar]
gIds <- (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
t -> Type -> String -> TcPluginM TyVar
freshId Type
t (String
"g" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..] (Type -> Type -> [Type]
instAt Type
bTy Type
cTy)
              [TyVar]
hIds <- (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
t -> Type -> String -> TcPluginM TyVar
freshId Type
t (String
"h" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..] (Type -> Type -> [Type]
instAt Type
a2Ty Type
bTy)
              TyVar
gCb <- Type -> String -> TcPluginM TyVar
freshId (TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
bTy, Type
cTy]))  String
"gcb"
              TyVar
hCb <- Type -> String -> TcPluginM TyVar
freshId (TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
a2Ty, Type
bTy])) String
"hcb"
              let compVal :: CatFld -> Arg b -> TyVar -> TyVar -> Arg b
compVal (CatF Type
h Type -> Type -> Coercion
coFn) Arg b
dE TyVar
gi TyVar
hi =
                    Arg b -> Coercion -> Arg b
forall b. Expr b -> Coercion -> Expr b
cast' (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
compSel)
                             [ Type -> Arg b
forall b. Type -> Expr b
Type Type
kTy, Type -> Arg b
forall b. Type -> Expr b
Type Type
h, Arg b
dE, Type -> Arg b
forall b. Type -> Expr b
Type Type
bTy, Type -> Arg b
forall b. Type -> Expr b
Type Type
cTy, Type -> Arg b
forall b. Type -> Expr b
Type Type
a2Ty
                             , Arg b -> Coercion -> Arg b
forall b. Expr b -> Coercion -> Expr b
cast' (TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
gi) (Type -> Type -> Coercion
coFn Type
bTy Type
cTy), Arg b -> Coercion -> Arg b
forall b. Expr b -> Coercion -> Expr b
cast' (TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
hi) (Type -> Type -> Coercion
coFn Type
a2Ty Type
bTy) ])
                          (Coercion -> Coercion
mkSymCo (Type -> Type -> Coercion
coFn Type
a2Ty Type
cTy))
                  compVal (MonF Type
m)      Arg b
dE TyVar
gi TyVar
hi =
                    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
m, Arg b
dE, TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
gi, TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
hi]   -- g . h = g <> h
                  comps :: [EvExpr]
comps = (CatFld -> EvExpr -> TyVar -> TyVar -> EvExpr)
-> [CatFld] -> [EvExpr] -> [TyVar] -> [TyVar] -> [EvExpr]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 CatFld -> EvExpr -> TyVar -> TyVar -> EvExpr
forall {b}. CatFld -> Arg b -> TyVar -> TyVar -> Arg b
compVal [CatFld]
flds [EvExpr]
dEs [TyVar]
gIds [TyVar]
hIds
                  resCast :: EvExpr
resCast = EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (DataCon -> [EvExpr] -> EvExpr
mkCoreConApps DataCon
dc ((Type -> EvExpr) -> [Type] -> [EvExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> EvExpr
forall b. Type -> Expr b
Type ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
a2Ty, Type
cTy]) [EvExpr] -> [EvExpr] -> [EvExpr]
forall a. [a] -> [a] -> [a]
++ [EvExpr]
comps))
                                 (Coercion -> Coercion
mkSymCo (Type -> Type -> Coercion
coDown Type
a2Ty Type
cTy))
                  inner :: EvExpr
inner = EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
hId) (Type -> Type -> Coercion
coDown Type
a2Ty Type
bTy)) TyVar
hCb Type
resTy [AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [TyVar]
hIds EvExpr
resCast]
                  body :: EvExpr
body  = EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
gId) (Type -> Type -> Coercion
coDown Type
bTy Type
cTy))  TyVar
gCb Type
resTy [AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [TyVar]
gIds EvExpr
inner]
                  compImpl :: EvExpr
compImpl = [TyVar] -> EvExpr -> EvExpr
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
bTv, TyVar
cTv, TyVar
a2Tv, TyVar
gId, TyVar
hId] EvExpr
body
                  dict :: EvExpr
dict = EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
dictCon) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
kTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
wrappedTy, EvExpr
idImpl, EvExpr
compImpl]
              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 (EvExpr -> EvTerm
EvExpr EvExpr
dict, [Ct]
dWs))
    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

-- | Total list indexing.
safeIdx :: [a] -> Int -> Maybe a
safeIdx :: forall a. [a] -> Int -> Maybe a
safeIdx [a]
xs Int
i = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs then a -> Maybe a
forall a. a -> Maybe a
Just ([a]
xs [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) else Maybe a
forall a. Maybe a
Nothing


-- | Synthesize @Bifoldable (Stock2 P)@.  @bifoldMap@ maps @a@-fields with the
-- first function, @b@-fields with the second, folds @h a@/@h b@ fields with
-- @h@'s own @foldMap@, drops constants, and combines with @(<>)@; all other
-- methods come from the class defaults.  No superclass (unlike @Bifunctor@).
synthBifoldable :: GenEnv -> Class -> CtLoc -> Type -> Type
                -> TcPluginM (Maybe (EvTerm, [Ct]))
synthBifoldable :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthBifoldable GenEnv
gen Class
cls CtLoc
loc Type
wrappedTy Type
p =
  case (GenEnv -> Maybe TyCon
geStock2 GenEnv
gen, Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realP) of
    (Just TyCon
st2Tc, Just TyCon
pTc) -> do
      Class
monoidCls   <- Name -> TcPluginM Class
tcLookupClass Name
monoidClassName
      Class
foldableCls <- Name -> TcPluginM Class
tcLookupClass Name
foldableClassName
      let fixed :: [Type]
fixed       = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
          dcons :: [DataCon]
dcons       = TyCon -> [DataCon]
tyConDataCons TyCon
pTc
          foldMapSel :: TyVar
foldMapSel   = String -> Class -> TyVar
classMethod String
"foldMap" Class
foldableCls
          memptySel :: TyVar
memptySel    = String -> Class -> TyVar
classMethod String
"mempty" Class
monoidCls
          mappendSel :: TyVar
mappendSel   = String -> Class -> TyVar
classMethod String
"mappend" Class
monoidCls
          coAt :: Type -> Type -> Coercion
coAt Type
t1 Type
t2   = Maybe TyCon
-> TyCon -> Type -> Type -> Type -> Type -> Type -> Coercion
coDown2With (GenEnv -> Maybe TyCon
geOverride2 GenEnv
gen) TyCon
st2Tc Type
wrappedTy Type
p Type
realP Type
t1 Type
t2
      TyVar
mtv <- String -> TcPluginM TyVar
freshTyVar String
"m" ; TyVar
atv <- String -> TcPluginM TyVar
freshTyVar String
"a" ; TyVar
btv <- String -> TcPluginM TyVar
freshTyVar String
"b"
      let mTy :: Type
mTy = TyVar -> Type
mkTyVarTy TyVar
mtv ; aTy :: Type
aTy = TyVar -> Type
mkTyVarTy TyVar
atv ; bTy :: Type
bTy = TyVar -> Type
mkTyVarTy TyVar
btv
          innerAB :: Type
innerAB = TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy])
      TyVar
dM  <- Type -> String -> TcPluginM TyVar
freshId (Class -> [Type] -> Type
mkClassPred Class
monoidCls [Type
mTy]) String
"dM"
      TyVar
gA  <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aTy Type
mTy) String
"gA"
      TyVar
gB  <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
bTy Type
mTy) String
"gB"
      TyVar
tId <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy) Type
bTy) String
"t"
      TyVar
cb  <- Type -> String -> TcPluginM TyVar
freshId Type
innerAB String
"cb"
      let memptyE :: Expr b
memptyE      = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> Expr b
forall b. TyVar -> Expr b
Var TyVar
memptySel) [Type -> Expr b
forall b. Type -> Expr b
Type Type
mTy, TyVar -> Expr b
forall b. TyVar -> Expr b
Var TyVar
dM]
          mappendE :: Arg b -> Arg b -> Arg b
mappendE Arg b
x Arg b
y = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
mappendSel) [Type -> Arg b
forall b. Type -> Expr b
Type Type
mTy, TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
dM, Arg b
x, Arg b
y]
          -- fold an @h pTy@ field via the modifier @m@'s @foldMap@, casting the
          -- field value @h pTy ~R m pTy@ first.
          foldOver :: Int
-> Type
-> TyVar
-> Type
-> TyVar
-> TcPluginM (Maybe (Maybe (EvExpr, [Ct])))
foldOver Int
i Type
h TyVar
g Type
pTy TyVar
x = do
            let m :: Type
m = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
h (GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i)
            CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
foldableCls [Type
m])
            Maybe (Maybe (EvExpr, [Ct]))
-> TcPluginM (Maybe (Maybe (EvExpr, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EvExpr, [Ct]) -> Maybe (Maybe (EvExpr, [Ct]))
forall a. a -> Maybe a
Just ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just ( EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
foldMapSel)
                                 [Type -> EvExpr
forall b. Type -> Expr b
Type Type
m, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Type -> EvExpr
forall b. Type -> Expr b
Type Type
mTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
pTy, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
dM, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
g
                                 , EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x) (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
m Type
pTy)]
                             , [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev] )))
          contrib :: Int -> TyVar -> Type -> TcPluginM (Maybe (Maybe (EvExpr, [Ct])))
contrib Int
i TyVar
x Type
ft = case TyVar -> TyVar -> Type -> Type -> Type -> Maybe BiField
classifyBiField TyVar
atv TyVar
btv Type
aTy Type
bTy Type
ft of
            Maybe BiField
Nothing          -> Maybe (Maybe (EvExpr, [Ct]))
-> TcPluginM (Maybe (Maybe (EvExpr, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Maybe (EvExpr, [Ct]))
forall a. Maybe a
Nothing
            Just BiField
BFConst     -> Maybe (Maybe (EvExpr, [Ct]))
-> TcPluginM (Maybe (Maybe (EvExpr, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EvExpr, [Ct]) -> Maybe (Maybe (EvExpr, [Ct]))
forall a. a -> Maybe a
Just Maybe (EvExpr, [Ct])
forall a. Maybe a
Nothing)
            Just BiField
BFA         -> Maybe (Maybe (EvExpr, [Ct]))
-> TcPluginM (Maybe (Maybe (EvExpr, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EvExpr, [Ct]) -> Maybe (Maybe (EvExpr, [Ct]))
forall a. a -> Maybe a
Just ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
gA) (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x), [])))
            Just BiField
BFB         -> Maybe (Maybe (EvExpr, [Ct]))
-> TcPluginM (Maybe (Maybe (EvExpr, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EvExpr, [Ct]) -> Maybe (Maybe (EvExpr, [Ct]))
forall a. a -> Maybe a
Just ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
gB) (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x), [])))
            Just (BFFoldA Type
h) -> Int
-> Type
-> TyVar
-> Type
-> TyVar
-> TcPluginM (Maybe (Maybe (EvExpr, [Ct])))
foldOver Int
i Type
h TyVar
gA Type
aTy TyVar
x
            Just (BFFoldB Type
h) -> Int
-> Type
-> TyVar
-> Type
-> TyVar
-> TcPluginM (Maybe (Maybe (EvExpr, [Ct])))
foldOver Int
i Type
h TyVar
gB Type
bTy TyVar
x
      [Maybe (Alt TyVar, [Ct])]
malts <- [DataCon]
-> (DataCon -> TcPluginM (Maybe (Alt TyVar, [Ct])))
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DataCon]
dcons \DataCon
dc -> do
        let 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
aTy, Type
bTy]))
        [TyVar]
xs  <- (Int -> Type -> TcPluginM TyVar)
-> [Int] -> [Type] -> TcPluginM [TyVar]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
n Type
ft -> Type -> String -> TcPluginM TyVar
freshId Type
ft (String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..] [Type]
fts
        [Maybe (Maybe (EvExpr, [Ct]))]
mcs <- [TcPluginM (Maybe (Maybe (EvExpr, [Ct])))]
-> TcPluginM [Maybe (Maybe (EvExpr, [Ct]))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((Int -> TyVar -> Type -> TcPluginM (Maybe (Maybe (EvExpr, [Ct]))))
-> [Int]
-> [TyVar]
-> [Type]
-> [TcPluginM (Maybe (Maybe (EvExpr, [Ct])))]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> TyVar -> Type -> TcPluginM (Maybe (Maybe (EvExpr, [Ct])))
contrib [Int
0 :: Int ..] [TyVar]
xs [Type]
fts)
        case [Maybe (Maybe (EvExpr, [Ct]))] -> Maybe [Maybe (EvExpr, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Maybe (EvExpr, [Ct]))]
mcs of
          Maybe [Maybe (EvExpr, [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 (EvExpr, [Ct])]
contribs ->
            let ([EvExpr]
es, [[Ct]]
wss) = [(EvExpr, [Ct])] -> ([EvExpr], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([Maybe (EvExpr, [Ct])] -> [(EvExpr, [Ct])]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (EvExpr, [Ct])]
contribs)
                body :: EvExpr
body = if [EvExpr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvExpr]
es then EvExpr
forall {b}. Expr b
memptyE else (EvExpr -> EvExpr -> EvExpr) -> [EvExpr] -> EvExpr
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
mappendE [EvExpr]
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] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [TyVar]
xs EvExpr
body, [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))
      -- @bifoldr@ (so a lazy bi-fold does not fall back to the @Endo@ default,
      -- which drags the @Stock2@ coercion along).  @bifoldr f g z (Con .. xi ..)@
      -- nests a contribution per field around @z@: a constant passes the
      -- accumulator through; an @a@\/@b@ field is @f xi rest@\/@g xi rest@; an
      -- @h a@\/@h b@ field is @(\\b1 b2 -> foldr f b2 b1) xi rest@ (GHC's flip
      -- shape).  @bifoldr@'s forall order is @a c b@.  Skipped under @Override2@.
      let foldrSel :: TyVar
foldrSel = String -> Class -> TyVar
classMethod String
"foldr" Class
foldableCls
          bidxOf :: String -> Int
bidxOf 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
cls)
                               , 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 ]
      TyVar
rcTv <- String -> TcPluginM TyVar
freshTyVar String
"c" ; TyVar
raTv <- String -> TcPluginM TyVar
freshTyVar String
"a" ; TyVar
rbTv <- String -> TcPluginM TyVar
freshTyVar String
"b"
      let rcTy :: Type
rcTy = TyVar -> Type
mkTyVarTy TyVar
rcTv ; raTy :: Type
raTy = TyVar -> Type
mkTyVarTy TyVar
raTv ; rbTy :: Type
rbTy = TyVar -> Type
mkTyVarTy TyVar
rbTv
      TyVar
rfId <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
raTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
rcTy Type
rcTy)) String
"f"
      TyVar
rgId <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
rbTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
rcTy Type
rcTy)) String
"g"
      TyVar
rzId <- Type -> String -> TcPluginM TyVar
freshId Type
rcTy String
"z"
      TyVar
rtId <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
raTy) Type
rbTy) String
"t"
      TyVar
rcb  <- Type -> String -> TcPluginM TyVar
freshId (TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
raTy, Type
rbTy])) String
"cb"
      let foldrField :: Type
-> TyVar
-> Type
-> TyVar
-> EvExpr
-> TcPluginM (Maybe (EvExpr, [Ct]))
foldrField Type
h TyVar
fn Type
elemTy TyVar
x EvExpr
k = do
            CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
foldableCls [Type
h])
            TyVar
b1 <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy Type
h Type
elemTy) String
"b1" ; TyVar
b2 <- Type -> String -> TcPluginM TyVar
freshId Type
rcTy String
"b2"
            let flipLam :: EvExpr
flipLam = [TyVar] -> EvExpr -> EvExpr
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
b1, TyVar
b2] (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
foldrSel)
                  [Type -> EvExpr
forall b. Type -> Expr b
Type Type
h, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Type -> EvExpr
forall b. Type -> Expr b
Type Type
elemTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
rcTy, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
fn, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
b2, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
b1])
            Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps EvExpr
flipLam [TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x, EvExpr
k], [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
          contribBR :: TyVar -> Type -> EvExpr -> TcPluginM (Maybe (EvExpr, [Ct]))
contribBR TyVar
x Type
ft EvExpr
k = case TyVar -> TyVar -> Type -> Type -> Type -> Maybe BiField
classifyBiField TyVar
raTv TyVar
rbTv Type
raTy Type
rbTy Type
ft of
            Maybe BiField
Nothing          -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvExpr, [Ct])
forall a. Maybe a
Nothing
            Just BiField
BFConst     -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr
k, []))
            Just BiField
BFA         -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
rfId) [TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x, EvExpr
k], []))
            Just BiField
BFB         -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
rgId) [TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x, EvExpr
k], []))
            Just (BFFoldA Type
h) -> Type
-> TyVar
-> Type
-> TyVar
-> EvExpr
-> TcPluginM (Maybe (EvExpr, [Ct]))
foldrField Type
h TyVar
rfId Type
raTy TyVar
x EvExpr
k
            Just (BFFoldB Type
h) -> Type
-> TyVar
-> Type
-> TyVar
-> EvExpr
-> TcPluginM (Maybe (EvExpr, [Ct]))
foldrField Type
h TyVar
rgId Type
rbTy TyVar
x EvExpr
k
          combineBR :: [(Type, TyVar)] -> EvExpr -> TcPluginM (Maybe (EvExpr, [Ct]))
combineBR []            EvExpr
k = Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr
k, []))
          combineBR ((Type
ft, TyVar
x) : [(Type, TyVar)]
r) EvExpr
k = do
            Maybe (EvExpr, [Ct])
mr <- [(Type, TyVar)] -> EvExpr -> TcPluginM (Maybe (EvExpr, [Ct]))
combineBR [(Type, TyVar)]
r EvExpr
k
            case Maybe (EvExpr, [Ct])
mr of
              Maybe (EvExpr, [Ct])
Nothing       -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvExpr, [Ct])
forall a. Maybe a
Nothing
              Just (EvExpr
k', [Ct]
w') -> do Maybe (EvExpr, [Ct])
mc <- TyVar -> Type -> EvExpr -> TcPluginM (Maybe (EvExpr, [Ct]))
contribBR TyVar
x Type
ft EvExpr
k'
                                  Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((EvExpr, [Ct]) -> (EvExpr, [Ct]))
-> Maybe (EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(EvExpr
e, [Ct]
w) -> (EvExpr
e, [Ct]
w [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
w')) Maybe (EvExpr, [Ct])
mc)
      Maybe [(Alt TyVar, [Ct])]
mBiFoldrAlts <- if Maybe [Type] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Type]
mMods then Maybe [(Alt TyVar, [Ct])] -> TcPluginM (Maybe [(Alt TyVar, [Ct])])
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(Alt TyVar, [Ct])]
forall a. Maybe a
Nothing else ([Maybe (Alt TyVar, [Ct])] -> Maybe [(Alt TyVar, [Ct])])
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
-> TcPluginM (Maybe [(Alt TyVar, [Ct])])
forall a b. (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (Alt TyVar, [Ct])] -> Maybe [(Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (TcPluginM [Maybe (Alt TyVar, [Ct])]
 -> TcPluginM (Maybe [(Alt TyVar, [Ct])]))
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
-> TcPluginM (Maybe [(Alt TyVar, [Ct])])
forall a b. (a -> b) -> a -> b
$ [DataCon]
-> (DataCon -> TcPluginM (Maybe (Alt TyVar, [Ct])))
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DataCon]
dcons \DataCon
dc -> do
        let 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
raTy, Type
rbTy]))
        [TyVar]
xs <- (Int -> Type -> TcPluginM TyVar)
-> [Int] -> [Type] -> TcPluginM [TyVar]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
n Type
ft -> Type -> String -> TcPluginM TyVar
freshId Type
ft (String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..] [Type]
fts
        Maybe (EvExpr, [Ct])
mb <- [(Type, TyVar)] -> EvExpr -> TcPluginM (Maybe (EvExpr, [Ct]))
combineBR ([Type] -> [TyVar] -> [(Type, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
fts [TyVar]
xs) (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
rzId)
        Maybe (Alt TyVar, [Ct]) -> TcPluginM (Maybe (Alt TyVar, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((EvExpr, [Ct]) -> (Alt TyVar, [Ct]))
-> Maybe (EvExpr, [Ct]) -> Maybe (Alt TyVar, [Ct])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(EvExpr
body, [Ct]
w) -> (AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [TyVar]
xs EvExpr
body, [Ct]
w)) Maybe (EvExpr, [Ct])
mb)
      case [Maybe (Alt TyVar, [Ct])] -> Maybe [(Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Alt TyVar, [Ct])]
malts of
        Maybe [(Alt TyVar, [Ct])]
Nothing     -> Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvTerm, [Ct])
forall a. Maybe a
Nothing
        Just [(Alt TyVar, [Ct])]
altWss -> do
          let ([Alt TyVar]
alts, [[Ct]]
wss) = [(Alt TyVar, [Ct])] -> ([Alt TyVar], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt TyVar, [Ct])]
altWss
              biFoldMapImpl :: EvExpr
biFoldMapImpl = [TyVar] -> EvExpr -> EvExpr
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
mtv, TyVar
atv, TyVar
btv, TyVar
dM, TyVar
gA, TyVar
gB, TyVar
tId]
                (TyCon -> [Type] -> EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
destructInner TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy])
                               (EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
tId) (Type -> Type -> Coercion
coAt Type
aTy Type
bTy)) TyVar
cb Type
mTy [Alt TyVar]
alts)
              ([(Int, EvExpr)]
biFoldrMethods, [Ct]
biFoldrWs) = case Maybe [(Alt TyVar, [Ct])]
mBiFoldrAlts of
                Just [(Alt TyVar, [Ct])]
altWs ->
                  let ([Alt TyVar]
rAlts, [[Ct]]
rWss) = [(Alt TyVar, [Ct])] -> ([Alt TyVar], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt TyVar, [Ct])]
altWs
                      biFoldrImpl :: EvExpr
biFoldrImpl = [TyVar] -> EvExpr -> EvExpr
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
raTv, TyVar
rcTv, TyVar
rbTv, TyVar
rfId, TyVar
rgId, TyVar
rzId, TyVar
rtId]
                        (TyCon -> [Type] -> EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
destructInner TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
raTy, Type
rbTy])
                                       (EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
rtId) (Type -> Type -> Coercion
coAt Type
raTy Type
rbTy)) TyVar
rcb Type
rcTy [Alt TyVar]
rAlts)
                  in ([(String -> Int
bidxOf String
"bifoldr", EvExpr
biFoldrImpl)], [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
rWss)
                Maybe [(Alt TyVar, [Ct])]
Nothing -> ([], [])
          EvExpr
dict <- Class -> Type -> [EvExpr] -> [(Int, EvExpr)] -> TcPluginM EvExpr
recDictWith Class
cls Type
wrappedTy []
                    ((String -> Int
bidxOf String
"bifoldMap", EvExpr
biFoldMapImpl) (Int, EvExpr) -> [(Int, EvExpr)] -> [(Int, EvExpr)]
forall a. a -> [a] -> [a]
: [(Int, EvExpr)]
biFoldrMethods)
          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 (EvExpr -> EvTerm
EvExpr EvExpr
dict, [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
biFoldrWs))
    (Maybe TyCon, 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
  where (Type
realP, Maybe [Type]
mMods) = OvTcs -> Type -> (Type, Maybe [Type])
peelOverride2With (String -> GenEnv -> OvTcs
ovTcsGen String
"Override2" GenEnv
gen) Type
p

-- | Synthesize @Bitraversable (Stock2 P)@, directly (not by coercion — like
-- @Traversable@, @bitraverse@'s result @f (t c d)@ puts the wrapper under an
-- abstract applicative, so DerivingVia can't coerce it onto @P@; the instance
-- is usable at @Stock2 P@ / via the one-liner).  Per constructor,
-- @pure mkCon \<*\> f1 \<*\> …@: an @a@\/@b@ field uses the supplied function,
-- a constant uses @pure@, and an @h a@\/@h b@ field uses @traverse \@h@ (an
-- @Override2@-reshaped functor goes through the modifier, re-wrapped with
-- @pure coerce \<*\> _@).  @Bifunctor@ and @Bifoldable@ superclasses come from
-- their own synthesizers.
synthBitraversable :: GenEnv -> Class -> CtLoc -> Type -> Type
                   -> TcPluginM (Maybe (EvTerm, [Ct]))
synthBitraversable :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthBitraversable GenEnv
gen Class
bitravCls CtLoc
loc Type
wrappedTy Type
p =
  case (GenEnv -> Maybe TyCon
geStock2 GenEnv
gen, Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realP) of
    (Just TyCon
st2Tc, Just TyCon
pTc) -> do
      Class
appCls  <- Name -> TcPluginM Class
tcLookupClass Name
applicativeClassName
      Class
travCls <- Name -> TcPluginM Class
tcLookupClass Name
traversableClassName
      let fixed :: [Type]
fixed = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
          dcons :: [DataCon]
dcons = TyCon -> [DataCon]
tyConDataCons TyCon
pTc
          traverseSel :: TyVar
traverseSel = String -> Class -> TyVar
classMethod String
"traverse" Class
travCls
          pureSel :: TyVar
pureSel     = String -> Class -> TyVar
classMethod String
"pure" Class
appCls
          apSel :: TyVar
apSel       = String -> Class -> TyVar
classMethod String
"<*>"  Class
appCls
          coAt :: Type -> Type -> Coercion
coAt Type
t1 Type
t2  = Maybe TyCon
-> TyCon -> Type -> Type -> Type -> Type -> Type -> Coercion
coDown2With (GenEnv -> Maybe TyCon
geOverride2 GenEnv
gen) TyCon
st2Tc Type
wrappedTy Type
p Type
realP Type
t1 Type
t2
      TyVar
fTv <- Type -> String -> TcPluginM TyVar
freshTyVarK (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
liftedTypeKind Type
liftedTypeKind) String
"f"   -- f :: Type -> Type
      TyVar
aTv <- String -> TcPluginM TyVar
freshTyVar String
"a" ; TyVar
cTv <- String -> TcPluginM TyVar
freshTyVar String
"c"
      TyVar
bTv <- String -> TcPluginM TyVar
freshTyVar String
"b" ; TyVar
dTv <- String -> TcPluginM TyVar
freshTyVar String
"d"           -- bitraverse: forall f a c b d
      let fTy :: Type
fTy = TyVar -> Type
mkTyVarTy TyVar
fTv
          aTy :: Type
aTy = TyVar -> Type
mkTyVarTy TyVar
aTv ; cTy :: Type
cTy = TyVar -> Type
mkTyVarTy TyVar
cTv
          bTy :: Type
bTy = TyVar -> Type
mkTyVarTy TyVar
bTv ; dTy :: Type
dTy = TyVar -> Type
mkTyVarTy TyVar
dTv
          fOf :: Type -> Type
fOf Type
t   = Type -> Type -> Type
mkAppTy Type
fTy Type
t
          innerAB :: Type
innerAB = TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy])
          stcdTy :: Type
stcdTy  = Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
cTy) Type
dTy        -- Stock2 P c d
      TyVar
dApp <- Type -> String -> TcPluginM TyVar
freshId (Class -> [Type] -> Type
mkClassPred Class
appCls [Type
fTy]) String
"dApp"
      TyVar
gA   <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aTy (Type -> Type
fOf Type
cTy)) String
"gA"      -- a -> f c
      TyVar
gB   <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
bTy (Type -> Type
fOf Type
dTy)) String
"gB"      -- b -> f d
      TyVar
tId  <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy) Type
bTy) String
"t"
      TyVar
cb   <- Type -> String -> TcPluginM TyVar
freshId Type
innerAB String
"cb"
      let pureE :: Type -> Arg b -> Arg b
pureE Type
ty Arg b
e        = 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
pureSel) [Type -> Arg b
forall b. Type -> Expr b
Type Type
fTy, TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
dApp, Type -> Arg b
forall b. Type -> Expr b
Type Type
ty, Arg b
e]
          apE :: Type -> Type -> Arg b -> Arg b -> Arg b
apE Type
tyA Type
tyB Arg b
ac Arg b
fe = 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
apSel)   [Type -> Arg b
forall b. Type -> Expr b
Type Type
fTy, TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
dApp, Type -> Arg b
forall b. Type -> Expr b
Type Type
tyA, Type -> Arg b
forall b. Type -> Expr b
Type Type
tyB, Arg b
ac, Arg b
fe]
          -- traverse a sub-functor @h@ field at (inParam → outParam) with @g@;
          -- under Override2 reshape @h → m@, re-wrap @m out -> h out@.
          travField :: Int
-> Type
-> TyVar
-> Type
-> Type
-> TyVar
-> TcPluginM (Maybe (EvExpr, [Ct]))
travField Int
i Type
h TyVar
g Type
inTy Type
outTy TyVar
x = case GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i of
            Maybe Type
Nothing -> do
              CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
travCls [Type
h])
              Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just ( EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
traverseSel)
                             [Type -> EvExpr
forall b. Type -> Expr b
Type Type
h, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Type -> EvExpr
forall b. Type -> Expr b
Type Type
fTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
inTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
outTy
                             , TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
dApp, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
g, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x]                       -- :: f (h out)
                         , [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev] ))
            Just Type
m -> do
              CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
travCls [Type
m])
              let trav :: EvExpr
trav = EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
traverseSel)
                           [Type -> EvExpr
forall b. Type -> Expr b
Type Type
m, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Type -> EvExpr
forall b. Type -> Expr b
Type Type
fTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
inTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
outTy
                           , TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
dApp, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
g, EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x) (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
m Type
inTy)]  -- f (m out)
                  hOut :: Type
hOut = Type -> Type -> Type
mkAppTy Type
h Type
outTy ; mOut :: Type
mOut = Type -> Type -> Type
mkAppTy Type
m Type
outTy
              TyVar
mo <- Type -> String -> TcPluginM TyVar
freshId Type
mOut String
"mo"
              let coerceFn :: EvExpr
coerceFn = TyVar -> EvExpr -> EvExpr
forall b. b -> Expr b -> Expr b
Lam TyVar
mo (EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
mo) (Type -> Type -> Type -> Coercion
reshapeCo Type
m Type
h Type
outTy))          -- m out -> h out
              Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just ( Type -> Type -> EvExpr -> EvExpr -> EvExpr
forall {b}. Type -> Type -> Arg b -> Arg b -> Arg b
apE Type
mOut Type
hOut (Type -> EvExpr -> EvExpr
forall {b}. Type -> Arg b -> Arg b
pureE (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
mOut Type
hOut) EvExpr
coerceFn) EvExpr
trav
                         , [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev] ))
          fieldOf :: Int -> TyVar -> Type -> TcPluginM (Maybe (EvExpr, [Ct]))
fieldOf Int
i TyVar
x Type
ftA = case TyVar -> TyVar -> Type -> Type -> Type -> Maybe BiField
classifyBiField TyVar
aTv TyVar
bTv Type
aTy Type
bTy Type
ftA of
            Maybe BiField
Nothing          -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvExpr, [Ct])
forall a. Maybe a
Nothing
            Just BiField
BFConst     -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (Type -> EvExpr -> EvExpr
forall {b}. Type -> Arg b -> Arg b
pureE Type
ftA (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x), []))
            Just BiField
BFA         -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
gA) (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x), []))
            Just BiField
BFB         -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
gB) (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x), []))
            Just (BFFoldA Type
h) -> Int
-> Type
-> TyVar
-> Type
-> Type
-> TyVar
-> TcPluginM (Maybe (EvExpr, [Ct]))
travField Int
i Type
h TyVar
gA Type
aTy Type
cTy TyVar
x
            Just (BFFoldB Type
h) -> Int
-> Type
-> TyVar
-> Type
-> Type
-> TyVar
-> TcPluginM (Maybe (EvExpr, [Ct]))
travField Int
i Type
h TyVar
gB Type
bTy Type
dTy TyVar
x
      [Maybe (Alt TyVar, [Ct])]
malts <- [DataCon]
-> (DataCon -> TcPluginM (Maybe (Alt TyVar, [Ct])))
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DataCon]
dcons \DataCon
dc -> do
        let 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
aTy, Type
bTy]))
            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
cTy, Type
dTy]))
        [TyVar]
xs   <- (Int -> Type -> TcPluginM TyVar)
-> [Int] -> [Type] -> TcPluginM [TyVar]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
n Type
ft -> Type -> String -> TcPluginM TyVar
freshId Type
ft (String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..] [Type]
fts
        [Maybe (EvExpr, [Ct])]
mfes <- [TcPluginM (Maybe (EvExpr, [Ct]))]
-> TcPluginM [Maybe (EvExpr, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((Int -> TyVar -> Type -> TcPluginM (Maybe (EvExpr, [Ct])))
-> [Int] -> [TyVar] -> [Type] -> [TcPluginM (Maybe (EvExpr, [Ct]))]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> TyVar -> Type -> TcPluginM (Maybe (EvExpr, [Ct]))
fieldOf [Int
0 :: Int ..] [TyVar]
xs [Type]
fts)
        case [Maybe (EvExpr, [Ct])] -> Maybe [(EvExpr, [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 (EvExpr, [Ct])]
mfes of
          Maybe [(EvExpr, [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 [(EvExpr, [Ct])]
fes -> do
            let ([EvExpr]
fieldExprs, [[Ct]]
wss) = [(EvExpr, [Ct])] -> ([EvExpr], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(EvExpr, [Ct])]
fes
            [TyVar]
ys <- (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
"y" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..] [Type]
rvFts
            let mkCon :: EvExpr
mkCon = [TyVar] -> EvExpr -> EvExpr
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar]
ys (EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (DataCon -> [EvExpr] -> EvExpr
mkCoreConApps DataCon
dc ((Type -> EvExpr) -> [Type] -> [EvExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> EvExpr
forall b. Type -> Expr b
Type ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
cTy, Type
dTy]) [EvExpr] -> [EvExpr] -> [EvExpr]
forall a. [a] -> [a] -> [a]
++ (TyVar -> EvExpr) -> [TyVar] -> [EvExpr]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> EvExpr
forall b. TyVar -> Expr b
Var [TyVar]
ys))
                                        (Coercion -> Coercion
mkSymCo (Type -> Type -> Coercion
coAt Type
cTy Type
dTy)))
                rs :: [Type]
rs    = (Type -> Type -> Type) -> Type -> [Type] -> [Type]
forall a b. (a -> b -> b) -> b -> [a] -> [b]
scanr HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
stcdTy [Type]
rvFts
                body :: EvExpr
body  = (EvExpr -> (Int, EvExpr, Type) -> EvExpr)
-> EvExpr -> [(Int, EvExpr, Type)] -> EvExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\EvExpr
ac (Int
k, EvExpr
fe, Type
rvFt) -> Type -> Type -> EvExpr -> EvExpr -> EvExpr
forall {b}. Type -> Type -> Arg b -> Arg b -> Arg b
apE Type
rvFt ([Type]
rs [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) EvExpr
ac EvExpr
fe)
                              (Type -> EvExpr -> EvExpr
forall {b}. Type -> Arg b -> Arg b
pureE ([Type] -> Type
forall a. HasCallStack => [a] -> a
head [Type]
rs) EvExpr
mkCon)
                              ([Int] -> [EvExpr] -> [Type] -> [(Int, EvExpr, Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
0 :: Int ..] [EvExpr]
fieldExprs [Type]
rvFts)
            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] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [TyVar]
xs EvExpr
body, [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))
      case [Maybe (Alt TyVar, [Ct])] -> Maybe [(Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Alt TyVar, [Ct])]
malts of
        Maybe [(Alt TyVar, [Ct])]
Nothing     -> Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvTerm, [Ct])
forall a. Maybe a
Nothing
        Just [(Alt TyVar, [Ct])]
altWss -> do
          let ([Alt TyVar]
alts, [[Ct]]
wss) = [(Alt TyVar, [Ct])] -> ([Alt TyVar], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt TyVar, [Ct])]
altWss
              bitraverseImpl :: EvExpr
bitraverseImpl = [TyVar] -> EvExpr -> EvExpr
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
fTv, TyVar
aTv, TyVar
cTv, TyVar
bTv, TyVar
dTv, TyVar
dApp, TyVar
gA, TyVar
gB, TyVar
tId]
                (TyCon -> [Type] -> EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
destructInner TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy]) (EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
tId) (Type -> Type -> Coercion
coAt Type
aTy Type
bTy)) TyVar
cb (Type -> Type
fOf Type
stcdTy) [Alt TyVar]
alts)
              -- superclasses (Bifunctor, Bifoldable) in classSCTheta order
              superClss :: [Class]
superClss = [ Class
c | Type
pr <- Class -> [Type]
classSCTheta Class
bitravCls, ClassPred Class
c [Type]
_ <- [Type -> Pred
classifyPredType Type
pr] ]
          [Maybe (EvTerm, [Ct])]
superDictsM <- [Class]
-> (Class -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM [Maybe (EvTerm, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Class]
superClss \Class
c ->
            case OccName -> String
occNameString (Name -> OccName
nameOccName (Class -> Name
className Class
c)) of
              String
"Bifunctor"  -> GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthBifunctor  GenEnv
gen Class
c CtLoc
loc Type
wrappedTy Type
p
              String
"Bifoldable" -> GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthBifoldable GenEnv
gen Class
c CtLoc
loc Type
wrappedTy Type
p
              String
_            -> 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
          case [Maybe (EvTerm, [Ct])] -> Maybe [(EvTerm, [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 (EvTerm, [Ct])]
superDictsM of
            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, [Ct])]
sds -> do
              EvExpr
dict <- Class -> Type -> [EvExpr] -> [(Int, EvExpr)] -> TcPluginM EvExpr
recDictWith Class
bitravCls Type
wrappedTy (((EvTerm, [Ct]) -> EvExpr) -> [(EvTerm, [Ct])] -> [EvExpr]
forall a b. (a -> b) -> [a] -> [b]
map (EvTerm -> EvExpr
unwrapEv (EvTerm -> EvExpr)
-> ((EvTerm, [Ct]) -> EvTerm) -> (EvTerm, [Ct]) -> EvExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EvTerm, [Ct]) -> EvTerm
forall a b. (a, b) -> a
fst) [(EvTerm, [Ct])]
sds) [(Int
0, EvExpr
bitraverseImpl)]
              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 (EvExpr -> EvTerm
EvExpr EvExpr
dict, ((EvTerm, [Ct]) -> [Ct]) -> [(EvTerm, [Ct])] -> [Ct]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (EvTerm, [Ct]) -> [Ct]
forall a b. (a, b) -> b
snd [(EvTerm, [Ct])]
sds [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))
    (Maybe TyCon, 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
  where (Type
realP, Maybe [Type]
mMods) = OvTcs -> Type -> (Type, Maybe [Type])
peelOverride2With (String -> GenEnv -> OvTcs
ovTcsGen String
"Override2" GenEnv
gen) Type
p

-- | Synthesize @Bifunctor (Stock2 P)@.  @bimap@ maps @a@-fields with the first
-- function and @b@-fields with the second; @first@/@second@ come from the class
-- defaults.  @Bifunctor@ has a quantified superclass @forall a. Functor (p a)@,
-- which we supply by synthesizing the @Functor (Stock2 P a)@ dictionary under a
-- type-lambda (the @Functor@ maps the second parameter).
synthBifunctor :: GenEnv -> Class -> CtLoc -> Type -> Type
               -> TcPluginM (Maybe (EvTerm, [Ct]))
synthBifunctor :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthBifunctor GenEnv
gen Class
cls CtLoc
loc Type
wrappedTy Type
p =
  case (GenEnv -> Maybe TyCon
geStock2 GenEnv
gen, Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realP) of
    (Just TyCon
st2Tc, Just TyCon
pTc) -> do
      Class
functorCls <- Name -> TcPluginM Class
tcLookupClass Name
functorClassName
      let fixed :: [Type]
fixed     = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
          dcons :: [DataCon]
dcons     = TyCon -> [DataCon]
tyConDataCons TyCon
pTc
          bimapSel :: TyVar
bimapSel  = String -> Class -> TyVar
classMethod String
"bimap" Class
cls             -- bimap
          coAt :: Type -> Type -> Coercion
coAt Type
t1 Type
t2 = Maybe TyCon
-> TyCon -> Type -> Type -> Type -> Type -> Type -> Coercion
coDown2With (GenEnv -> Maybe TyCon
geOverride2 GenEnv
gen) TyCon
st2Tc Type
wrappedTy Type
p Type
realP Type
t1 Type
t2
      TyVar
apTv <- String -> TcPluginM TyVar
freshTyVar String
"a'" ; TyVar
aTv <- String -> TcPluginM TyVar
freshTyVar String
"a"
      TyVar
bpTv <- String -> TcPluginM TyVar
freshTyVar String
"b'" ; TyVar
bTv <- String -> TcPluginM TyVar
freshTyVar String
"b"
      let apTy :: Type
apTy = TyVar -> Type
mkTyVarTy TyVar
apTv ; aTy :: Type
aTy = TyVar -> Type
mkTyVarTy TyVar
aTv
          bpTy :: Type
bpTy = TyVar -> Type
mkTyVarTy TyVar
bpTv ; bTy :: Type
bTy = TyVar -> Type
mkTyVarTy TyVar
bTv
          innerAB :: Type
innerAB = TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy])
      TyVar
gA  <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aTy Type
apTy) String
"gA"        -- a -> a'
      TyVar
gB  <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
bTy Type
bpTy) String
"gB"        -- b -> b'
      TyVar
sf  <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy) Type
bTy) String
"sf"
      TyVar
cb  <- Type -> String -> TcPluginM TyVar
freshId Type
innerAB String
"cb"
      -- map one field (instantiated at [a,b]) to its [a',b'] image — the
      -- n-ary variance engine at [Co, Co], so it also descends through arrows
      -- and nested functors (e.g. @[Either Int b]@) that the flat
      -- 'classifyBiField' cannot.  Contravariant occurrences of a (covariant)
      -- parameter have no mapper, so they fail cleanly (no @mContra@).
      let bimapParams :: [(TyVar, Type, Maybe (Expr b), Maybe a)]
bimapParams = [ (TyVar
aTv, Type
apTy, Expr b -> Maybe (Expr b)
forall a. a -> Maybe a
Just (TyVar -> Expr b
forall b. TyVar -> Expr b
Var TyVar
gA), Maybe a
forall a. Maybe a
Nothing)
                        , (TyVar
bTv, Type
bpTy, Expr b -> Maybe (Expr b)
forall a. a -> Maybe a
Just (TyVar -> Expr b
forall b. TyVar -> Expr b
Var TyVar
gB), Maybe a
forall a. Maybe a
Nothing) ]
          -- a nested @q a b@ field: recurse via @q@'s own @bimap@ (so e.g.
          -- @Either a b@ / @(a, b)@ fields work, beyond the flat classifier).
          selfBi :: Type -> TcPluginM (Maybe (EvExpr, [Ct]))
selfBi Type
q = do
            CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
cls [Type
q])
            Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just ( EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
bimapSel)
                           [ Type -> EvExpr
forall b. Type -> Expr b
Type Type
q, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Type -> EvExpr
forall b. Type -> Expr b
Type Type
aTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
apTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
bTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
bpTy
                           , TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
gA, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
gB ]
                       , [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev] ))
          -- a plain field: map it pointwise with the n-ary engine.
          mapPlain :: TyVar -> Type -> TcPluginM (Maybe (EvExpr, [Ct]))
mapPlain TyVar
x Type
ft = do
            Maybe (EvExpr, [Ct])
m <- Class
-> Maybe Class
-> CtLoc
-> [(TyVar, Type, Maybe EvExpr, Maybe EvExpr)]
-> Maybe (Type -> TcPluginM (Maybe (EvExpr, [Ct])))
-> Variance
-> Type
-> TcPluginM (Maybe (EvExpr, [Ct]))
varMapN Class
functorCls Maybe Class
forall a. Maybe a
Nothing CtLoc
loc [(TyVar, Type, Maybe EvExpr, Maybe EvExpr)]
forall {b} {a}. [(TyVar, Type, Maybe (Expr b), Maybe a)]
bimapParams ((Type -> TcPluginM (Maybe (EvExpr, [Ct])))
-> Maybe (Type -> TcPluginM (Maybe (EvExpr, [Ct])))
forall a. a -> Maybe a
Just Type -> TcPluginM (Maybe (EvExpr, [Ct]))
selfBi) Variance
Cov Type
ft
            Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((EvExpr, [Ct]) -> (EvExpr, [Ct]))
-> Maybe (EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(EvExpr
e, [Ct]
ws) -> (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App EvExpr
e (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x), [Ct]
ws)) Maybe (EvExpr, [Ct])
m)
          -- under @Override2@, an @h a@/@h b@ field is reshaped to @mod a@/@mod b@:
          -- map via @mod@'s @fmap@ on the coerced value, then coerce the result back.
          mapField :: Int -> TyVar -> Type -> TcPluginM (Maybe (EvExpr, [Ct]))
mapField Int
i TyVar
x Type
ft = case (GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i, TyVar -> TyVar -> Type -> Type -> Type -> Maybe BiField
classifyBiField TyVar
aTv TyVar
bTv Type
aTy Type
bTy Type
ft) of
            (Just Type
mod_, Just (BFFoldA Type
h)) -> Type
-> Type
-> TyVar
-> Type
-> Type
-> TcPluginM (Maybe (EvExpr, [Ct]))
mapVia Type
mod_ Type
h TyVar
x Type
aTy Type
apTy
            (Just Type
mod_, Just (BFFoldB Type
h)) -> Type
-> Type
-> TyVar
-> Type
-> Type
-> TcPluginM (Maybe (EvExpr, [Ct]))
mapVia Type
mod_ Type
h TyVar
x Type
bTy Type
bpTy
            (Maybe Type, Maybe BiField)
_                             -> TyVar -> Type -> TcPluginM (Maybe (EvExpr, [Ct]))
mapPlain TyVar
x Type
ft
          mapVia :: Type
-> Type
-> TyVar
-> Type
-> Type
-> TcPluginM (Maybe (EvExpr, [Ct]))
mapVia Type
mod_ Type
h TyVar
x Type
inTy Type
outTy = do
            Maybe (EvExpr, [Ct])
m <- Class
-> Maybe Class
-> CtLoc
-> [(TyVar, Type, Maybe EvExpr, Maybe EvExpr)]
-> Maybe (Type -> TcPluginM (Maybe (EvExpr, [Ct])))
-> Variance
-> Type
-> TcPluginM (Maybe (EvExpr, [Ct]))
varMapN Class
functorCls Maybe Class
forall a. Maybe a
Nothing CtLoc
loc [(TyVar, Type, Maybe EvExpr, Maybe EvExpr)]
forall {b} {a}. [(TyVar, Type, Maybe (Expr b), Maybe a)]
bimapParams ((Type -> TcPluginM (Maybe (EvExpr, [Ct])))
-> Maybe (Type -> TcPluginM (Maybe (EvExpr, [Ct])))
forall a. a -> Maybe a
Just Type -> TcPluginM (Maybe (EvExpr, [Ct]))
selfBi) Variance
Cov (Type -> Type -> Type
mkAppTy Type
mod_ Type
inTy)
            Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct])))
-> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a b. (a -> b) -> a -> b
$ (((EvExpr, [Ct]) -> (EvExpr, [Ct]))
 -> Maybe (EvExpr, [Ct]) -> Maybe (EvExpr, [Ct]))
-> Maybe (EvExpr, [Ct])
-> ((EvExpr, [Ct]) -> (EvExpr, [Ct]))
-> Maybe (EvExpr, [Ct])
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((EvExpr, [Ct]) -> (EvExpr, [Ct]))
-> Maybe (EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (EvExpr, [Ct])
m \(EvExpr
e, [Ct]
ws) ->
              ( EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App EvExpr
e (EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x) (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
mod_ Type
inTy))) (Coercion -> Coercion
mkSymCo (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
mod_ Type
outTy)), [Ct]
ws )
      [Maybe (Alt TyVar, [Ct])]
malts <- [DataCon]
-> (DataCon -> TcPluginM (Maybe (Alt TyVar, [Ct])))
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DataCon]
dcons \DataCon
dc -> do
        let fts :: [Type]
fts = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy]))
        [TyVar]
xs  <- (Int -> Type -> TcPluginM TyVar)
-> [Int] -> [Type] -> TcPluginM [TyVar]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
n Type
ft -> Type -> String -> TcPluginM TyVar
freshId Type
ft (String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..] [Type]
fts
        [Maybe (EvExpr, [Ct])]
mfs <- [TcPluginM (Maybe (EvExpr, [Ct]))]
-> TcPluginM [Maybe (EvExpr, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((Int -> TyVar -> Type -> TcPluginM (Maybe (EvExpr, [Ct])))
-> [Int] -> [TyVar] -> [Type] -> [TcPluginM (Maybe (EvExpr, [Ct]))]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> TyVar -> Type -> TcPluginM (Maybe (EvExpr, [Ct]))
mapField [Int
0 :: Int ..] [TyVar]
xs [Type]
fts)
        case [Maybe (EvExpr, [Ct])] -> Maybe [(EvExpr, [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 (EvExpr, [Ct])]
mfs of
          Maybe [(EvExpr, [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 [(EvExpr, [Ct])]
pairs ->
            let ([EvExpr]
vals, [[Ct]]
wss) = [(EvExpr, [Ct])] -> ([EvExpr], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(EvExpr, [Ct])]
pairs
                body :: EvExpr
body = EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (DataCon -> [EvExpr] -> EvExpr
mkCoreConApps DataCon
dc ((Type -> EvExpr) -> [Type] -> [EvExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> EvExpr
forall b. Type -> Expr b
Type ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
apTy, Type
bpTy]) [EvExpr] -> [EvExpr] -> [EvExpr]
forall a. [a] -> [a] -> [a]
++ [EvExpr]
vals))
                            (Coercion -> Coercion
mkSymCo (Type -> Type -> Coercion
coAt Type
apTy Type
bpTy))
            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] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [TyVar]
xs EvExpr
body, [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))
      case [Maybe (Alt TyVar, [Ct])] -> Maybe [(Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Alt TyVar, [Ct])]
malts of
        Maybe [(Alt TyVar, [Ct])]
Nothing     -> Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvTerm, [Ct])
forall a. Maybe a
Nothing
        Just [(Alt TyVar, [Ct])]
altWss -> do
          let ([Alt TyVar]
alts, [[Ct]]
wss) = [(Alt TyVar, [Ct])] -> ([Alt TyVar], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt TyVar, [Ct])]
altWss
              -- bimap quantifies @forall a b c d@: (a->b) maps the first param,
              -- (c->d) the second.  So the binder order is input1,output1,input2,output2.
              bimapImpl :: EvExpr
bimapImpl = [TyVar] -> EvExpr -> EvExpr
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
aTv, TyVar
apTv, TyVar
bTv, TyVar
bpTv, TyVar
gA, TyVar
gB, TyVar
sf]
                (TyCon -> [Type] -> EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
destructInner TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy]) (EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
sf) (Type -> Type -> Coercion
coAt Type
aTy Type
bTy))
                               TyVar
cb (Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
apTy) Type
bpTy) [Alt TyVar]
alts)
          TyVar
dmFirst  <- Class -> Int -> TcPluginM TyVar
defMethId Class
cls Int
1                       -- first
          TyVar
dmSecond <- Class -> Int -> TcPluginM TyVar
defMethId Class
cls Int
2                       -- second
          TyVar
fdmConst <- Class -> Int -> TcPluginM TyVar
defMethId Class
functorCls Int
1                -- Functor's (<$)
          -- The superclass  forall a. Functor (Stock2 P a)  is just @fmap = bimap
          -- id@ (a Bifunctor law): under @/\sc@ we build a @Functor (Stock2 P sc)@
          -- dictionary whose @fmap g = bimap id g@, reusing the Bifunctor dict.
          TyVar
sctv  <- String -> TcPluginM TyVar
freshTyVar String
"sc"
          TyVar
b2tv  <- String -> TcPluginM TyVar
freshTyVar String
"b" ; TyVar
b2ptv <- String -> TcPluginM TyVar
freshTyVar String
"b'"
          TyVar
zId   <- Type -> String -> TcPluginM TyVar
freshId (TyVar -> Type
mkTyVarTy TyVar
sctv) String
"z"
          TyVar
g2Id  <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany (TyVar -> Type
mkTyVarTy TyVar
b2tv) (TyVar -> Type
mkTyVarTy TyVar
b2ptv)) String
"g2"
          TyVar
x2Id  <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy Type
wrappedTy (TyVar -> Type
mkTyVarTy TyVar
sctv) Type -> Type -> Type
`mkAppTy` TyVar -> Type
mkTyVarTy TyVar
b2tv) String
"x2"
          EvExpr
dict <- Class -> Type -> (TyVar -> TcPluginM [EvExpr]) -> TcPluginM EvExpr
recClassDict Class
cls Type
wrappedTy \TyVar
dvar -> do
            let scTy :: Type
scTy   = TyVar -> Type
mkTyVarTy TyVar
sctv
                idA :: EvExpr
idA    = TyVar -> EvExpr -> EvExpr
forall b. b -> Expr b -> Expr b
Lam TyVar
zId (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
zId)                  -- id @sc
                -- fmap g x = bimap @(Stock2 P) dvar @sc @sc @b @b' id g x
                fmapSC :: EvExpr
fmapSC = [TyVar] -> EvExpr -> EvExpr
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
b2tv, TyVar
b2ptv, TyVar
g2Id, TyVar
x2Id] (EvExpr -> EvExpr) -> EvExpr -> EvExpr
forall a b. (a -> b) -> a -> b
$
                  EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
bimapSel)
                    [ Type -> EvExpr
forall b. Type -> Expr b
Type Type
wrappedTy, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
dvar
                    , Type -> EvExpr
forall b. Type -> Expr b
Type Type
scTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
scTy, Type -> EvExpr
forall b. Type -> Expr b
Type (TyVar -> Type
mkTyVarTy TyVar
b2tv), Type -> EvExpr
forall b. Type -> Expr b
Type (TyVar -> Type
mkTyVarTy TyVar
b2ptv)
                    , EvExpr
idA, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
g2Id, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x2Id ]
            EvExpr
supDict <- Class -> Type -> (TyVar -> TcPluginM [EvExpr]) -> TcPluginM EvExpr
recClassDict Class
functorCls (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
scTy) \TyVar
fdvar ->
                         [EvExpr] -> TcPluginM [EvExpr]
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ EvExpr
fmapSC
                              , EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
fdmConst) [Type -> EvExpr
forall b. Type -> Expr b
Type (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
scTy), TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
fdvar] ]
            [EvExpr] -> TcPluginM [EvExpr]
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ TyVar -> EvExpr -> EvExpr
forall b. b -> Expr b -> Expr b
Lam TyVar
sctv EvExpr
supDict
                 , EvExpr
bimapImpl
                 , EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
dmFirst)  [Type -> EvExpr
forall b. Type -> Expr b
Type Type
wrappedTy, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
dvar]
                 , EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
dmSecond) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
wrappedTy, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
dvar] ]
          Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvTerm, [Ct]) -> Maybe (EvTerm, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> EvTerm
EvExpr EvExpr
dict, [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))
    (Maybe TyCon, 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
  where (Type
realP, Maybe [Type]
mMods) = OvTcs -> Type -> (Type, Maybe [Type])
peelOverride2With (String -> GenEnv -> OvTcs
ovTcsGen String
"Override2" GenEnv
gen) Type
p

-- | A fresh kind-@Type@ type variable (for the @forall a b@ in @fmap@).

-- | The @Stock2@ counterpart of 'zipLift2': walk two values of the same
-- @Stock2 P@ shape (@fa :: P a c@, @fb :: P b d@) in lock-step, combining the
-- per-field-pair results of matching constructors.  Shared by @liftEq2@
-- (short-circuit conjunction) and @liftCompare2@ (lexicographic).
zipLiftBi :: TyCon -> [Type] -> (Type -> Type -> Coercion)
          -> (Type, Type) -> (Type, Type) -> Type   -- (a,c) for fa, (b,d) for fb, result
          -> Id -> Id                                -- the two scrutinees
          -> (Int -> Int -> CoreExpr)                -- mismatched-constructor result
          -> ([CoreExpr] -> TcPluginM CoreExpr)      -- combine field results
          -> (Int -> Type -> Id -> Id -> TcPluginM (Maybe (CoreExpr, [Ct])))  -- per field pair (with index)
          -> TcPluginM (Maybe (CoreExpr, [Ct]))
zipLiftBi :: TyCon
-> [Type]
-> (Type -> Type -> Coercion)
-> (Type, Type)
-> (Type, Type)
-> Type
-> TyVar
-> TyVar
-> (Int -> Int -> EvExpr)
-> ([EvExpr] -> TcPluginM EvExpr)
-> (Int
    -> Type -> TyVar -> TyVar -> TcPluginM (Maybe (EvExpr, [Ct])))
-> TcPluginM (Maybe (EvExpr, [Ct]))
zipLiftBi TyCon
pTc [Type]
fixed Type -> Type -> Coercion
coAt2 (Type
aTy, Type
cTy) (Type
bTy, Type
dTy) Type
resTy TyVar
faId TyVar
fbId Int -> Int -> EvExpr
mismatch [EvExpr] -> TcPluginM EvExpr
combine Int -> Type -> TyVar -> TyVar -> TcPluginM (Maybe (EvExpr, [Ct]))
fieldOp = do
  let dcons :: [DataCon]
dcons         = TyCon -> [DataCon]
tyConDataCons TyCon
pTc
      fieldsBi :: DataCon -> Type -> Type -> [Type]
fieldsBi DataCon
dc Type
t1 Type
t2 = (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
t1, Type
t2]))
      freshF :: DataCon -> Type -> Type -> TcPluginM [TyVar]
freshF DataCon
dc Type
t1 Type
t2   = (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 ..] (DataCon -> Type -> Type -> [Type]
fieldsBi DataCon
dc Type
t1 Type
t2)
      indexed :: [(Int, DataCon)]
indexed       = [Int] -> [DataCon] -> [(Int, DataCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [DataCon]
dcons
  [Maybe (Alt TyVar, [Ct])]
mInner <- [(Int, DataCon)]
-> ((Int, DataCon) -> TcPluginM (Maybe (Alt TyVar, [Ct])))
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Int, DataCon)]
indexed \(Int
i, DataCon
dci) -> do
    [TyVar]
xs    <- DataCon -> Type -> Type -> TcPluginM [TyVar]
freshF DataCon
dci Type
aTy Type
cTy
    [Maybe (Alt TyVar, [Ct])]
mAlts <- [(Int, DataCon)]
-> ((Int, DataCon) -> TcPluginM (Maybe (Alt TyVar, [Ct])))
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Int, DataCon)]
indexed \(Int
j, DataCon
dcj) -> do
      [TyVar]
ys <- DataCon -> Type -> Type -> TcPluginM [TyVar]
freshF DataCon
dcj Type
bTy Type
dTy
      if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
j
        then 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] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dcj) [TyVar]
ys (Int -> Int -> EvExpr
mismatch Int
i Int
j), []))
        else do
          [Maybe (EvExpr, [Ct])]
mops <- [TcPluginM (Maybe (EvExpr, [Ct]))]
-> TcPluginM [Maybe (EvExpr, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((Int -> Type -> TyVar -> TyVar -> TcPluginM (Maybe (EvExpr, [Ct])))
-> [Int]
-> [Type]
-> [TyVar]
-> [TyVar]
-> [TcPluginM (Maybe (EvExpr, [Ct]))]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 Int -> Type -> TyVar -> TyVar -> TcPluginM (Maybe (EvExpr, [Ct]))
fieldOp [Int
0 :: Int ..] (DataCon -> Type -> Type -> [Type]
fieldsBi DataCon
dci Type
aTy Type
cTy) [TyVar]
xs [TyVar]
ys)
          case [Maybe (EvExpr, [Ct])] -> Maybe [(EvExpr, [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 (EvExpr, [Ct])]
mops of
            Maybe [(EvExpr, [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 [(EvExpr, [Ct])]
ows -> do EvExpr
body <- [EvExpr] -> TcPluginM EvExpr
combine (((EvExpr, [Ct]) -> EvExpr) -> [(EvExpr, [Ct])] -> [EvExpr]
forall a b. (a -> b) -> [a] -> [b]
map (EvExpr, [Ct]) -> EvExpr
forall a b. (a, b) -> a
fst [(EvExpr, [Ct])]
ows)
                           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] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dcj) [TyVar]
ys EvExpr
body, ((EvExpr, [Ct]) -> [Ct]) -> [(EvExpr, [Ct])] -> [Ct]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (EvExpr, [Ct]) -> [Ct]
forall a b. (a, b) -> b
snd [(EvExpr, [Ct])]
ows))
    case [Maybe (Alt TyVar, [Ct])] -> Maybe [(Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Alt TyVar, [Ct])]
mAlts of
      Maybe [(Alt TyVar, [Ct])]
Nothing     -> Maybe (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 [(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
        TyVar
cbB <- Type -> String -> TcPluginM TyVar
freshId (TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
bTy, Type
dTy])) String
"cbb"
        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] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dci) [TyVar]
xs
                       (TyCon -> [Type] -> EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
destructInner TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
bTy, Type
dTy]) (EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
fbId) (Type -> Type -> Coercion
coAt2 Type
bTy Type
dTy)) TyVar
cbB Type
resTy [Alt TyVar]
alts)
                   , [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss ))
  case [Maybe (Alt TyVar, [Ct])] -> Maybe [(Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Alt TyVar, [Ct])]
mInner of
    Maybe [(Alt TyVar, [Ct])]
Nothing     -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvExpr, [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
      TyVar
cbA <- Type -> String -> TcPluginM TyVar
freshId (TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
cTy])) String
"cba"
      Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just ( TyCon -> [Type] -> EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
destructInner TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
cTy]) (EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
faId) (Type -> Type -> Coercion
coAt2 Type
aTy Type
cTy)) TyVar
cbA Type
resTy [Alt TyVar]
alts
                 , [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss ))

-- | The superclass evidence for @C2 (Stock2 P)@: each entry of @C2@'s
-- @classSCTheta@ instantiated at the via-target and requested as a wanted
-- (discharged by the plugin: lifted built-ins, or the @Stock2@ passthrough).
stock2Supers :: Class -> Type -> CtLoc -> TcPluginM ([CoreExpr], [Ct])
stock2Supers :: Class -> Type -> CtLoc -> TcPluginM ([EvExpr], [Ct])
stock2Supers Class
cls Type
wrappedTy CtLoc
loc = do
  let subst :: Subst
subst = case Class -> [TyVar]
classTyVars Class
cls of
                (TyVar
tv : [TyVar]
_) -> [TyVar] -> [Type] -> Subst
HasDebugCallStack => [TyVar] -> [Type] -> Subst
zipTvSubst [TyVar
tv] [Type
wrappedTy]
                [TyVar]
_        -> Subst
emptySubst
  [CtEvidence]
evs <- [Type] -> (Type -> TcPluginM CtEvidence) -> TcPluginM [CtEvidence]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst) (Class -> [Type]
classSCTheta Class
cls)) (CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc)
  ([EvExpr], [Ct]) -> TcPluginM ([EvExpr], [Ct])
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CtEvidence -> EvExpr) -> [CtEvidence] -> [EvExpr]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr [CtEvidence]
evs, (CtEvidence -> Ct) -> [CtEvidence] -> [Ct]
forall a b. (a -> b) -> [a] -> [b]
map CtEvidence -> Ct
mkNonCanonical [CtEvidence]
evs)

-- | Synthesize @Eq2 (Stock2 P)@: @liftEq2@ is same-constructor-and-all-fields,
-- with @a@-fields compared by the first function, @b@-fields by the second,
-- @h a@\/@h b@ fields by @liftEq@, constants by @(==)@.
-- Override2 is transparent for Eq2: a hashing/forcing modifier does not change
-- structural equality, so peel the wrapper and compare the real fields.  (This
-- makes @deriving Hashable2 via Overriding2 …@ work: its @Eq2@ superclass is
-- dragged through the same config.)
synthEq2 :: GenEnv -> Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))
synthEq2 :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthEq2 GenEnv
gen Class
eq2Cls CtLoc
loc Type
wrappedTy Type
p0 =
  case (GenEnv -> Maybe TyCon
geStock2 GenEnv
gen, Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realP) of
    (Just TyCon
st2Tc, Just TyCon
pTc) -> do
      Class
eqCls <- Name -> TcPluginM Class
tcLookupClass Name
eqClassName
      Maybe Class
mEq1  <- String -> String -> TcPluginM (Maybe Class)
lookupClassMaybe String
"Data.Functor.Classes" String
"Eq1"
      case Maybe Class
mEq1 of
        Maybe Class
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 Class
eq1Cls -> do
          let fixed :: [Type]
fixed      = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
              liftEqSel :: TyVar
liftEqSel  = String -> Class -> TyVar
classMethod String
"liftEq" Class
eq1Cls
              eqSel :: TyVar
eqSel      = String -> Class -> TyVar
classMethod String
"==" Class
eqCls
              true_ :: Expr b
true_      = TyVar -> Expr b
forall b. TyVar -> Expr b
Var (DataCon -> TyVar
dataConWorkId DataCon
trueDataCon)
              false_ :: Expr b
false_     = TyVar -> Expr b
forall b. TyVar -> Expr b
Var (DataCon -> TyVar
dataConWorkId DataCon
falseDataCon)
              coAt2 :: Type -> Type -> Coercion
coAt2 Type
t1 Type
t2 = Maybe TyCon
-> TyCon -> Type -> Type -> Type -> Type -> Type -> Coercion
coDown2With (GenEnv -> Maybe TyCon
geOverride2 GenEnv
gen) TyCon
st2Tc Type
wrappedTy Type
p0 Type
realP Type
t1 Type
t2
          TyVar
aTv <- String -> TcPluginM TyVar
freshTyVar String
"a" ; TyVar
bTv <- String -> TcPluginM TyVar
freshTyVar String
"b" ; TyVar
cTv <- String -> TcPluginM TyVar
freshTyVar String
"c" ; TyVar
dTv <- String -> TcPluginM TyVar
freshTyVar String
"d"
          let aTy :: Type
aTy = TyVar -> Type
mkTyVarTy TyVar
aTv ; bTy :: Type
bTy = TyVar -> Type
mkTyVarTy TyVar
bTv ; cTy :: Type
cTy = TyVar -> Type
mkTyVarTy TyVar
cTv ; dTy :: Type
dTy = TyVar -> Type
mkTyVarTy TyVar
dTv
          TyVar
eqAB <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
bTy Type
boolTy)) String
"eqAB"
          TyVar
eqCD <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
cTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
dTy Type
boolTy)) String
"eqCD"
          TyVar
faId <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy) Type
cTy) String
"fa"
          TyVar
fbId <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
bTy) Type
dTy) String
"fb"
          let conj :: [EvExpr] -> TcPluginM EvExpr
conj []         = EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EvExpr
forall {b}. Expr b
true_
              conj (EvExpr
e : [EvExpr]
more)  = do EvExpr
rest <- [EvExpr] -> TcPluginM EvExpr
conj [EvExpr]
more
                                    TyVar
scr  <- Type -> String -> TcPluginM TyVar
freshId Type
boolTy String
"c"
                                    EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case EvExpr
e TyVar
scr Type
boolTy [ AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] EvExpr
forall {b}. Expr b
false_
                                                            , AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  [] EvExpr
rest ])
              fieldOp :: Int -> Type -> TyVar -> TyVar -> TcPluginM (Maybe (EvExpr, [Ct]))
fieldOp Int
i Type
ft TyVar
x TyVar
y = case TyVar -> TyVar -> Type -> Type -> Type -> Maybe BiField
classifyBiField TyVar
aTv TyVar
cTv Type
aTy Type
cTy Type
ft of
                Maybe BiField
Nothing          -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvExpr, [Ct])
forall a. Maybe a
Nothing
                Just BiField
BFA         -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
eqAB) [TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
y], []))
                Just BiField
BFB         -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
eqCD) [TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
y], []))
                Just BiField
BFConst     -> do CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
eqCls [Type
ft])
                                       Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
eqSel) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
ft, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
y], [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
                Just (BFFoldA Type
h) -> do let m :: Type
m = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
h (GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i)
                                       CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
eq1Cls [Type
m])
                                       Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
liftEqSel) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
m, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Type -> EvExpr
forall b. Type -> Expr b
Type Type
aTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
bTy, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
eqAB, EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x) (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
m Type
aTy), EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
y) (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
m Type
bTy)], [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
                Just (BFFoldB Type
h) -> do let m :: Type
m = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
h (GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i)
                                       CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
eq1Cls [Type
m])
                                       Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
liftEqSel) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
m, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Type -> EvExpr
forall b. Type -> Expr b
Type Type
cTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
dTy, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
eqCD, EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x) (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
m Type
cTy), EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
y) (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
m Type
dTy)], [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
          Maybe (EvExpr, [Ct])
mBody <- TyCon
-> [Type]
-> (Type -> Type -> Coercion)
-> (Type, Type)
-> (Type, Type)
-> Type
-> TyVar
-> TyVar
-> (Int -> Int -> EvExpr)
-> ([EvExpr] -> TcPluginM EvExpr)
-> (Int
    -> Type -> TyVar -> TyVar -> TcPluginM (Maybe (EvExpr, [Ct])))
-> TcPluginM (Maybe (EvExpr, [Ct]))
zipLiftBi TyCon
pTc [Type]
fixed Type -> Type -> Coercion
coAt2 (Type
aTy, Type
cTy) (Type
bTy, Type
dTy) Type
boolTy TyVar
faId TyVar
fbId (\Int
_ Int
_ -> EvExpr
forall {b}. Expr b
false_) [EvExpr] -> TcPluginM EvExpr
conj Int -> Type -> TyVar -> TyVar -> TcPluginM (Maybe (EvExpr, [Ct]))
fieldOp
          case Maybe (EvExpr, [Ct])
mBody of
            Maybe (EvExpr, [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 (EvExpr
body, [Ct]
ws) -> do
              ([EvExpr]
supers, [Ct]
scWs) <- Class -> Type -> CtLoc -> TcPluginM ([EvExpr], [Ct])
stock2Supers Class
eq2Cls Type
wrappedTy CtLoc
loc
              let impl :: EvExpr
impl = [TyVar] -> EvExpr -> EvExpr
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
aTv, TyVar
bTv, TyVar
cTv, TyVar
dTv, TyVar
eqAB, TyVar
eqCD, TyVar
faId, TyVar
fbId] EvExpr
body
              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 (EvExpr -> EvTerm
EvExpr (Class -> Type -> [EvExpr] -> EvExpr
mkClassDict Class
eq2Cls Type
wrappedTy ([EvExpr]
supers [EvExpr] -> [EvExpr] -> [EvExpr]
forall a. [a] -> [a] -> [a]
++ [EvExpr
impl])), [Ct]
scWs [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
ws))
    (Maybe TyCon, 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
  where (Type
realP, Maybe [Type]
mMods) = OvTcs -> Type -> (Type, Maybe [Type])
peelOverride2With (String -> GenEnv -> OvTcs
ovTcsGen String
"Override2" GenEnv
gen) Type
p0

-- | Synthesize @Ord2 (Stock2 P)@: @liftCompare2@ orders by constructor tag,
-- then lexicographically by fields (first-param fields by the first function,
-- second by the second, @h a@\/@h b@ by @liftCompare@, constants by @compare@).
synthOrd2 :: GenEnv -> Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))
synthOrd2 :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthOrd2 GenEnv
gen Class
ord2Cls CtLoc
loc Type
wrappedTy Type
p =
  case (GenEnv -> Maybe TyCon
geStock2 GenEnv
gen, Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realP) of
    (Just TyCon
st2Tc, Just TyCon
pTc) -> do
      Class
ordCls <- Name -> TcPluginM Class
tcLookupClass Name
ordClassName
      Maybe Class
mOrd1  <- String -> String -> TcPluginM (Maybe Class)
lookupClassMaybe String
"Data.Functor.Classes" String
"Ord1"
      case Maybe Class
mOrd1 of
        Maybe Class
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 Class
ord1Cls -> do
          let fixed :: [Type]
fixed       = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
              liftCmpSel :: TyVar
liftCmpSel  = String -> Class -> TyVar
classMethod String
"liftCompare" Class
ord1Cls
              cmpSel :: TyVar
cmpSel      = String -> Class -> TyVar
classMethod String
"compare" Class
ordCls
              ordTy :: Type
ordTy       = TyCon -> Type
mkTyConTy TyCon
orderingTyCon
              [DataCon
ltC, DataCon
eqC, DataCon
gtC] = TyCon -> [DataCon]
tyConDataCons TyCon
orderingTyCon
              ltE :: Expr b
ltE = TyVar -> Expr b
forall b. TyVar -> Expr b
Var (DataCon -> TyVar
dataConWorkId DataCon
ltC) ; eqE :: Expr b
eqE = TyVar -> Expr b
forall b. TyVar -> Expr b
Var (DataCon -> TyVar
dataConWorkId DataCon
eqC) ; gtE :: Expr b
gtE = TyVar -> Expr b
forall b. TyVar -> Expr b
Var (DataCon -> TyVar
dataConWorkId DataCon
gtC)
              coAt2 :: Type -> Type -> Coercion
coAt2 Type
t1 Type
t2 = Maybe TyCon
-> TyCon -> Type -> Type -> Type -> Type -> Type -> Coercion
coDown2With (GenEnv -> Maybe TyCon
geOverride2 GenEnv
gen) TyCon
st2Tc Type
wrappedTy Type
p Type
realP Type
t1 Type
t2
          TyVar
aTv <- String -> TcPluginM TyVar
freshTyVar String
"a" ; TyVar
bTv <- String -> TcPluginM TyVar
freshTyVar String
"b" ; TyVar
cTv <- String -> TcPluginM TyVar
freshTyVar String
"c" ; TyVar
dTv <- String -> TcPluginM TyVar
freshTyVar String
"d"
          let aTy :: Type
aTy = TyVar -> Type
mkTyVarTy TyVar
aTv ; bTy :: Type
bTy = TyVar -> Type
mkTyVarTy TyVar
bTv ; cTy :: Type
cTy = TyVar -> Type
mkTyVarTy TyVar
cTv ; dTy :: Type
dTy = TyVar -> Type
mkTyVarTy TyVar
dTv
          TyVar
cmpAB <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
bTy Type
ordTy)) String
"cmpAB"
          TyVar
cmpCD <- Type -> String -> TcPluginM TyVar
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
cTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
dTy Type
ordTy)) String
"cmpCD"
          TyVar
faId  <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy) Type
cTy) String
"fa"
          TyVar
fbId  <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
bTy) Type
dTy) String
"fb"
          let lexCmp :: [EvExpr] -> TcPluginM EvExpr
lexCmp []         = EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EvExpr
forall {b}. Expr b
eqE
              lexCmp (EvExpr
e : [EvExpr]
more)  = do EvExpr
rest <- [EvExpr] -> TcPluginM EvExpr
lexCmp [EvExpr]
more
                                      TyVar
scr  <- Type -> String -> TcPluginM TyVar
freshId Type
ordTy String
"o"
                                      EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case EvExpr
e TyVar
scr Type
ordTy [ AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
ltC) [] EvExpr
forall {b}. Expr b
ltE
                                                             , AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
eqC) [] EvExpr
rest
                                                             , AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
gtC) [] EvExpr
forall {b}. Expr b
gtE ])
              fieldOp :: Int -> Type -> TyVar -> TyVar -> TcPluginM (Maybe (EvExpr, [Ct]))
fieldOp Int
i Type
ft TyVar
x TyVar
y = case TyVar -> TyVar -> Type -> Type -> Type -> Maybe BiField
classifyBiField TyVar
aTv TyVar
cTv Type
aTy Type
cTy Type
ft of
                Maybe BiField
Nothing          -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvExpr, [Ct])
forall a. Maybe a
Nothing
                Just BiField
BFA         -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
cmpAB) [TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
y], []))
                Just BiField
BFB         -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
cmpCD) [TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
y], []))
                Just BiField
BFConst     -> do CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
ordCls [Type
ft])
                                       Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
cmpSel) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
ft, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
y], [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
                Just (BFFoldA Type
h) -> do let m :: Type
m = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
h (GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i)
                                       CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
ord1Cls [Type
m])
                                       Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
liftCmpSel) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
m, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Type -> EvExpr
forall b. Type -> Expr b
Type Type
aTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
bTy, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
cmpAB, EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x) (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
m Type
aTy), EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
y) (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
m Type
bTy)], [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
                Just (BFFoldB Type
h) -> do let m :: Type
m = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
h (GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i)
                                       CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
ord1Cls [Type
m])
                                       Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
liftCmpSel) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
m, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Type -> EvExpr
forall b. Type -> Expr b
Type Type
cTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
dTy, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
cmpCD, EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
x) (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
m Type
cTy), EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
y) (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
m Type
dTy)], [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
          Maybe (EvExpr, [Ct])
mBody <- TyCon
-> [Type]
-> (Type -> Type -> Coercion)
-> (Type, Type)
-> (Type, Type)
-> Type
-> TyVar
-> TyVar
-> (Int -> Int -> EvExpr)
-> ([EvExpr] -> TcPluginM EvExpr)
-> (Int
    -> Type -> TyVar -> TyVar -> TcPluginM (Maybe (EvExpr, [Ct])))
-> TcPluginM (Maybe (EvExpr, [Ct]))
zipLiftBi TyCon
pTc [Type]
fixed Type -> Type -> Coercion
coAt2 (Type
aTy, Type
cTy) (Type
bTy, Type
dTy) Type
ordTy TyVar
faId TyVar
fbId
                             (\Int
i Int
j -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
j then EvExpr
forall {b}. Expr b
ltE else EvExpr
forall {b}. Expr b
gtE) [EvExpr] -> TcPluginM EvExpr
lexCmp Int -> Type -> TyVar -> TyVar -> TcPluginM (Maybe (EvExpr, [Ct]))
fieldOp
          case Maybe (EvExpr, [Ct])
mBody of
            Maybe (EvExpr, [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 (EvExpr
body, [Ct]
ws) -> do
              ([EvExpr]
supers, [Ct]
scWs) <- Class -> Type -> CtLoc -> TcPluginM ([EvExpr], [Ct])
stock2Supers Class
ord2Cls Type
wrappedTy CtLoc
loc
              let impl :: EvExpr
impl = [TyVar] -> EvExpr -> EvExpr
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
aTv, TyVar
bTv, TyVar
cTv, TyVar
dTv, TyVar
cmpAB, TyVar
cmpCD, TyVar
faId, TyVar
fbId] EvExpr
body
              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 (EvExpr -> EvTerm
EvExpr (Class -> Type -> [EvExpr] -> EvExpr
mkClassDict Class
ord2Cls Type
wrappedTy ([EvExpr]
supers [EvExpr] -> [EvExpr] -> [EvExpr]
forall a. [a] -> [a] -> [a]
++ [EvExpr
impl])), [Ct]
scWs [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
ws))
    (Maybe TyCon, 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
  where (Type
realP, Maybe [Type]
mMods) = OvTcs -> Type -> (Type, Maybe [Type])
peelOverride2With (String -> GenEnv -> OvTcs
ovTcsGen String
"Override2" GenEnv
gen) Type
p

-- | Synthesize @Show2 (Stock2 P)@: @liftShowsPrec2@ renders like derived @Show@
-- (prefix / infix / record, precedence-parenthesised) but shows a first-param
-- field with @spA@, a second with @spB@, an @h a@\/@h b@ field with
-- @liftShowsPrec@, a constant with its own @showsPrec@.
synthShow2 :: GenEnv -> Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))
synthShow2 :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthShow2 GenEnv
gen Class
show2Cls CtLoc
loc Type
wrappedTy Type
p =
  case (GenEnv -> Maybe TyCon
geStock2 GenEnv
gen, Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realP) of
    (Just TyCon
st2Tc, Just TyCon
pTc) -> do
      Maybe Class
mShow1 <- String -> String -> TcPluginM (Maybe Class)
lookupClassMaybe String
"Data.Functor.Classes" String
"Show1"
      case Maybe Class
mShow1 of
        Maybe Class
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 Class
show1Cls -> do
          Class
showCls  <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_SHOW (String -> OccName
mkTcOcc String
"Show") TcPluginM Name -> (Name -> TcPluginM Class) -> TcPluginM Class
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Class
tcLookupClass
          Class
ordCls   <- Name -> TcPluginM Class
tcLookupClass Name
ordClassName
          TyVar
appendId <- Name -> TcPluginM TyVar
tcLookupId Name
appendName
          let fixed :: [Type]
fixed       = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
              dcons :: [DataCon]
dcons       = TyCon -> [DataCon]
tyConDataCons TyCon
pTc
              showSTy :: Type
showSTy     = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
stringTy Type
stringTy
              liftSpSel :: TyVar
liftSpSel   = String -> Class -> TyVar
classMethod String
"liftShowsPrec" Class
show1Cls
              showsPrecSel :: TyVar
showsPrecSel = String -> Class -> TyVar
classMethod String
"showsPrec" Class
showCls
              gtSel :: TyVar
gtSel       = String -> Class -> TyVar
classMethod String
">" Class
ordCls
              coAt2 :: Type -> Type -> Coercion
coAt2 Type
t1 Type
t2 = Maybe TyCon
-> TyCon -> Type -> Type -> Type -> Type -> Type -> Coercion
coDown2With (GenEnv -> Maybe TyCon
geOverride2 GenEnv
gen) TyCon
st2Tc Type
wrappedTy Type
p Type
realP Type
t1 Type
t2
              cons :: EvExpr -> EvExpr -> EvExpr
cons EvExpr
c EvExpr
t    = DataCon -> [EvExpr] -> EvExpr
mkCoreConApps DataCon
consDataCon [Type -> EvExpr
forall b. Type -> Expr b
Type Type
charTy, EvExpr
c, EvExpr
t]
              append :: Arg b -> Arg b -> Arg b
append Arg b
s Arg b
t  = 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
appendId) [Type -> Arg b
forall b. Type -> Expr b
Type Type
charTy, Arg b
s, Arg b
t]
              str :: String -> TcPluginM EvExpr
str String
s       = TcM EvExpr -> TcPluginM EvExpr
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (FastString -> TcM EvExpr
forall (m :: * -> *). MonadThings m => FastString -> m EvExpr
mkStringExprFS (String -> FastString
fsLit String
s))
          CtEvidence
ordIntEv <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
ordCls [Type
intTy])
          let ordIntDict :: EvExpr
ordIntDict = HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ordIntEv
          TyVar
aTv <- String -> TcPluginM TyVar
freshTyVar String
"a" ; TyVar
bTv <- String -> TcPluginM TyVar
freshTyVar String
"b"
          let aTy :: Type
aTy = TyVar -> Type
mkTyVarTy TyVar
aTv ; bTy :: Type
bTy = TyVar -> Type
mkTyVarTy TyVar
bTv
              spTyOf :: Type -> Type
spTyOf Type
t = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
intTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
t Type
showSTy)
              slTyOf :: Type -> Type
slTyOf Type
t = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany (Type -> Type
mkListTy Type
t) Type
showSTy
          TyVar
spA <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type
spTyOf Type
aTy) String
"spA" ; TyVar
slA <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type
slTyOf Type
aTy) String
"slA"
          TyVar
spB <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type
spTyOf Type
bTy) String
"spB" ; TyVar
slB <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type
slTyOf Type
bTy) String
"slB"
          TyVar
dId <- Type -> String -> TcPluginM TyVar
freshId Type
intTy String
"d" ; TyVar
vId <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy) Type
bTy) String
"v"
          let mkRenderer :: Int -> Type -> TyVar -> TcPluginM (Maybe (Integer -> EvExpr, [Ct]))
mkRenderer Int
i Type
ft TyVar
xi = case TyVar -> TyVar -> Type -> Type -> Type -> Maybe BiField
classifyBiField TyVar
aTv TyVar
bTv Type
aTy Type
bTy Type
ft of
                Maybe BiField
Nothing          -> Maybe (Integer -> EvExpr, [Ct])
-> TcPluginM (Maybe (Integer -> EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Integer -> EvExpr, [Ct])
forall a. Maybe a
Nothing
                Just BiField
BFA         -> Maybe (Integer -> EvExpr, [Ct])
-> TcPluginM (Maybe (Integer -> EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Integer -> EvExpr, [Ct]) -> Maybe (Integer -> EvExpr, [Ct])
forall a. a -> Maybe a
Just (\Integer
pr -> EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
spA) [Integer -> EvExpr
mkUncheckedIntExpr Integer
pr, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
xi], []))
                Just BiField
BFB         -> Maybe (Integer -> EvExpr, [Ct])
-> TcPluginM (Maybe (Integer -> EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Integer -> EvExpr, [Ct]) -> Maybe (Integer -> EvExpr, [Ct])
forall a. a -> Maybe a
Just (\Integer
pr -> EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
spB) [Integer -> EvExpr
mkUncheckedIntExpr Integer
pr, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
xi], []))
                Just BiField
BFConst     -> do CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
showCls [Type
ft])
                                       Maybe (Integer -> EvExpr, [Ct])
-> TcPluginM (Maybe (Integer -> EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Integer -> EvExpr, [Ct]) -> Maybe (Integer -> EvExpr, [Ct])
forall a. a -> Maybe a
Just (\Integer
pr -> EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
showsPrecSel) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
ft, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Integer -> EvExpr
mkUncheckedIntExpr Integer
pr, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
xi], [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
                Just (BFFoldA Type
h) -> do let m :: Type
m = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
h (GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i)
                                       CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
show1Cls [Type
m])
                                       Maybe (Integer -> EvExpr, [Ct])
-> TcPluginM (Maybe (Integer -> EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Integer -> EvExpr, [Ct]) -> Maybe (Integer -> EvExpr, [Ct])
forall a. a -> Maybe a
Just (\Integer
pr -> EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
liftSpSel) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
m, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Type -> EvExpr
forall b. Type -> Expr b
Type Type
aTy, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
spA, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
slA, Integer -> EvExpr
mkUncheckedIntExpr Integer
pr, EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
xi) (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
m Type
aTy)], [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
                Just (BFFoldB Type
h) -> do let m :: Type
m = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
h (GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i)
                                       CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
show1Cls [Type
m])
                                       Maybe (Integer -> EvExpr, [Ct])
-> TcPluginM (Maybe (Integer -> EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Integer -> EvExpr, [Ct]) -> Maybe (Integer -> EvExpr, [Ct])
forall a. a -> Maybe a
Just (\Integer
pr -> EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
liftSpSel) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
m, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Type -> EvExpr
forall b. Type -> Expr b
Type Type
bTy, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
spB, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
slB, Integer -> EvExpr
mkUncheckedIntExpr Integer
pr, EvExpr -> Coercion -> EvExpr
castReshape (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
xi) (Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
m Type
bTy)], [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
          [Maybe (Alt TyVar, [Ct])]
mAltWss <- [DataCon]
-> (DataCon -> TcPluginM (Maybe (Alt TyVar, [Ct])))
-> TcPluginM [Maybe (Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DataCon]
dcons \DataCon
dc -> do
            let fts :: [Type]
fts    = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy]))
                name :: String
name   = OccName -> String
occNameString (DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
dc)
                labels :: [String]
labels = (FieldLabel -> String) -> [FieldLabel] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> String
occNameString (OccName -> String)
-> (FieldLabel -> OccName) -> FieldLabel -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (FieldLabel -> Name) -> FieldLabel -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> Name
flSelector) (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc)
            EvExpr
nameStr <- String -> TcPluginM EvExpr
str String
name
            [TyVar]
xs      <- (Int -> Type -> TcPluginM TyVar)
-> [Int] -> [Type] -> TcPluginM [TyVar]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
n Type
ft -> Type -> String -> TcPluginM TyVar
freshId Type
ft (String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..] [Type]
fts
            TyVar
rest    <- Type -> String -> TcPluginM TyVar
freshId Type
stringTy String
"r"
            TyVar
gtBndr  <- Type -> String -> TcPluginM TyVar
freshId Type
boolTy String
"pb"
            Integer
prec    <- DataCon -> TcPluginM Integer
conPrec DataCon
dc
            [Maybe (Integer -> EvExpr, [Ct])]
mRends  <- [TcPluginM (Maybe (Integer -> EvExpr, [Ct]))]
-> TcPluginM [Maybe (Integer -> EvExpr, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((Int
 -> Type -> TyVar -> TcPluginM (Maybe (Integer -> EvExpr, [Ct])))
-> [Int]
-> [Type]
-> [TyVar]
-> [TcPluginM (Maybe (Integer -> EvExpr, [Ct]))]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> Type -> TyVar -> TcPluginM (Maybe (Integer -> EvExpr, [Ct]))
mkRenderer [Int
0 :: Int ..] [Type]
fts [TyVar]
xs)
            case [Maybe (Integer -> EvExpr, [Ct])]
-> Maybe [(Integer -> EvExpr, [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 (Integer -> EvExpr, [Ct])]
mRends of
              Maybe [(Integer -> EvExpr, [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 [(Integer -> EvExpr, [Ct])]
rends -> do
                let ([Integer -> EvExpr]
renderers, [[Ct]]
wss) = [(Integer -> EvExpr, [Ct])] -> ([Integer -> EvExpr], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Integer -> EvExpr, [Ct])]
rends
                    parenAt :: Integer -> (EvExpr -> EvExpr) -> EvExpr -> EvExpr
parenAt Integer
thr EvExpr -> EvExpr
mk EvExpr
t =
                      EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
gtSel) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
intTy, EvExpr
ordIntDict, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
dId, Integer -> EvExpr
mkUncheckedIntExpr Integer
thr])
                           TyVar
gtBndr Type
stringTy
                        [ AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] (EvExpr -> EvExpr
mk EvExpr
t)
                        , AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  [] (EvExpr -> EvExpr -> EvExpr
cons (Char -> EvExpr
mkCharExpr Char
'(') (EvExpr -> EvExpr
mk (EvExpr -> EvExpr -> EvExpr
cons (Char -> EvExpr
mkCharExpr Char
')') EvExpr
t))) ]
                    goPrefix :: EvExpr -> EvExpr
goPrefix EvExpr
t   = ((Integer -> EvExpr) -> EvExpr -> EvExpr)
-> EvExpr -> [Integer -> EvExpr] -> EvExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Integer -> EvExpr
r EvExpr
acc -> EvExpr -> EvExpr -> EvExpr
cons (Char -> EvExpr
mkCharExpr Char
' ') (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App (Integer -> EvExpr
r Integer
11) EvExpr
acc)) EvExpr
t [Integer -> EvExpr]
renderers
                    prefixBody :: EvExpr -> EvExpr
prefixBody EvExpr
t = EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
append EvExpr
nameStr (EvExpr -> EvExpr
goPrefix EvExpr
t)
                EvExpr
body <-
                  if DataCon -> Bool
dataConIsInfix DataCon
dc
                    then do EvExpr
opStr <- String -> TcPluginM EvExpr
str (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ")
                            let [Integer -> EvExpr
l, Integer -> EvExpr
r] = [Integer -> EvExpr]
renderers
                                mk :: EvExpr -> EvExpr
mk EvExpr
t = EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App (Integer -> EvExpr
l (Integer
prec Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)) (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
append EvExpr
opStr (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App (Integer -> EvExpr
r (Integer
prec Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)) EvExpr
t))
                            EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> (EvExpr -> EvExpr) -> EvExpr -> EvExpr
parenAt Integer
prec EvExpr -> EvExpr
mk (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
rest))
                    else if Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
labels)
                      then do EvExpr
openB <- String -> TcPluginM EvExpr
str String
" {" ; EvExpr
eqB <- String -> TcPluginM EvExpr
str String
" = " ; EvExpr
commaB <- String -> TcPluginM EvExpr
str String
", " ; EvExpr
closeB <- String -> TcPluginM EvExpr
str String
"}"
                              [EvExpr]
lblStrs <- (String -> TcPluginM EvExpr) -> [String] -> TcPluginM [EvExpr]
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 String -> TcPluginM EvExpr
str [String]
labels
                              let recF :: [(EvExpr, Integer -> EvExpr)]
recF = [EvExpr] -> [Integer -> EvExpr] -> [(EvExpr, Integer -> EvExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [EvExpr]
lblStrs [Integer -> EvExpr]
renderers
                                  goRec :: [(EvExpr, t -> EvExpr)] -> EvExpr -> EvExpr
goRec [(EvExpr
lbl, t -> EvExpr
r)] EvExpr
c     = EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
append EvExpr
lbl (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
append EvExpr
eqB (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App (t -> EvExpr
r t
0) (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
append EvExpr
closeB EvExpr
c)))
                                  goRec ((EvExpr
lbl, t -> EvExpr
r) : [(EvExpr, t -> EvExpr)]
m) EvExpr
c = EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
append EvExpr
lbl (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
append EvExpr
eqB (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App (t -> EvExpr
r t
0) (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
append EvExpr
commaB ([(EvExpr, t -> EvExpr)] -> EvExpr -> EvExpr
goRec [(EvExpr, t -> EvExpr)]
m EvExpr
c))))
                                  goRec [] EvExpr
c             = EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
append EvExpr
closeB EvExpr
c
                                  recBody :: EvExpr -> EvExpr
recBody EvExpr
t = EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
append EvExpr
nameStr (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
append EvExpr
openB ([(EvExpr, Integer -> EvExpr)] -> EvExpr -> EvExpr
forall {t}. Num t => [(EvExpr, t -> EvExpr)] -> EvExpr -> EvExpr
goRec [(EvExpr, Integer -> EvExpr)]
recF EvExpr
t))
                              EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> (EvExpr -> EvExpr) -> EvExpr -> EvExpr
parenAt Integer
10 EvExpr -> EvExpr
recBody (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
rest))
                      else if [TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
xs then EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
append EvExpr
nameStr (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
rest))
                                      else EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> (EvExpr -> EvExpr) -> EvExpr -> EvExpr
parenAt Integer
10 EvExpr -> EvExpr
prefixBody (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
rest))
                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] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [TyVar]
xs (TyVar -> EvExpr -> EvExpr
forall b. b -> Expr b -> Expr b
Lam TyVar
rest EvExpr
body), [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))
          case [Maybe (Alt TyVar, [Ct])] -> Maybe [(Alt TyVar, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Alt TyVar, [Ct])]
mAltWss 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
              TyVar
cb <- Type -> String -> TcPluginM TyVar
freshId (TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy])) String
"cb"
              let impl :: EvExpr
impl = [TyVar] -> EvExpr -> EvExpr
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
aTv, TyVar
bTv, TyVar
spA, TyVar
slA, TyVar
spB, TyVar
slB, TyVar
dId, TyVar
vId]
                           (TyCon -> [Type] -> EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
destructInner TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy]) (EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
vId) (Type -> Type -> Coercion
coAt2 Type
aTy Type
bTy)) TyVar
cb Type
showSTy [Alt TyVar]
alts)
              ([EvExpr]
supers, [Ct]
scWs) <- Class -> Type -> CtLoc -> TcPluginM ([EvExpr], [Ct])
stock2Supers Class
show2Cls Type
wrappedTy CtLoc
loc
              EvExpr
dict <- Class -> Type -> [EvExpr] -> [(Int, EvExpr)] -> TcPluginM EvExpr
recDictWith Class
show2Cls Type
wrappedTy [EvExpr]
supers [(Int
0, EvExpr
impl)]
              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 (EvExpr -> EvTerm
EvExpr EvExpr
dict, CtEvidence -> Ct
mkNonCanonical CtEvidence
ordIntEv Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
scWs [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))
    (Maybe TyCon, 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
  where (Type
realP, Maybe [Type]
mMods) = OvTcs -> Type -> (Type, Maybe [Type])
peelOverride2With (String -> GenEnv -> OvTcs
ovTcsGen String
"Override2" GenEnv
gen) Type
p

-- | Synthesize @Read2 (Stock2 P)@: @liftReadsPrec2@ parses like derived @Read@
-- (prefix / infix / record, precedence-aware) but reads a first-param field
-- with @rp1@, a second with @rp2@, an @h a@\/@h b@ field with @liftReadsPrec@,
-- a constant with its own @readsPrec@.  The bivariate counterpart of
-- 'Stock.Classes1.synthRead1'; quantified superclasses come via 'stock2Supers'.
synthRead2 :: GenEnv -> Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))
synthRead2 :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthRead2 GenEnv
gen Class
read2Cls CtLoc
loc Type
wrappedTy Type
p =
  case (GenEnv -> Maybe TyCon
geStock2 GenEnv
gen, Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realP) of
    (Just TyCon
st2Tc, Just TyCon
pTc) -> do
      Maybe Class
mRead1 <- String -> String -> TcPluginM (Maybe Class)
lookupClassMaybe String
"Data.Functor.Classes" String
"Read1"
      case Maybe Class
mRead1 of
        Maybe Class
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 Class
read1Cls -> do
          Class
readCls     <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_READ (String -> OccName
mkTcOcc String
"Read") TcPluginM Name -> (Name -> TcPluginM Class) -> TcPluginM Class
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Class
tcLookupClass
          Class
ordCls      <- Name -> TcPluginM Class
tcLookupClass Name
ordClassName
          TyVar
appendId    <- Name -> TcPluginM TyVar
tcLookupId Name
appendName
          TyVar
eqStringId  <- Name -> TcPluginM TyVar
tcLookupId Name
eqStringName
          TyVar
lexId       <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_READ (String -> OccName
mkVarOcc String
"lex")       TcPluginM Name -> (Name -> TcPluginM TyVar) -> TcPluginM TyVar
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM TyVar
tcLookupId
          TyVar
readParenId <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_READ (String -> OccName
mkVarOcc String
"readParen") TcPluginM Name -> (Name -> TcPluginM TyVar) -> TcPluginM TyVar
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM TyVar
tcLookupId
          TyVar
concatMapId <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_LIST (String -> OccName
mkVarOcc String
"concatMap") TcPluginM Name -> (Name -> TcPluginM TyVar) -> TcPluginM TyVar
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM TyVar
tcLookupId
          let liftRpSel :: TyVar
liftRpSel    = String -> Class -> TyVar
classMethod String
"liftReadsPrec" Class
read1Cls
              readsPrecSel :: TyVar
readsPrecSel = String -> Class -> TyVar
classMethod String
"readsPrec" Class
readCls
              gtSel :: TyVar
gtSel        = String -> Class -> TyVar
classMethod String
">" Class
ordCls
              fixed :: [Type]
fixed        = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
              dcons :: [DataCon]
dcons        = TyCon -> [DataCon]
tyConDataCons TyCon
pTc
              coAt2 :: Type -> Type -> Coercion
coAt2 Type
t1 Type
t2  = Maybe TyCon
-> TyCon -> Type -> Type -> Type -> Type -> Type -> Coercion
coDown2With (GenEnv -> Maybe TyCon
geOverride2 GenEnv
gen) TyCon
st2Tc Type
wrappedTy Type
p Type
realP Type
t1 Type
t2
          CtEvidence
ordIntEv <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
ordCls [Type
intTy])
          let ordIntDict :: EvExpr
ordIntDict = HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ordIntEv
          TyVar
aTv <- String -> TcPluginM TyVar
freshTyVar String
"a" ; TyVar
bTv <- String -> TcPluginM TyVar
freshTyVar String
"b"
          let aTy :: Type
aTy = TyVar -> Type
mkTyVarTy TyVar
aTv ; bTy :: Type
bTy = TyVar -> Type
mkTyVarTy TyVar
bTv
              innerAB :: Type
innerAB   = TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy])
              gabTy :: Type
gabTy     = Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy) Type
bTy
              readSOf :: Type -> Type
readSOf Type
t = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
stringTy (Type -> Type
mkListTy ([Type] -> Type
mkBoxedTupleTy [Type
t, Type
stringTy]))
              rpTyOf :: Type -> Type
rpTyOf Type
t  = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
intTy (Type -> Type
readSOf Type
t)       -- Int -> ReadS t
              rlTyOf :: Type -> Type
rlTyOf Type
t  = Type -> Type
readSOf (Type -> Type
mkListTy Type
t)                   -- ReadS [t]
              pairTy :: Type
pairTy    = [Type] -> Type
mkBoxedTupleTy [Type
gabTy, Type
stringTy]
              strPairTy :: Type
strPairTy = [Type] -> Type
mkBoxedTupleTy [Type
stringTy, Type
stringTy]
              listPair :: Type
listPair  = Type -> Type
mkListTy Type
pairTy
              tup2 :: DataCon
tup2      = Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed Int
2
              nilPair :: EvExpr
nilPair   = Type -> EvExpr
mkNilExpr Type
pairTy
              false_ :: Expr b
false_    = TyVar -> Expr b
forall b. TyVar -> Expr b
Var (DataCon -> TyVar
dataConWorkId DataCon
falseDataCon)
              toWrapped :: Expr b -> Expr b
toWrapped Expr b
e = Expr b -> Coercion -> Expr b
forall b. Expr b -> Coercion -> Expr b
Cast Expr b
e (Coercion -> Coercion
mkSymCo (Type -> Type -> Coercion
coAt2 Type
aTy Type
bTy))
              mkPairW :: EvExpr -> EvExpr -> EvExpr
mkPairW EvExpr
v EvExpr
r = DataCon -> [EvExpr] -> EvExpr
mkCoreConApps DataCon
tup2 [Type -> EvExpr
forall b. Type -> Expr b
Type Type
gabTy, Type -> EvExpr
forall b. Type -> Expr b
Type Type
stringTy, EvExpr
v, EvExpr
r]
              concatMapTo :: Type -> Arg b -> Arg b -> Arg b
concatMapTo Type
srcElem Arg b
fn Arg b
src = 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
concatMapId) [Type -> Arg b
forall b. Type -> Expr b
Type Type
srcElem, Type -> Arg b
forall b. Type -> Expr b
Type Type
pairTy, Arg b
fn, Arg b
src]
              str :: String -> TcPluginM EvExpr
str String
s = TcM EvExpr -> TcPluginM EvExpr
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (FastString -> TcM EvExpr
forall (m :: * -> *). MonadThings m => FastString -> m EvExpr
mkStringExprFS (String -> FastString
fsLit String
s))
          TyVar
rp1Id <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type
rpTyOf Type
aTy) String
"rp1" ; TyVar
rl1Id <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type
rlTyOf Type
aTy) String
"rl1"
          TyVar
rp2Id <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type
rpTyOf Type
bTy) String
"rp2" ; TyVar
rl2Id <- Type -> String -> TcPluginM TyVar
freshId (Type -> Type
rlTyOf Type
bTy) String
"rl2"
          TyVar
dId   <- Type -> String -> TcPluginM TyVar
freshId Type
intTy String
"d" ; TyVar
rId <- Type -> String -> TcPluginM TyVar
freshId Type
stringTy String
"r"

          -- one field's reader @prec -> restString -> [(ft, String)]@.
          let resOf :: Type -> Type
resOf Type
t = Type -> Type
mkListTy ([Type] -> Type
mkBoxedTupleTy [Type
t, Type
stringTy])   -- [(t, String)]
              -- read an @h a@/@h b@ field via the modifier @m@, then cast the
              -- parsed @[(m a,String)]@ back to the real @[(h a,String)]@.
              readFold :: Type
-> TyVar
-> TyVar
-> Int
-> Type
-> TcPluginM (Maybe (Integer -> EvExpr -> EvExpr, [Ct]))
readFold Type
tArg TyVar
rpI TyVar
rlI Int
i Type
h = do
                let mMod :: Maybe Type
mMod = GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i
                    m :: Type
m    = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
h Maybe Type
mMod
                CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
read1Cls [Type
m])
                let rdr :: Integer -> EvExpr -> EvExpr
rdr Integer
prec EvExpr
rest =
                      let parsed :: EvExpr
parsed = EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
liftRpSel)
                            [Type -> EvExpr
forall b. Type -> Expr b
Type Type
m, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Type -> EvExpr
forall b. Type -> Expr b
Type Type
tArg, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
rpI, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
rlI
                            , Integer -> EvExpr
mkUncheckedIntExpr Integer
prec, EvExpr
rest]
                      in case Maybe Type
mMod of
                           Maybe Type
Nothing -> EvExpr
parsed
                           Just Type
_  -> EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast EvExpr
parsed (UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkStockCo (String -> UnivCoProvenance
PluginProv String
"stock") Role
Representational
                                        (Type -> Type
resOf (Type -> Type -> Type
mkAppTy Type
m Type
tArg)) (Type -> Type
resOf (Type -> Type -> Type
mkAppTy Type
h Type
tArg)))
                Maybe (Integer -> EvExpr -> EvExpr, [Ct])
-> TcPluginM (Maybe (Integer -> EvExpr -> EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Integer -> EvExpr -> EvExpr, [Ct])
-> Maybe (Integer -> EvExpr -> EvExpr, [Ct])
forall a. a -> Maybe a
Just (Integer -> EvExpr -> EvExpr
rdr, [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
              mkFieldReader :: Int
-> Type -> TcPluginM (Maybe (Integer -> EvExpr -> EvExpr, [Ct]))
mkFieldReader Int
i Type
ft = case TyVar -> TyVar -> Type -> Type -> Type -> Maybe BiField
classifyBiField TyVar
aTv TyVar
bTv Type
aTy Type
bTy Type
ft of
                Maybe BiField
Nothing          -> Maybe (Integer -> EvExpr -> EvExpr, [Ct])
-> TcPluginM (Maybe (Integer -> EvExpr -> EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Integer -> EvExpr -> EvExpr, [Ct])
forall a. Maybe a
Nothing
                Just BiField
BFA         -> Maybe (Integer -> EvExpr -> EvExpr, [Ct])
-> TcPluginM (Maybe (Integer -> EvExpr -> EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Integer -> EvExpr -> EvExpr, [Ct])
-> Maybe (Integer -> EvExpr -> EvExpr, [Ct])
forall a. a -> Maybe a
Just ((\Integer
prec EvExpr
rest -> EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
rp1Id) [Integer -> EvExpr
mkUncheckedIntExpr Integer
prec, EvExpr
rest]), []))
                Just BiField
BFB         -> Maybe (Integer -> EvExpr -> EvExpr, [Ct])
-> TcPluginM (Maybe (Integer -> EvExpr -> EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Integer -> EvExpr -> EvExpr, [Ct])
-> Maybe (Integer -> EvExpr -> EvExpr, [Ct])
forall a. a -> Maybe a
Just ((\Integer
prec EvExpr
rest -> EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
rp2Id) [Integer -> EvExpr
mkUncheckedIntExpr Integer
prec, EvExpr
rest]), []))
                Just BiField
BFConst     -> do CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
readCls [Type
ft])
                                       Maybe (Integer -> EvExpr -> EvExpr, [Ct])
-> TcPluginM (Maybe (Integer -> EvExpr -> EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Integer -> EvExpr -> EvExpr, [Ct])
-> Maybe (Integer -> EvExpr -> EvExpr, [Ct])
forall a. a -> Maybe a
Just ((\Integer
prec EvExpr
rest -> EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
readsPrecSel)
                                              [Type -> EvExpr
forall b. Type -> Expr b
Type Type
ft, HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev, Integer -> EvExpr
mkUncheckedIntExpr Integer
prec, EvExpr
rest]), [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
                Just (BFFoldA Type
h) -> Type
-> TyVar
-> TyVar
-> Int
-> Type
-> TcPluginM (Maybe (Integer -> EvExpr -> EvExpr, [Ct]))
readFold Type
aTy TyVar
rp1Id TyVar
rl1Id Int
i Type
h
                Just (BFFoldB Type
h) -> Type
-> TyVar
-> TyVar
-> Int
-> Type
-> TcPluginM (Maybe (Integer -> EvExpr -> EvExpr, [Ct]))
readFold Type
bTy TyVar
rp2Id TyVar
rl2Id Int
i Type
h

          let buildChain :: DataCon
-> [(Type, Integer -> EvExpr -> EvExpr)]
-> [TyVar]
-> EvExpr
-> TcPluginM EvExpr
buildChain DataCon
dc [] [TyVar]
accRev EvExpr
restE =
                EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvExpr -> TcPluginM EvExpr) -> EvExpr -> TcPluginM EvExpr
forall a b. (a -> b) -> a -> b
$ DataCon -> [EvExpr] -> EvExpr
mkCoreConApps DataCon
consDataCon
                  [ Type -> EvExpr
forall b. Type -> Expr b
Type Type
pairTy
                  , EvExpr -> EvExpr -> EvExpr
mkPairW (EvExpr -> EvExpr
forall {b}. Expr b -> Expr b
toWrapped (Type -> DataCon -> [EvExpr] -> EvExpr
conAppAt Type
innerAB DataCon
dc ((TyVar -> EvExpr) -> [TyVar] -> [EvExpr]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> EvExpr
forall b. TyVar -> Expr b
Var ([TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse [TyVar]
accRev)))) EvExpr
restE
                  , EvExpr
nilPair ]
              buildChain DataCon
dc ((Type
ft, Integer -> EvExpr -> EvExpr
rdr) : [(Type, Integer -> EvExpr -> EvExpr)]
more) [TyVar]
accRev EvExpr
restE = do
                TyVar
a  <- Type -> String -> TcPluginM TyVar
freshId Type
ft String
"a" ; TyVar
r' <- Type -> String -> TcPluginM TyVar
freshId Type
stringTy String
"r"
                TyVar
pc <- Type -> String -> TcPluginM TyVar
freshId ([Type] -> Type
mkBoxedTupleTy [Type
ft, Type
stringTy]) String
"p"
                TyVar
cb <- Type -> String -> TcPluginM TyVar
freshId ([Type] -> Type
mkBoxedTupleTy [Type
ft, Type
stringTy]) String
"pc"
                EvExpr
rest <- DataCon
-> [(Type, Integer -> EvExpr -> EvExpr)]
-> [TyVar]
-> EvExpr
-> TcPluginM EvExpr
buildChain DataCon
dc [(Type, Integer -> EvExpr -> EvExpr)]
more (TyVar
a TyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
: [TyVar]
accRev) (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
r')
                let parsed :: EvExpr
parsed = Integer -> EvExpr -> EvExpr
rdr (Integer
11 :: Integer) EvExpr
restE
                    lam :: EvExpr
lam = TyVar -> EvExpr -> EvExpr
forall b. b -> Expr b -> Expr b
Lam TyVar
pc (EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
pc) TyVar
cb Type
listPair [AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
tup2) [TyVar
a, TyVar
r'] EvExpr
rest])
                EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> EvExpr -> EvExpr -> EvExpr
forall {b}. Type -> Arg b -> Arg b -> Arg b
concatMapTo ([Type] -> Type
mkBoxedTupleTy [Type
ft, Type
stringTy]) EvExpr
lam EvExpr
parsed)

              expectTok :: EvExpr
-> EvExpr -> (Expr b -> TcPluginM EvExpr) -> TcPluginM EvExpr
expectTok EvExpr
expStr EvExpr
restE Expr b -> TcPluginM EvExpr
k = do
                TyVar
pp <- Type -> String -> TcPluginM TyVar
freshId Type
strPairTy String
"p"; TyVar
cb <- Type -> String -> TcPluginM TyVar
freshId Type
strPairTy String
"pc"
                TyVar
tk <- Type -> String -> TcPluginM TyVar
freshId Type
stringTy String
"t"; TyVar
r' <- Type -> String -> TcPluginM TyVar
freshId Type
stringTy String
"r"; TyVar
ecb <- Type -> String -> TcPluginM TyVar
freshId Type
boolTy String
"b"
                EvExpr
body <- Expr b -> TcPluginM EvExpr
k (TyVar -> Expr b
forall b. TyVar -> Expr b
Var TyVar
r')
                let lam :: EvExpr
lam = TyVar -> EvExpr -> EvExpr
forall b. b -> Expr b -> Expr b
Lam TyVar
pp (EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
pp) TyVar
cb Type
listPair
                      [AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
tup2) [TyVar
tk, TyVar
r']
                         (EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
eqStringId) [TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
tk, EvExpr
expStr]) TyVar
ecb Type
listPair
                            [ AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] EvExpr
nilPair
                            , AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  [] EvExpr
body ])])
                EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> EvExpr -> EvExpr -> EvExpr
forall {b}. Type -> Arg b -> Arg b -> Arg b
concatMapTo Type
strPairTy EvExpr
lam (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
lexId) EvExpr
restE))

              parseFieldP :: t
-> Type
-> (t -> t -> EvExpr)
-> t
-> (Expr b -> Expr b -> TcPluginM EvExpr)
-> TcPluginM EvExpr
parseFieldP t
prec Type
ft t -> t -> EvExpr
rdr t
restE Expr b -> Expr b -> TcPluginM EvExpr
k = do
                TyVar
pp <- Type -> String -> TcPluginM TyVar
freshId ([Type] -> Type
mkBoxedTupleTy [Type
ft, Type
stringTy]) String
"p"
                TyVar
cb <- Type -> String -> TcPluginM TyVar
freshId ([Type] -> Type
mkBoxedTupleTy [Type
ft, Type
stringTy]) String
"pc"
                TyVar
v <- Type -> String -> TcPluginM TyVar
freshId Type
ft String
"v"; TyVar
r' <- Type -> String -> TcPluginM TyVar
freshId Type
stringTy String
"r"
                EvExpr
body <- Expr b -> Expr b -> TcPluginM EvExpr
k (TyVar -> Expr b
forall b. TyVar -> Expr b
Var TyVar
v) (TyVar -> Expr b
forall b. TyVar -> Expr b
Var TyVar
r')
                let lam :: EvExpr
lam = TyVar -> EvExpr -> EvExpr
forall b. b -> Expr b -> Expr b
Lam TyVar
pp (EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
pp) TyVar
cb Type
listPair [AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
tup2) [TyVar
v, TyVar
r'] EvExpr
body])
                EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> EvExpr -> EvExpr -> EvExpr
forall {b}. Type -> Arg b -> Arg b -> Arg b
concatMapTo ([Type] -> Type
mkBoxedTupleTy [Type
ft, Type
stringTy]) EvExpr
lam (t -> t -> EvExpr
rdr t
prec t
restE))

              recChain :: DataCon
-> [(String, Type, Integer -> Expr b -> EvExpr)]
-> EvExpr
-> TcPluginM EvExpr
recChain DataCon
dc [(String, Type, Integer -> Expr b -> EvExpr)]
fields EvExpr
restAfterName = do
                EvExpr
openB <- String -> TcPluginM EvExpr
str String
"{"; EvExpr
closeB <- String -> TcPluginM EvExpr
str String
"}"; EvExpr
eqB <- String -> TcPluginM EvExpr
str String
"="; EvExpr
commaB <- String -> TcPluginM EvExpr
str String
","
                let result :: [EvExpr] -> EvExpr -> EvExpr
result [EvExpr]
accRev EvExpr
rEnd = DataCon -> [EvExpr] -> EvExpr
mkCoreConApps DataCon
consDataCon
                      [ Type -> EvExpr
forall b. Type -> Expr b
Type Type
pairTy
                      , EvExpr -> EvExpr -> EvExpr
mkPairW (EvExpr -> EvExpr
forall {b}. Expr b -> Expr b
toWrapped (Type -> DataCon -> [EvExpr] -> EvExpr
conAppAt Type
innerAB DataCon
dc ([EvExpr] -> [EvExpr]
forall a. [a] -> [a]
reverse [EvExpr]
accRev))) EvExpr
rEnd
                      , EvExpr
nilPair ]
                    go :: EvExpr
-> [EvExpr]
-> [(String, Type, Integer -> Expr b -> EvExpr)]
-> Bool
-> TcPluginM EvExpr
go EvExpr
restE [EvExpr]
accRev [] Bool
_ = EvExpr
-> EvExpr -> (EvExpr -> TcPluginM EvExpr) -> TcPluginM EvExpr
forall {b}.
EvExpr
-> EvExpr -> (Expr b -> TcPluginM EvExpr) -> TcPluginM EvExpr
expectTok EvExpr
closeB EvExpr
restE (\EvExpr
rEnd -> EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([EvExpr] -> EvExpr -> EvExpr
result [EvExpr]
accRev EvExpr
rEnd))
                    go EvExpr
restE [EvExpr]
accRev ((String
lbl, Type
ft, Integer -> Expr b -> EvExpr
rdr) : [(String, Type, Integer -> Expr b -> EvExpr)]
more) Bool
isFirst = do
                      EvExpr
lblStr <- String -> TcPluginM EvExpr
str String
lbl
                      let after :: EvExpr -> TcPluginM EvExpr
after EvExpr
rr = EvExpr
-> EvExpr -> (EvExpr -> TcPluginM EvExpr) -> TcPluginM EvExpr
forall {b}.
EvExpr
-> EvExpr -> (Expr b -> TcPluginM EvExpr) -> TcPluginM EvExpr
expectTok EvExpr
lblStr EvExpr
rr \EvExpr
r1 ->
                                     EvExpr
-> EvExpr -> (Expr b -> TcPluginM EvExpr) -> TcPluginM EvExpr
forall {b}.
EvExpr
-> EvExpr -> (Expr b -> TcPluginM EvExpr) -> TcPluginM EvExpr
expectTok EvExpr
eqB EvExpr
r1 \Expr b
r2 ->
                                     Integer
-> Type
-> (Integer -> Expr b -> EvExpr)
-> Expr b
-> (EvExpr -> EvExpr -> TcPluginM EvExpr)
-> TcPluginM EvExpr
forall {t} {t} {b} {b}.
t
-> Type
-> (t -> t -> EvExpr)
-> t
-> (Expr b -> Expr b -> TcPluginM EvExpr)
-> TcPluginM EvExpr
parseFieldP (Integer
0 :: Integer) Type
ft Integer -> Expr b -> EvExpr
rdr Expr b
r2 \EvExpr
v EvExpr
r3 ->
                                     EvExpr
-> [EvExpr]
-> [(String, Type, Integer -> Expr b -> EvExpr)]
-> Bool
-> TcPluginM EvExpr
go EvExpr
r3 (EvExpr
v EvExpr -> [EvExpr] -> [EvExpr]
forall a. a -> [a] -> [a]
: [EvExpr]
accRev) [(String, Type, Integer -> Expr b -> EvExpr)]
more Bool
False
                      if Bool
isFirst then EvExpr -> TcPluginM EvExpr
after EvExpr
restE else EvExpr
-> EvExpr -> (EvExpr -> TcPluginM EvExpr) -> TcPluginM EvExpr
forall {b}.
EvExpr
-> EvExpr -> (Expr b -> TcPluginM EvExpr) -> TcPluginM EvExpr
expectTok EvExpr
commaB EvExpr
restE EvExpr -> TcPluginM EvExpr
after
                EvExpr
-> EvExpr -> (EvExpr -> TcPluginM EvExpr) -> TcPluginM EvExpr
forall {b}.
EvExpr
-> EvExpr -> (Expr b -> TcPluginM EvExpr) -> TcPluginM EvExpr
expectTok EvExpr
openB EvExpr
restAfterName (\EvExpr
r0 -> EvExpr
-> [EvExpr]
-> [(String, Type, Integer -> Expr b -> EvExpr)]
-> Bool
-> TcPluginM EvExpr
forall {b}.
EvExpr
-> [EvExpr]
-> [(String, Type, Integer -> Expr b -> EvExpr)]
-> Bool
-> TcPluginM EvExpr
go EvExpr
r0 [] [(String, Type, Integer -> Expr b -> EvExpr)]
fields Bool
True)

          [Maybe (EvExpr, [Ct])]
mParserWss <- [DataCon]
-> (DataCon -> TcPluginM (Maybe (EvExpr, [Ct])))
-> TcPluginM [Maybe (EvExpr, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DataCon]
dcons \DataCon
dc -> do
            let fts :: [Type]
fts    = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy]))
                name :: String
name   = OccName -> String
occNameString (DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
dc)
                labels :: [String]
labels = (FieldLabel -> String) -> [FieldLabel] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> String
occNameString (OccName -> String)
-> (FieldLabel -> OccName) -> FieldLabel -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (FieldLabel -> Name) -> FieldLabel -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> Name
flSelector) (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc)
            EvExpr
nameStr <- String -> TcPluginM EvExpr
str String
name
            [Maybe (Integer -> EvExpr -> EvExpr, [Ct])]
mRdrs   <- (Int
 -> Type -> TcPluginM (Maybe (Integer -> EvExpr -> EvExpr, [Ct])))
-> [Int]
-> [Type]
-> TcPluginM [Maybe (Integer -> EvExpr -> EvExpr, [Ct])]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Int
-> Type -> TcPluginM (Maybe (Integer -> EvExpr -> EvExpr, [Ct]))
mkFieldReader [Int
0 :: Int ..] [Type]
fts
            case [Maybe (Integer -> EvExpr -> EvExpr, [Ct])]
-> Maybe [(Integer -> EvExpr -> EvExpr, [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 (Integer -> EvExpr -> EvExpr, [Ct])]
mRdrs of
              Maybe [(Integer -> EvExpr -> EvExpr, [Ct])]
Nothing      -> Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvExpr, [Ct])
forall a. Maybe a
Nothing
              Just [(Integer -> EvExpr -> EvExpr, [Ct])]
rdrPrs  -> do
                let ([Integer -> EvExpr -> EvExpr]
rdrs, [[Ct]]
wss) = [(Integer -> EvExpr -> EvExpr, [Ct])]
-> ([Integer -> EvExpr -> EvExpr], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Integer -> EvExpr -> EvExpr, [Ct])]
rdrPrs
                    gtThr :: Integer -> EvExpr
gtThr Integer
thr = EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
gtSel) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
intTy, EvExpr
ordIntDict, TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
dId, Integer -> EvExpr
mkUncheckedIntExpr Integer
thr]
                    mkParser :: Arg b -> Arg b -> Arg b
mkParser Arg b
flag Arg b
inner =
                      Arg b -> Arg b -> Arg b
forall b. Expr b -> Expr b -> Expr b
App (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
readParenId) [Type -> Arg b
forall b. Type -> Expr b
Type Type
gabTy, Arg b
flag, Arg b
inner]) (TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
rId)
                EvExpr
parserApp <-
                  if DataCon -> Bool
dataConIsInfix DataCon
dc
                    then do
                      Integer
prec <- DataCon -> TcPluginM Integer
conPrec DataCon
dc
                      let [(Type
ft0, Integer -> EvExpr -> EvExpr
rdr0), (Type
ft1, Integer -> EvExpr -> EvExpr
rdr1)] = [Type]
-> [Integer -> EvExpr -> EvExpr]
-> [(Type, Integer -> EvExpr -> EvExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
fts [Integer -> EvExpr -> EvExpr]
rdrs
                      TyVar
r0 <- Type -> String -> TcPluginM TyVar
freshId Type
stringTy String
"r0"
                      EvExpr
body <- Integer
-> Type
-> (Integer -> EvExpr -> EvExpr)
-> EvExpr
-> (EvExpr -> EvExpr -> TcPluginM EvExpr)
-> TcPluginM EvExpr
forall {t} {t} {b} {b}.
t
-> Type
-> (t -> t -> EvExpr)
-> t
-> (Expr b -> Expr b -> TcPluginM EvExpr)
-> TcPluginM EvExpr
parseFieldP (Integer
prec Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Type
ft0 Integer -> EvExpr -> EvExpr
rdr0 (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
r0) \EvExpr
x EvExpr
rA ->
                              EvExpr
-> EvExpr -> (EvExpr -> TcPluginM EvExpr) -> TcPluginM EvExpr
forall {b}.
EvExpr
-> EvExpr -> (Expr b -> TcPluginM EvExpr) -> TcPluginM EvExpr
expectTok EvExpr
nameStr EvExpr
rA \EvExpr
rB ->
                              Integer
-> Type
-> (Integer -> EvExpr -> EvExpr)
-> EvExpr
-> (EvExpr -> EvExpr -> TcPluginM EvExpr)
-> TcPluginM EvExpr
forall {t} {t} {b} {b}.
t
-> Type
-> (t -> t -> EvExpr)
-> t
-> (Expr b -> Expr b -> TcPluginM EvExpr)
-> TcPluginM EvExpr
parseFieldP (Integer
prec Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Type
ft1 Integer -> EvExpr -> EvExpr
rdr1 EvExpr
rB \EvExpr
y EvExpr
rC ->
                              EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvExpr -> TcPluginM EvExpr) -> EvExpr -> TcPluginM EvExpr
forall a b. (a -> b) -> a -> b
$ DataCon -> [EvExpr] -> EvExpr
mkCoreConApps DataCon
consDataCon
                                [ Type -> EvExpr
forall b. Type -> Expr b
Type Type
pairTy
                                , EvExpr -> EvExpr -> EvExpr
mkPairW (EvExpr -> EvExpr
forall {b}. Expr b -> Expr b
toWrapped (Type -> DataCon -> [EvExpr] -> EvExpr
conAppAt Type
innerAB DataCon
dc [EvExpr
x, EvExpr
y])) EvExpr
rC
                                , EvExpr
nilPair ]
                      EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
mkParser (Integer -> EvExpr
gtThr Integer
prec) (TyVar -> EvExpr -> EvExpr
forall b. b -> Expr b -> Expr b
Lam TyVar
r0 EvExpr
body))
                    else do
                      TyVar
r0   <- Type -> String -> TcPluginM TyVar
freshId Type
stringTy String
"r0"
                      TyVar
ptok <- Type -> String -> TcPluginM TyVar
freshId Type
strPairTy String
"pt"; TyVar
tcb <- Type -> String -> TcPluginM TyVar
freshId Type
strPairTy String
"ptc"
                      TyVar
tok  <- Type -> String -> TcPluginM TyVar
freshId Type
stringTy String
"tok"; TyVar
r1 <- Type -> String -> TcPluginM TyVar
freshId Type
stringTy String
"r1"; TyVar
ecb <- Type -> String -> TcPluginM TyVar
freshId Type
boolTy String
"bc"
                      EvExpr
chain <- if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
labels
                                 then DataCon
-> [(Type, Integer -> EvExpr -> EvExpr)]
-> [TyVar]
-> EvExpr
-> TcPluginM EvExpr
buildChain DataCon
dc ([Type]
-> [Integer -> EvExpr -> EvExpr]
-> [(Type, Integer -> EvExpr -> EvExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
fts [Integer -> EvExpr -> EvExpr]
rdrs) [] (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
r1)
                                 else DataCon
-> [(String, Type, Integer -> EvExpr -> EvExpr)]
-> EvExpr
-> TcPluginM EvExpr
forall {b}.
DataCon
-> [(String, Type, Integer -> Expr b -> EvExpr)]
-> EvExpr
-> TcPluginM EvExpr
recChain DataCon
dc ([String]
-> [Type]
-> [Integer -> EvExpr -> EvExpr]
-> [(String, Type, Integer -> EvExpr -> EvExpr)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [String]
labels [Type]
fts [Integer -> EvExpr -> EvExpr]
rdrs) (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
r1)
                      let tokBody :: EvExpr
tokBody = EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
eqStringId) [TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
tok, EvExpr
nameStr]) TyVar
ecb Type
listPair
                            [ AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] EvExpr
nilPair
                            , AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  [] EvExpr
chain ]
                          tokLam :: EvExpr
tokLam = TyVar -> EvExpr -> EvExpr
forall b. b -> Expr b -> Expr b
Lam TyVar
ptok (EvExpr -> TyVar -> Type -> [Alt TyVar] -> EvExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
ptok) TyVar
tcb Type
listPair
                            [AltCon -> [TyVar] -> EvExpr -> Alt TyVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
tup2) [TyVar
tok, TyVar
r1] EvExpr
tokBody])
                          inner :: EvExpr
inner = TyVar -> EvExpr -> EvExpr
forall b. b -> Expr b -> Expr b
Lam TyVar
r0 (Type -> EvExpr -> EvExpr -> EvExpr
forall {b}. Type -> Arg b -> Arg b -> Arg b
concatMapTo Type
strPairTy EvExpr
tokLam (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
lexId) (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
r0)))
                          -- record syntax never needs surrounding parens (see Stock.Read)
                          flag :: EvExpr
flag  = if [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
fts Bool -> Bool -> Bool
|| Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
labels) then EvExpr
forall {b}. Expr b
false_ else Integer -> EvExpr
gtThr (Integer
10 :: Integer)
                      EvExpr -> TcPluginM EvExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
mkParser EvExpr
flag EvExpr
inner)
                Maybe (EvExpr, [Ct]) -> TcPluginM (Maybe (EvExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvExpr, [Ct]) -> Maybe (EvExpr, [Ct])
forall a. a -> Maybe a
Just (EvExpr
parserApp, [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))

          case [Maybe (EvExpr, [Ct])] -> Maybe [(EvExpr, [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 (EvExpr, [Ct])]
mParserWss of
            Maybe [(EvExpr, [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 [(EvExpr, [Ct])]
parserWss -> do
              let ([EvExpr]
parserApps, [[Ct]]
wss) = [(EvExpr, [Ct])] -> ([EvExpr], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(EvExpr, [Ct])]
parserWss
                  liftRp2Impl :: EvExpr
liftRp2Impl = [TyVar] -> EvExpr -> EvExpr
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar
aTv, TyVar
bTv, TyVar
rp1Id, TyVar
rl1Id, TyVar
rp2Id, TyVar
rl2Id, TyVar
dId, TyVar
rId] (EvExpr -> EvExpr) -> EvExpr -> EvExpr
forall a b. (a -> b) -> a -> b
$
                    (EvExpr -> EvExpr -> EvExpr) -> EvExpr -> [EvExpr] -> EvExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\EvExpr
e EvExpr
acc -> EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> EvExpr
forall b. TyVar -> Expr b
Var TyVar
appendId) [Type -> EvExpr
forall b. Type -> Expr b
Type Type
pairTy, EvExpr
e, EvExpr
acc]) EvExpr
nilPair [EvExpr]
parserApps
              ([EvExpr]
supers, [Ct]
scWs) <- Class -> Type -> CtLoc -> TcPluginM ([EvExpr], [Ct])
stock2Supers Class
read2Cls Type
wrappedTy CtLoc
loc
              EvExpr
dict <- Class -> Type -> [EvExpr] -> [(Int, EvExpr)] -> TcPluginM EvExpr
recDictWith Class
read2Cls Type
wrappedTy [EvExpr]
supers [(Int
0, EvExpr
liftRp2Impl)]
              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 (EvExpr -> EvTerm
EvExpr EvExpr
dict, CtEvidence -> Ct
mkNonCanonical CtEvidence
ordIntEv Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
scWs [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))
    (Maybe TyCon, 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
  where (Type
realP, Maybe [Type]
mMods) = OvTcs -> Type -> (Type, Maybe [Type])
peelOverride2With (String -> GenEnv -> OvTcs
ovTcsGen String
"Override2" GenEnv
gen) Type
p