{-# 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     = HasDebugCallStack => 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
      Id
aTv <- String -> TcPluginM Id
freshTyVar String
"a" ; Id
bTv <- String -> TcPluginM Id
freshTyVar String
"b"
      let aTy :: Type
aTy = Id -> Type
mkTyVarTy Id
aTv ; bTy :: Type
bTy = Id -> Type
mkTyVarTy Id
bTv
          eqFnTy :: Type
eqFnTy = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
bTy Type
boolTy)
      Id
eqId <- Type -> String -> TcPluginM Id
freshId Type
eqFnTy String
"eq"
      Id
faId <- Type -> String -> TcPluginM Id
freshId (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy) String
"fa"
      Id
fbId <- Type -> String -> TcPluginM Id
freshId (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
bTy) String
"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 -> Type -> Id -> Id -> TcPluginM (Maybe (CoreExpr, [Ct]))
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
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
            CoreExpr
rest <- [CoreExpr] -> TcPluginM CoreExpr
conj [CoreExpr]
more
            Id
scr  <- Type -> String -> TcPluginM Id
freshId Type
boolTy String
"c"
            CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
e Id
scr Type
boolTy [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] CoreExpr
forall {b}. Expr b
false_
                                    , AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  [] CoreExpr
rest ])

      Maybe (CoreExpr, [Ct])
mBody <- TyCon
-> [Type]
-> (Type -> Coercion)
-> Type
-> Type
-> Type
-> Id
-> Id
-> (Int -> Int -> CoreExpr)
-> ([CoreExpr] -> TcPluginM CoreExpr)
-> (Int -> Type -> Id -> Id -> TcPluginM (Maybe (CoreExpr, [Ct])))
-> TcPluginM (Maybe (CoreExpr, [Ct]))
zipLift2 TyCon
fTc [Type]
fixed Type -> Coercion
coAt Type
aTy Type
bTy Type
boolTy Id
faId Id
fbId
                        (\Int
_ Int
_ -> CoreExpr
forall {b}. Expr b
false_) [CoreExpr] -> TcPluginM CoreExpr
conj Int -> Type -> Id -> Id -> TcPluginM (Maybe (CoreExpr, [Ct]))
fieldEq
      Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((CoreExpr, [Ct]) -> (CoreExpr, [Ct]))
-> Maybe (CoreExpr, [Ct]) -> Maybe (CoreExpr, [Ct])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
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)) Maybe (CoreExpr, [Ct])
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      = HasDebugCallStack => 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
      Id
aTv <- String -> TcPluginM Id
freshTyVar String
"a" ; Id
bTv <- String -> TcPluginM Id
freshTyVar String
"b"
      let aTy :: Type
aTy = Id -> Type
mkTyVarTy Id
aTv ; bTy :: Type
bTy = Id -> Type
mkTyVarTy Id
bTv
          cmpFnTy :: Type
cmpFnTy = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
bTy Type
ordTy)
      Id
cmpId <- Type -> String -> TcPluginM Id
freshId Type
cmpFnTy String
"cmp"
      Id
faId  <- Type -> String -> TcPluginM Id
freshId (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy) String
"fa"
      Id
fbId  <- Type -> String -> TcPluginM Id
freshId (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
bTy) String
"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 -> Type -> Id -> Id -> TcPluginM (Maybe (CoreExpr, [Ct]))
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
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
            CoreExpr
rest <- [CoreExpr] -> TcPluginM CoreExpr
lexCmp [CoreExpr]
more
            Id
scr  <- Type -> String -> TcPluginM Id
freshId Type
ordTy String
"o"
            CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
e Id
scr Type
ordTy [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
ltC) [] CoreExpr
forall {b}. Expr b
ltE
                                   , AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
eqC) [] CoreExpr
rest
                                   , AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
gtC) [] CoreExpr
forall {b}. Expr b
gtE ])

      Maybe (CoreExpr, [Ct])
mBody <- TyCon
-> [Type]
-> (Type -> Coercion)
-> Type
-> Type
-> Type
-> Id
-> Id
-> (Int -> Int -> CoreExpr)
-> ([CoreExpr] -> TcPluginM CoreExpr)
-> (Int -> Type -> Id -> Id -> TcPluginM (Maybe (CoreExpr, [Ct])))
-> TcPluginM (Maybe (CoreExpr, [Ct]))
zipLift2 TyCon
fTc [Type]
fixed Type -> Coercion
coAt Type
aTy Type
bTy Type
ordTy Id
faId Id
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) [CoreExpr] -> TcPluginM CoreExpr
lexCmp Int -> Type -> Id -> Id -> TcPluginM (Maybe (CoreExpr, [Ct]))
fieldCmp
      Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((CoreExpr, [Ct]) -> (CoreExpr, [Ct]))
-> Maybe (CoreExpr, [Ct]) -> Maybe (CoreExpr, [Ct])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
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)) Maybe (CoreExpr, [Ct])
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
  Id
aTv <- String -> TcPluginM Id
freshTyVar String
"a"
  let aTy :: Type
aTy = Id -> Type
mkTyVarTy Id
aTv ; gaTy :: Type
gaTy = Type -> Type -> Type
mkAppTy Type
gTy Type
aTy
  Id
dA <- Type -> String -> TcPluginM Id
freshId (Class -> [Type] -> Type
mkClassPred Class
baseCls [Type
aTy]) String
"d"
  CoreExpr
inner <- Type -> Type -> Id -> TcPluginM CoreExpr
mk Type
aTy Type
gaTy Id
dA
  CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
aTv, Id
dA] CoreExpr
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
  Id
x <- Type -> String -> TcPluginM Id
freshId Type
tT String
"x" ; Id
y <- Type -> String -> TcPluginM Id
freshId Type
tT String
"y" ; Id
s <- Type -> String -> TcPluginM Id
freshId Type
boolTy String
"c"
  let neq :: CoreExpr
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)) ])
  CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Class -> Type -> [CoreExpr] -> CoreExpr
mkClassDict Class
eqCls Type
tT [CoreExpr
eqImpl, CoreExpr
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]
    CoreExpr
eqDictGa <- Class -> Type -> CoreExpr -> TcPluginM CoreExpr
mkEqDict Class
eqCls Type
gaTy CoreExpr
eqGA
    Class
-> Type -> [CoreExpr] -> [(Int, CoreExpr)] -> TcPluginM CoreExpr
recDictWith Class
ordCls Type
gaTy [CoreExpr
eqDictGa] [(Int
0, CoreExpr
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
  Class
eqCls <- Name -> TcPluginM Class
tcLookupClass Name
eqClassName
  Maybe (CoreExpr, [Ct])
m <- GenEnv
-> Class
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
buildLiftEq GenEnv
gen Class
eq1Cls Class
eqCls CtLoc
loc Type
wrappedTy Type
f
  case Maybe (CoreExpr, [Ct])
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
      [CoreExpr]
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
      Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvTerm, [Ct]) -> Maybe (EvTerm, [Ct])
forall a. a -> Maybe a
Just (CoreExpr -> EvTerm
EvExpr (Class -> Type -> [CoreExpr] -> CoreExpr
mkClassDict Class
eq1Cls Type
wrappedTy ([CoreExpr]
supers [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr
liftEqImpl])), [Ct]
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        = HasDebugCallStack => 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))
      CtEvidence
ordIntEv <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
ordCls [Type
intTy])
      let ordIntDict :: CoreExpr
ordIntDict = HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ordIntEv
      Id
aTv <- String -> TcPluginM Id
freshTyVar String
"a"
      let aTy :: Type
aTy    = Id -> Type
mkTyVarTy Id
aTv
          innerA :: Type
innerA = TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy])
          spTy :: Type
spTy   = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
intTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
aTy Type
showSTy)
          slTy :: Type
slTy   = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany (Type -> Type
mkListTy Type
aTy) Type
showSTy
      Id
spId <- Type -> String -> TcPluginM Id
freshId Type
spTy String
"sp" ; Id
slId <- Type -> String -> TcPluginM Id
freshId Type
slTy String
"sl"
      Id
dId  <- Type -> String -> TcPluginM Id
freshId Type
intTy String
"d" ; Id
vId  <- Type -> String -> TcPluginM Id
freshId (Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy) String
"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 -> Type -> Id -> TcPluginM (Maybe (Integer -> CoreExpr, [Ct]))
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

      [Maybe (Alt Id, [Ct])]
mAltWss <- [DataCon]
-> (DataCon -> TcPluginM (Maybe (Alt Id, [Ct])))
-> TcPluginM [Maybe (Alt Id, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DataCon]
dcons \DataCon
dc -> do
        let fts :: [Type]
fts    = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy]))
            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)
        CoreExpr
nameStr <- String -> TcPluginM CoreExpr
str String
name
        [Id]
xs      <- (Int -> Type -> TcPluginM Id) -> [Int] -> [Type] -> TcPluginM [Id]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
n Type
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)) [Int
0 :: Int ..] [Type]
fts
        Id
rest    <- Type -> String -> TcPluginM Id
freshId Type
stringTy String
"r"
        Id
gtBndr  <- Type -> String -> TcPluginM Id
freshId Type
boolTy String
"p"
        Integer
prec    <- DataCon -> TcPluginM Integer
conPrec DataCon
dc
        [Maybe (Integer -> CoreExpr, [Ct])]
mRends  <- [TcPluginM (Maybe (Integer -> CoreExpr, [Ct]))]
-> TcPluginM [Maybe (Integer -> CoreExpr, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((Int
 -> Type -> Id -> TcPluginM (Maybe (Integer -> CoreExpr, [Ct])))
-> [Int]
-> [Type]
-> [Id]
-> [TcPluginM (Maybe (Integer -> CoreExpr, [Ct]))]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> Type -> Id -> TcPluginM (Maybe (Integer -> CoreExpr, [Ct]))
mkRenderer [Int
0 :: Int ..] [Type]
fts [Id]
xs)
        case [Maybe (Integer -> CoreExpr, [Ct])]
-> Maybe [(Integer -> CoreExpr, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Integer -> CoreExpr, [Ct])]
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)
            CoreExpr
body <-
              if DataCon -> Bool
dataConIsInfix DataCon
dc
                then do
                  CoreExpr
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 [Integer -> CoreExpr
l, Integer -> CoreExpr
r] = [Integer -> CoreExpr]
renderers
                      mk :: CoreExpr -> CoreExpr
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))
                  CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
parenAt Integer
prec CoreExpr -> CoreExpr
mk (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
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
                    CoreExpr
openB <- String -> TcPluginM CoreExpr
str String
" {"; CoreExpr
eqB <- String -> TcPluginM CoreExpr
str String
" = "; CoreExpr
commaB <- String -> TcPluginM CoreExpr
str String
", "; CoreExpr
closeB <- String -> TcPluginM CoreExpr
str String
"}"
                    [CoreExpr]
lblStrs <- (String -> TcPluginM CoreExpr) -> [String] -> TcPluginM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> TcPluginM CoreExpr
str [String]
labels
                    let recF :: [(CoreExpr, Integer -> CoreExpr)]
recF = [CoreExpr]
-> [Integer -> CoreExpr] -> [(CoreExpr, Integer -> CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CoreExpr]
lblStrs [Integer -> CoreExpr]
renderers
                        goRec :: [(CoreExpr, t -> CoreExpr)] -> CoreExpr -> CoreExpr
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 -> CoreExpr
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))
                    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
recBody (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
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))
            Maybe (Alt Id, [Ct]) -> TcPluginM (Maybe (Alt Id, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Alt Id, [Ct]) -> Maybe (Alt Id, [Ct])
forall a. a -> Maybe a
Just (AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [Id]
xs (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
rest CoreExpr
body), [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))

      case [Maybe (Alt Id, [Ct])] -> Maybe [(Alt Id, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Alt Id, [Ct])]
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
          Id
cb <- Type -> String -> TcPluginM Id
freshId Type
innerA String
"cb"
          let spImpl :: CoreExpr
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)
          Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CoreExpr, [Ct]) -> Maybe (CoreExpr, [Ct])
forall a. a -> Maybe a
Just (CoreExpr
spImpl, CtEvidence -> Ct
mkNonCanonical CtEvidence
ordIntEv Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))
    (Maybe TyCon, Maybe TyCon)
_ -> Maybe (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
  Id
vS <- Type -> String -> TcPluginM Id
freshId Type
tT String
"v" ; Id
vL <- Type -> String -> TcPluginM Id
freshId Type
tT String
"v"
  let showImpl :: CoreExpr
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 :: CoreExpr
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
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]
  CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Class -> Type -> [CoreExpr] -> CoreExpr
mkClassDict Class
showCls Type
tT [CoreExpr
spImpl, CoreExpr
showImpl, CoreExpr
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
  Class
showCls      <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_SHOW (String -> OccName
mkTcOcc String
"Show") TcPluginM Name -> (Name -> TcPluginM Class) -> TcPluginM Class
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Class
tcLookupClass
  Class
ordCls       <- Name -> TcPluginM Class
tcLookupClass Name
ordClassName
  Id
appendId     <- Name -> TcPluginM Id
tcLookupId Name
appendName
  Id
showList__Id <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_SHOW (String -> OccName
mkVarOcc String
"showList__") TcPluginM Name -> (Name -> TcPluginM Id) -> TcPluginM Id
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 Id
tcLookupId
  Maybe (CoreExpr, [Ct])
m <- 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 Maybe (CoreExpr, [Ct])
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
      [CoreExpr]
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
      CoreExpr
dict <- Class
-> Type -> [CoreExpr] -> [(Int, CoreExpr)] -> TcPluginM CoreExpr
recDictWith Class
show1Cls Type
wrappedTy [CoreExpr]
supers [(Int
0, CoreExpr
liftSpImpl)]
      Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvTerm, [Ct]) -> Maybe (EvTerm, [Ct])
forall a. a -> Maybe a
Just (CoreExpr -> EvTerm
EvExpr CoreExpr
dict, [Ct]
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
  Class
ordCls  <- Name -> TcPluginM Class
tcLookupClass Name
ordClassName
  Class
eqCls   <- Name -> TcPluginM Class
tcLookupClass Name
eqClassName
  Maybe Class
mEq1Cls <- String -> String -> TcPluginM (Maybe Class)
lookupClassMaybe String
"Data.Functor.Classes" String
"Eq1"
  case Maybe Class
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
      Maybe (CoreExpr, [Ct])
mCmp <- GenEnv
-> Class
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
buildLiftCompare GenEnv
gen Class
ord1Cls Class
ordCls CtLoc
loc Type
wrappedTy Type
f
      Maybe (CoreExpr, [Ct])
mEq  <- GenEnv
-> Class
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
buildLiftEq GenEnv
gen Class
eq1Cls Class
eqCls CtLoc
loc Type
wrappedTy Type
f
      case (Maybe (CoreExpr, [Ct])
mCmp, Maybe (CoreExpr, [Ct])
mEq) of
        (Just (CoreExpr
liftCmpImpl, [Ct]
wsC), Just (CoreExpr
liftEqImpl, [Ct]
wsE)) -> do
          -- the full Eq1 superclass dictionary (with its own quantified Eq super)
          [CoreExpr]
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 :: CoreExpr
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)@.
          [CoreExpr]
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
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
          CoreExpr
dict <- Class
-> Type -> [CoreExpr] -> [(Int, CoreExpr)] -> TcPluginM CoreExpr
recDictWith Class
ord1Cls Type
wrappedTy [CoreExpr]
supers [(Int
0, CoreExpr
liftCmpImpl)]
          Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvTerm, [Ct]) -> Maybe (EvTerm, [Ct])
forall a. a -> Maybe a
Just (CoreExpr -> EvTerm
EvExpr CoreExpr
dict, [Ct]
wsC [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
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
      (ReadPrecEnv
env, Ct
monadCt) <- CtLoc -> TcPluginM (ReadPrecEnv, Ct)
lookupReadPrecEnv CtLoc
loc
      let liftRpSel :: Id
liftRpSel   = String -> Class -> Id
classMethod String
"liftReadPrec" Class
read1Cls
          readPrecSel :: Id
readPrecSel = String -> Class -> Id
classMethod String
"readPrec" Class
readCls
          fixed :: [Type]
fixed       = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
realF
          dcons :: [DataCon]
dcons       = TyCon -> [DataCon]
tyConDataCons TyCon
fTc
          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
          rpcOf :: Type -> Type
rpcOf Type
t     = TyCon -> [Type] -> Type
mkTyConApp (ReadPrecEnv -> TyCon
rpReadPrecTc ReadPrecEnv
env) [Type
t]
      Id
aTv <- String -> TcPluginM Id
freshTyVar String
"a"
      let aTy :: Type
aTy    = Id -> Type
mkTyVarTy Id
aTv
          innerA :: Type
innerA = TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy])
          gaTy :: Type
gaTy   = Type -> Type -> Type
mkAppTy Type
wrappedTy Type
aTy
          toWrapped :: Expr b -> Expr b
toWrapped Expr b
e = Expr b -> Coercion -> Expr b
forall b. Expr b -> Coercion -> Expr b
Cast Expr b
e (Coercion -> Coercion
mkSymCo (Type -> Coercion
coAt Type
aTy))
      Id
rpId <- Type -> String -> TcPluginM Id
freshId (Type -> Type
rpcOf Type
aTy) String
"rp"
      Id
rlId <- Type -> String -> TcPluginM Id
freshId (Type -> Type
rpcOf (Type -> Type
mkListTy Type
aTy)) String
"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 -> Type -> TcPluginM (Maybe ((Type, CoreExpr, Coercion), [Ct]))
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
      [Maybe (DataCon, [(Type, CoreExpr, Coercion)], [Ct])]
mConsWss <- [DataCon]
-> (DataCon
    -> TcPluginM (Maybe (DataCon, [(Type, CoreExpr, Coercion)], [Ct])))
-> TcPluginM [Maybe (DataCon, [(Type, CoreExpr, Coercion)], [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DataCon]
dcons \DataCon
dc -> do
        let fts :: [Type]
fts = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy]))
        [Maybe ((Type, CoreExpr, Coercion), [Ct])]
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 [Maybe ((Type, CoreExpr, Coercion), [Ct])]
-> Maybe [((Type, CoreExpr, Coercion), [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe ((Type, CoreExpr, Coercion), [Ct])]
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 [Maybe (DataCon, [(Type, CoreExpr, Coercion)], [Ct])]
-> Maybe [(DataCon, [(Type, CoreExpr, Coercion)], [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (DataCon, [(Type, CoreExpr, Coercion)], [Ct])]
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))
          CoreExpr
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 :: CoreExpr
liftRpImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
aTv, Id
rpId, Id
rlId] CoreExpr
body
          Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CoreExpr, [Ct]) -> Maybe (CoreExpr, [Ct])
forall a. a -> Maybe a
Just (CoreExpr
liftRpImpl, Ct
monadCt Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: ((DataCon, [(Type, CoreExpr, Coercion)], [Ct]) -> [Ct])
-> [(DataCon, [(Type, CoreExpr, Coercion)], [Ct])] -> [Ct]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(DataCon
_, [(Type, CoreExpr, Coercion)]
_, [Ct]
w) -> [Ct]
w) [(DataCon, [(Type, CoreExpr, Coercion)], [Ct])]
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
  Class
readCls <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_READ (String -> OccName
mkTcOcc String
"Read") TcPluginM Name -> (Name -> TcPluginM Class) -> TcPluginM Class
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Class
tcLookupClass
  Maybe (CoreExpr, [Ct])
m <- GenEnv
-> Class
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
buildLiftReadPrec GenEnv
gen Class
read1Cls Class
readCls CtLoc
loc Type
wrappedTy Type
f
  case Maybe (CoreExpr, [Ct])
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
      [CoreExpr]
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
      CoreExpr
dict <- Class
-> Type -> [CoreExpr] -> [(Int, CoreExpr)] -> TcPluginM CoreExpr
recDictWith Class
read1Cls Type
wrappedTy [CoreExpr]
supers [(Int
2, CoreExpr
liftRpImpl)]
      Maybe (EvTerm, [Ct]) -> TcPluginM (Maybe (EvTerm, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvTerm, [Ct]) -> Maybe (EvTerm, [Ct])
forall a. a -> Maybe a
Just (CoreExpr -> EvTerm
EvExpr CoreExpr
dict, [Ct]
ws))