ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred,
- lookupInst, lookupSimpleInst, LookupInstResult(..),
+ lookupInst, LookupInstResult(..),
isDict, isClassDict, isMethod,
isLinearInst, linearInstType, isIPDict, isInheritableInst,
mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
)
import TcRnMonad
-import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon )
+import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl )
import InstEnv ( InstLookupResult(..), lookupInstEnv )
import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames( fromIntegerName, fromRationalName, rationalTyConName )
-import Util ( equalLength )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
import Outputable
-- to simplify Insts
tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
- -- Instantiate the specified class op, but *only* with the main
- -- class dictionary. For example, given 'op' defined thus:
- -- class Foo a where
- -- op :: (?x :: String) => a -> a
- -- (tcInstClassOp op T) should return an Inst with type
- -- (?x :: String) => T -> T
- -- That is, the class-op's context is still there.
- -- This is really important in the use of tcInstClassOp in TcClassDcls.mkMethodBind
tcInstClassOp inst_loc sel_id tys
= let
(tyvars,rho) = tcSplitForAllTys (idType sel_id)
- rho_ty = substTyWith tyvars tys rho
- (pred,tau) = tcSplitMethodTy rho_ty
- -- Split off exactly one predicate (see the example above)
+ rho_ty = ASSERT( length tyvars == length tys )
+ substTyWith tyvars tys rho
+ (preds,tau) = tcSplitPhiTy rho_ty
in
- ASSERT( isClassPred pred )
- newMethod inst_loc sel_id tys [pred] tau
+ newMethod inst_loc sel_id tys preds tau
---------------------------
newMethod inst_loc id tys theta tau
pprInstsInFull insts
= vcat (map go insts)
where
- go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
+ go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))]
pprInst (LitInst u lit ty loc)
= hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
-- Dictionaries
-lookupInst dict@(Dict _ (ClassP clas tys) loc)
+lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
= getDOpts `thenM` \ dflags ->
tcGetInstEnv `thenM` \ inst_env ->
case lookupInstEnv dflags inst_env clas tys of
-- instance C X a => D X where ...
-- (presumably there's a functional dependency in class C)
-- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
+ getStage `thenM` \ use_stage ->
+ checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
+ (topIdLvl dfun_id) use_stage `thenM_`
+ traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_`
let
(tyvars, rho) = tcSplitForAllTys (idType dfun_id)
mk_ty_arg tv = case lookupSubstEnv tenv tv of
returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
\end{code}
-There is a second, simpler interface, when you want an instance of a
-class at a given nullary type constructor. It just returns the
-appropriate dictionary if it exists. It is used only when resolving
-ambiguous dictionaries.
-
-\begin{code}
-lookupSimpleInst :: Class
- -> [Type] -- Look up (c,t)
- -> TcM (Maybe ThetaType) -- Here are the needed (c,t)s
-
-lookupSimpleInst clas tys
- = getDOpts `thenM` \ dflags ->
- tcGetInstEnv `thenM` \ inst_env ->
- case lookupInstEnv dflags inst_env clas tys of
- FoundInst tenv dfun
- -> returnM (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
- where
- (_, rho) = tcSplitForAllTys (idType dfun)
- (theta,_) = tcSplitPhiTy rho
-
- other -> returnM Nothing
-\end{code}
%************************************************************************