More newMethod tidying up
Inst,
pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
Inst,
pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
- newDictsFromOld, newDicts, cloneDict,
- newMethod, newMethodFromName, newMethodWithGivenTy,
- newMethodWith, tcInstClassOp,
+ newDictsFromOld, newDicts, cloneDict,
newOverloadedLit, newIPDict,
newOverloadedLit, newIPDict,
- tcInstCall, tcInstDataCon, tcSyntaxName,
+ newMethod, newMethodFromName, newMethodWithGivenTy,
+ tcInstClassOp, tcInstCall, tcInstDataCon, tcSyntaxName,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
isClassPred, isTyVarClassPred, isLinearPred, predHasFDs,
getClassPredTys, getClassPredTys_maybe, mkPredName,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
isClassPred, isTyVarClassPred, isLinearPred, predHasFDs,
getClassPredTys, getClassPredTys_maybe, mkPredName,
- isInheritablePred, isIPPred, tcSplitFunTy_maybe, tcSplitPredTy_maybe,
+ isInheritablePred, isIPPred,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
)
import CoreFVs ( idFreeTyVars )
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
)
import CoreFVs ( idFreeTyVars )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName )
import PprType ( pprPred, pprParendType )
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 Literal ( inIntRange )
import Var ( TyVar )
import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
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 ->
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.
-- 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]
-
-newMethod :: InstOrigin
- -> TcId
- -> [TcType]
- -> TcM Id
-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
+ getInstLoc origin `thenM` \ loc ->
+ tcInstClassOp loc id [ty] `thenM` \ inst ->
+ extendLIE inst `thenM_`
+ returnM (instToId inst)
newMethodWithGivenTy orig id tys theta tau
= getInstLoc orig `thenM` \ loc ->
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 (instToId inst)
--------------------------------------------
extendLIE inst `thenM_`
returnM (instToId inst)
--------------------------------------------
--- tcInstClassOp, and newMethodWith 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
-- Inst into the LIE; they just returns the Inst
-- This is important because they are used by TcSimplify
-- to simplify Insts
-- This is really important in the use of tcInstClassOp in TcClassDcls.mkMethodBind
tcInstClassOp inst_loc sel_id tys
= let
-- 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 = ASSERT( equalLength tyvars tys )
- substTy (mkTopTyVarSubst tyvars tys) rho
- Just (pred_ty,tau) = tcSplitFunTy_maybe rho_ty
- Just pred = tcSplitPredTy_maybe pred_ty
+ (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 )
-- Split off exactly one predicate (see the example above)
in
ASSERT( isClassPred pred )
- newMethodWith inst_loc sel_id tys [pred] tau
+ newMethod inst_loc sel_id tys [pred] tau
-newMethodWith inst_loc@(_,loc,_) id tys theta tau
+---------------------------
+newMethod inst_loc@(_,loc,_) id tys theta tau
= newUnique `thenM` \ new_uniq ->
let
meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
= newUnique `thenM` \ new_uniq ->
let
meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
let
-- C.f. newMethodAtLoc
([tv], _, tau) = tcSplitSigmaTy (idType std_id)
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 ->
in
addErrCtxtM (syntaxNameCtxt user_nm orig tau1) $
tcExpr (HsVar user_nm) tau1 `thenM` \ user_fn ->
tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
TyVarDetails(..)
)
tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
TyVarDetails(..)
)
-import Inst ( InstOrigin(..), newMethod, tcInstClassOp,
- newDicts, instToId, showLIE )
+import Inst ( InstOrigin(..), tcInstClassOp, newDicts, instToId, showLIE )
import TcDeriv ( tcDeriving )
import TcEnv ( tcExtendGlobalValEnv,
tcLookupClass, tcExtendTyVarEnv2,
import TcDeriv ( tcDeriving )
import TcEnv ( tcExtendGlobalValEnv,
tcLookupClass, tcExtendTyVarEnv2,
-- Derived newtype instances
tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
avail_insts op_items (NewTypeDerived rep_tys)
-- Derived newtype instances
tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
avail_insts op_items (NewTypeDerived rep_tys)
- = getInstLoc InstanceDeclOrigin `thenM` \ inst_loc ->
- getLIE (mapAndUnzipM (do_one inst_loc) op_items) `thenM` \ ((meth_ids, meth_binds), lie) ->
+ = getInstLoc InstanceDeclOrigin `thenM` \ inst_loc ->
+ mapAndUnzip3M (do_one inst_loc) op_items `thenM` \ (meth_ids, meth_binds, rhs_insts) ->
tcSimplifyCheck
(ptext SLIT("newtype derived instance"))
tcSimplifyCheck
(ptext SLIT("newtype derived instance"))
- inst_tyvars' avail_insts lie `thenM` \ lie_binds ->
+ inst_tyvars' avail_insts rhs_insts `thenM` \ lie_binds ->
-- I don't think we have to do the checkSigTyVars thing
-- I don't think we have to do the checkSigTyVars thing
tcInstClassOp inst_loc sel_id inst_tys' `thenM` \ meth_inst ->
-- Make the *occurrence on the rhs*
tcInstClassOp inst_loc sel_id inst_tys' `thenM` \ meth_inst ->
-- Make the *occurrence on the rhs*
- newMethod InstanceDeclOrigin sel_id rep_tys' `thenM` \ rhs_id ->
+ tcInstClassOp inst_loc sel_id rep_tys' `thenM` \ rhs_inst ->
let
meth_id = instToId meth_inst
in
let
meth_id = instToId meth_inst
in
- return (meth_id, VarMonoBind meth_id (HsVar rhs_id))
+ return (meth_id, VarMonoBind meth_id (HsVar (instToId rhs_inst)), rhs_inst)
-- Instantiate rep_tys with the relevant type variables
rep_tys' = map (substTy subst) rep_tys
-- Instantiate rep_tys with the relevant type variables
rep_tys' = map (substTy subst) rep_tys
liftedTypeKind, unliftedTypeKind, mkArrowKind,
mkArrowKinds, tcSplitFunTy_maybe, tcSplitForAllTys
)
liftedTypeKind, unliftedTypeKind, mkArrowKind,
mkArrowKinds, tcSplitFunTy_maybe, tcSplitForAllTys
)
-import Inst ( Inst, InstOrigin(..), newMethodWith, instToId )
+import Inst ( Inst, InstOrigin(..), newMethod, instToId )
import Id ( mkLocalId, idName, idType )
import Var ( TyVar, mkTyVar, tyVarKind )
import Id ( mkLocalId, idName, idType )
import Var ( TyVar, mkTyVar, tyVarKind )
tcInstType SigTv (idType poly_id) `thenM` \ (tyvars', theta', tau') ->
getInstLoc SignatureOrigin `thenM` \ inst_loc ->
tcInstType SigTv (idType poly_id) `thenM` \ (tyvars', theta', tau') ->
getInstLoc SignatureOrigin `thenM` \ inst_loc ->
- newMethodWith inst_loc poly_id
- (mkTyVarTys tyvars')
- theta' tau' `thenM` \ inst ->
+ newMethod inst_loc poly_id
+ (mkTyVarTys tyvars')
+ theta' tau' `thenM` \ inst ->
-- We make a Method even if it's not overloaded; no harm
-- But do not extend the LIE! We're just making an Id.
-- We make a Method even if it's not overloaded; no harm
-- But do not extend the LIE! We're just making an Id.