[project @ 2002-11-19 12:34:55 by simonpj]

More newMethod tidying up

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 35d1c55..201a93f 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -12,11 +12,10 @@ module Inst (
        Inst, 
        pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
 
-       newDictsFromOld, newDicts, cloneDict,
-       newMethod, newMethodFromName, newMethodWithGivenTy, 
-       newMethodWith, tcInstClassOp,
+       newDictsFromOld, newDicts, cloneDict, 
        newOverloadedLit, newIPDict, 
-       tcInstCall, tcInstDataCon, tcSyntaxName,
+       newMethod, newMethodFromName, newMethodWithGivenTy, 
+       tcInstClassOp, tcInstCall, tcInstDataCon, tcSyntaxName,
 
        tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, 
        ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
@@ -58,7 +57,7 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
                  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 )
@@ -68,9 +67,7 @@ import Id     ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique
 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(..) )
@@ -300,7 +297,6 @@ tcInstDataCon orig data_con
 
     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 ->
@@ -308,29 +304,19 @@ newMethodFromName origin ty name
        -- 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 ->
-    newMethodWith loc id tys theta tau `thenM` \ inst ->
+    newMethod loc id tys theta tau     `thenM` \ 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
@@ -346,17 +332,16 @@ tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
   -- 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 )
-    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
@@ -701,7 +686,7 @@ tcSyntaxName orig ty std_nm user_nm
     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 ->

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 427ec92..4f670fa 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -31,8 +31,7 @@ import TcType         ( mkClassPred, mkTyVarTy, tcSplitForAllTys, tyVarsOfType,
                          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,
@@ -628,12 +627,12 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_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"))
-        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
 
@@ -646,11 +645,11 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
          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
-         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

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index fb575ab..b45acab 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -40,7 +40,7 @@ import TcType         ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
                          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 )
@@ -622,9 +622,9 @@ mkTcSig poly_id src_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.