{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Instance.Class (
matchGlobalInst, matchEqualityInst,
ClsInstResult(..),
InstanceWhat(..), safeOverlap, instanceReturnsDictCon,
AssocInstInfo(..), isNotAssociated,
lookupHasFieldLabel
) where
import GHC.Prelude
import GHC.Driver.DynFlags
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.Types.CtLoc
import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) )
import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst, FamInstEnvs )
import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) )
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Builtin.Names
import GHC.Builtin.PrimOps ( PrimOp(..) )
import GHC.Builtin.PrimOps.Ids ( primOpId )
import GHC.Types.FieldLabel
import GHC.Types.Name.Reader
import GHC.Types.SafeHaskell
import GHC.Types.Name ( Name )
import GHC.Types.Var.Env ( VarEnv )
import GHC.Types.Id
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(..) )
import GHC.StgToCmm.Closure ( isSmallFamily )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc( splitAtList, fstOf3 )
import GHC.Data.FastString
import GHC.Unit.Module.Warnings
import GHC.Hs.Extension
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import GHC.Types.Id.Info
import GHC.Tc.Errors.Types
import Data.Functor
import Data.Maybe
data AssocInstInfo
= NotAssociated
| InClsInst { AssocInstInfo -> Class
ai_class :: Class
, AssocInstInfo -> [DFunId]
ai_tyvars :: [TyVar]
, AssocInstInfo -> VarEnv PredType
ai_inst_env :: VarEnv Type
}
isNotAssociated :: AssocInstInfo -> Bool
isNotAssociated :: AssocInstInfo -> Bool
isNotAssociated (NotAssociated {}) = Bool
True
isNotAssociated (InClsInst {}) = Bool
False
data ClsInstResult
= NoInstance
| OneInst { ClsInstResult -> [PredType]
cir_new_theta :: [TcPredType]
, ClsInstResult -> [EvExpr] -> EvTerm
cir_mk_ev :: [EvExpr] -> EvTerm
, ClsInstResult -> CanonicalEvidence
cir_canonical :: CanonicalEvidence
, ClsInstResult -> InstanceWhat
cir_what :: InstanceWhat }
| NotSure
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 -> [PredType]
cir_new_theta = [PredType]
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 [[PredType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PredType]
ev, InstanceWhat -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstanceWhat
what]
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] -> Maybe CtLoc
-> TcM ClsInstResult
matchGlobalInst :: DynFlags
-> Bool -> Class -> [PredType] -> Maybe CtLoc -> TcM ClsInstResult
matchGlobalInst DynFlags
dflags Bool
short_cut Class
clas [PredType]
tys Maybe CtLoc
mb_loc
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
knownNatClassName = DynFlags -> Bool -> Class -> [PredType] -> TcM ClsInstResult
matchKnownNat DynFlags
dflags Bool
short_cut Class
clas [PredType]
tys
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
knownSymbolClassName = DynFlags -> Bool -> Class -> [PredType] -> TcM ClsInstResult
matchKnownSymbol DynFlags
dflags Bool
short_cut Class
clas [PredType]
tys
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
knownCharClassName = DynFlags -> Bool -> Class -> [PredType] -> TcM ClsInstResult
matchKnownChar DynFlags
dflags Bool
short_cut Class
clas [PredType]
tys
| Class -> Bool
isCTupleClass Class
clas = Class -> [PredType] -> TcM ClsInstResult
matchCTuple Class
clas [PredType]
tys
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeableClassName = Class -> [PredType] -> TcM ClsInstResult
matchTypeable Class
clas [PredType]
tys
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
withDictClassName = [PredType] -> TcM ClsInstResult
matchWithDict [PredType]
tys
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
dataToTagClassName = Class -> [PredType] -> TcM ClsInstResult
matchDataToTag Class
clas [PredType]
tys
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
hasFieldClassName = DynFlags
-> Bool -> Class -> [PredType] -> Maybe CtLoc -> TcM ClsInstResult
matchHasField DynFlags
dflags Bool
short_cut Class
clas [PredType]
tys Maybe CtLoc
mb_loc
| Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unsatisfiableClassName = TcM ClsInstResult
matchUnsatisfiable
| Bool
otherwise = DynFlags -> Bool -> Class -> [PredType] -> TcM ClsInstResult
matchInstEnv DynFlags
dflags Bool
short_cut Class
clas [PredType]
tys
where
cls_name :: Name
cls_name = Class -> Name
className Class
clas
matchUnsatisfiable :: TcM ClsInstResult
matchUnsatisfiable :: TcM ClsInstResult
matchUnsatisfiable
= ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance
matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv :: DynFlags -> Bool -> Class -> [PredType] -> TcM ClsInstResult
matchInstEnv DynFlags
dflags Bool
short_cut_solver Class
clas [PredType]
tys
= do { instEnvs <- TcM InstEnvs
tcGetInstEnvs
; let 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]
(matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys
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)
; traceTc "matchInstEnv" $
vcat [ text "goal:" <+> ppr clas <+> ppr tys
, text "matches:" <+> ppr matches
, text "unify:" <+> ppr unify ]
; case (matches, unify, safeHaskFail) of
([], NoUnifiers{}, Bool
_)
-> do { String -> SDoc -> TcRn ()
traceTc String
"matchClass not matching" (PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
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)], NoUnifiers CanonicalEvidence
canonical, Bool
False)
| Bool
short_cut_solver
, ClsInst -> Bool
isOverlappable ClsInst
ispec
-> do { String -> SDoc -> TcRn ()
traceTc String
"matchClass: ignoring overlappable" (PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
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
warn :: Maybe (WarningTxt GhcRn)
warn = ClsInst -> Maybe (WarningTxt GhcRn)
instanceWarning 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
<+> PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
pred SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CanonicalEvidence -> SDoc
forall a. Outputable a => a -> SDoc
ppr CanonicalEvidence
canonical,
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
<+> PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DFunId -> PredType
idType DFunId
dfun_id) ]
; Bool
-> CanonicalEvidence
-> DFunId
-> [DFunInstType]
-> Maybe (WarningTxt GhcRn)
-> TcM ClsInstResult
match_one ([InstMatch] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstMatch]
unsafeOverlaps) CanonicalEvidence
canonical DFunId
dfun_id [DFunInstType]
inst_tys Maybe (WarningTxt GhcRn)
warn }
([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
<+> PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
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 :: PredType
pred = Class -> [PredType] -> PredType
mkClassPred Class
clas [PredType]
tys
match_one :: SafeOverlapping -> CanonicalEvidence -> DFunId -> [DFunInstType]
-> Maybe (WarningTxt GhcRn) -> TcM ClsInstResult
match_one :: Bool
-> CanonicalEvidence
-> DFunId
-> [DFunInstType]
-> Maybe (WarningTxt GhcRn)
-> TcM ClsInstResult
match_one Bool
so CanonicalEvidence
canonical DFunId
dfun_id [DFunInstType]
mb_inst_tys Maybe (WarningTxt GhcRn)
warn
= 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)
; (tys, theta) <- DFunId -> [DFunInstType] -> TcM ([PredType], [PredType])
instDFunType DFunId
dfun_id [DFunInstType]
mb_inst_tys
; traceTc "match_one 2" (ppr dfun_id $$ ppr tys $$ ppr theta)
; return $ OneInst { cir_new_theta = theta
, cir_mk_ev = evDFunApp dfun_id tys
, cir_canonical = canonical
, cir_what = TopLevInstance { iw_dfun_id = dfun_id
, iw_safe_over = so
, iw_warn = warn } } }
matchCTuple :: Class -> [Type] -> TcM ClsInstResult
matchCTuple :: Class -> [PredType] -> TcM ClsInstResult
matchCTuple Class
clas [PredType]
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 :: [PredType]
cir_new_theta = [PredType]
tys
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = [EvExpr] -> EvTerm
tuple_ev
, cir_canonical :: CanonicalEvidence
cir_canonical = CanonicalEvidence
EvCanonical
, 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 -> [PredType] -> [EvExpr] -> EvTerm
evDFunApp (DataCon -> DFunId
dataConWrapId DataCon
data_con) [PredType]
tys
matchKnownNat :: DynFlags
-> Bool
-> Class -> [Type] -> TcM ClsInstResult
matchKnownNat :: DynFlags -> Bool -> Class -> [PredType] -> TcM ClsInstResult
matchKnownNat DynFlags
dflags Bool
_ Class
clas [PredType
ty]
| Just Integer
n <- PredType -> Maybe Integer
isNumLitTy PredType
ty = Class -> PredType -> EvExpr -> TcM ClsInstResult
makeLitDict Class
clas PredType
ty (Platform -> Integer -> EvExpr
mkNaturalExpr (DynFlags -> Platform
targetPlatform DynFlags
dflags) Integer
n)
matchKnownNat DynFlags
df Bool
sc Class
clas [PredType]
tys = DynFlags -> Bool -> Class -> [PredType] -> TcM ClsInstResult
matchInstEnv DynFlags
df Bool
sc Class
clas [PredType]
tys
matchKnownSymbol :: DynFlags
-> Bool
-> Class -> [Type] -> TcM ClsInstResult
matchKnownSymbol :: DynFlags -> Bool -> Class -> [PredType] -> TcM ClsInstResult
matchKnownSymbol DynFlags
_ Bool
_ Class
clas [PredType
ty]
| Just FastString
s <- PredType -> Maybe FastString
isStrLitTy PredType
ty = do
et <- FastString -> IOEnv (Env TcGblEnv TcLclEnv) EvExpr
forall (m :: * -> *). MonadThings m => FastString -> m EvExpr
mkStringExprFS FastString
s
makeLitDict clas ty et
matchKnownSymbol DynFlags
df Bool
sc Class
clas [PredType]
tys = DynFlags -> Bool -> Class -> [PredType] -> TcM ClsInstResult
matchInstEnv DynFlags
df Bool
sc Class
clas [PredType]
tys
matchKnownChar :: DynFlags
-> Bool
-> Class -> [Type] -> TcM ClsInstResult
matchKnownChar :: DynFlags -> Bool -> Class -> [PredType] -> TcM ClsInstResult
matchKnownChar DynFlags
_ Bool
_ Class
clas [PredType
ty]
| Just Char
s <- PredType -> Maybe Char
isCharLitTy PredType
ty = Class -> PredType -> EvExpr -> TcM ClsInstResult
makeLitDict Class
clas PredType
ty (Char -> EvExpr
mkCharExpr Char
s)
matchKnownChar DynFlags
df Bool
sc Class
clas [PredType]
tys = DynFlags -> Bool -> Class -> [PredType] -> TcM ClsInstResult
matchInstEnv DynFlags
df Bool
sc Class
clas [PredType]
tys
makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult
makeLitDict :: Class -> PredType -> EvExpr -> TcM ClsInstResult
makeLitDict Class
clas PredType
ty EvExpr
et
| Just (PredType
_, TcCoercion
co_dict) <- TyCon -> [PredType] -> Maybe (PredType, TcCoercion)
tcInstNewTyCon_maybe (Class -> TyCon
classTyCon Class
clas) [PredType
ty]
, [ DFunId
meth ] <- Class -> [DFunId]
classMethods Class
clas
, Just TyCon
tcRep <- PredType -> Maybe TyCon
tyConAppTyCon_maybe (DFunId -> PredType
classMethodTy DFunId
meth)
, Just (PredType
_, TcCoercion
co_rep) <- TyCon -> [PredType] -> Maybe (PredType, TcCoercion)
tcInstNewTyCon_maybe TyCon
tcRep [PredType
ty]
, let ev_tm :: EvTerm
ev_tm = EvExpr -> TcCoercion -> EvTerm
mkEvCast EvExpr
et (TcCoercion -> TcCoercion
mkSymCo (HasDebugCallStack => TcCoercion -> TcCoercion -> TcCoercion
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 :: [PredType]
cir_new_theta = []
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = \[EvExpr]
_ -> EvTerm
ev_tm
, cir_canonical :: CanonicalEvidence
cir_canonical = CanonicalEvidence
EvCanonical
, 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 (PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (PredType -> SDoc) -> (DFunId -> PredType) -> DFunId -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DFunId -> PredType
idType) (Class -> [DFunId]
classMethods Class
clas))
matchWithDict :: [Type] -> TcM ClsInstResult
matchWithDict :: [PredType] -> TcM ClsInstResult
matchWithDict [PredType
cls, PredType
mty]
| Just (TyCon
dict_tc, [PredType]
dict_args) <- HasDebugCallStack => PredType -> Maybe (TyCon, [PredType])
PredType -> Maybe (TyCon, [PredType])
tcSplitTyConApp_maybe PredType
cls
, Just (PredType
inst_meth_ty, TcCoercion
co) <- TyCon -> [PredType] -> Maybe (PredType, TcCoercion)
tcInstNewTyCon_maybe TyCon
dict_tc [PredType]
dict_args
= do { sv <- FastString
-> PredType -> PredType -> IOEnv (Env TcGblEnv TcLclEnv) DFunId
forall (m :: * -> *).
MonadUnique m =>
FastString -> PredType -> PredType -> m DFunId
mkSysLocalM (String -> FastString
fsLit String
"withDict_s") PredType
ManyTy PredType
mty
; k <- mkSysLocalM (fsLit "withDict_k") ManyTy (mkInvisFunTy cls openAlphaTy)
; let 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
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` HasDebugCallStack => TcCoercion -> TcCoercion -> TcCoercion
TcCoercion -> TcCoercion -> TcCoercion
mkTransCo (HasDebugCallStack => TcCoercion -> TcCoercion
TcCoercion -> TcCoercion
mkSubCo TcCoercion
co2) (TcCoercion -> TcCoercion
mkSymCo TcCoercion
co))
; tc <- tcLookupTyCon withDictClassName
; let Just withdict_data_con
= tyConSingleDataCon_maybe tc
mk_ev [EvExpr
c] = DataCon -> [PredType] -> [EvExpr] -> EvTerm
evDataConApp DataCon
withdict_data_con
[PredType
cls, PredType
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)
; return $ OneInst { cir_new_theta = [mkNomEqPred mty inst_meth_ty]
, cir_mk_ev = mk_ev
, cir_canonical = EvNonCanonical
, cir_what = BuiltinInstance }
}
matchWithDict [PredType]
_
= ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance
matchDataToTag :: Class -> [Type] -> TcM ClsInstResult
matchDataToTag :: Class -> [PredType] -> TcM ClsInstResult
matchDataToTag Class
dataToTagClass [PredType
levity, PredType
dty] = do
famEnvs <- TcM FamInstEnvs
tcGetFamInstEnvs
(gbl_env, _lcl_env) <- getEnvs
platform <- getPlatform
if | isConcreteType levity
, Just (rawTyCon, rawTyConArgs) <- tcSplitTyConApp_maybe dty
, let (repTyCon, repArgs, repCo)
= tcLookupDataFamInst famEnvs rawTyCon rawTyConArgs
, not (isTypeDataTyCon repTyCon)
, Just constrs <- tyConAlgDataCons_maybe repTyCon
, let rdr_env = TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
gbl_env
inScope DataCon
con = Maybe (GlobalRdrEltX GREInfo) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (GlobalRdrEltX GREInfo) -> Bool)
-> Maybe (GlobalRdrEltX GREInfo) -> Bool
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> Name -> Maybe (GlobalRdrEltX GREInfo)
forall info.
Outputable info =>
GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info)
lookupGRE_Name GlobalRdrEnv
rdr_env (Name -> Maybe (GlobalRdrEltX GREInfo))
-> Name -> Maybe (GlobalRdrEltX GREInfo)
forall a b. (a -> b) -> a -> b
$ DataCon -> Name
dataConName DataCon
con
, all inScope constrs
, let repTy = TyCon -> [PredType] -> PredType
mkTyConApp TyCon
repTyCon [PredType]
repArgs
numConstrs = TyCon -> Int
tyConFamilySize TyCon
repTyCon
!whichOp
| Platform -> Int -> Bool
isSmallFamily Platform
platform Int
numConstrs
= PrimOp -> DFunId
primOpId PrimOp
DataToTagSmallOp
| Bool
otherwise
= PrimOp -> DFunId
primOpId PrimOp
DataToTagLargeOp
methodRep = DFunId -> EvExpr
forall b. DFunId -> Expr b
Var DFunId
whichOp EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
`App` PredType -> EvExpr
forall b. PredType -> Expr b
Type PredType
levity EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
`App` PredType -> EvExpr
forall b. PredType -> Expr b
Type PredType
repTy
methodCo = Role
-> FunTyFlag
-> TcCoercion
-> TcCoercion
-> TcCoercion
-> TcCoercion
mkFunCo Role
Representational
FunTyFlag
FTF_T_T
(PredType -> TcCoercion
mkNomReflCo PredType
ManyTy)
(TcCoercion -> TcCoercion
mkSymCo TcCoercion
repCo)
(Role -> PredType -> TcCoercion
mkReflCo Role
Representational PredType
intPrimTy)
dataToTagDataCon = TyCon -> DataCon
tyConSingleDataCon (Class -> TyCon
classTyCon Class
dataToTagClass)
mk_ev [EvExpr]
_ = DataCon -> [PredType] -> [EvExpr] -> EvTerm
evDataConApp DataCon
dataToTagDataCon
[PredType
levity, PredType
dty]
[EvExpr
methodRep EvExpr -> TcCoercion -> EvExpr
forall b. Expr b -> TcCoercion -> Expr b
`Cast` TcCoercion
methodCo]
-> addUsedDataCons rdr_env repTyCon
$> OneInst { cir_new_theta = []
, cir_mk_ev = mk_ev
, cir_canonical = EvCanonical
, cir_what = BuiltinInstance
}
| otherwise -> pure NoInstance
matchDataToTag Class
_ [PredType]
_ = ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClsInstResult
NoInstance
matchTypeable :: Class -> [Type] -> TcM ClsInstResult
matchTypeable :: Class -> [PredType] -> TcM ClsInstResult
matchTypeable Class
clas [PredType
k,PredType
t]
| PredType -> Bool
isForAllTy PredType
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,PredType
mult,PredType
arg,PredType
ret) <- PredType -> Maybe (FunTyFlag, PredType, PredType, PredType)
splitFunTy_maybe PredType
t
= if FunTyFlag -> Bool
isVisibleFunArg FunTyFlag
af
then Class
-> PredType
-> PredType
-> PredType
-> PredType
-> TcM ClsInstResult
doFunTy Class
clas PredType
t PredType
mult PredType
arg PredType
ret
else ClsInstResult -> TcM ClsInstResult
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance
| PredType
k HasCallStack => PredType -> PredType -> Bool
PredType -> PredType -> Bool
`eqType` PredType
naturalTy = Name -> PredType -> TcM ClsInstResult
doTyLit Name
knownNatClassName PredType
t
| PredType
k HasCallStack => PredType -> PredType -> Bool
PredType -> PredType -> Bool
`eqType` PredType
typeSymbolKind = Name -> PredType -> TcM ClsInstResult
doTyLit Name
knownSymbolClassName PredType
t
| PredType
k HasCallStack => PredType -> PredType -> Bool
PredType -> PredType -> Bool
`eqType` PredType
charTy = Name -> PredType -> TcM ClsInstResult
doTyLit Name
knownCharClassName PredType
t
| Just (TyCon
tc, [PredType]
ks) <- HasDebugCallStack => PredType -> Maybe (TyCon, [PredType])
PredType -> Maybe (TyCon, [PredType])
splitTyConApp_maybe PredType
t
, TyCon -> [PredType] -> Bool
onlyNamedBndrsApplied TyCon
tc [PredType]
ks = Class -> PredType -> TyCon -> [PredType] -> TcM ClsInstResult
doTyConApp Class
clas PredType
t TyCon
tc [PredType]
ks
| Just (PredType
f,PredType
kt) <- PredType -> Maybe (PredType, PredType)
splitAppTy_maybe PredType
t = Class -> PredType -> PredType -> PredType -> TcM ClsInstResult
doTyApp Class
clas PredType
t PredType
f PredType
kt
matchTypeable Class
_ [PredType]
_ = 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
-> PredType
-> PredType
-> PredType
-> PredType
-> TcM ClsInstResult
doFunTy Class
clas PredType
ty PredType
mult PredType
arg_ty PredType
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 :: [PredType]
cir_new_theta = [PredType]
preds
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = [EvExpr] -> EvTerm
mk_ev
, cir_canonical :: CanonicalEvidence
cir_canonical = CanonicalEvidence
EvCanonical
, cir_what :: InstanceWhat
cir_what = InstanceWhat
BuiltinInstance }
where
preds :: [PredType]
preds = (PredType -> PredType) -> [PredType] -> [PredType]
forall a b. (a -> b) -> [a] -> [b]
map (Class -> PredType -> PredType
mk_typeable_pred Class
clas) [PredType
mult, PredType
arg_ty, PredType
ret_ty]
mk_ev :: [EvExpr] -> EvTerm
mk_ev [EvExpr
mult_ev, EvExpr
arg_ev, EvExpr
ret_ev] = PredType -> EvTypeable -> EvTerm
evTypeable PredType
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.Instance.Class.doFunTy"
doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult
doTyConApp :: Class -> PredType -> TyCon -> [PredType] -> TcM ClsInstResult
doTyConApp Class
clas PredType
ty TyCon
tc [PredType]
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 :: [PredType]
cir_new_theta = (PredType -> PredType) -> [PredType] -> [PredType]
forall a b. (a -> b) -> [a] -> [b]
map (Class -> PredType -> PredType
mk_typeable_pred Class
clas) [PredType]
kind_args
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = [EvExpr] -> EvTerm
mk_ev
, cir_canonical :: CanonicalEvidence
cir_canonical = CanonicalEvidence
EvCanonical
, 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 = PredType -> EvTypeable -> EvTerm
evTypeable PredType
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 -> [PredType] -> Bool
onlyNamedBndrsApplied TyCon
tc [PredType]
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) = [PredType] -> [TyConBinder] -> ([TyConBinder], [TyConBinder])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [PredType]
ks [TyConBinder]
bndrs
doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult
doTyApp :: Class -> PredType -> PredType -> PredType -> TcM ClsInstResult
doTyApp Class
clas PredType
ty PredType
f PredType
tk
| PredType -> Bool
isForAllTy (HasDebugCallStack => PredType -> PredType
PredType -> PredType
typeKind PredType
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 :: [PredType]
cir_new_theta = (PredType -> PredType) -> [PredType] -> [PredType]
forall a b. (a -> b) -> [a] -> [b]
map (Class -> PredType -> PredType
mk_typeable_pred Class
clas) [PredType
f, PredType
tk]
, cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev = [EvExpr] -> EvTerm
mk_ev
, cir_canonical :: CanonicalEvidence
cir_canonical = CanonicalEvidence
EvCanonical
, cir_what :: InstanceWhat
cir_what = InstanceWhat
BuiltinInstance }
where
mk_ev :: [EvExpr] -> EvTerm
mk_ev [EvExpr
t1,EvExpr
t2] = PredType -> EvTypeable -> EvTerm
evTypeable PredType
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 -> PredType -> PredType
mk_typeable_pred Class
clas PredType
ty = Class -> [PredType] -> PredType
mkClassPred Class
clas [ HasDebugCallStack => PredType -> PredType
PredType -> PredType
typeKind PredType
ty, PredType
ty ]
doTyLit :: Name -> Type -> TcM ClsInstResult
doTyLit :: Name -> PredType -> TcM ClsInstResult
doTyLit Name
kc PredType
t = do { kc_clas <- Name -> TcM Class
tcLookupClass Name
kc
; let kc_pred = Class -> [PredType] -> PredType
mkClassPred Class
kc_clas [ PredType
t ]
mk_ev [EvExpr
ev] = PredType -> EvTypeable -> EvTerm
evTypeable PredType
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"
; return (OneInst { cir_new_theta = [kc_pred]
, cir_mk_ev = mk_ev
, cir_canonical = EvCanonical
, cir_what = BuiltinInstance }) }
matchEqualityInst :: Class -> [Type] -> (DataCon, Role, Type, Type)
matchEqualityInst :: Class -> [PredType] -> (DataCon, Role, PredType, PredType)
matchEqualityInst Class
cls [PredType]
args
| Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqTyConKey
, [PredType
_,PredType
t1,PredType
t2] <- [PredType]
args
= (DataCon
eqDataCon, Role
Nominal, PredType
t1, PredType
t2)
| Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqTyConKey
, [PredType
_,PredType
_,PredType
t1,PredType
t2] <- [PredType]
args
= (DataCon
heqDataCon, Role
Nominal, PredType
t1, PredType
t2)
| Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleTyConKey
, [PredType
_, PredType
t1, PredType
t2] <- [PredType]
args
= (DataCon
coercibleDataCon, Role
Representational, PredType
t1, PredType
t2)
| Bool
otherwise
= String -> SDoc -> (DataCon, Role, PredType, PredType)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"matchEqualityInst" (PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> [PredType] -> PredType
mkClassPred Class
cls [PredType]
args))
matchHasField :: DynFlags -> Bool -> Class -> [Type]
-> Maybe CtLoc
-> TcM ClsInstResult
matchHasField :: DynFlags
-> Bool -> Class -> [PredType] -> Maybe CtLoc -> TcM ClsInstResult
matchHasField DynFlags
dflags Bool
short_cut Class
clas [PredType]
tys Maybe CtLoc
mb_ct_loc
= do { fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; rdr_env <- getGlobalRdrEnv
; case lookupHasFieldLabel fam_inst_envs rdr_env tys of
Just (Name
sel_name, GlobalRdrEltX GREInfo
gre, PredType
r_ty, PredType
a_ty) ->
do { sel_id <- Name -> IOEnv (Env TcGblEnv TcLclEnv) DFunId
tcLookupId Name
sel_name
; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id
; let tvs = [DFunId] -> [PredType]
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)
theta = PredType -> PredType -> PredType
mkNomEqPred PredType
sel_ty (HasDebugCallStack => PredType -> PredType -> PredType
PredType -> PredType -> PredType
mkVisFunTyMany PredType
r_ty PredType
a_ty) PredType -> [PredType] -> [PredType]
forall a. a -> [a] -> [a]
: [PredType]
preds
mk_ev (EvExpr
ev1:[EvExpr]
evs) = DFunId -> [PredType] -> [EvExpr] -> EvExpr
evSelector DFunId
sel_id [PredType]
tvs [EvExpr]
evs EvExpr -> TcCoercion -> EvTerm
`evCast` TcCoercion
co
where
co :: TcCoercion
co = HasDebugCallStack => TcCoercion -> TcCoercion
TcCoercion -> TcCoercion
mkSubCo (EvTerm -> TcCoercion
evTermCoercion (EvExpr -> EvTerm
EvExpr EvExpr
ev1))
HasDebugCallStack => TcCoercion -> TcCoercion -> TcCoercion
TcCoercion -> TcCoercion -> TcCoercion
`mkTransCo` TcCoercion -> TcCoercion
mkSymCo TcCoercion
co2
mk_ev [] = String -> EvTerm
forall a. HasCallStack => String -> a
panic String
"matchHasField.mk_ev"
Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas) tys
; if (isNaughtyRecordSelector sel_id) || not (isTauTy sel_ty)
then try_user_instances
else
do { case mb_ct_loc of
Maybe CtLoc
Nothing -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just CtLoc
loc -> CtLoc -> TcRn () -> TcRn ()
forall a. CtLoc -> TcM a -> TcM a
setCtLocM CtLoc
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do {
DeprecationWarnings -> GlobalRdrEltX GREInfo -> TcRn ()
addUsedGRE DeprecationWarnings
AllDeprecationWarnings GlobalRdrEltX GREInfo
gre
; Name -> TcRn ()
keepAlive Name
sel_name
; DynFlags -> DFunId -> CtLoc -> TcRn ()
warnIncompleteRecSel DynFlags
dflags DFunId
sel_id CtLoc
loc }
; return OneInst { cir_new_theta = theta
, cir_mk_ev = mk_ev
, cir_canonical = EvCanonical
, cir_what = BuiltinInstance } } }
Maybe (Name, GlobalRdrEltX GREInfo, PredType, PredType)
Nothing -> TcM ClsInstResult
try_user_instances }
where
try_user_instances :: TcM ClsInstResult
try_user_instances = DynFlags -> Bool -> Class -> [PredType] -> TcM ClsInstResult
matchInstEnv DynFlags
dflags Bool
short_cut Class
clas [PredType]
tys
warnIncompleteRecSel :: DynFlags -> Id -> CtLoc -> TcM ()
warnIncompleteRecSel :: DynFlags -> DFunId -> CtLoc -> TcRn ()
warnIncompleteRecSel DynFlags
dflags DFunId
sel_id CtLoc
ct_loc
| Bool -> Bool
not (CtOrigin -> Bool
isGetFieldOrigin (CtLoc -> CtOrigin
ctLocOrigin CtLoc
ct_loc))
, RecSelId { sel_cons :: IdDetails -> RecSelInfo
sel_cons = RSI { rsi_undef :: RecSelInfo -> [ConLike]
rsi_undef = [ConLike]
fallible_cons } } <- DFunId -> IdDetails
idDetails DFunId
sel_id
, Bool -> Bool
not ([ConLike] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConLike]
fallible_cons)
= TcRnMessage -> TcRn ()
addDiagnostic (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Name -> [ConLike] -> Int -> TcRnMessage
TcRnHasFieldResolvedIncomplete (DFunId -> Name
idName DFunId
sel_id) [ConLike]
fallible_cons Int
maxCons
| Bool
otherwise
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
maxCons :: Int
maxCons = DynFlags -> Int
maxUncoveredPatterns DynFlags
dflags
isGetFieldOrigin :: CtOrigin -> Bool
isGetFieldOrigin (GetFieldOrigin {}) = Bool
True
isGetFieldOrigin CtOrigin
_ = Bool
False
lookupHasFieldLabel
:: FamInstEnvs -> GlobalRdrEnv -> [Type]
-> Maybe ( Name
, GlobalRdrElt
, Type
, Type )
lookupHasFieldLabel :: FamInstEnvs
-> GlobalRdrEnv
-> [PredType]
-> Maybe (Name, GlobalRdrEltX GREInfo, PredType, PredType)
lookupHasFieldLabel FamInstEnvs
fam_inst_envs GlobalRdrEnv
rdr_env [PredType]
arg_tys
|
(PredType
_k : PredType
_rec_rep : PredType
_fld_rep : PredType
x_ty : PredType
rec_ty : PredType
fld_ty : [PredType]
_) <- [PredType]
arg_tys
, Just FastString
x <- PredType -> Maybe FastString
isStrLitTy PredType
x_ty
, Just (TyCon
tc, [PredType]
args) <- HasDebugCallStack => PredType -> Maybe (TyCon, [PredType])
PredType -> Maybe (TyCon, [PredType])
tcSplitTyConApp_maybe PredType
rec_ty
, let r_tc :: TyCon
r_tc = (TyCon, [PredType], TcCoercion) -> TyCon
forall a b c. (a, b, c) -> a
fstOf3 (FamInstEnvs
-> TyCon -> [PredType] -> (TyCon, [PredType], TcCoercion)
tcLookupDataFamInst FamInstEnvs
fam_inst_envs TyCon
tc [PredType]
args)
, Just FieldLabel
fl <- FieldLabelString -> TyCon -> Maybe FieldLabel
lookupTyConFieldLabel (FastString -> FieldLabelString
FieldLabelString FastString
x) TyCon
r_tc
, Just GlobalRdrEltX GREInfo
gre <- GlobalRdrEnv -> FieldLabel -> Maybe (GlobalRdrEltX GREInfo)
lookupGRE_FieldLabel GlobalRdrEnv
rdr_env FieldLabel
fl
= (Name, GlobalRdrEltX GREInfo, PredType, PredType)
-> Maybe (Name, GlobalRdrEltX GREInfo, PredType, PredType)
forall a. a -> Maybe a
Just (FieldLabel -> Name
flSelector FieldLabel
fl, GlobalRdrEltX GREInfo
gre, PredType
rec_ty, PredType
fld_ty)
| Bool
otherwise
= Maybe (Name, GlobalRdrEltX GREInfo, PredType, PredType)
forall a. Maybe a
Nothing