Inst,
pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
- newDictsFromOld, newDicts, cloneDict,
- newMethod, newMethodFromName, newMethodWithGivenTy,
- newMethodWith, newMethodAtLoc,
+ newDictsFromOld, newDicts, cloneDict,
newOverloadedLit, newIPDict,
- tcInstCall, tcInstDataCon, tcSyntaxName,
+ newMethod, newMethodFromName, newMethodWithGivenTy,
+ tcInstClassOp, tcInstCall, tcInstDataCon, tcSyntaxName,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
isClassPred, isTyVarClassPred, isLinearPred, predHasFDs,
getClassPredTys, getClassPredTys_maybe, mkPredName,
- isInheritablePred, isIPPred,
+ isInheritablePred, isIPPred,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
)
import CoreFVs ( idFreeTyVars )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName )
import PprType ( pprPred, pprParendType )
-import Subst ( emptyInScopeSet, mkSubst,
- substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
- )
+import Subst ( emptyInScopeSet, mkSubst, substTy, substTyWith, substTheta, mkTyVarSubst )
import Literal ( inIntRange )
import Var ( TyVar )
import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
import Util ( equalLength )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
-import Bag
import Outputable
\end{code}
returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
-
newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
newMethodFromName origin ty name
= tcLookupId name `thenM` \ id ->
-- always a class op, but with -fno-implicit-prelude GHC is
-- meant to find whatever thing is in scope, and that may
-- be an ordinary function.
- newMethod origin id [ty] `thenM` \ inst ->
+ getInstLoc origin `thenM` \ loc ->
+ tcInstClassOp loc id [ty] `thenM` \ inst ->
+ extendLIE inst `thenM_`
returnM (instToId inst)
-newMethod :: InstOrigin
- -> TcId
- -> [TcType]
- -> TcM Inst
-newMethod orig id tys
- = -- Get the Id type and instantiate it at the specified types
- let
- (tyvars, rho) = tcSplitForAllTys (idType id)
- rho_ty = substTyWith tyvars tys rho
- (pred, tau) = tcSplitMethodTy rho_ty
- in
- newMethodWithGivenTy orig id tys [pred] tau
-
newMethodWithGivenTy orig id tys theta tau
= getInstLoc orig `thenM` \ loc ->
- newMethodWith loc id tys theta tau `thenM` \ inst ->
+ newMethod loc id tys theta tau `thenM` \ inst ->
extendLIE inst `thenM_`
- returnM inst
+ returnM (instToId inst)
--------------------------------------------
--- newMethodWith and newMethodAtLoc do *not* drop the
+-- tcInstClassOp, and newMethod do *not* drop the
-- Inst into the LIE; they just returns the Inst
-- This is important because they are used by TcSimplify
-- to simplify Insts
-newMethodWith inst_loc@(_,loc,_) id tys theta tau
+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)
+ in
+ ASSERT( isClassPred pred )
+ newMethod inst_loc sel_id tys [pred] tau
+
+---------------------------
+newMethod inst_loc@(_,loc,_) id tys theta tau
= newUnique `thenM` \ new_uniq ->
let
meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
inst = Method meth_id id tys theta tau inst_loc
in
returnM inst
-
-newMethodAtLoc :: InstLoc
- -> Id -> [TcType]
- -> TcM Inst
-newMethodAtLoc inst_loc real_id tys
- -- This actually builds the Inst
- = -- Get the Id type and instantiate it at the specified types
- let
- (tyvars,rho) = tcSplitForAllTys (idType real_id)
- rho_ty = ASSERT( equalLength tyvars tys )
- substTy (mkTopTyVarSubst tyvars tys) rho
- (theta, tau) = tcSplitPhiTy rho_ty
- in
- newMethodWith inst_loc real_id tys theta tau
\end{code}
In newOverloadedLit we convert directly to an Int or Integer if we
| otherwise
= ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
tcLookupId fromIntegerName `thenM` \ from_integer ->
- newMethodAtLoc loc from_integer [ty] `thenM` \ method_inst ->
+ tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
returnM (GenInst [method_inst]
(HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i))))
| otherwise
= ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
tcLookupId fromRationalName `thenM` \ from_rational ->
- newMethodAtLoc loc from_rational [ty] `thenM` \ method_inst ->
+ tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
mkRatLit f `thenM` \ rat_lit ->
returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
\end{code}
let
-- C.f. newMethodAtLoc
([tv], _, tau) = tcSplitSigmaTy (idType std_id)
- tau1 = substTy (mkTopTyVarSubst [tv] [ty]) tau
+ tau1 = substTyWith [tv] [ty] tau
in
addErrCtxtM (syntaxNameCtxt user_nm orig tau1) $
tcExpr (HsVar user_nm) tau1 `thenM` \ user_fn ->