{-# 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 modifiers (Keep-filled).  Use the shared decoder
      -- ('peelOverride2With' -> 'decodeOvCfg') so it accepts the field-keyed
      -- forms (@Con at i via M@, @name via M@) and not only the dense
      -- positional @'[ '[ .. ] ]@ list.
      | let (Type
realP, Maybe [Type]
mMods) = OvTcs -> Type -> (Type, Maybe [Type])
peelOverride2With (String -> GenEnv -> OvTcs
ovTcsGen String
"Override2" GenEnv
gen) Type
p0
      , 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
          monoidCls <- Name -> TcPluginM Class
tcLookupClass Name
monoidClassName
          let fixed   = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
              idSel   = String -> Class -> TyVar
classMethod String
"id" Class
catCls
              compSel = String -> Class -> TyVar
classMethod String
"." Class
catCls
              memptySel  = String -> Class -> TyVar
classMethod String
"mempty"  Class
monoidCls
              mappendSel = String -> Class -> TyVar
classMethod String
"mappend" Class
monoidCls
              wargs   = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
wrappedTy          -- [k, k, P]  (P may be Override2 …)
              kTy     = [Type] -> Type
forall a. HasCallStack => [a] -> a
head [Type]
wargs                      -- the kind k (Type here)
              dictCon = DataCon -> TyVar
dataConWorkId (Class -> DataCon
classDataCon Class
catCls)
              app2 Type
m Type
t1 Type
t2 = Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
m Type
t1) Type
t2
              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
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
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)
                                          (HasCallStack => 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
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
          pTv <- freshTyVar "p" ; qTv <- freshTyVar "q"
          let realFtsPQ = Type -> Type -> [Type]
instAt (TyVar -> Type
mkTyVarTy TyVar
pTv) (TyVar -> Type
mkTyVarTy TyVar
qTv)
              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
i Type
ftPQ = case Maybe [Type]
mMods of
                Just [Type]
mods | Just Type
m0 <- [Type] -> Int -> Maybe Type
forall a. [a] -> Int -> Maybe a
safeIdx [Type]
mods Int
i, Bool -> Bool
not (Type -> Bool
isKeep Type
m0) ->
                  -- A modifier decoded from the field-keyed @At Con i := M@ form
                  -- can carry skolem /kind/ variables for phantom parameters
                  -- (e.g. @Basic m a b@'s @a@\/@b@), unlike the dense list form
                  -- which pins them to the datatype's param kind.  Re-kind those
                  -- free variables to @k@ so @Category (m a b)@ is solvable.
                  let fvs :: [TyVar]
fvs = VarSet -> [TyVar]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (Type -> VarSet
tyCoVarsOfType Type
m0)
                      m :: Type
m   = [TyVar] -> [Type] -> Type -> Type
HasDebugCallStack => [TyVar] -> [Type] -> Type -> Type
substTyWith [TyVar]
fvs ((TyVar -> Type) -> [TyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> TyVar -> Type
forall a b. a -> b -> a
const Type
kTy) [TyVar]
fvs) Type
m0
                  in 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 -> ([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 badLen then Nothing
               else traverse (uncurry resolve) (zip [0 :: Int ..] 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
              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 ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
catCls [Type
kTy, Type
h])
                                      pure (ctEvExpr ev, mkNonCanonical ev)
                       MonF Type
m   -> do ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
monoidCls [Type
m])
                                      pure (ctEvExpr ev, mkNonCanonical ev)) [CatFld]
flds
              let (dEs, dWs) = unzip dws
              -- validate each override reshape (@realField ~R m a b@) with a GHC
              -- wanted, so the unchecked @mkStockCo@ axioms can't smuggle in an
              -- unsound coercion (reject @Int via Op@, @a->b via Op@, …).
              ovWs <- case mMods of
                Maybe [Type]
Nothing   -> [Ct] -> TcPluginM [Ct]
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                Just [Type]
mods -> ([[Ct]] -> [Ct]) -> TcPluginM [[Ct]] -> TcPluginM [Ct]
forall a b. (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (TcPluginM [[Ct]] -> TcPluginM [Ct])
-> TcPluginM [[Ct]] -> TcPluginM [Ct]
forall a b. (a -> b) -> a -> b
$ [(Int, Type)]
-> ((Int, Type) -> TcPluginM [Ct]) -> TcPluginM [[Ct]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Int] -> [Type] -> [(Int, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [Type]
realFtsPQ) \(Int
i, Type
ftPQ) ->
                  case [Type] -> Int -> Maybe Type
forall a. [a] -> Int -> Maybe a
safeIdx [Type]
mods Int
i of
                    Just Type
m0 | Bool -> Bool
not (Type -> Bool
isKeep Type
m0) -> do
                      let fvs :: [TyVar]
fvs = VarSet -> [TyVar]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (Type -> VarSet
tyCoVarsOfType Type
m0)
                          m :: Type
m   = [TyVar] -> [Type] -> Type -> Type
HasDebugCallStack => [TyVar] -> [Type] -> Type -> Type
substTyWith [TyVar]
fvs ((TyVar -> Type) -> [TyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> TyVar -> Type
forall a b. a -> b -> a
const Type
kTy) [TyVar]
fvs) Type
m0
                      -- validate at closed types (see Stock.Functor) so the
                      -- evidence stays free of @pTv@\/@qTv@.  The two params get
                      -- DISTINCT closed types (@()@ and @Bool@): collapsing both to
                      -- the same type would hide an order-swap (@a->b@ vs @b->a@ via
                      -- @Op@ both become @()->()@), wrongly accepting it.
                      vw <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Type -> Type -> Type
mkStockReprEq
                              ([TyVar] -> [Type] -> Type -> Type
HasDebugCallStack => [TyVar] -> [Type] -> Type -> Type
substTyWith [TyVar
pTv, TyVar
qTv] [Type
unitTy, Type
boolTy] Type
ftPQ)
                              (Type -> Type -> Type -> Type
app2 Type
m Type
unitTy Type
boolTy))
                      pure [mkNonCanonical vw]
                    Maybe Type
_ -> [Ct] -> TcPluginM [Ct]
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
              -- id = /\a. (P <id of each field>..) |> sym (Stock2(..) a a ~ P a a)
              aTv <- freshTyVar "a"
              let aTy = TyVar -> Type
mkTyVarTy TyVar
aTv
                  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 = 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
              bTv <- freshTyVar "b" ; cTv <- freshTyVar "c" ; a2Tv <- freshTyVar "a"
              let bTy = TyVar -> Type
mkTyVarTy TyVar
bTv ; cTy = TyVar -> Type
mkTyVarTy TyVar
cTv ; a2Ty = TyVar -> Type
mkTyVarTy TyVar
a2Tv
                  resTy = Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
a2Ty) Type
cTy   -- Stock2(..) a c
              gId <- freshId (mkAppTy (mkAppTy wrappedTy bTy) cTy) "g"
              hId <- freshId (mkAppTy (mkAppTy wrappedTy a2Ty) bTy) "h"
              gIds <- 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)) [0 :: Int ..] (instAt bTy cTy)
              hIds <- 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)) [0 :: Int ..] (instAt a2Ty bTy)
              gCb <- freshId (mkTyConApp pTc (fixed ++ [bTy, cTy]))  "gcb"
              hCb <- freshId (mkTyConApp pTc (fixed ++ [a2Ty, bTy])) "hcb"
              let 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 = (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 -> 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 -> 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 -> 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 = [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 -> [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]
              pure (Just (EvExpr dict, dWs ++ ovWs))
    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
      monoidCls   <- Name -> TcPluginM Class
tcLookupClass Name
monoidClassName
      foldableCls <- tcLookupClass foldableClassName
      let fixed       = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
          dcons       = TyCon -> [DataCon]
tyConDataCons TyCon
pTc
          foldMapSel   = String -> Class -> TyVar
classMethod String
"foldMap" Class
foldableCls
          memptySel    = String -> Class -> TyVar
classMethod String
"mempty" Class
monoidCls
          mappendSel   = String -> Class -> TyVar
classMethod String
"mappend" Class
monoidCls
          coAt Type
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
      mtv <- freshTyVar "m" ; atv <- freshTyVar "a" ; btv <- freshTyVar "b"
      let mTy = TyVar -> Type
mkTyVarTy TyVar
mtv ; aTy = TyVar -> Type
mkTyVarTy TyVar
atv ; bTy = TyVar -> Type
mkTyVarTy TyVar
btv
          innerAB = TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy])
      dM  <- freshId (mkClassPred monoidCls [mTy]) "dM"
      gA  <- freshId (mkVisFunTyMany aTy mTy) "gA"
      gB  <- freshId (mkVisFunTyMany bTy mTy) "gB"
      tId <- freshId (mkAppTy (mkAppTy wrappedTy aTy) bTy) "t"
      cb  <- freshId innerAB "cb"
      let memptyE      = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> Expr b
forall b. TyVar -> Expr b
Var TyVar
memptySel) [Type -> Expr b
forall b. Type -> Expr b
Type Type
mTy, TyVar -> Expr b
forall b. TyVar -> Expr b
Var TyVar
dM]
          mappendE Arg b
x Arg b
y = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
mappendSel) [Type -> Arg b
forall b. Type -> Expr b
Type Type
mTy, TyVar -> Arg b
forall b. TyVar -> Expr b
Var TyVar
dM, Arg b
x, Arg b
y]
          -- fold an @h pTy@ field via the modifier @m@'s @foldMap@, casting the
          -- field value @h pTy ~R m pTy@ first.
          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)
            ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
foldableCls [Type
m])
            pure (Just (Just ( mkApps (Var foldMapSel)
                                 [Type m, ctEvExpr ev, Type mTy, Type pTy, Var dM, Var g
                                 , castReshape (Var x) (reshapeCo h m pTy)]
                             , [mkNonCanonical ev] )))
          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
      malts <- forM dcons \DataCon
dc -> do
        let fts :: [Type]
fts = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy]))
        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
        mcs <- sequence (zipWith3 contrib [0 :: Int ..] xs fts)
        case sequence 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 = String -> Class -> TyVar
classMethod String
"foldr" Class
foldableCls
          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 ]
      rcTv <- freshTyVar "c" ; raTv <- freshTyVar "a" ; rbTv <- freshTyVar "b"
      let rcTy = TyVar -> Type
mkTyVarTy TyVar
rcTv ; raTy = TyVar -> Type
mkTyVarTy TyVar
raTv ; rbTy = TyVar -> Type
mkTyVarTy TyVar
rbTv
      rfId <- freshId (mkVisFunTyMany raTy (mkVisFunTyMany rcTy rcTy)) "f"
      rgId <- freshId (mkVisFunTyMany rbTy (mkVisFunTyMany rcTy rcTy)) "g"
      rzId <- freshId rcTy "z"
      rtId <- freshId (mkAppTy (mkAppTy wrappedTy raTy) rbTy) "t"
      rcb  <- freshId (mkTyConApp pTc (fixed ++ [raTy, rbTy])) "cb"
      let foldrField Type
h TyVar
fn Type
elemTy TyVar
x EvExpr
k = do
            ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
foldableCls [Type
h])
            b1 <- freshId (mkAppTy h elemTy) "b1" ; b2 <- freshId rcTy "b2"
            let 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])
            pure (Just (mkApps flipLam [Var x, k], [mkNonCanonical ev]))
          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 []            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
            mr <- [(Type, TyVar)] -> EvExpr -> TcPluginM (Maybe (EvExpr, [Ct]))
combineBR [(Type, TyVar)]
r EvExpr
k
            case 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 mc <- TyVar -> Type -> EvExpr -> TcPluginM (Maybe (EvExpr, [Ct]))
contribBR TyVar
x Type
ft EvExpr
k'
                                  pure (fmap (\(EvExpr
e, [Ct]
w) -> (EvExpr
e, [Ct]
w [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
w')) mc)
      mBiFoldrAlts <- if isJust mMods then pure Nothing else fmap sequence $ forM dcons \DataCon
dc -> do
        let fts :: [Type]
fts = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
raTy, Type
rbTy]))
        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
        mb <- combineBR (zip fts xs) (Var rzId)
        pure (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)) mb)
      case sequence malts of
        Maybe [(Alt TyVar, [Ct])]
Nothing     -> Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvTerm, [Ct])
forall a. Maybe a
Nothing
        Just [(Alt TyVar, [Ct])]
altWss -> do
          let ([Alt TyVar]
alts, [[Ct]]
wss) = [(Alt TyVar, [Ct])] -> ([Alt TyVar], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt TyVar, [Ct])]
altWss
              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 -> ([], [])
          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)
          pure (Just (EvExpr dict, concat wss ++ 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
      appCls  <- Name -> TcPluginM Class
tcLookupClass Name
applicativeClassName
      travCls <- tcLookupClass traversableClassName
      let fixed = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
          dcons = TyCon -> [DataCon]
tyConDataCons TyCon
pTc
          traverseSel = String -> Class -> TyVar
classMethod String
"traverse" Class
travCls
          pureSel     = String -> Class -> TyVar
classMethod String
"pure" Class
appCls
          apSel       = String -> Class -> TyVar
classMethod String
"<*>"  Class
appCls
          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
      fTv <- freshTyVarK (mkVisFunTyMany liftedTypeKind liftedTypeKind) "f"   -- f :: Type -> Type
      aTv <- freshTyVar "a" ; cTv <- freshTyVar "c"
      bTv <- freshTyVar "b" ; dTv <- freshTyVar "d"           -- bitraverse: forall f a c b d
      let fTy = TyVar -> Type
mkTyVarTy TyVar
fTv
          aTy = TyVar -> Type
mkTyVarTy TyVar
aTv ; cTy = TyVar -> Type
mkTyVarTy TyVar
cTv
          bTy = TyVar -> Type
mkTyVarTy TyVar
bTv ; dTy = TyVar -> Type
mkTyVarTy TyVar
dTv
          fOf Type
t   = Type -> Type -> Type
mkAppTy Type
fTy Type
t
          innerAB = TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy])
          stcdTy  = Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
cTy) Type
dTy        -- Stock2 P c d
      dApp <- freshId (mkClassPred appCls [fTy]) "dApp"
      gA   <- freshId (mkVisFunTyMany aTy (fOf cTy)) "gA"      -- a -> f c
      gB   <- freshId (mkVisFunTyMany bTy (fOf dTy)) "gB"      -- b -> f d
      tId  <- freshId (mkAppTy (mkAppTy wrappedTy aTy) bTy) "t"
      cb   <- freshId innerAB "cb"
      let 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
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
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
              ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
travCls [Type
h])
              pure (Just ( mkApps (Var traverseSel)
                             [Type h, ctEvExpr ev, Type fTy, Type inTy, Type outTy
                             , Var dApp, Var g, Var x]                       -- :: f (h out)
                         , [mkNonCanonical ev] ))
            Just Type
m -> do
              ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
travCls [Type
m])
              let 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 -> Type -> Type
mkAppTy Type
h Type
outTy ; mOut = Type -> Type -> Type
mkAppTy Type
m Type
outTy
              mo <- freshId mOut "mo"
              let 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
              pure (Just ( apE mOut hOut (pureE (mkVisFunTyMany mOut hOut) coerceFn) trav
                         , [mkNonCanonical ev] ))
          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
      malts <- forM dcons \DataCon
dc -> do
        let fts :: [Type]
fts   = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
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]))
        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
        mfes <- sequence (zipWith3 fieldOf [0 :: Int ..] xs fts)
        case sequence 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
            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 = [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 -> 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 -> (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)
            pure (Just (Alt (DataAlt dc) xs body, concat wss))
      case sequence malts of
        Maybe [(Alt TyVar, [Ct])]
Nothing     -> Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvTerm, [Ct])
forall a. Maybe a
Nothing
        Just [(Alt TyVar, [Ct])]
altWss -> do
          let ([Alt TyVar]
alts, [[Ct]]
wss) = [(Alt TyVar, [Ct])] -> ([Alt TyVar], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt TyVar, [Ct])]
altWss
              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] ]
          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 sequence 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
              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)]
              pure (Just (EvExpr dict, concatMap snd sds ++ concat 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
      functorCls <- Name -> TcPluginM Class
tcLookupClass Name
functorClassName
      let fixed     = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
          dcons     = TyCon -> [DataCon]
tyConDataCons TyCon
pTc
          bimapSel  = String -> Class -> TyVar
classMethod String
"bimap" Class
cls             -- bimap
          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
      apTv <- freshTyVar "a'" ; aTv <- freshTyVar "a"
      bpTv <- freshTyVar "b'" ; bTv <- freshTyVar "b"
      let apTy = TyVar -> Type
mkTyVarTy TyVar
apTv ; aTy = TyVar -> Type
mkTyVarTy TyVar
aTv
          bpTy = TyVar -> Type
mkTyVarTy TyVar
bpTv ; bTy = TyVar -> Type
mkTyVarTy TyVar
bTv
          innerAB = TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy])
      gA  <- freshId (mkVisFunTyMany aTy apTy) "gA"        -- a -> a'
      gB  <- freshId (mkVisFunTyMany bTy bpTy) "gB"        -- b -> b'
      sf  <- freshId (mkAppTy (mkAppTy wrappedTy aTy) bTy) "sf"
      cb  <- freshId innerAB "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
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
q = do
            ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
cls [Type
q])
            pure (Just ( mkApps (Var bimapSel)
                           [ Type q, ctEvExpr ev, Type aTy, Type apTy, Type bTy, Type bpTy
                           , Var gA, Var gB ]
                       , [mkNonCanonical ev] ))
          -- a plain field: map it pointwise with the n-ary engine.
          mapPlain TyVar
x Type
ft = do
            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
            pure (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)) 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
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
mod_ Type
h TyVar
x Type
inTy Type
outTy = do
            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)
            pure $ flip fmap 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 )
      malts <- forM dcons \DataCon
dc -> do
        let fts :: [Type]
fts = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy]))
        xs  <- (Int -> Type -> TcPluginM TyVar)
-> [Int] -> [Type] -> TcPluginM [TyVar]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
n Type
ft -> Type -> String -> TcPluginM TyVar
freshId Type
ft (String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..] [Type]
fts
        mfs <- sequence (zipWith3 mapField [0 :: Int ..] xs fts)
        case sequence 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 sequence malts of
        Maybe [(Alt TyVar, [Ct])]
Nothing     -> Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EvTerm, [Ct])
forall a. Maybe a
Nothing
        Just [(Alt TyVar, [Ct])]
altWss -> do
          let ([Alt TyVar]
alts, [[Ct]]
wss) = [(Alt TyVar, [Ct])] -> ([Alt TyVar], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt TyVar, [Ct])]
altWss
              -- 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)
          dmFirst  <- Class -> Int -> TcPluginM TyVar
defMethId Class
cls Int
1                       -- first
          dmSecond <- defMethId cls 2                       -- second
          fdmConst <- defMethId functorCls 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.
          sctv  <- freshTyVar "sc"
          b2tv  <- freshTyVar "b" ; b2ptv <- freshTyVar "b'"
          zId   <- freshId (mkTyVarTy sctv) "z"
          g2Id  <- freshId (mkVisFunTyMany (mkTyVarTy b2tv) (mkTyVarTy b2ptv)) "g2"
          x2Id  <- freshId (mkAppTy wrappedTy (mkTyVarTy sctv) `mkAppTy` mkTyVarTy b2tv) "x2"
          dict <- recClassDict cls 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 ]
            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] ]
            pure [ Lam sctv supDict
                 , bimapImpl
                 , mkApps (Var dmFirst)  [Type wrappedTy, Var dvar]
                 , mkApps (Var dmSecond) [Type wrappedTy, Var dvar] ]
          pure (Just (EvExpr dict, concat 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
  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
    xs    <- DataCon -> Type -> Type -> TcPluginM [TyVar]
freshF DataCon
dci Type
aTy Type
cTy
    mAlts <- forM indexed \(Int
j, DataCon
dcj) -> do
      ys <- DataCon -> Type -> Type -> TcPluginM [TyVar]
freshF DataCon
dcj Type
bTy Type
dTy
      if i /= j
        then pure (Just (Alt (DataAlt dcj) ys (mismatch i j), []))
        else do
          mops <- sequence (zipWith4 fieldOp [0 :: Int ..] (fieldsBi dci aTy cTy) xs ys)
          case sequence 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 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)
                           pure (Just (Alt (DataAlt dcj) ys body, concatMap snd ows))
    case sequence 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
        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"
        pure (Just ( Alt (DataAlt dci) xs
                       (destructInner pTc (fixed ++ [bTy, dTy]) (Cast (Var fbId) (coAt2 bTy dTy)) cbB resTy alts)
                   , concat wss ))
  case sequence 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
      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"
      pure (Just ( destructInner pTc (fixed ++ [aTy, cTy]) (Cast (Var faId) (coAt2 aTy cTy)) cbA resTy alts
                 , concat 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
  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)
  pure (map ctEvExpr evs, map mkNonCanonical 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
      eqCls <- Name -> TcPluginM Class
tcLookupClass Name
eqClassName
      mEq1  <- lookupClassMaybe "Data.Functor.Classes" "Eq1"
      case 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      = HasCallStack => 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
          aTv <- String -> TcPluginM TyVar
freshTyVar String
"a" ; bTv <- freshTyVar "b" ; cTv <- freshTyVar "c" ; dTv <- freshTyVar "d"
          let aTy = TyVar -> Type
mkTyVarTy TyVar
aTv ; bTy = TyVar -> Type
mkTyVarTy TyVar
bTv ; cTy = TyVar -> Type
mkTyVarTy TyVar
cTv ; dTy = TyVar -> Type
mkTyVarTy TyVar
dTv
          eqAB <- freshId (mkVisFunTyMany aTy (mkVisFunTyMany bTy boolTy)) "eqAB"
          eqCD <- freshId (mkVisFunTyMany cTy (mkVisFunTyMany dTy boolTy)) "eqCD"
          faId <- freshId (mkAppTy (mkAppTy wrappedTy aTy) cTy) "fa"
          fbId <- freshId (mkAppTy (mkAppTy wrappedTy bTy) dTy) "fb"
          let 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 rest <- [EvExpr] -> TcPluginM EvExpr
conj [EvExpr]
more
                                    scr  <- freshId boolTy "c"
                                    pure (Case e scr boolTy [ Alt (DataAlt falseDataCon) [] false_
                                                            , Alt (DataAlt trueDataCon)  [] rest ])
              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 ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
eqCls [Type
ft])
                                       pure (Just (mkApps (Var eqSel) [Type ft, ctEvExpr ev, Var x, Var y], [mkNonCanonical 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)
                                       ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
eq1Cls [Type
m])
                                       pure (Just (mkApps (Var liftEqSel) [Type m, ctEvExpr ev, Type aTy, Type bTy, Var eqAB, castReshape (Var x) (reshapeCo h m aTy), castReshape (Var y) (reshapeCo h m bTy)], [mkNonCanonical 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)
                                       ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
eq1Cls [Type
m])
                                       pure (Just (mkApps (Var liftEqSel) [Type m, ctEvExpr ev, Type cTy, Type dTy, Var eqCD, castReshape (Var x) (reshapeCo h m cTy), castReshape (Var y) (reshapeCo h m dTy)], [mkNonCanonical ev]))
          mBody <- zipLiftBi pTc fixed coAt2 (aTy, cTy) (bTy, dTy) boolTy faId fbId (\Int
_ Int
_ -> EvExpr
forall {b}. Expr b
false_) conj fieldOp
          case 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
              (supers, scWs) <- Class -> Type -> CtLoc -> TcPluginM ([EvExpr], [Ct])
stock2Supers Class
eq2Cls Type
wrappedTy CtLoc
loc
              let 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
              pure (Just (EvExpr (mkClassDict eq2Cls wrappedTy (supers ++ [impl])), scWs ++ 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
      ordCls <- Name -> TcPluginM Class
tcLookupClass Name
ordClassName
      mOrd1  <- lookupClassMaybe "Data.Functor.Classes" "Ord1"
      case 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       = HasCallStack => 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
          aTv <- String -> TcPluginM TyVar
freshTyVar String
"a" ; bTv <- freshTyVar "b" ; cTv <- freshTyVar "c" ; dTv <- freshTyVar "d"
          let aTy = TyVar -> Type
mkTyVarTy TyVar
aTv ; bTy = TyVar -> Type
mkTyVarTy TyVar
bTv ; cTy = TyVar -> Type
mkTyVarTy TyVar
cTv ; dTy = TyVar -> Type
mkTyVarTy TyVar
dTv
          cmpAB <- freshId (mkVisFunTyMany aTy (mkVisFunTyMany bTy ordTy)) "cmpAB"
          cmpCD <- freshId (mkVisFunTyMany cTy (mkVisFunTyMany dTy ordTy)) "cmpCD"
          faId  <- freshId (mkAppTy (mkAppTy wrappedTy aTy) cTy) "fa"
          fbId  <- freshId (mkAppTy (mkAppTy wrappedTy bTy) dTy) "fb"
          let 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 rest <- [EvExpr] -> TcPluginM EvExpr
lexCmp [EvExpr]
more
                                      scr  <- freshId ordTy "o"
                                      pure (Case e scr ordTy [ Alt (DataAlt ltC) [] ltE
                                                             , Alt (DataAlt eqC) [] rest
                                                             , Alt (DataAlt gtC) [] gtE ])
              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 ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
ordCls [Type
ft])
                                       pure (Just (mkApps (Var cmpSel) [Type ft, ctEvExpr ev, Var x, Var y], [mkNonCanonical 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)
                                       ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
ord1Cls [Type
m])
                                       pure (Just (mkApps (Var liftCmpSel) [Type m, ctEvExpr ev, Type aTy, Type bTy, Var cmpAB, castReshape (Var x) (reshapeCo h m aTy), castReshape (Var y) (reshapeCo h m bTy)], [mkNonCanonical 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)
                                       ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
ord1Cls [Type
m])
                                       pure (Just (mkApps (Var liftCmpSel) [Type m, ctEvExpr ev, Type cTy, Type dTy, Var cmpCD, castReshape (Var x) (reshapeCo h m cTy), castReshape (Var y) (reshapeCo h m dTy)], [mkNonCanonical ev]))
          mBody <- zipLiftBi pTc fixed coAt2 (aTy, cTy) (bTy, dTy) ordTy faId 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) lexCmp fieldOp
          case 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
              (supers, scWs) <- Class -> Type -> CtLoc -> TcPluginM ([EvExpr], [Ct])
stock2Supers Class
ord2Cls Type
wrappedTy CtLoc
loc
              let 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
              pure (Just (EvExpr (mkClassDict ord2Cls wrappedTy (supers ++ [impl])), scWs ++ 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
      mShow1 <- String -> String -> TcPluginM (Maybe Class)
lookupClassMaybe String
"Data.Functor.Classes" String
"Show1"
      case 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
          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
          ordCls   <- tcLookupClass ordClassName
          appendId <- tcLookupId appendName
          let fixed       = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
              dcons       = TyCon -> [DataCon]
tyConDataCons TyCon
pTc
              showSTy     = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
stringTy Type
stringTy
              liftSpSel   = String -> Class -> TyVar
classMethod String
"liftShowsPrec" Class
show1Cls
              showsPrecSel = String -> Class -> TyVar
classMethod String
"showsPrec" Class
showCls
              gtSel       = String -> Class -> TyVar
classMethod String
">" Class
ordCls
              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
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
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
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))
          ordIntEv <- newWanted loc (mkClassPred ordCls [intTy])
          let ordIntDict = HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ordIntEv
          aTv <- freshTyVar "a" ; bTv <- freshTyVar "b"
          let aTy = TyVar -> Type
mkTyVarTy TyVar
aTv ; bTy = TyVar -> Type
mkTyVarTy TyVar
bTv
              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
t = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany (Type -> Type
mkListTy Type
t) Type
showSTy
          spA <- freshId (spTyOf aTy) "spA" ; slA <- freshId (slTyOf aTy) "slA"
          spB <- freshId (spTyOf bTy) "spB" ; slB <- freshId (slTyOf bTy) "slB"
          dId <- freshId intTy "d" ; vId <- freshId (mkAppTy (mkAppTy wrappedTy aTy) bTy) "v"
          let 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 ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
showCls [Type
ft])
                                       pure (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], [mkNonCanonical 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)
                                       ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
show1Cls [Type
m])
                                       pure (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)], [mkNonCanonical 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)
                                       ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
show1Cls [Type
m])
                                       pure (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)], [mkNonCanonical ev]))
          mAltWss <- forM dcons \DataCon
dc -> do
            let fts :: [Type]
fts    = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
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)
            nameStr <- String -> TcPluginM EvExpr
str String
name
            xs      <- 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)) [0 :: Int ..] fts
            rest    <- freshId stringTy "r"
            gtBndr  <- freshId boolTy "pb"
            prec    <- conPrec dc
            mRends  <- sequence (zipWith3 mkRenderer [0 :: Int ..] fts xs)
            case sequence 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)
                body <-
                  if DataCon -> Bool
dataConIsInfix DataCon
dc
                    then do 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 [l, r] = renderers
                                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))
                            pure (parenAt prec mk (Var 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 openB <- String -> TcPluginM EvExpr
str String
" {" ; eqB <- str " = " ; commaB <- str ", " ; closeB <- str "}"
                              lblStrs <- mapM str labels
                              let recF = [EvExpr] -> [Integer -> EvExpr] -> [(EvExpr, Integer -> EvExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [EvExpr]
lblStrs [Integer -> EvExpr]
renderers
                                  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
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))
                              pure (parenAt 10 recBody (Var 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))
                pure (Just (Alt (DataAlt dc) xs (Lam rest body), concat wss))
          case sequence 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
              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 = [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)
              (supers, scWs) <- stock2Supers show2Cls wrappedTy loc
              dict <- recDictWith show2Cls wrappedTy supers [(0, impl)]
              pure (Just (EvExpr dict, mkNonCanonical ordIntEv : scWs ++ concat 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
      mRead1 <- String -> String -> TcPluginM (Maybe Class)
lookupClassMaybe String
"Data.Functor.Classes" String
"Read1"
      case 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
          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
          ordCls      <- tcLookupClass ordClassName
          appendId    <- tcLookupId appendName
          eqStringId  <- tcLookupId eqStringName
          lexId       <- lookupOrig gHC_INTERNAL_READ (mkVarOcc "lex")       >>= tcLookupId
          readParenId <- lookupOrig gHC_INTERNAL_READ (mkVarOcc "readParen") >>= tcLookupId
          concatMapId <- lookupOrig gHC_INTERNAL_LIST (mkVarOcc "concatMap") >>= tcLookupId
          let liftRpSel    = String -> Class -> TyVar
classMethod String
"liftReadsPrec" Class
read1Cls
              readsPrecSel = String -> Class -> TyVar
classMethod String
"readsPrec" Class
readCls
              gtSel        = String -> Class -> TyVar
classMethod String
">" Class
ordCls
              fixed        = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realP
              dcons        = TyCon -> [DataCon]
tyConDataCons TyCon
pTc
              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
          ordIntEv <- newWanted loc (mkClassPred ordCls [intTy])
          let ordIntDict = HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ordIntEv
          aTv <- freshTyVar "a" ; bTv <- freshTyVar "b"
          let aTy = TyVar -> Type
mkTyVarTy TyVar
aTv ; bTy = TyVar -> Type
mkTyVarTy TyVar
bTv
              innerAB   = TyCon -> [Type] -> Type
mkTyConApp TyCon
pTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy, Type
bTy])
              gabTy     = Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy) Type
bTy
              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
t  = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
intTy (Type -> Type
readSOf Type
t)       -- Int -> ReadS t
              rlTyOf Type
t  = Type -> Type
readSOf (Type -> Type
mkListTy Type
t)                   -- ReadS [t]
              pairTy    = [Type] -> Type
mkBoxedTupleTy [Type
gabTy, Type
stringTy]
              strPairTy = [Type] -> Type
mkBoxedTupleTy [Type
stringTy, Type
stringTy]
              listPair  = Type -> Type
mkListTy Type
pairTy
              tup2      = Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed Int
2
              nilPair   = Type -> EvExpr
mkNilExpr Type
pairTy
              false_    = TyVar -> Expr b
forall b. TyVar -> Expr b
Var (DataCon -> TyVar
dataConWorkId DataCon
falseDataCon)
              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
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
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
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))
          rp1Id <- freshId (rpTyOf aTy) "rp1" ; rl1Id <- freshId (rlTyOf aTy) "rl1"
          rp2Id <- freshId (rpTyOf bTy) "rp2" ; rl2Id <- freshId (rlTyOf bTy) "rl2"
          dId   <- freshId intTy "d" ; rId <- freshId stringTy "r"

          -- one field's reader @prec -> restString -> [(ft, String)]@.
          let 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
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
                ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
read1Cls [Type
m])
                let 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)))
                pure (Just (rdr, [mkNonCanonical ev]))
              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 ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
readCls [Type
ft])
                                       pure (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]), [mkNonCanonical 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
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
                a  <- Type -> String -> TcPluginM TyVar
freshId Type
ft String
"a" ; r' <- freshId stringTy "r"
                pc <- freshId (mkBoxedTupleTy [ft, stringTy]) "p"
                cb <- freshId (mkBoxedTupleTy [ft, stringTy]) "pc"
                rest <- buildChain dc more (a : accRev) (Var r')
                let parsed = Integer -> EvExpr -> EvExpr
rdr (Integer
11 :: Integer) EvExpr
restE
                    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])
                pure (concatMapTo (mkBoxedTupleTy [ft, stringTy]) lam parsed)

              expectTok EvExpr
expStr EvExpr
restE Expr b -> TcPluginM EvExpr
k = do
                pp <- Type -> String -> TcPluginM TyVar
freshId Type
strPairTy String
"p"; cb <- freshId strPairTy "pc"
                tk <- freshId stringTy "t"; r' <- freshId stringTy "r"; ecb <- freshId boolTy "b"
                body <- k (Var r')
                let 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 ])])
                pure (concatMapTo strPairTy lam (App (Var lexId) restE))

              parseFieldP t
prec Type
ft t -> t -> EvExpr
rdr t
restE Expr b -> Expr b -> TcPluginM EvExpr
k = do
                pp <- Type -> String -> TcPluginM TyVar
freshId ([Type] -> Type
mkBoxedTupleTy [Type
ft, Type
stringTy]) String
"p"
                cb <- freshId (mkBoxedTupleTy [ft, stringTy]) "pc"
                v <- freshId ft "v"; r' <- freshId stringTy "r"
                body <- k (Var v) (Var r')
                let 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])
                pure (concatMapTo (mkBoxedTupleTy [ft, stringTy]) lam (rdr prec restE))

              recChain DataCon
dc [(String, Type, Integer -> Expr b -> EvExpr)]
fields EvExpr
restAfterName = do
                openB <- String -> TcPluginM EvExpr
str String
"{"; closeB <- str "}"; eqB <- str "="; commaB <- str ","
                let 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
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
                      lblStr <- String -> TcPluginM EvExpr
str String
lbl
                      let 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 isFirst then after restE else expectTok commaB restE after
                expectTok openB 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)

          mParserWss <- forM dcons \DataCon
dc -> do
            let fts :: [Type]
fts    = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
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)
            nameStr <- String -> TcPluginM EvExpr
str String
name
            mRdrs   <- zipWithM mkFieldReader [0 :: Int ..] fts
            case sequence 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)
                parserApp <-
                  if DataCon -> Bool
dataConIsInfix DataCon
dc
                    then do
                      prec <- DataCon -> TcPluginM Integer
conPrec DataCon
dc
                      let [(ft0, rdr0), (ft1, rdr1)] = zip fts rdrs
                      r0 <- freshId stringTy "r0"
                      body <- parseFieldP (prec + 1) ft0 rdr0 (Var 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 ]
                      pure (mkParser (gtThr prec) (Lam r0 body))
                    else do
                      r0   <- Type -> String -> TcPluginM TyVar
freshId Type
stringTy String
"r0"
                      ptok <- freshId strPairTy "pt"; tcb <- freshId strPairTy "ptc"
                      tok  <- freshId stringTy "tok"; r1 <- freshId stringTy "r1"; ecb <- freshId boolTy "bc"
                      chain <- if null labels
                                 then buildChain dc (zip fts rdrs) [] (Var r1)
                                 else recChain dc (zip3 labels fts rdrs) (Var r1)
                      let 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 = 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 = 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  = 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)
                      pure (mkParser flag inner)
                pure (Just (parserApp, concat wss))

          case sequence 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
              (supers, scWs) <- Class -> Type -> CtLoc -> TcPluginM ([EvExpr], [Ct])
stock2Supers Class
read2Cls Type
wrappedTy CtLoc
loc
              dict <- recDictWith read2Cls wrappedTy supers [(0, liftRp2Impl)]
              pure (Just (EvExpr dict, mkNonCanonical ordIntEv : scWs ++ concat 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