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

-- | The lifted @Data.Functor.Classes@ hierarchy over @Stock1 F@: @Eq1@,
-- @Ord1@, @Show1@, @Read1@.  Each is the structural synthesizer of its unlifted twin
-- (@Eq@\/@Ord@) with one change: a field that /is/ the functor parameter @a@
-- is handled by the supplied function argument (@liftEq@'s @eq@,
-- @liftCompare@'s @cmp@) instead of the field's own instance, and a field of
-- shape @H a@ recurses through @H@'s own lifted method.
--
-- Since base-4.18 these classes carry a /quantified/ superclass — @Eq1 f@
-- requires @forall a. Eq a => Eq (f a)@ and @Ord1 f@ likewise for @Ord@ — so
-- we synthesize those superclass dictionaries too (from the same lifted
-- method, instantiated at @eq = (==)@ \/ @cmp = compare@).
module Stock.Classes1 (synthEq1, synthOrd1, synthShow1, synthRead1) where

import GHC.Plugins hiding (TcPlugin)
import GHC.Tc.Plugin
import GHC.Tc.Types.Constraint
#if MIN_VERSION_ghc(9,12,0)
import GHC.Tc.Types.CtLoc (CtLoc)
#else
import GHC.Tc.Types.Constraint (CtLoc)
#endif
import GHC.Tc.Types.Evidence
import GHC.Core.Class (Class, className, classSCTheta, classSCSelId)
import GHC.Core.Predicate (mkClassPred, isClassPred)
import GHC.Builtin.Names (eqClassName, ordClassName, appendName, eqStringName)
import GHC.Core.Multiplicity (scaledThing)
import GHC.Core.TyCo.Rep (UnivCoProvenance(PluginProv))
import Stock.Compat (gHC_INTERNAL_SHOW, gHC_INTERNAL_READ, gHC_INTERNAL_LIST)
import Control.Monad (forM, zipWithM)
import Stock.Derive (classMethod, castInto)
import Stock.Internal  -- 'castReshape' (skip-Refl cast) comes from here
import Data.Maybe (fromJust)

-- ----- the structural lifted methods --------------------------------------

-- | Build the @liftEq@ method body @\\\@a \@b eq fa fb -> …@ for @Stock1 F@,
-- or 'Nothing' if some field shape is unsupported.  Returns the field-instance
-- wanteds (@Eq H@ for constant fields, @Eq1 H@ for @H a@ fields).
buildLiftEq :: GenEnv -> Class -> Class -> CtLoc -> Type -> Type
            -> TcPluginM (Maybe (CoreExpr, [Ct]))
buildLiftEq :: GenEnv
-> Class
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
buildLiftEq GenEnv
gen Class
eq1Cls Class
eqCls CtLoc
loc Type
wrappedTy Type
f =
  case (GenEnv -> Maybe TyCon
geStock1 GenEnv
gen, Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realF) of
    (Just TyCon
st1Tc, Just TyCon
fTc) -> do
      let liftEqSel :: Id
liftEqSel = String -> Class -> Id
classMethod String
"liftEq" Class
eq1Cls
          eqSel :: Id
eqSel     = String -> Class -> Id
classMethod String
"==" Class
eqCls
          fixed :: [Type]
fixed     = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realF
          true_ :: Expr b
true_     = Id -> Expr b
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
trueDataCon)
          false_ :: Expr b
false_    = Id -> Expr b
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
falseDataCon)
          coAt :: Type -> Coercion
coAt Type
t    = GenEnv -> TyCon -> Type -> Type -> Type -> Type -> Coercion
coDown1 GenEnv
gen TyCon
st1Tc Type
wrappedTy Type
f Type
realF Type
t
      aTv <- String -> TcPluginM Id
freshTyVar String
"a" ; bTv <- freshTyVar "b"
      let aTy = Id -> Type
mkTyVarTy Id
aTv ; bTy = Id -> Type
mkTyVarTy Id
bTv
          eqFnTy = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
bTy Type
boolTy)
      eqId <- freshId eqFnTy "eq"
      faId <- freshId (mkAppTy wrappedTy aTy) "fa"
      fbId <- freshId (mkAppTy wrappedTy bTy) "fb"

      -- one field-pair becomes a Bool: the parameter via @eq@, a constant via
      -- its own @(==)@, an @H a@ field via @liftEq \@m eq@ (the @Override1@
      -- modifier @m@; the field values cast @h ~R m@ via @coB@).
      let fieldEq Int
i Type
ft Id
x Id
y = Class
-> Class
-> Id
-> Type
-> CtLoc
-> Maybe Type
-> Roles CoreExpr
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
forall r.
Class
-> Class
-> Id
-> Type
-> CtLoc
-> Maybe Type
-> Roles r
-> Type
-> TcPluginM (Maybe (r, [Ct]))
interpField Class
eqCls Class
eq1Cls Id
aTv Type
aTy CtLoc
loc (GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i) Roles
            { onParam :: CoreExpr
onParam = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
eqId)     [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y]
            , onConst :: CtEvidence -> Type -> CoreExpr
onConst = \CtEvidence
ev Type
t -> CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
eqSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
t, HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y]
            , onApply :: CtEvidence -> Type -> (Type -> Coercion) -> CoreExpr
onApply = \CtEvidence
ev Type
m Type -> Coercion
coB -> CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
liftEqSel)
                [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
m, HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aTy, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
bTy, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
eqId
                , CoreExpr -> Coercion -> CoreExpr
castReshape (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x) (Type -> Coercion
coB Type
aTy), CoreExpr -> Coercion -> CoreExpr
castReshape (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y) (Type -> Coercion
coB Type
bTy) ]
            } Type
ft
          -- conjunction with short-circuit: @case e of False -> False; True -> …@
          conj []         = CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreExpr
forall {b}. Expr b
true_
          conj (CoreExpr
e : [CoreExpr]
more) = do
            rest <- [CoreExpr] -> TcPluginM CoreExpr
conj [CoreExpr]
more
            scr  <- freshId boolTy "c"
            pure (Case e scr boolTy [ Alt (DataAlt falseDataCon) [] false_
                                    , Alt (DataAlt trueDataCon)  [] rest ])

      mBody <- zipLift2 fTc fixed coAt aTy bTy boolTy faId fbId
                        (\Int
_ Int
_ -> CoreExpr
forall {b}. Expr b
false_) conj fieldEq
      pure (fmap (\(CoreExpr
body, [Ct]
ws) -> ([Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
aTv, Id
bTv, Id
eqId, Id
faId, Id
fbId] CoreExpr
body, [Ct]
ws)) mBody)
    (Maybe TyCon, Maybe TyCon)
_ -> Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CoreExpr, [Ct])
forall a. Maybe a
Nothing
  where (Type
realF, Maybe [Type]
mMods) = GenEnv -> Type -> (Type, Maybe [Type])
peelOverride1 GenEnv
gen Type
f

-- | Build the @liftCompare@ method body for @Stock1 F@: tag order between
-- constructors, lexicographic within.  Wanteds: @Ord H@ \/ @Ord1 H@ per field.
buildLiftCompare :: GenEnv -> Class -> Class -> CtLoc -> Type -> Type
                 -> TcPluginM (Maybe (CoreExpr, [Ct]))
buildLiftCompare :: GenEnv
-> Class
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
buildLiftCompare GenEnv
gen Class
ord1Cls Class
ordCls CtLoc
loc Type
wrappedTy Type
f =
  case (GenEnv -> Maybe TyCon
geStock1 GenEnv
gen, Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realF) of
    (Just TyCon
st1Tc, Just TyCon
fTc) -> do
      let liftCmpSel :: Id
liftCmpSel = String -> Class -> Id
classMethod String
"liftCompare" Class
ord1Cls
          cmpSel :: Id
cmpSel     = String -> Class -> Id
classMethod String
"compare" Class
ordCls
          fixed :: [Type]
fixed      = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realF
          ordTy :: Type
ordTy      = TyCon -> Type
mkTyConTy TyCon
orderingTyCon
          [DataCon
ltC, DataCon
eqC, DataCon
gtC] = TyCon -> [DataCon]
tyConDataCons TyCon
orderingTyCon
          ltE :: Expr b
ltE = Id -> Expr b
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
ltC)
          eqE :: Expr b
eqE = Id -> Expr b
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
eqC)
          gtE :: Expr b
gtE = Id -> Expr b
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
gtC)
          coAt :: Type -> Coercion
coAt Type
t = GenEnv -> TyCon -> Type -> Type -> Type -> Type -> Coercion
coDown1 GenEnv
gen TyCon
st1Tc Type
wrappedTy Type
f Type
realF Type
t
      aTv <- String -> TcPluginM Id
freshTyVar String
"a" ; bTv <- freshTyVar "b"
      let aTy = Id -> Type
mkTyVarTy Id
aTv ; bTy = Id -> Type
mkTyVarTy Id
bTv
          cmpFnTy = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
bTy Type
ordTy)
      cmpId <- freshId cmpFnTy "cmp"
      faId  <- freshId (mkAppTy wrappedTy aTy) "fa"
      fbId  <- freshId (mkAppTy wrappedTy bTy) "fb"

      -- one field-pair becomes an Ordering: the parameter via @cmp@, a constant
      -- via its own @compare@, an @H a@ field via @liftCompare \@m cmp@.
      let fieldCmp Int
i Type
ft Id
x Id
y = Class
-> Class
-> Id
-> Type
-> CtLoc
-> Maybe Type
-> Roles CoreExpr
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
forall r.
Class
-> Class
-> Id
-> Type
-> CtLoc
-> Maybe Type
-> Roles r
-> Type
-> TcPluginM (Maybe (r, [Ct]))
interpField Class
ordCls Class
ord1Cls Id
aTv Type
aTy CtLoc
loc (GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i) Roles
            { onParam :: CoreExpr
onParam = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
cmpId)      [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y]
            , onConst :: CtEvidence -> Type -> CoreExpr
onConst = \CtEvidence
ev Type
t -> CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
cmpSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
t, HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y]
            , onApply :: CtEvidence -> Type -> (Type -> Coercion) -> CoreExpr
onApply = \CtEvidence
ev Type
m Type -> Coercion
coB -> CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
liftCmpSel)
                [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
m, HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aTy, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
bTy, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
cmpId
                , CoreExpr -> Coercion -> CoreExpr
castReshape (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x) (Type -> Coercion
coB Type
aTy), CoreExpr -> Coercion -> CoreExpr
castReshape (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y) (Type -> Coercion
coB Type
bTy) ]
            } Type
ft
          -- lexicographic: @case e of LT -> LT; GT -> GT; EQ -> …@
          lexCmp []         = CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreExpr
forall {b}. Expr b
eqE
          lexCmp (CoreExpr
e : [CoreExpr]
more) = do
            rest <- [CoreExpr] -> TcPluginM CoreExpr
lexCmp [CoreExpr]
more
            scr  <- freshId ordTy "o"
            pure (Case e scr ordTy [ Alt (DataAlt ltC) [] ltE
                                   , Alt (DataAlt eqC) [] rest
                                   , Alt (DataAlt gtC) [] gtE ])

      mBody <- zipLift2 fTc fixed coAt aTy bTy ordTy faId fbId
                        (\Int
i Int
j -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
j then CoreExpr
forall {b}. Expr b
ltE else CoreExpr
forall {b}. Expr b
gtE) lexCmp fieldCmp
      pure (fmap (\(CoreExpr
body, [Ct]
ws) -> ([Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
aTv, Id
bTv, Id
cmpId, Id
faId, Id
fbId] CoreExpr
body, [Ct]
ws)) mBody)
    (Maybe TyCon, Maybe TyCon)
_ -> Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CoreExpr, [Ct])
forall a. Maybe a
Nothing
  where (Type
realF, Maybe [Type]
mMods) = GenEnv -> Type -> (Type, Maybe [Type])
peelOverride1 GenEnv
gen Type
f

-- ----- quantified-superclass dictionaries ---------------------------------

-- | A quantified superclass @forall a. C a => D (g a)@ as evidence: bind @a@
-- and its @C a@ dictionary, then build the @D (g a)@ dictionary.  The callback
-- receives @a@, @g a@, and the @C a@ dictionary binder.  This is the shape
-- shared by every @Eq1@\/@Ord1@\/@Show1@\/@Read1@ superclass.
buildQuantSuper :: Class -> Type
                -> (Type -> Type -> Id -> TcPluginM CoreExpr)
                -> TcPluginM CoreExpr
buildQuantSuper :: Class
-> Type
-> (Type -> Type -> Id -> TcPluginM CoreExpr)
-> TcPluginM CoreExpr
buildQuantSuper Class
baseCls Type
gTy Type -> Type -> Id -> TcPluginM CoreExpr
mk = do
  aTv <- String -> TcPluginM Id
freshTyVar String
"a"
  let aTy = Id -> Type
mkTyVarTy Id
aTv ; gaTy = Type -> Type -> Type
mkAppTy Type
gTy Type
aTy
  dA <- freshId (mkClassPred baseCls [aTy]) "d"
  inner <- mk aTy gaTy dA
  pure (mkLams [aTv, dA] inner)

-- | @Eq T@ dictionary from an equality test @eqImpl :: T -> T -> Bool@.
mkEqDict :: Class -> Type -> CoreExpr -> TcPluginM CoreExpr
mkEqDict :: Class -> Type -> CoreExpr -> TcPluginM CoreExpr
mkEqDict Class
eqCls Type
tT CoreExpr
eqImpl = do
  x <- Type -> String -> TcPluginM Id
freshId Type
tT String
"x" ; y <- freshId tT "y" ; s <- freshId boolTy "c"
  let neq = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
x, Id
y] (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
eqImpl [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y]) Id
s Type
boolTy
              [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
trueDataCon))
              , AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  [] (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
falseDataCon)) ])
  pure (mkClassDict eqCls tT [eqImpl, neq])

-- | The quantified @Eq@ superclass @forall a. Eq a => Eq (g a)@, built from
-- the @liftEq@ method instantiated at @eq = (==) \@a@.
buildQuantEq :: Class -> Type -> CoreExpr -> TcPluginM CoreExpr
buildQuantEq :: Class -> Type -> CoreExpr -> TcPluginM CoreExpr
buildQuantEq Class
eqCls Type
gTy CoreExpr
liftEqImpl =
  Class
-> Type
-> (Type -> Type -> Id -> TcPluginM CoreExpr)
-> TcPluginM CoreExpr
buildQuantSuper Class
eqCls Type
gTy \Type
aTy Type
gaTy Id
dEqA -> do
    let eqA :: Expr b
eqA  = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr b
forall b. Id -> Expr b
Var (String -> Class -> Id
classMethod String
"==" Class
eqCls)) [Type -> Expr b
forall b. Type -> Expr b
Type Type
aTy, Id -> Expr b
forall b. Id -> Expr b
Var Id
dEqA]
        eqGA :: CoreExpr
eqGA = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
liftEqImpl [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aTy, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aTy, CoreExpr
forall {b}. Expr b
eqA]
    Class -> Type -> CoreExpr -> TcPluginM CoreExpr
mkEqDict Class
eqCls Type
gaTy CoreExpr
eqGA

-- | The quantified @Ord@ superclass @forall a. Ord a => Ord (g a)@, built from
-- @liftCompare@ (instantiated at @compare \@a@) plus the @Eq (g a)@ it needs as
-- its own superclass (from @liftEq@ instantiated at the @Eq a@ inside @Ord a@).
buildQuantOrd :: Class -> Class -> Type -> CoreExpr -> CoreExpr -> TcPluginM CoreExpr
buildQuantOrd :: Class
-> Class -> Type -> CoreExpr -> CoreExpr -> TcPluginM CoreExpr
buildQuantOrd Class
ordCls Class
eqCls Type
gTy CoreExpr
liftCmpImpl CoreExpr
liftEqImpl =
  Class
-> Type
-> (Type -> Type -> Id -> TcPluginM CoreExpr)
-> TcPluginM CoreExpr
buildQuantSuper Class
ordCls Type
gTy \Type
aTy Type
gaTy Id
dOrdA -> do
    let cmpA :: Expr b
cmpA  = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr b
forall b. Id -> Expr b
Var (String -> Class -> Id
classMethod String
"compare" Class
ordCls)) [Type -> Expr b
forall b. Type -> Expr b
Type Type
aTy, Id -> Expr b
forall b. Id -> Expr b
Var Id
dOrdA]
        cmpGA :: CoreExpr
cmpGA = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
liftCmpImpl [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aTy, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aTy, CoreExpr
forall {b}. Expr b
cmpA]
        dEqA :: Expr b
dEqA  = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr b
forall b. Id -> Expr b
Var (Class -> Int -> Id
classSCSelId Class
ordCls Int
0)) [Type -> Expr b
forall b. Type -> Expr b
Type Type
aTy, Id -> Expr b
forall b. Id -> Expr b
Var Id
dOrdA]  -- Eq a from Ord a
        eqA :: Expr b
eqA   = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr b
forall b. Id -> Expr b
Var (String -> Class -> Id
classMethod String
"==" Class
eqCls)) [Type -> Expr b
forall b. Type -> Expr b
Type Type
aTy, Expr b
forall {b}. Expr b
dEqA]
        eqGA :: CoreExpr
eqGA  = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
liftEqImpl [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aTy, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aTy, CoreExpr
forall {b}. Expr b
eqA]
    eqDictGa <- Class -> Type -> CoreExpr -> TcPluginM CoreExpr
mkEqDict Class
eqCls Type
gaTy CoreExpr
eqGA
    recDictWith ordCls gaTy [eqDictGa] [(0, cmpGA)]

-- ----- the two entry points -----------------------------------------------

synthEq1 :: GenEnv -> Class -> CtLoc -> Type -> Type
         -> TcPluginM (Maybe (EvTerm, [Ct]))
synthEq1 :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthEq1 GenEnv
gen Class
eq1Cls CtLoc
loc Type
wrappedTy Type
f = do
  eqCls <- Name -> TcPluginM Class
tcLookupClass Name
eqClassName
  m <- buildLiftEq gen eq1Cls eqCls loc wrappedTy f
  case m of
    Maybe (CoreExpr, [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 (CoreExpr
liftEqImpl, [Ct]
ws) -> do
      supers <- [Type] -> (Type -> TcPluginM CoreExpr) -> TcPluginM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Class -> [Type]
classSCTheta Class
eq1Cls) \Type
_ -> Class -> Type -> CoreExpr -> TcPluginM CoreExpr
buildQuantEq Class
eqCls Type
wrappedTy CoreExpr
liftEqImpl
      pure (Just (EvExpr (mkClassDict eq1Cls wrappedTy (supers ++ [liftEqImpl])), ws))

-- ----- Show1 --------------------------------------------------------------

-- | Build @liftShowsPrec@'s body @\\\@a sp sl d v -> …@ for @Stock1 F@,
-- mirroring derived @showsPrec@ (prefix / infix / record / nullary, with the
-- @d > prec@ parenthesisation) but rendering the parameter field with the
-- supplied @sp@, an @H a@ field with @liftShowsPrec \@H sp sl@ (a @Show1 H@
-- wanted), and any other field with its own @showsPrec@ (a @Show H@ wanted).
buildLiftShowsPrec :: GenEnv -> Class -> Class -> Class -> Id -> CtLoc -> Type -> Type
                   -> TcPluginM (Maybe (CoreExpr, [Ct]))
buildLiftShowsPrec :: GenEnv
-> Class
-> Class
-> Class
-> Id
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
buildLiftShowsPrec GenEnv
gen Class
show1Cls Class
showCls Class
ordCls Id
appendId CtLoc
loc Type
wrappedTy Type
f =
  case (GenEnv -> Maybe TyCon
geStock1 GenEnv
gen, Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realF) of
    (Just TyCon
st1Tc, Just TyCon
fTc) -> do
      let liftSpSel :: Id
liftSpSel    = String -> Class -> Id
classMethod String
"liftShowsPrec" Class
show1Cls
          showsPrecSel :: Id
showsPrecSel = String -> Class -> Id
classMethod String
"showsPrec" Class
showCls
          gtSel :: Id
gtSel        = String -> Class -> Id
classMethod String
">" Class
ordCls
          fixed :: [Type]
fixed        = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realF
          dcons :: [DataCon]
dcons        = TyCon -> [DataCon]
tyConDataCons TyCon
fTc
          showSTy :: Type
showSTy      = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
stringTy Type
stringTy
          coAt :: Type -> Coercion
coAt Type
t       = GenEnv -> TyCon -> Type -> Type -> Type -> Type -> Coercion
coDown1 GenEnv
gen TyCon
st1Tc Type
wrappedTy Type
f Type
realF Type
t
          cons :: CoreExpr -> CoreExpr -> CoreExpr
cons CoreExpr
c CoreExpr
t     = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
consDataCon [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
charTy, CoreExpr
c, CoreExpr
t]
          append :: Arg b -> Arg b -> Arg b
append Arg b
s Arg b
t   = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Arg b
forall b. Id -> Expr b
Var Id
appendId) [Type -> Arg b
forall b. Type -> Expr b
Type Type
charTy, Arg b
s, Arg b
t]
          str :: String -> TcPluginM CoreExpr
str String
s        = TcM CoreExpr -> TcPluginM CoreExpr
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (FastString -> TcM CoreExpr
forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS (String -> FastString
fsLit String
s))
      ordIntEv <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
ordCls [Type
intTy])
      let ordIntDict = HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ordIntEv
      aTv <- freshTyVar "a"
      let aTy    = Id -> Type
mkTyVarTy Id
aTv
          innerA = TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy])
          spTy   = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
intTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aTy Type
showSTy)
          slTy   = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany (Type -> Type
mkListTy Type
aTy) Type
showSTy
      spId <- freshId spTy "sp" ; slId <- freshId slTy "sl"
      dId  <- freshId intTy "d" ; vId  <- freshId (mkAppTy wrappedTy aTy) "v"

      -- one field becomes a precedence-parameterised ShowS renderer (@p -> ShowS@):
      -- the parameter via @sp@, a constant via its own @showsPrec@, an @H a@
      -- field via @liftShowsPrec \@H sp sl@.
      let mkRenderer Int
i Type
ftA Id
xi = Class
-> Class
-> Id
-> Type
-> CtLoc
-> Maybe Type
-> Roles (Integer -> CoreExpr)
-> Type
-> TcPluginM (Maybe (Integer -> CoreExpr, [Ct]))
forall r.
Class
-> Class
-> Id
-> Type
-> CtLoc
-> Maybe Type
-> Roles r
-> Type
-> TcPluginM (Maybe (r, [Ct]))
interpField Class
showCls Class
show1Cls Id
aTv Type
aTy CtLoc
loc (GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i) Roles
            { onParam :: Integer -> CoreExpr
onParam     = \Integer
p -> CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
spId) [Integer -> CoreExpr
mkUncheckedIntExpr Integer
p, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
xi]
            , onConst :: CtEvidence -> Type -> Integer -> CoreExpr
onConst = \CtEvidence
ev Type
t -> \Integer
p -> CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
showsPrecSel)
                                    [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
t, HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev, Integer -> CoreExpr
mkUncheckedIntExpr Integer
p, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
xi]
            , onApply :: CtEvidence -> Type -> (Type -> Coercion) -> Integer -> CoreExpr
onApply = \CtEvidence
ev Type
m Type -> Coercion
coB -> \Integer
p -> CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
liftSpSel)
                                    [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
m, HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aTy, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
spId, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
slId
                                    , Integer -> CoreExpr
mkUncheckedIntExpr Integer
p, CoreExpr -> Coercion -> CoreExpr
castReshape (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
xi) (Type -> Coercion
coB Type
aTy) ]
            } Type
ftA

      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]))
            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 CoreExpr
str String
name
        xs      <- zipWithM (\Int
n Type
ft -> Type -> String -> TcPluginM Id
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 "p"
        prec    <- conPrec dc
        mRends  <- sequence (zipWith3 mkRenderer [0 :: Int ..] fts xs)
        case sequence mRends of
          Maybe [(Integer -> CoreExpr, [Ct])]
Nothing    -> Maybe (Alt Id, [Ct]) -> TcPluginM (Maybe (Alt Id, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Alt Id, [Ct])
forall a. Maybe a
Nothing
          Just [(Integer -> CoreExpr, [Ct])]
rends -> do
            let ([Integer -> CoreExpr]
renderers, [[Ct]]
wss) = [(Integer -> CoreExpr, [Ct])] -> ([Integer -> CoreExpr], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Integer -> CoreExpr, [Ct])]
rends
                parenAt :: Integer -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
parenAt Integer
thr CoreExpr -> CoreExpr
mk CoreExpr
t =
                  CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
gtSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy, CoreExpr
ordIntDict, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
dId, Integer -> CoreExpr
mkUncheckedIntExpr Integer
thr])
                       Id
gtBndr Type
stringTy
                    [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] (CoreExpr -> CoreExpr
mk CoreExpr
t)
                    , AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  []
                        (CoreExpr -> CoreExpr -> CoreExpr
cons (Char -> CoreExpr
mkCharExpr Char
'(') (CoreExpr -> CoreExpr
mk (CoreExpr -> CoreExpr -> CoreExpr
cons (Char -> CoreExpr
mkCharExpr Char
')') CoreExpr
t))) ]
                goPrefix :: CoreExpr -> CoreExpr
goPrefix CoreExpr
t = ((Integer -> CoreExpr) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [Integer -> CoreExpr] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Integer -> CoreExpr
r CoreExpr
acc -> CoreExpr -> CoreExpr -> CoreExpr
cons (Char -> CoreExpr
mkCharExpr Char
' ') (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Integer -> CoreExpr
r Integer
11) CoreExpr
acc)) CoreExpr
t [Integer -> CoreExpr]
renderers
                prefixBody :: CoreExpr -> CoreExpr
prefixBody CoreExpr
t = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
nameStr (CoreExpr -> CoreExpr
goPrefix CoreExpr
t)
            body <-
              if DataCon -> Bool
dataConIsInfix DataCon
dc
                then do
                  opStr <- String -> TcPluginM CoreExpr
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 CoreExpr
t = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Integer -> CoreExpr
l (Integer
prec Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)) (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
opStr (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Integer -> CoreExpr
r (Integer
prec Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)) CoreExpr
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 CoreExpr
str String
" {"; eqB <- str " = "; commaB <- str ", "; closeB <- str "}"
                    lblStrs <- mapM str labels
                    let recF = [CoreExpr]
-> [Integer -> CoreExpr] -> [(CoreExpr, Integer -> CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CoreExpr]
lblStrs [Integer -> CoreExpr]
renderers
                        goRec [(CoreExpr
lbl, t -> CoreExpr
r)] CoreExpr
c    = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
lbl (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
eqB (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (t -> CoreExpr
r t
0) (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
closeB CoreExpr
c)))
                        goRec ((CoreExpr
lbl, t -> CoreExpr
r) : [(CoreExpr, t -> CoreExpr)]
m) CoreExpr
c = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
lbl (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
eqB (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (t -> CoreExpr
r t
0) (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
commaB ([(CoreExpr, t -> CoreExpr)] -> CoreExpr -> CoreExpr
goRec [(CoreExpr, t -> CoreExpr)]
m CoreExpr
c))))
                        goRec [] CoreExpr
c            = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
closeB CoreExpr
c
                        recBody CoreExpr
t = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
nameStr (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
openB ([(CoreExpr, Integer -> CoreExpr)] -> CoreExpr -> CoreExpr
forall {t}.
Num t =>
[(CoreExpr, t -> CoreExpr)] -> CoreExpr -> CoreExpr
goRec [(CoreExpr, Integer -> CoreExpr)]
recF CoreExpr
t))
                    pure (parenAt 10 recBody (Var rest))
                  else if [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
xs
                    then CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
nameStr (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rest))
                    else CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
parenAt Integer
10 CoreExpr -> CoreExpr
prefixBody (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rest))
            pure (Just (Alt (DataAlt dc) xs (Lam rest body), concat wss))

      case sequence mAltWss of
        Maybe [(Alt Id, [Ct])]
Nothing     -> Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CoreExpr, [Ct])
forall a. Maybe a
Nothing
        Just [(Alt Id, [Ct])]
altWss -> do
          let ([Alt Id]
alts, [[Ct]]
wss) = [(Alt Id, [Ct])] -> ([Alt Id], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt Id, [Ct])]
altWss
          cb <- Type -> String -> TcPluginM Id
freshId Type
innerA String
"cb"
          let spImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
aTv, Id
spId, Id
slId, Id
dId, Id
vId]
                (TyCon -> [Type] -> CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
destructInner TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy]) (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
vId) (Type -> Coercion
coAt Type
aTy)) Id
cb Type
showSTy [Alt Id]
alts)
          pure (Just (spImpl, mkNonCanonical ordIntEv : concat wss))
    (Maybe TyCon, Maybe TyCon)
_ -> Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CoreExpr, [Ct])
forall a. Maybe a
Nothing
  where (Type
realF, Maybe [Type]
mMods) = GenEnv -> Type -> (Type, Maybe [Type])
peelOverride1 GenEnv
gen Type
f

-- | A @Show T@ dictionary from a @showsPrec@ implementation.
mkShowDict :: Class -> Id -> Type -> CoreExpr -> TcPluginM CoreExpr
mkShowDict :: Class -> Id -> Type -> CoreExpr -> TcPluginM CoreExpr
mkShowDict Class
showCls Id
showList__Id Type
tT CoreExpr
spImpl = do
  vS <- Type -> String -> TcPluginM Id
freshId Type
tT String
"v" ; vL <- freshId tT "v"
  let showImpl     = Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
vS (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
spImpl [Integer -> CoreExpr
mkUncheckedIntExpr Integer
0, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
vS, Type -> CoreExpr
mkNilExpr Type
charTy])
      sp0          = Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
vL (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
spImpl [Integer -> CoreExpr
mkUncheckedIntExpr Integer
0, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
vL])
      showListImpl = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
showList__Id) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
tT, CoreExpr
sp0]
  pure (mkClassDict showCls tT [spImpl, showImpl, showListImpl])

-- | The quantified @Show@ superclass @forall a. Show a => Show (g a)@, from
-- @liftShowsPrec@ instantiated at @sp = showsPrec \@a@, @sl = showList \@a@.
buildQuantShow :: Class -> Id -> Type -> CoreExpr -> TcPluginM CoreExpr
buildQuantShow :: Class -> Id -> Type -> CoreExpr -> TcPluginM CoreExpr
buildQuantShow Class
showCls Id
showList__Id Type
gTy CoreExpr
liftSpImpl =
  Class
-> Type
-> (Type -> Type -> Id -> TcPluginM CoreExpr)
-> TcPluginM CoreExpr
buildQuantSuper Class
showCls Type
gTy \Type
aTy Type
gaTy Id
dShowA -> do
    let spA :: Expr b
spA  = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr b
forall b. Id -> Expr b
Var (String -> Class -> Id
classMethod String
"showsPrec" Class
showCls))   [Type -> Expr b
forall b. Type -> Expr b
Type Type
aTy, Id -> Expr b
forall b. Id -> Expr b
Var Id
dShowA]
        slA :: Expr b
slA  = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr b
forall b. Id -> Expr b
Var (String -> Class -> Id
classMethod String
"showList" Class
showCls))     [Type -> Expr b
forall b. Type -> Expr b
Type Type
aTy, Id -> Expr b
forall b. Id -> Expr b
Var Id
dShowA]
        spGA :: CoreExpr
spGA = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
liftSpImpl [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aTy, CoreExpr
forall {b}. Expr b
spA, CoreExpr
forall {b}. Expr b
slA]
    Class -> Id -> Type -> CoreExpr -> TcPluginM CoreExpr
mkShowDict Class
showCls Id
showList__Id Type
gaTy CoreExpr
spGA

synthShow1 :: GenEnv -> Class -> CtLoc -> Type -> Type
           -> TcPluginM (Maybe (EvTerm, [Ct]))
synthShow1 :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthShow1 GenEnv
gen Class
show1Cls CtLoc
loc Type
wrappedTy Type
f = 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
  showList__Id <- lookupOrig gHC_INTERNAL_SHOW (mkVarOcc "showList__") >>= tcLookupId
  m <- buildLiftShowsPrec gen show1Cls showCls ordCls appendId loc wrappedTy f
  case m of
    Maybe (CoreExpr, [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 (CoreExpr
liftSpImpl, [Ct]
ws) -> do
      supers <- [Type] -> (Type -> TcPluginM CoreExpr) -> TcPluginM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Class -> [Type]
classSCTheta Class
show1Cls) \Type
_ ->
                  Class -> Id -> Type -> CoreExpr -> TcPluginM CoreExpr
buildQuantShow Class
showCls Id
showList__Id Type
wrappedTy CoreExpr
liftSpImpl
      dict <- recDictWith show1Cls wrappedTy supers [(0, liftSpImpl)]
      pure (Just (EvExpr dict, ws))

synthOrd1 :: GenEnv -> Class -> CtLoc -> Type -> Type
          -> TcPluginM (Maybe (EvTerm, [Ct]))
synthOrd1 :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthOrd1 GenEnv
gen Class
ord1Cls CtLoc
loc Type
wrappedTy Type
f = do
  ordCls  <- Name -> TcPluginM Class
tcLookupClass Name
ordClassName
  eqCls   <- tcLookupClass eqClassName
  mEq1Cls <- lookupClassMaybe "Data.Functor.Classes" "Eq1"
  case mEq1Cls 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
      mCmp <- GenEnv
-> Class
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
buildLiftCompare GenEnv
gen Class
ord1Cls Class
ordCls CtLoc
loc Type
wrappedTy Type
f
      mEq  <- buildLiftEq gen eq1Cls eqCls loc wrappedTy f
      case (mCmp, mEq) of
        (Just (CoreExpr
liftCmpImpl, [Ct]
wsC), Just (CoreExpr
liftEqImpl, [Ct]
wsE)) -> do
          -- the full Eq1 superclass dictionary (with its own quantified Eq super)
          eqSupers <- [Type] -> (Type -> TcPluginM CoreExpr) -> TcPluginM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Class -> [Type]
classSCTheta Class
eq1Cls) \Type
_ -> Class -> Type -> CoreExpr -> TcPluginM CoreExpr
buildQuantEq Class
eqCls Type
wrappedTy CoreExpr
liftEqImpl
          let eq1Dict = Class -> Type -> [CoreExpr] -> CoreExpr
mkClassDict Class
eq1Cls Type
wrappedTy ([CoreExpr]
eqSupers [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr
liftEqImpl])
          -- Ord1's superclasses, in declaration order: the plain @Eq1 f@ and the
          -- quantified @forall a. Ord a => Ord (f a)@.
          supers <- forM (classSCTheta ord1Cls) \Type
p ->
            if Type -> Bool
isClassPred Type
p
              then CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreExpr
eq1Dict
              else Class
-> Class -> Type -> CoreExpr -> CoreExpr -> TcPluginM CoreExpr
buildQuantOrd Class
ordCls Class
eqCls Type
wrappedTy CoreExpr
liftCmpImpl CoreExpr
liftEqImpl
          dict <- recDictWith ord1Cls wrappedTy supers [(0, liftCmpImpl)]
          pure (Just (EvExpr dict, wsC ++ wsE))
        (Maybe (CoreExpr, [Ct]), Maybe (CoreExpr, [Ct]))
_ -> 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

-- ----- Read1 --------------------------------------------------------------

-- | Build @liftReadPrec@'s body @\@a rp rl -> ...@ for @Stock1 F@, by reusing
-- the shared GHC-faithful @readPrec@ assembler ('buildReadPrecBody'): the
-- parameter field reads with the supplied @rp@, a constant field with its own
-- @readPrec@, and an @H a@ field with @liftReadPrec \@H rp rl@ (cast back to the
-- real field type when @Override1@ reshapes the functor).
buildLiftReadPrec :: GenEnv -> Class -> Class -> CtLoc -> Type -> Type
                  -> TcPluginM (Maybe (CoreExpr, [Ct]))
buildLiftReadPrec :: GenEnv
-> Class
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
buildLiftReadPrec GenEnv
gen Class
read1Cls Class
readCls CtLoc
loc Type
wrappedTy Type
f =
  case (GenEnv -> Maybe TyCon
geStock1 GenEnv
gen, Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realF) of
    (Just TyCon
st1Tc, Just TyCon
fTc) -> do
      (env, monadCt) <- CtLoc -> TcPluginM (ReadPrecEnv, Ct)
lookupReadPrecEnv CtLoc
loc
      let liftRpSel   = String -> Class -> Id
classMethod String
"liftReadPrec" Class
read1Cls
          readPrecSel = String -> Class -> Id
classMethod String
"readPrec" Class
readCls
          fixed       = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realF
          dcons       = TyCon -> [DataCon]
tyConDataCons TyCon
fTc
          coAt Type
t      = GenEnv -> TyCon -> Type -> Type -> Type -> Type -> Coercion
coDown1 GenEnv
gen TyCon
st1Tc Type
wrappedTy Type
f Type
realF Type
t
          rpcOf Type
t     = TyCon -> [Type] -> Type
mkTyConApp (ReadPrecEnv -> TyCon
rpReadPrecTc ReadPrecEnv
env) [Type
t]
      aTv <- freshTyVar "a"
      let aTy    = Id -> Type
mkTyVarTy Id
aTv
          innerA = TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy])
          gaTy   = Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy
          toWrapped Expr b
e = Expr b -> Coercion -> Expr b
forall b. Expr b -> Coercion -> Expr b
Cast Expr b
e (Coercion -> Coercion
mkSymCo (Type -> Coercion
coAt Type
aTy))
      rpId <- freshId (rpcOf aTy) "rp"
      rlId <- freshId (rpcOf (mkListTy aTy)) "rl"
      -- each field's raw reader, plus the coercion casting the read type back to
      -- the real field type (Refl unless Override1 reshaped an @H a@ field).
      let mkFieldReader Int
i Type
ftA = Class
-> Class
-> Id
-> Type
-> CtLoc
-> Maybe Type
-> Roles (Type, CoreExpr, Coercion)
-> Type
-> TcPluginM (Maybe ((Type, CoreExpr, Coercion), [Ct]))
forall r.
Class
-> Class
-> Id
-> Type
-> CtLoc
-> Maybe Type
-> Roles r
-> Type
-> TcPluginM (Maybe (r, [Ct]))
interpField Class
readCls Class
read1Cls Id
aTv Type
aTy CtLoc
loc (GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen Maybe [Type]
mMods Int
i) Roles
            { onParam :: (Type, CoreExpr, Coercion)
onParam = (Type
aTy, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rpId, Role -> Type -> Coercion
mkReflCo Role
Representational Type
aTy)
            , onConst :: CtEvidence -> Type -> (Type, CoreExpr, Coercion)
onConst = \CtEvidence
ev Type
t -> (Type
t, CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
readPrecSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
t, HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev], Role -> Type -> Coercion
mkReflCo Role
Representational Type
t)
            , onApply :: CtEvidence
-> Type -> (Type -> Coercion) -> (Type, CoreExpr, Coercion)
onApply = \CtEvidence
ev Type
m Type -> Coercion
coB ->
                ( Type -> Type -> Type
mkAppTy Type
m Type
aTy
                , CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
liftRpSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
m, HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aTy, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rpId, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rlId]
                , if Coercion -> Bool
isReflCo (Type -> Coercion
coB Type
aTy) then Role -> Type -> Coercion
mkReflCo Role
Representational Type
ftA else Coercion -> Coercion
mkSymCo (Type -> Coercion
coB Type
aTy) )
            } Type
ftA
      mConsWss <- 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]))
        mRdrs <- (Int
 -> Type -> TcPluginM (Maybe ((Type, CoreExpr, Coercion), [Ct])))
-> [Int]
-> [Type]
-> TcPluginM [Maybe ((Type, CoreExpr, Coercion), [Ct])]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Int -> Type -> TcPluginM (Maybe ((Type, CoreExpr, Coercion), [Ct]))
mkFieldReader [Int
0 :: Int ..] [Type]
fts
        case sequence mRdrs of
          Maybe [((Type, CoreExpr, Coercion), [Ct])]
Nothing    -> Maybe (DataCon, [(Type, CoreExpr, Coercion)], [Ct])
-> TcPluginM (Maybe (DataCon, [(Type, CoreExpr, Coercion)], [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (DataCon, [(Type, CoreExpr, Coercion)], [Ct])
forall a. Maybe a
Nothing
          Just [((Type, CoreExpr, Coercion), [Ct])]
trips -> let ([(Type, CoreExpr, Coercion)]
rdrs, [[Ct]]
wss) = [((Type, CoreExpr, Coercion), [Ct])]
-> ([(Type, CoreExpr, Coercion)], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [((Type, CoreExpr, Coercion), [Ct])]
trips in Maybe (DataCon, [(Type, CoreExpr, Coercion)], [Ct])
-> TcPluginM (Maybe (DataCon, [(Type, CoreExpr, Coercion)], [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((DataCon, [(Type, CoreExpr, Coercion)], [Ct])
-> Maybe (DataCon, [(Type, CoreExpr, Coercion)], [Ct])
forall a. a -> Maybe a
Just (DataCon
dc, [(Type, CoreExpr, Coercion)]
rdrs, [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))
      case sequence mConsWss of
        Maybe [(DataCon, [(Type, CoreExpr, Coercion)], [Ct])]
Nothing   -> Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CoreExpr, [Ct])
forall a. Maybe a
Nothing
        Just [(DataCon, [(Type, CoreExpr, Coercion)], [Ct])]
cons -> do
          let consForAsm :: [(DataCon, [(Type, CoreExpr)])]
consForAsm = [ (DataCon
dc, [ (Type
ty, CoreExpr
rd) | (Type
ty, CoreExpr
rd, Coercion
_) <- [(Type, CoreExpr, Coercion)]
rdrs ]) | (DataCon
dc, [(Type, CoreExpr, Coercion)]
rdrs, [Ct]
_) <- [(DataCon, [(Type, CoreExpr, Coercion)], [Ct])]
cons ]
              castMap :: [(Unique, [Coercion])]
castMap    = [ (DataCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique DataCon
dc, [ Coercion
co | (Type
_, CoreExpr
_, Coercion
co) <- [(Type, CoreExpr, Coercion)]
rdrs ]) | (DataCon
dc, [(Type, CoreExpr, Coercion)]
rdrs, [Ct]
_) <- [(DataCon, [(Type, CoreExpr, Coercion)], [Ct])]
cons ]
              mkConVal :: DataCon -> [Id] -> CoreExpr
mkConVal DataCon
dc [Id]
argIds =
                let castCos :: [Coercion]
castCos = Maybe [Coercion] -> [Coercion]
forall a. HasCallStack => Maybe a -> a
fromJust (Unique -> [(Unique, [Coercion])] -> Maybe [Coercion]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (DataCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique DataCon
dc) [(Unique, [Coercion])]
castMap)
                in CoreExpr -> CoreExpr
forall {b}. Expr b -> Expr b
toWrapped (Type -> DataCon -> [CoreExpr] -> CoreExpr
conAppAt Type
innerA DataCon
dc ((Id -> Coercion -> CoreExpr) -> [Id] -> [Coercion] -> [CoreExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Id
a Coercion
c -> CoreExpr -> Coercion -> CoreExpr
castInto (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
a) Coercion
c) [Id]
argIds [Coercion]
castCos))
          body <- ReadPrecEnv
-> Type
-> (DataCon -> [Id] -> CoreExpr)
-> [(DataCon, [(Type, CoreExpr)])]
-> TcPluginM CoreExpr
buildReadPrecBody ReadPrecEnv
env Type
gaTy DataCon -> [Id] -> CoreExpr
mkConVal [(DataCon, [(Type, CoreExpr)])]
consForAsm
          let liftRpImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
aTv, Id
rpId, Id
rlId] CoreExpr
body
          pure (Just (liftRpImpl, monadCt : concatMap (\(DataCon
_, [(Type, CoreExpr, Coercion)]
_, [Ct]
w) -> [Ct]
w) cons))
    (Maybe TyCon, Maybe TyCon)
_ -> Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CoreExpr, [Ct])
forall a. Maybe a
Nothing
  where (Type
realF, Maybe [Type]
mMods) = GenEnv -> Type -> (Type, Maybe [Type])
peelOverride1 GenEnv
gen Type
f

-- | A @Read T@ dictionary from a @readPrec@ implementation (other methods come
-- from the class defaults via a recursive dictionary).
mkReadDict :: Class -> Type -> CoreExpr -> TcPluginM CoreExpr
mkReadDict :: Class -> Type -> CoreExpr -> TcPluginM CoreExpr
mkReadDict Class
readCls Type
tT CoreExpr
rpImpl = Class
-> Type -> [CoreExpr] -> [(Int, CoreExpr)] -> TcPluginM CoreExpr
recDictWith Class
readCls Type
tT [] [(Int
2, CoreExpr
rpImpl)]

-- | The quantified @Read@ superclass @forall a. Read a => Read (g a)@, from
-- @liftReadPrec@ instantiated at @rp = readPrec \@a@, @rl = readListPrec \@a@.
buildQuantRead :: Class -> Type -> CoreExpr -> TcPluginM CoreExpr
buildQuantRead :: Class -> Type -> CoreExpr -> TcPluginM CoreExpr
buildQuantRead Class
readCls Type
gTy CoreExpr
liftRpImpl =
  Class
-> Type
-> (Type -> Type -> Id -> TcPluginM CoreExpr)
-> TcPluginM CoreExpr
buildQuantSuper Class
readCls Type
gTy \Type
aTy Type
gaTy Id
dReadA -> do
    let rpA :: Expr b
rpA  = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr b
forall b. Id -> Expr b
Var (String -> Class -> Id
classMethod String
"readPrec" Class
readCls))     [Type -> Expr b
forall b. Type -> Expr b
Type Type
aTy, Id -> Expr b
forall b. Id -> Expr b
Var Id
dReadA]
        rlpA :: Expr b
rlpA = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr b
forall b. Id -> Expr b
Var (String -> Class -> Id
classMethod String
"readListPrec" Class
readCls)) [Type -> Expr b
forall b. Type -> Expr b
Type Type
aTy, Id -> Expr b
forall b. Id -> Expr b
Var Id
dReadA]
        rpGA :: CoreExpr
rpGA = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
liftRpImpl [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
aTy, CoreExpr
forall {b}. Expr b
rpA, CoreExpr
forall {b}. Expr b
rlpA]
    Class -> Type -> CoreExpr -> TcPluginM CoreExpr
mkReadDict Class
readCls Type
gaTy CoreExpr
rpGA

synthRead1 :: GenEnv -> Class -> CtLoc -> Type -> Type
           -> TcPluginM (Maybe (EvTerm, [Ct]))
synthRead1 :: GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthRead1 GenEnv
gen Class
read1Cls CtLoc
loc Type
wrappedTy Type
f = 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
  m <- buildLiftReadPrec gen read1Cls readCls loc wrappedTy f
  case m of
    Maybe (CoreExpr, [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 (CoreExpr
liftRpImpl, [Ct]
ws) -> do
      supers <- [Type] -> (Type -> TcPluginM CoreExpr) -> TcPluginM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Class -> [Type]
classSCTheta Class
read1Cls) \Type
_ -> Class -> Type -> CoreExpr -> TcPluginM CoreExpr
buildQuantRead Class
readCls Type
wrappedTy CoreExpr
liftRpImpl
      dict <- recDictWith read1Cls wrappedTy supers [(2, liftRpImpl)]
      pure (Just (EvExpr dict, ws))