[project @ 2002-11-18 14:25:50 by simonpj]

----------------------------------------
	Class ops that do not introduce for-alls
	----------------------------------------

	MERGE TO STABLE (if poss)

The handling of class ops that do not add an extra for-all
was utterly bogus.  For example:

	class C a where
	    fc :: (?p :: String) => a;

	class D a where
	    fd :: (Ord a) => [a] -> [a]

De-bogus-ing means

a) Being careful when taking apart the class op type in
	MkIface.tcClassOpSig

b) Ditto when making the method Id in an instance binding.
   Hence new function Inst.tcInstClassOp, and its calls
   in TcInstDcls, and TcClassDcls

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index b4178db..5025473 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -55,7 +55,7 @@ import TyCon          ( DataConDetails(..), tyConTyVars, tyConDataCons, tyConTheta,
                          getSynTyConDefn, tyConGenInfo, tyConDataConDetails, tyConArity )
 import Class           ( classExtraBigSig, classTyCon, DefMeth(..) )
 import FieldLabel      ( fieldLabelType )
-import TcType          ( tcSplitSigmaTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead )
+import TcType          ( tcSplitForAllTys, tcFunResultTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead )
 import SrcLoc          ( noSrcLoc )
 import Module          ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule,
                          ModLocation(..), mkSysModuleNameFS, 
@@ -248,7 +248,13 @@ ifaceTyThing (AClass clas) = cls_decl
        = ASSERT(sel_tyvars == clas_tyvars)
          ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc
        where
-         (sel_tyvars, _, op_ty) = tcSplitSigmaTy (idType sel_id)
+               -- Be careful when splitting the type, because of things
+               -- like         class Foo a where
+               --                op :: (?x :: String) => a -> a
+               -- and          class Baz a where
+               --                op :: (Ord a) => a -> a
+         (sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id)
+         op_ty                = tcFunResultTy rho_ty
          def_meth' = case def_meth of
                         NoDefMeth  -> NoDefMeth
                         GenDefMeth -> GenDefMeth

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index ccd8e43..35d1c55 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -14,7 +14,7 @@ module Inst (
 
        newDictsFromOld, newDicts, cloneDict,
        newMethod, newMethodFromName, newMethodWithGivenTy, 
-       newMethodWith, newMethodAtLoc,
+       newMethodWith, tcInstClassOp,
        newOverloadedLit, newIPDict, 
        tcInstCall, tcInstDataCon, tcSyntaxName,
 
@@ -58,7 +58,7 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
                  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
                  isClassPred, isTyVarClassPred, isLinearPred, predHasFDs,
                  getClassPredTys, getClassPredTys_maybe, mkPredName,
-                 isInheritablePred, isIPPred,
+                 isInheritablePred, isIPPred, tcSplitFunTy_maybe, tcSplitPredTy_maybe,
                  tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
                )
 import CoreFVs ( idFreeTyVars )
@@ -330,11 +330,32 @@ newMethodWithGivenTy orig id tys theta tau
     returnM (instToId inst)
 
 --------------------------------------------
--- newMethodWith and newMethodAtLoc do *not* drop the 
+-- tcInstClassOp, and newMethodWith 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
 
+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             = ASSERT( equalLength tyvars tys )
+                            substTy (mkTopTyVarSubst tyvars tys) rho
+       Just (pred_ty,tau) = tcSplitFunTy_maybe rho_ty
+       Just pred          = tcSplitPredTy_maybe pred_ty
+               -- Split off exactly one predicate (see the example above)
+    in
+    ASSERT( isClassPred pred )
+    newMethodWith inst_loc sel_id tys [pred] tau
+
 newMethodWith inst_loc@(_,loc,_) id tys theta tau
   = newUnique          `thenM` \ new_uniq ->
     let
@@ -342,20 +363,6 @@ newMethodWith inst_loc@(_,loc,_) id tys theta tau
        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
@@ -605,7 +612,7 @@ lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
   | 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))))
 
@@ -617,7 +624,7 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
   | 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}

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index c39d8a0..191ff05 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -24,7 +24,7 @@ import RnHsSyn                ( RenamedTyClDecl, RenamedSig,
 import RnEnv           ( lookupSysName )
 import TcHsSyn         ( TcMonoBinds )
 
-import Inst            ( Inst, InstOrigin(..), instToId, newDicts, newMethodAtLoc )
+import Inst            ( Inst, InstOrigin(..), instToId, newDicts, tcInstClassOp )
 import TcEnv           ( TyThingDetails(..), 
                          tcLookupClass, tcExtendTyVarEnv2, 
                          tcExtendTyVarEnv
@@ -518,7 +518,7 @@ mkMethodBind :: InstOrigin
 
 mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
   = getInstLoc origin                          `thenM` \ inst_loc ->
-    newMethodAtLoc inst_loc sel_id inst_tys    `thenM` \ meth_inst ->
+    tcInstClassOp inst_loc sel_id inst_tys     `thenM` \ meth_inst ->
        -- Do not dump anything into the LIE
     let
        meth_id    = instToId meth_inst

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 6d9f99f..427ec92 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -31,7 +31,7 @@ import TcType         ( mkClassPred, mkTyVarTy, tcSplitForAllTys, tyVarsOfType,
                          tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
                          TyVarDetails(..)
                        )
-import Inst            ( InstOrigin(..), newMethod, newMethodAtLoc, 
+import Inst            ( InstOrigin(..), newMethod, tcInstClassOp, 
                          newDicts, instToId, showLIE )
 import TcDeriv         ( tcDeriving )
 import TcEnv           ( tcExtendGlobalValEnv, 
@@ -641,10 +641,12 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
 
   where
     do_one inst_loc (sel_id, _)
-       = newMethodAtLoc inst_loc sel_id inst_tys'      `thenM` \ meth_inst ->
-               -- Like in mkMethodBind
+       = -- The binding is like "op @ NewTy = op @ RepTy"
+               -- Make the *binder*, like in mkMethodBind
+         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 ->
-               -- The binding is like "op @ NewTy = op @ RepTy"
          let
             meth_id = instToId meth_inst
          in

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index d017154..758659a 100644 (file)
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -33,7 +33,7 @@ import Inst           ( lookupInst, LookupInstResult(..),
                          instToId, tyVarsOfInsts,  cloneDict,
                          ipNamesOfInsts, ipNamesOfInst, dictPred,
                          instBindingRequired, instCanBeGeneralised,
-                         newDictsFromOld, newMethodAtLoc,
+                         newDictsFromOld, tcInstClassOp,
                          getDictClassTys, isTyVarDict,
                          instLoc, pprInst, zonkInst, tidyInsts, tidyMoreInsts,
                          Inst, pprInsts, pprInstsInFull,
@@ -1450,8 +1450,8 @@ addLinearAvailable avails avail wanted
 
   | otherwise
   = tcLookupId splitName                       `thenM` \ split_id ->
-    newMethodAtLoc (instLoc wanted) split_id 
-                  [linearInstType wanted]      `thenM` \ split_inst ->
+    tcInstClassOp (instLoc wanted) split_id 
+                 [linearInstType wanted]       `thenM` \ split_inst ->
     returnM (addToFM avails wanted (Linear 2 split_inst avail), [split_inst])
 
   where