[project @ 2003-02-04 12:28:22 by simonpj]

---------------------------------------------------
	Important fix to the handling of class methods that
	      mention their own class type variable
	---------------------------------------------------

[NB: I'm not 100% certain that this commit is independent of the
     Template-Haskell-related commit I'm doing at the same time.
     I've tried to separate them but may not have succeeded totally.]

This bug gives utterly bogus (detected by Core Lint) programs.
Isaac Jones discovered it.  Here's an example, now enshrined as tc165.

    class C a where
	f :: (Eq a) => a

    instance C () where
	f = f

The instance decl was translated as

    dfC() = MkC (let f = \dEq -> f in f)

which is utterly wrong.  Reason: the 'f' on the left was being treated
as an available Inst, but it doesn't obey INVARIANT 2 for Insts, which
is that they are applied to all their dictionaries.  (See the data type
decl for Inst.)

Solution: don't include such class methods in the available Insts.

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 083c364..cd189a5 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -323,23 +323,14 @@ newMethodWithGivenTy orig id tys theta tau
 -- 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
@@ -480,7 +471,7 @@ pprInsts insts  = parens (sep (punctuate comma (map pprInst insts)))
 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]

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 86d3bba..fb29e56 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, tcInstClassOp )
+import Inst            ( Inst, InstOrigin(..), instToId, newDicts, newMethod )
 import TcEnv           ( TyThingDetails(..), 
                          tcLookupClass, tcExtendTyVarEnv2, 
                          tcExtendTyVarEnv
@@ -36,7 +36,8 @@ import TcUnify                ( checkSigTyVars, sigCtxt )
 import TcMType         ( tcInstTyVars )
 import TcType          ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar, 
                          mkTyVarTys, mkPredTys, mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
-                         tcIsTyVarTy, tcSplitTyConApp_maybe
+                         tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy,
+                         getClassPredTys_maybe, mkPhiTy
                        )
 import TcRnMonad
 import Generics                ( mkGenericRhs )
@@ -44,9 +45,10 @@ import PrelInfo              ( nO_METHOD_BINDING_ERROR_ID )
 import Class           ( classTyVars, classBigSig, classTyCon, 
                          Class, ClassOpItem, DefMeth (..) )
 import TyCon           ( tyConGenInfo )
+import Subst           ( substTyWith )
 import MkId            ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
 import DataCon         ( mkDataCon )
-import Id              ( Id, idType, idName, setIdLocalExported, setInlinePragma )
+import Id              ( Id, idType, idName, mkUserLocal, setIdLocalExported, setInlinePragma )
 import Name            ( Name, NamedThing(..) )
 import NameEnv         ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
 import NameSet         ( emptyNameSet, unitNameSet )
@@ -57,7 +59,7 @@ import Var            ( TyVar )
 import CmdLineOpts
 import UnicodeUtil     ( stringToUtf8 )
 import ErrUtils                ( dumpIfSet )
-import Util            ( count, lengthIs )
+import Util            ( count, lengthIs, isSingleton )
 import Maybes          ( seqMaybe )
 import Maybe           ( isJust )
 import FastString
@@ -391,7 +393,7 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
     in
     newDicts origin theta                              `thenM` \ [this_dict] ->
 
-    mkMethodBind origin clas inst_tys binds_in op_item `thenM` \ (dm_inst, meth_info) ->
+    mkMethodBind origin clas inst_tys binds_in op_item `thenM` \ (_, meth_info) ->
     getLIE (tcMethodBind xtve clas_tyvars theta 
                         [this_dict] prags meth_info)   `thenM` \ (defm_bind, insts_needed) ->
     
@@ -408,10 +410,11 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
     checkSigTyVars clas_tyvars         `thenM` \ clas_tyvars' ->
     
     let
+       (_,dm_inst_id,_) = meth_info
         full_bind = AbsBinds
                    clas_tyvars'
                    [instToId this_dict]
-                   [(clas_tyvars', local_dm_id, instToId dm_inst)]
+                   [(clas_tyvars', local_dm_id, dm_inst_id)]
                    emptyNameSet        -- No inlines (yet)
                    (dict_binds `andMonoBinds` defm_bind)
     in
@@ -435,7 +438,7 @@ tyvar sets.
 
 \begin{code}
 type MethodSpec = (Id,                         -- Global selector Id
-                  TcSigInfo,           -- Signature 
+                  Id,                  -- Local Id (class tyvars instantiated)
                   RenamedMonoBinds)    -- Binding for the method
 
 tcMethodBind 
@@ -453,9 +456,11 @@ tcMethodBind
        -> TcM TcMonoBinds
 
 tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
-            (sel_id, meth_sig, meth_bind)
+            (sel_id, meth_id, meth_bind)
   =    -- Check the bindings; first adding inst_tyvars to the envt
        -- so that we don't quantify over them in nested places
+    mkTcSig meth_id                            `thenM` \ meth_sig ->
+
      tcExtendTyVarEnv2 xtve (
        addErrCtxt (methodCtxt sel_id)          $
        getLIE (tcMonoBinds meth_bind [meth_sig] NonRecursive)
@@ -510,17 +515,14 @@ mkMethodBind :: InstOrigin
             -> Class -> [TcType]       -- Class and instance types
             -> RenamedMonoBinds        -- Method binding (pick the right one from in here)
             -> ClassOpItem
-            -> TcM (Inst,              -- Method inst
+            -> TcM (Maybe Inst,                -- Method inst
                     MethodSpec)
 -- Find the binding for the specified method, or make
 -- up a suitable default method if it isn't there
 
 mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
-  = getInstLoc origin                          `thenM` \ inst_loc ->
-    tcInstClassOp inst_loc sel_id inst_tys     `thenM` \ meth_inst ->
-       -- Do not dump anything into the LIE
+  = mkMethId origin clas sel_id inst_tys               `thenM` \ (mb_inst, meth_id) ->
     let
-       meth_id    = instToId meth_inst
        meth_name  = idName meth_id
     in
        -- Figure out what method binding to use
@@ -530,13 +532,53 @@ mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
        Just user_bind -> returnM user_bind 
        Nothing        -> mkDefMethRhs origin clas inst_tys sel_id loc dm_info  `thenM` \ rhs ->
                          returnM (FunMonoBind meth_name False  -- Not infix decl
-                                               [mkSimpleMatch [] rhs placeHolderType loc] loc)
+                                              [mkSimpleMatch [] rhs placeHolderType loc] loc)
     )                                                          `thenM` \ meth_bind ->
 
-    mkTcSig meth_id loc                        `thenM` \ meth_sig ->
-
-    returnM (meth_inst, (sel_id, meth_sig, meth_bind))
-    
+    returnM (mb_inst, (sel_id, meth_id, meth_bind))
+
+mkMethId :: InstOrigin -> Class 
+        -> Id -> [TcType]      -- Selector, and instance types
+        -> TcM (Maybe Inst, Id)
+            
+-- mkMethId instantiates the selector Id at the specified types
+-- THe 
+mkMethId origin clas sel_id inst_tys
+  = let
+       (tyvars,rho) = tcSplitForAllTys (idType sel_id)
+       rho_ty       = ASSERT( length tyvars == length inst_tys )
+                      substTyWith tyvars inst_tys rho
+       (preds,tau)  = tcSplitPhiTy rho_ty
+        first_pred   = head preds
+    in
+       -- The first predicate should be of form (C a b)
+       -- where C is the class in question
+    ASSERT( not (null preds) && 
+           case getClassPredTys_maybe first_pred of
+               { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
+    )
+    if isSingleton preds then
+       -- If it's the only one, make a 'method'
+       getInstLoc origin                               `thenM` \ inst_loc ->
+       newMethod inst_loc sel_id inst_tys preds tau    `thenM` \ meth_inst ->
+       returnM (Just meth_inst, instToId meth_inst)
+    else
+       -- If it's not the only one we need to be careful
+       -- For example, given 'op' defined thus:
+       --      class Foo a where
+       --        op :: (?x :: String) => a -> a
+       -- (mkMethId op T) should return an Inst with type
+       --      (?x :: String) => T -> T
+       -- That is, the class-op's context is still there.  
+       -- BUT: it can't be a Method any more, because it breaks
+       --      INVARIANT 2 of methods.  (See the data decl for Inst.)
+       newUnique                       `thenM` \ uniq ->
+       getSrcLocM                      `thenM` \ loc ->
+       let 
+           real_tau = mkPhiTy (tail preds) tau
+           meth_id  = mkUserLocal (getOccName sel_id) uniq real_tau loc
+       in
+       returnM (Nothing, meth_id)
 
      -- The user didn't supply a method binding, 
      -- so we have to make up a default binding

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index b30af59..cf705ae 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -610,7 +610,7 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
     let
        mk_method_bind = mkMethodBind InstanceDeclOrigin clas inst_tys' monobinds
     in
-    mapAndUnzipM mk_method_bind  op_items      `thenM` \ (meth_insts, meth_infos) ->
+    mapAndUnzipM mk_method_bind op_items       `thenM` \ (meth_insts, meth_infos) ->
 
        -- And type check them
        -- It's really worth making meth_insts available to the tcMethodBind
@@ -630,13 +630,14 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
        -- Solution: make meth_insts available, so that 'then' refers directly
        --           to the local 'bind' rather than going via the dictionary.
     let
-       all_insts      = avail_insts ++ meth_insts
+       all_insts      = avail_insts ++ catMaybes meth_insts
        xtve           = inst_tyvars `zip` inst_tyvars'
        tc_method_bind = tcMethodBind xtve inst_tyvars' dfun_theta' all_insts uprags 
     in
     mapM tc_method_bind meth_infos             `thenM` \ meth_binds_s ->
    
-    returnM (map instToId meth_insts, andMonoBindList meth_binds_s)
+    returnM ([meth_id | (_,meth_id,_) <- meth_infos], 
+            andMonoBindList meth_binds_s)
 
 
 -- Derived newtype instances

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 320cf8d..e93f64d 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -654,13 +654,13 @@ maybeSig (sig@(TySigInfo sig_id _ _ _ _ _ _) : sigs) name
 tcTySig :: RenamedSig -> TcM TcSigInfo
 
 tcTySig (Sig v ty src_loc)
- = addSrcLoc src_loc                           $ 
-   tcHsSigType (FunSigCtxt v) ty               `thenM` \ sigma_tc_ty ->
-   mkTcSig (mkLocalId v sigma_tc_ty) src_loc   `thenM` \ sig -> 
+ = addSrcLoc src_loc                   $ 
+   tcHsSigType (FunSigCtxt v) ty       `thenM` \ sigma_tc_ty ->
+   mkTcSig (mkLocalId v sigma_tc_ty)   `thenM` \ sig -> 
    returnM sig
 
-mkTcSig :: TcId -> SrcLoc -> TcM TcSigInfo
-mkTcSig poly_id src_loc
+mkTcSig :: TcId -> TcM TcSigInfo
+mkTcSig poly_id
   =    -- Instantiate this type
        -- It's important to do this even though in the error-free case
        -- we could just split the sigma_tc_ty (since the tyvars don't
@@ -677,6 +677,7 @@ mkTcSig poly_id src_loc
        -- We make a Method even if it's not overloaded; no harm
        -- But do not extend the LIE!  We're just making an Id.
        
+   getSrcLocM                                  `thenM` \ src_loc ->
    returnM (TySigInfo poly_id tyvars' theta' tau' 
                          (instToId inst) [inst] src_loc)
 \end{code}