{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Instance.Class (
matchGlobalInst,
ClsInstResult(..),
InstanceWhat(..), safeOverlap, instanceReturnsDictCon,
AssocInstInfo(..), isNotAssociated,
) where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Core.TyCo.Rep
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Instantiate(instDFunType, tcInstType)
import GHC.Tc.Instance.Typeable
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Evidence
import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )
import GHC.Rename.Env( addUsedGRE )
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Builtin.Names
import GHC.Types.FieldLabel
import GHC.Types.Name.Reader( lookupGRE_FieldLabel, greMangledName )
import GHC.Types.SafeHaskell
import GHC.Types.Name ( Name, pprDefinedAt )
import GHC.Types.Var.Env ( VarEnv )
import GHC.Types.Id
import GHC.Types.Id.Make ( nospecId )
import GHC.Types.Var
import GHC.Core.Predicate
import GHC.Core.Coercion
import GHC.Core.InstEnv
import GHC.Core.Type
import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams )
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Class
import GHC.Core ( Expr(Var, App, Cast, Type) )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc( splitAtList, fstOf3 )
import GHC.Data.FastString
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
data AssocInstInfo
= NotAssociated
| InClsInst { AssocInstInfo -> Class
ai_class :: Class
, AssocInstInfo -> [DFunId]
ai_tyvars :: [TyVar]
, AssocInstInfo -> VarEnv Type
ai_inst_env :: VarEnv Type
}
isNotAssociated :: AssocInstInfo -> Bool
isNotAssociated :: AssocInstInfo -> Bool
isNotAssociated (NotAssociated {}) = Bool
True
isNotAssociated (InClsInst {}) = Bool
False
type SafeOverlapping = Bool
data ClsInstResult
= NoInstance
| OneInst { ClsInstResult -> [Type]
cir_new_theta :: [TcPredType]
, ClsInstResult -> [EvExpr] -> EvTerm
cir_mk_ev :: [EvExpr] -> EvTerm
, ClsInstResult -> InstanceWhat
cir_what :: InstanceWhat }
| NotSure
data InstanceWhat
= BuiltinEqInstance
| BuiltinTypeableInstance TyCon
| BuiltinInstance
| LocalInstance
| TopLevInstance
{ InstanceWhat -> DFunId
iw_dfun_id :: DFunId
, InstanceWhat -> Bool
iw_safe_over :: SafeOverlapping }
instance Outputable ClsInstResult where
ppr :: ClsInstResult -> SDoc
ppr ClsInstResult
NoInstance = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NoInstance"
ppr ClsInstResult
NotSure = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NotSure"
ppr (OneInst { cir_new_theta :: ClsInstResult -> [Type]
cir_new_theta = [Type]
ev
, cir_what :: ClsInstResult -> InstanceWhat
cir_what = InstanceWhat
what })
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"OneInst" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [[Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
ev, InstanceWhat -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstanceWhat
what]
instance Outputable InstanceWhat where
ppr :: InstanceWhat -> SDoc
ppr InstanceWhat
BuiltinInstance = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a built-in instance"
ppr BuiltinTypeableInstance {} = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a built-in typeable instance"
ppr InstanceWhat
BuiltinEqInstance = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a built-in equality instance"
ppr InstanceWhat
LocalInstance = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a locally-quantified instance"
ppr (TopLevInstance { iw_dfun_id :: InstanceWhat -> DFunId
iw_dfun_id = DFunId
dfun })
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"instance" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
pprSigmaType (DFunId -> Type
idType DFunId
dfun))
Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"--" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
pprDefinedAt (DFunId -> Name
idName DFunId
dfun))
safeOverlap :: InstanceWhat -> Bool
safeOverlap :: InstanceWhat -> Bool
safeOverlap (TopLevInstance { iw_safe_over :: InstanceWhat -> Bool
iw_safe_over = Bool
so }) = Bool
so
safeOverlap InstanceWhat
_ = Bool
True
instanceReturnsDictCon :: InstanceWhat -> Bool
instanceReturnsDictCon :: InstanceWhat -> Bool
instanceReturnsDictCon (TopLevInstance {}) = Bool
True
instanceReturnsDictCon InstanceWhat
BuiltinInstance = Bool
True
instanceReturnsDictCon BuiltinTypeableInstance {} = Bool
True
instanceReturnsDictCon InstanceWhat
BuiltinEqInstance = Bool
False
instanceReturnsDictCon InstanceWhat
LocalInstance = Bool
False
matchGlobalInst :: DynFlags
-> Bool
-> Class -> [Type] -> TcM ClsInstResult
matchGlobalInst :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchGlobalInst DynFlags
dflags Bool
short_cut Class
clas [Type]
tys
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
knownNatClassName = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchKnownNat DynFlags
dflags Bool
short_cut Class
clas [Type]
tys
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
knownSymbolClassName = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchKnownSymbol DynFlags
dflags Bool
short_cut Class
clas [Type]
tys
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
knownCharClassName = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchKnownChar DynFlags
dflags Bool
short_cut Class
clas [Type]
tys
| Class -> Bool
isCTupleClass Class
clas = Class -> [Type] -> TcM ClsInstResult
matchCTuple Class
clas [Type]
tys
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeableClassName = Class -> [Type] -> TcM ClsInstResult
matchTypeable Class
clas [Type]
tys
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
withDictClassName = [Type] -> TcM ClsInstResult
matchWithDict [Type]
tys
| Class
clas Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqTyConKey = [Type] -> TcM ClsInstResult
matchHeteroEquality [Type]
tys
| Class
clas Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqTyConKey = [Type] -> TcM ClsInstResult
matchHomoEquality [Type]
tys
| Class
clas Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleTyConKey = [Type] -> TcM ClsInstResult
matchCoercible [Type]
tys
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
hasFieldClassName = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchHasField DynFlags
dflags Bool
short_cut Class
clas [Type]
tys
| Bool
otherwise = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv DynFlags
dflags Bool
short_cut Class
clas [Type]
tys
where
cls_name :: Name
cls_name = Class -> Name
className Class
clas
matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv DynFlags
dflags Bool
short_cut_solver Class
clas [Type]
tys
= do { InstEnvs
instEnvs <- TcM InstEnvs
tcGetInstEnvs
; let safeOverlapCheck :: Bool
safeOverlapCheck = DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags SafeHaskellMode -> [SafeHaskellMode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SafeHaskellMode
Sf_Safe, SafeHaskellMode
Sf_Trustworthy]
([InstMatch]
matches, PotentialUnifiers
unify, [InstMatch]
unsafeOverlaps) = Bool
-> InstEnvs
-> Class
-> [Type]
-> ([InstMatch], PotentialUnifiers, [InstMatch])
lookupInstEnv Bool
True InstEnvs
instEnvs Class
clas [Type]
tys
safeHaskFail :: Bool
safeHaskFail = Bool
safeOverlapCheck Bool -> Bool -> Bool
&& Bool -> Bool
not ([InstMatch] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstMatch]
unsafeOverlaps)
; String -> SDoc -> TcRn ()
traceTc String
"matchInstEnv" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"goal:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
clas SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tys
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"matches:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [InstMatch] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstMatch]
matches
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unify:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> PotentialUnifiers -> SDoc
forall a. Outputable a => a -> SDoc
ppr PotentialUnifiers
unify ]
; case ([InstMatch]
matches, PotentialUnifiers
unify, Bool
safeHaskFail) of
([], PotentialUnifiers
NoUnifiers, Bool
_)
-> do { String -> SDoc -> TcRn ()
traceTc String
"matchClass not matching" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ InstEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr (InstEnvs -> InstEnv
ie_local InstEnvs
instEnvs))
; ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance }
([(ClsInst
ispec, [DFunInstType]
inst_tys)], PotentialUnifiers
NoUnifiers, Bool
False)
| Bool
short_cut_solver
, ClsInst -> Bool
isOverlappable ClsInst
ispec
-> do { String -> SDoc -> TcRn ()
traceTc String
"matchClass: ignoring overlappable" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred)
; ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NotSure }
| Bool
otherwise
-> do { let dfun_id :: DFunId
dfun_id = ClsInst -> DFunId
instanceDFunId ClsInst
ispec
; String -> SDoc -> TcRn ()
traceTc String
"matchClass success" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dict" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"witness" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DFunId -> SDoc
forall a. Outputable a => a -> SDoc
ppr DFunId
dfun_id
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DFunId -> Type
idType DFunId
dfun_id) ]
; Bool -> DFunId -> [DFunInstType] -> TcM ClsInstResult
match_one ([InstMatch] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstMatch]
unsafeOverlaps) DFunId
dfun_id [DFunInstType]
inst_tys }
([InstMatch], PotentialUnifiers, Bool)
_ -> do { String -> SDoc -> TcRn ()
traceTc String
"matchClass multiple matches, deferring choice" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dict" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"matches" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [InstMatch] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstMatch]
matches]
; ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NotSure } }
where
pred :: Type
pred = Class -> [Type] -> Type
mkClassPred Class
clas [Type]
tys
match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcM ClsInstResult
match_one :: Bool -> DFunId -> [DFunInstType] -> TcM ClsInstResult
match_one Bool
so DFunId
dfun_id [DFunInstType]
mb_inst_tys
= do { String -> SDoc -> TcRn ()
traceTc String
"match_one" (DFunId -> SDoc
forall a. Outputable a => a -> SDoc
ppr DFunId
dfun_id SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [DFunInstType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [DFunInstType]
mb_inst_tys)
; ([Type]
tys, [Type]
theta) <- DFunId -> [DFunInstType] -> TcM ([Type], [Type])
instDFunType DFunId
dfun_id [DFunInstType]
mb_inst_tys
; String -> SDoc -> TcRn ()
traceTc String
"match_one 2" (DFunId -> SDoc
forall a. Outputable a => a -> SDoc
ppr DFunId
dfun_id SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tys SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
theta)
; ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstResult -> TcM ClsInstResult)
-> ClsInstResult -> TcM ClsInstResult
forall a b. (a -> b) -> a -> b
$ OneInst { cir_new_theta :: [Type]
cir_new_theta = [Type]
theta
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = DFunId -> [Type] -> [EvExpr] -> EvTerm
evDFunApp DFunId
dfun_id [Type]
tys
, cir_what :: InstanceWhat
cir_what = TopLevInstance { iw_dfun_id :: DFunId
iw_dfun_id = DFunId
dfun_id
, iw_safe_over :: Bool
iw_safe_over = Bool
so } } }
matchCTuple :: Class -> [Type] -> TcM ClsInstResult
matchCTuple :: Class -> [Type] -> TcM ClsInstResult
matchCTuple Class
clas [Type]
tys
= ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (OneInst { cir_new_theta :: [Type]
cir_new_theta = [Type]
tys
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = [EvExpr] -> EvTerm
tuple_ev
, cir_what :: InstanceWhat
cir_what = InstanceWhat
BuiltinInstance })
where
data_con :: DataCon
data_con = TyCon -> DataCon
tyConSingleDataCon (Class -> TyCon
classTyCon Class
clas)
tuple_ev :: [EvExpr] -> EvTerm
tuple_ev = DFunId -> [Type] -> [EvExpr] -> EvTerm
evDFunApp (DataCon -> DFunId
dataConWrapId DataCon
data_con) [Type]
tys
matchKnownNat :: DynFlags
-> Bool
-> Class -> [Type] -> TcM ClsInstResult
matchKnownNat :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchKnownNat DynFlags
dflags Bool
_ Class
clas [Type
ty]
| Just Integer
n <- Type -> Maybe Integer
isNumLitTy Type
ty = Class -> Type -> EvExpr -> TcM ClsInstResult
makeLitDict Class
clas Type
ty (Platform -> Integer -> EvExpr
mkNaturalExpr (DynFlags -> Platform
targetPlatform DynFlags
dflags) Integer
n)
matchKnownNat DynFlags
df Bool
sc Class
clas [Type]
tys = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv DynFlags
df Bool
sc Class
clas [Type]
tys
matchKnownSymbol :: DynFlags
-> Bool
-> Class -> [Type] -> TcM ClsInstResult
matchKnownSymbol :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchKnownSymbol DynFlags
_ Bool
_ Class
clas [Type
ty]
| Just FastString
s <- Type -> Maybe FastString
isStrLitTy Type
ty = do
EvExpr
et <- FastString -> IOEnv (Env TcGblEnv TcLclEnv) EvExpr
forall (m :: * -> *). MonadThings m => FastString -> m EvExpr
mkStringExprFS FastString
s
Class -> Type -> EvExpr -> TcM ClsInstResult
makeLitDict Class
clas Type
ty EvExpr
et
matchKnownSymbol DynFlags
df Bool
sc Class
clas [Type]
tys = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv DynFlags
df Bool
sc Class
clas [Type]
tys
matchKnownChar :: DynFlags
-> Bool
-> Class -> [Type] -> TcM ClsInstResult
matchKnownChar :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchKnownChar DynFlags
_ Bool
_ Class
clas [Type
ty]
| Just Char
s <- Type -> Maybe Char
isCharLitTy Type
ty = Class -> Type -> EvExpr -> TcM ClsInstResult
makeLitDict Class
clas Type
ty (Char -> EvExpr
mkCharExpr Char
s)
matchKnownChar DynFlags
df Bool
sc Class
clas [Type]
tys = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv DynFlags
df Bool
sc Class
clas [Type]
tys
makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult
makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult
makeLitDict Class
clas Type
ty EvExpr
et
| Just (Type
_, TcCoercion
co_dict) <- TyCon -> [Type] -> Maybe (Type, TcCoercion)
tcInstNewTyCon_maybe (Class -> TyCon
classTyCon Class
clas) [Type
ty]
, [ DFunId
meth ] <- Class -> [DFunId]
classMethods Class
clas
, Just TyCon
tcRep <- Type -> Maybe TyCon
tyConAppTyCon_maybe (DFunId -> Type
classMethodTy DFunId
meth)
, Just (Type
_, TcCoercion
co_rep) <- TyCon -> [Type] -> Maybe (Type, TcCoercion)
tcInstNewTyCon_maybe TyCon
tcRep [Type
ty]
, let ev_tm :: EvTerm
ev_tm = EvExpr -> TcCoercion -> EvTerm
mkEvCast EvExpr
et (TcCoercion -> TcCoercion
mkSymCo (TcCoercion -> TcCoercion -> TcCoercion
mkTransCo TcCoercion
co_dict TcCoercion
co_rep))
= ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstResult -> TcM ClsInstResult)
-> ClsInstResult -> TcM ClsInstResult
forall a b. (a -> b) -> a -> b
$ OneInst { cir_new_theta :: [Type]
cir_new_theta = []
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = \[EvExpr]
_ -> EvTerm
ev_tm
, cir_what :: InstanceWhat
cir_what = InstanceWhat
BuiltinInstance }
| Bool
otherwise
= String -> SDoc -> TcM ClsInstResult
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"makeLitDict" (SDoc -> TcM ClsInstResult) -> SDoc -> TcM ClsInstResult
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unexpected evidence for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
clas)
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((DFunId -> SDoc) -> [DFunId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> SDoc) -> (DFunId -> Type) -> DFunId -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DFunId -> Type
idType) (Class -> [DFunId]
classMethods Class
clas))
matchWithDict :: [Type] -> TcM ClsInstResult
matchWithDict :: [Type] -> TcM ClsInstResult
matchWithDict [Type
cls, Type
mty]
| Just (TyCon
dict_tc, [Type]
dict_args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
cls
, Just (Type
inst_meth_ty, TcCoercion
co) <- TyCon -> [Type] -> Maybe (Type, TcCoercion)
tcInstNewTyCon_maybe TyCon
dict_tc [Type]
dict_args
= do { DFunId
sv <- FastString -> Type -> Type -> IOEnv (Env TcGblEnv TcLclEnv) DFunId
forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m DFunId
mkSysLocalM (String -> FastString
fsLit String
"withDict_s") Type
ManyTy Type
mty
; DFunId
k <- FastString -> Type -> Type -> IOEnv (Env TcGblEnv TcLclEnv) DFunId
forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m DFunId
mkSysLocalM (String -> FastString
fsLit String
"withDict_k") Type
ManyTy ((() :: Constraint) => Type -> Type -> Type
Type -> Type -> Type
mkInvisFunTy Type
cls Type
openAlphaTy)
; let evWithDict :: TcCoercion -> EvExpr
evWithDict TcCoercion
co2 =
[DFunId] -> EvExpr -> EvExpr
mkCoreLams [ DFunId
runtimeRep1TyVar, DFunId
openAlphaTyVar, DFunId
sv, DFunId
k ] (EvExpr -> EvExpr) -> EvExpr -> EvExpr
forall a b. (a -> b) -> a -> b
$
DFunId -> EvExpr
forall b. DFunId -> Expr b
Var DFunId
nospecId
EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
`App`
(Type -> EvExpr
forall b. Type -> Expr b
Type (Type -> EvExpr) -> Type -> EvExpr
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => Type -> Type -> Type
Type -> Type -> Type
mkInvisFunTy Type
cls Type
openAlphaTy)
EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
`App`
DFunId -> EvExpr
forall b. DFunId -> Expr b
Var DFunId
k
EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
`App`
(DFunId -> EvExpr
forall b. DFunId -> Expr b
Var DFunId
sv EvExpr -> TcCoercion -> EvExpr
forall b. Expr b -> TcCoercion -> Expr b
`Cast` TcCoercion -> TcCoercion -> TcCoercion
mkTransCo ((() :: Constraint) => TcCoercion -> TcCoercion
TcCoercion -> TcCoercion
mkSubCo TcCoercion
co2) (TcCoercion -> TcCoercion
mkSymCo TcCoercion
co))
; TyCon
tc <- Name -> TcM TyCon
tcLookupTyCon Name
withDictClassName
; let Just DataCon
withdict_data_con
= TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc
mk_ev :: [EvExpr] -> EvTerm
mk_ev [EvExpr
c] = DataCon -> [Type] -> [EvExpr] -> EvTerm
evDataConApp DataCon
withdict_data_con
[Type
cls, Type
mty] [TcCoercion -> EvExpr
evWithDict (EvTerm -> TcCoercion
evTermCoercion (EvExpr -> EvTerm
EvExpr EvExpr
c))]
mk_ev [EvExpr]
e = String -> SDoc -> EvTerm
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"matchWithDict" ([EvExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EvExpr]
e)
; ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstResult -> TcM ClsInstResult)
-> ClsInstResult -> TcM ClsInstResult
forall a b. (a -> b) -> a -> b
$ OneInst { cir_new_theta :: [Type]
cir_new_theta = [Type -> Type -> Type
mkPrimEqPred Type
mty Type
inst_meth_ty]
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = [EvExpr] -> EvTerm
mk_ev
, cir_what :: InstanceWhat
cir_what = InstanceWhat
BuiltinInstance }
}
matchWithDict [Type]
_
= ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance
matchTypeable :: Class -> [Type] -> TcM ClsInstResult
matchTypeable :: Class -> [Type] -> TcM ClsInstResult
matchTypeable Class
clas [Type
k,Type
t]
| Type -> Bool
isForAllTy Type
k = ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance
| Just (FunTyFlag
af,Type
mult,Type
arg,Type
ret) <- Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
t
= if FunTyFlag -> Bool
isVisibleFunArg FunTyFlag
af
then Class -> Type -> Type -> Type -> Type -> TcM ClsInstResult
doFunTy Class
clas Type
t Type
mult Type
arg Type
ret
else ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance
| Type
k Type -> Type -> Bool
`eqType` Type
naturalTy = Name -> Type -> TcM ClsInstResult
doTyLit Name
knownNatClassName Type
t
| Type
k Type -> Type -> Bool
`eqType` Type
typeSymbolKind = Name -> Type -> TcM ClsInstResult
doTyLit Name
knownSymbolClassName Type
t
| Type
k Type -> Type -> Bool
`eqType` Type
charTy = Name -> Type -> TcM ClsInstResult
doTyLit Name
knownCharClassName Type
t
| Just (TyCon
tc, [Type]
ks) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t
, TyCon -> [Type] -> Bool
onlyNamedBndrsApplied TyCon
tc [Type]
ks = Class -> Type -> TyCon -> [Type] -> TcM ClsInstResult
doTyConApp Class
clas Type
t TyCon
tc [Type]
ks
| Just (Type
f,Type
kt) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
t = Class -> Type -> Type -> Type -> TcM ClsInstResult
doTyApp Class
clas Type
t Type
f Type
kt
matchTypeable Class
_ [Type]
_ = ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance
doFunTy :: Class -> Type -> Mult -> Type -> Type -> TcM ClsInstResult
doFunTy :: Class -> Type -> Type -> Type -> Type -> TcM ClsInstResult
doFunTy Class
clas Type
ty Type
mult Type
arg_ty Type
ret_ty
= ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstResult -> TcM ClsInstResult)
-> ClsInstResult -> TcM ClsInstResult
forall a b. (a -> b) -> a -> b
$ OneInst { cir_new_theta :: [Type]
cir_new_theta = [Type]
preds
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = [EvExpr] -> EvTerm
mk_ev
, cir_what :: InstanceWhat
cir_what = InstanceWhat
BuiltinInstance }
where
preds :: [Type]
preds = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Class -> Type -> Type
mk_typeable_pred Class
clas) [Type
mult, Type
arg_ty, Type
ret_ty]
mk_ev :: [EvExpr] -> EvTerm
mk_ev [EvExpr
mult_ev, EvExpr
arg_ev, EvExpr
ret_ev] = Type -> EvTypeable -> EvTerm
evTypeable Type
ty (EvTypeable -> EvTerm) -> EvTypeable -> EvTerm
forall a b. (a -> b) -> a -> b
$
EvTerm -> EvTerm -> EvTerm -> EvTypeable
EvTypeableTrFun (EvExpr -> EvTerm
EvExpr EvExpr
mult_ev) (EvExpr -> EvTerm
EvExpr EvExpr
arg_ev) (EvExpr -> EvTerm
EvExpr EvExpr
ret_ev)
mk_ev [EvExpr]
_ = String -> EvTerm
forall a. HasCallStack => String -> a
panic String
"GHC.Tc.Solver.Interact.doFunTy"
doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult
doTyConApp :: Class -> Type -> TyCon -> [Type] -> TcM ClsInstResult
doTyConApp Class
clas Type
ty TyCon
tc [Type]
kind_args
| TyCon -> Bool
tyConIsTypeable TyCon
tc
= ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstResult -> TcM ClsInstResult)
-> ClsInstResult -> TcM ClsInstResult
forall a b. (a -> b) -> a -> b
$ OneInst { cir_new_theta :: [Type]
cir_new_theta = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Class -> Type -> Type
mk_typeable_pred Class
clas) [Type]
kind_args
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = [EvExpr] -> EvTerm
mk_ev
, cir_what :: InstanceWhat
cir_what = TyCon -> InstanceWhat
BuiltinTypeableInstance TyCon
tc }
| Bool
otherwise
= ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance
where
mk_ev :: [EvExpr] -> EvTerm
mk_ev [EvExpr]
kinds = Type -> EvTypeable -> EvTerm
evTypeable Type
ty (EvTypeable -> EvTerm) -> EvTypeable -> EvTerm
forall a b. (a -> b) -> a -> b
$ TyCon -> [EvTerm] -> EvTypeable
EvTypeableTyCon TyCon
tc ((EvExpr -> EvTerm) -> [EvExpr] -> [EvTerm]
forall a b. (a -> b) -> [a] -> [b]
map EvExpr -> EvTerm
EvExpr [EvExpr]
kinds)
onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool
onlyNamedBndrsApplied :: TyCon -> [Type] -> Bool
onlyNamedBndrsApplied TyCon
tc [Type]
ks
= (TyConBinder -> Bool) -> [TyConBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyConBinder -> Bool
isNamedTyConBinder [TyConBinder]
used_bndrs Bool -> Bool -> Bool
&&
Bool -> Bool
not ((TyConBinder -> Bool) -> [TyConBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TyConBinder -> Bool
isNamedTyConBinder [TyConBinder]
leftover_bndrs)
where
bndrs :: [TyConBinder]
bndrs = TyCon -> [TyConBinder]
tyConBinders TyCon
tc
([TyConBinder]
used_bndrs, [TyConBinder]
leftover_bndrs) = [Type] -> [TyConBinder] -> ([TyConBinder], [TyConBinder])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [Type]
ks [TyConBinder]
bndrs
doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult
doTyApp :: Class -> Type -> Type -> Type -> TcM ClsInstResult
doTyApp Class
clas Type
ty Type
f Type
tk
| Type -> Bool
isForAllTy ((() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
f)
= ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance
| Bool
otherwise
= ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstResult -> TcM ClsInstResult)
-> ClsInstResult -> TcM ClsInstResult
forall a b. (a -> b) -> a -> b
$ OneInst { cir_new_theta :: [Type]
cir_new_theta = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Class -> Type -> Type
mk_typeable_pred Class
clas) [Type
f, Type
tk]
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = [EvExpr] -> EvTerm
mk_ev
, cir_what :: InstanceWhat
cir_what = InstanceWhat
BuiltinInstance }
where
mk_ev :: [EvExpr] -> EvTerm
mk_ev [EvExpr
t1,EvExpr
t2] = Type -> EvTypeable -> EvTerm
evTypeable Type
ty (EvTypeable -> EvTerm) -> EvTypeable -> EvTerm
forall a b. (a -> b) -> a -> b
$ EvTerm -> EvTerm -> EvTypeable
EvTypeableTyApp (EvExpr -> EvTerm
EvExpr EvExpr
t1) (EvExpr -> EvTerm
EvExpr EvExpr
t2)
mk_ev [EvExpr]
_ = String -> EvTerm
forall a. HasCallStack => String -> a
panic String
"doTyApp"
mk_typeable_pred :: Class -> Type -> PredType
mk_typeable_pred :: Class -> Type -> Type
mk_typeable_pred Class
clas Type
ty = Class -> [Type] -> Type
mkClassPred Class
clas [ (() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty, Type
ty ]
doTyLit :: Name -> Type -> TcM ClsInstResult
doTyLit :: Name -> Type -> TcM ClsInstResult
doTyLit Name
kc Type
t = do { Class
kc_clas <- Name -> TcM Class
tcLookupClass Name
kc
; let kc_pred :: Type
kc_pred = Class -> [Type] -> Type
mkClassPred Class
kc_clas [ Type
t ]
mk_ev :: [EvExpr] -> EvTerm
mk_ev [EvExpr
ev] = Type -> EvTypeable -> EvTerm
evTypeable Type
t (EvTypeable -> EvTerm) -> EvTypeable -> EvTerm
forall a b. (a -> b) -> a -> b
$ EvTerm -> EvTypeable
EvTypeableTyLit (EvExpr -> EvTerm
EvExpr EvExpr
ev)
mk_ev [EvExpr]
_ = String -> EvTerm
forall a. HasCallStack => String -> a
panic String
"doTyLit"
; ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (OneInst { cir_new_theta :: [Type]
cir_new_theta = [Type
kc_pred]
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = [EvExpr] -> EvTerm
mk_ev
, cir_what :: InstanceWhat
cir_what = InstanceWhat
BuiltinInstance }) }
matchHeteroEquality :: [Type] -> TcM ClsInstResult
matchHeteroEquality :: [Type] -> TcM ClsInstResult
matchHeteroEquality [Type]
args
= ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (OneInst { cir_new_theta :: [Type]
cir_new_theta = [ TyCon -> [Type] -> Type
mkTyConApp TyCon
eqPrimTyCon [Type]
args ]
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = DataCon -> [Type] -> [EvExpr] -> EvTerm
evDataConApp DataCon
heqDataCon [Type]
args
, cir_what :: InstanceWhat
cir_what = InstanceWhat
BuiltinEqInstance })
matchHomoEquality :: [Type] -> TcM ClsInstResult
matchHomoEquality :: [Type] -> TcM ClsInstResult
matchHomoEquality args :: [Type]
args@[Type
k,Type
t1,Type
t2]
= ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (OneInst { cir_new_theta :: [Type]
cir_new_theta = [ TyCon -> [Type] -> Type
mkTyConApp TyCon
eqPrimTyCon [Type
k,Type
k,Type
t1,Type
t2] ]
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = DataCon -> [Type] -> [EvExpr] -> EvTerm
evDataConApp DataCon
eqDataCon [Type]
args
, cir_what :: InstanceWhat
cir_what = InstanceWhat
BuiltinEqInstance })
matchHomoEquality [Type]
args = String -> SDoc -> TcM ClsInstResult
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"matchHomoEquality" ([Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
args)
matchCoercible :: [Type] -> TcM ClsInstResult
matchCoercible :: [Type] -> TcM ClsInstResult
matchCoercible args :: [Type]
args@[Type
k, Type
t1, Type
t2]
= ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (OneInst { cir_new_theta :: [Type]
cir_new_theta = [ TyCon -> [Type] -> Type
mkTyConApp TyCon
eqReprPrimTyCon [Type]
args' ]
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = DataCon -> [Type] -> [EvExpr] -> EvTerm
evDataConApp DataCon
coercibleDataCon [Type]
args
, cir_what :: InstanceWhat
cir_what = InstanceWhat
BuiltinEqInstance })
where
args' :: [Type]
args' = [Type
k, Type
k, Type
t1, Type
t2]
matchCoercible [Type]
args = String -> SDoc -> TcM ClsInstResult
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"matchLiftedCoercible" ([Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
args)
matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchHasField DynFlags
dflags Bool
short_cut Class
clas [Type]
tys
= do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; case [Type]
tys of
[Type
_k_ty, Type
x_ty, Type
r_ty, Type
a_ty]
| Just FastString
x <- Type -> Maybe FastString
isStrLitTy Type
x_ty
, Just (TyCon
tc, [Type]
args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
r_ty
, let r_tc :: TyCon
r_tc = (TyCon, [Type], TcCoercion) -> TyCon
forall a b c. (a, b, c) -> a
fstOf3 (FamInstEnvs -> TyCon -> [Type] -> (TyCon, [Type], TcCoercion)
tcLookupDataFamInst FamInstEnvs
fam_inst_envs TyCon
tc [Type]
args)
, Just FieldLabel
fl <- FieldLabelString -> TyCon -> Maybe FieldLabel
lookupTyConFieldLabel (FastString -> FieldLabelString
FieldLabelString FastString
x) TyCon
r_tc
, Just GlobalRdrElt
gre <- GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt
lookupGRE_FieldLabel GlobalRdrEnv
rdr_env FieldLabel
fl
-> do { DFunId
sel_id <- Name -> IOEnv (Env TcGblEnv TcLclEnv) DFunId
tcLookupId (FieldLabel -> Name
flSelector FieldLabel
fl)
; ([(Name, DFunId)]
tv_prs, [Type]
preds, Type
sel_ty) <- ([DFunId] -> TcM (Subst, [DFunId]))
-> DFunId -> TcM ([(Name, DFunId)], [Type], Type)
tcInstType [DFunId] -> TcM (Subst, [DFunId])
newMetaTyVars DFunId
sel_id
; let theta :: [Type]
theta = Type -> Type -> Type
mkPrimEqPred Type
sel_ty ((() :: Constraint) => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
r_ty Type
a_ty) Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
preds
mk_ev :: [EvExpr] -> EvTerm
mk_ev (EvExpr
ev1:[EvExpr]
evs) = DFunId -> [Type] -> [EvExpr] -> EvExpr
evSelector DFunId
sel_id [Type]
tvs [EvExpr]
evs EvExpr -> TcCoercion -> EvTerm
`evCast` TcCoercion
co
where
co :: TcCoercion
co = (() :: Constraint) => TcCoercion -> TcCoercion
TcCoercion -> TcCoercion
mkSubCo (EvTerm -> TcCoercion
evTermCoercion (EvExpr -> EvTerm
EvExpr EvExpr
ev1))
TcCoercion -> TcCoercion -> TcCoercion
`mkTransCo` TcCoercion -> TcCoercion
mkSymCo TcCoercion
co2
mk_ev [] = String -> EvTerm
forall a. HasCallStack => String -> a
panic String
"matchHasField.mk_ev"
Just (Type
_, TcCoercion
co2) = TyCon -> [Type] -> Maybe (Type, TcCoercion)
tcInstNewTyCon_maybe (Class -> TyCon
classTyCon Class
clas)
[Type]
tys
tvs :: [Type]
tvs = [DFunId] -> [Type]
mkTyVarTys (((Name, DFunId) -> DFunId) -> [(Name, DFunId)] -> [DFunId]
forall a b. (a -> b) -> [a] -> [b]
map (Name, DFunId) -> DFunId
forall a b. (a, b) -> b
snd [(Name, DFunId)]
tv_prs)
; if Bool -> Bool
not (DFunId -> Bool
isNaughtyRecordSelector DFunId
sel_id) Bool -> Bool -> Bool
&& Type -> Bool
isTauTy Type
sel_ty
then do {
Bool -> GlobalRdrElt -> TcRn ()
addUsedGRE Bool
True GlobalRdrElt
gre
; Name -> TcRn ()
keepAlive (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)
; ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return OneInst { cir_new_theta :: [Type]
cir_new_theta = [Type]
theta
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = [EvExpr] -> EvTerm
mk_ev
, cir_what :: InstanceWhat
cir_what = InstanceWhat
BuiltinInstance } }
else DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv DynFlags
dflags Bool
short_cut Class
clas [Type]
tys }
[Type]
_ -> DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv DynFlags
dflags Bool
short_cut Class
clas [Type]
tys }