[project @ 2001-05-03 08:13:25 by simonpj]

****	MERGE WITH 5.00 BRANCH     ********

	--------------------------------
	Fix a bad implicit parameter bug
	--------------------------------

TcSimplify.tcSimplifyIPs was just completely wrong; it wasn't
doing improvement properly nor binding values properly. Sigh.

To make this work nicely I added
	Inst.instName :: Inst -> Name

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 4d258ee..c0c5f78 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -26,7 +26,7 @@ module Inst (
        instBindingRequired, instCanBeGeneralised,
 
        zonkInst, zonkInsts,
-       instToId, 
+       instToId, instName,
 
        InstOrigin(..), InstLoc, pprInstLoc
     ) where
@@ -48,9 +48,9 @@ import TcType ( TcThetaType,
                )
 import CoreFVs ( idFreeTyVars )
 import Class   ( Class )
-import Id      ( Id, idType, mkUserLocal, mkSysLocal, mkLocalId )
+import Id      ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId )
 import PrelInfo        ( isStandardClass, isCcallishClass, isNoDictClass )
-import Name    ( mkMethodOcc, getOccName )
+import Name    ( Name, mkMethodOcc, getOccName )
 import NameSet ( NameSet )
 import PprType ( pprPred )     
 import Type    ( Type, PredType(..), ThetaType,
@@ -195,6 +195,9 @@ cmpInst (LitInst _ _ _ _)     other                     = GT
 Selection
 ~~~~~~~~~
 \begin{code}
+instName :: Inst -> Name
+instName inst = idName (instToId inst)
+
 instToId :: Inst -> TcId
 instToId (Dict id _ _)        = id
 instToId (Method id _ _ _ _ _) = id
@@ -312,6 +315,8 @@ newDictsAtLoc inst_loc@(_,loc,_) theta
   where
     mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
 
+-- For implicit parameters, since there is only one in scope
+-- at any time, we use the name of the implicit parameter itself
 newIPDict orig name ty
   = tcGetInstLoc orig                  `thenNF_Tc` \ inst_loc ->
     returnNF_Tc (Dict (mkLocalId name (mkPredTy pred)) pred inst_loc)

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index ebc25af..07c3374 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -629,7 +629,10 @@ Implicit Parameter bindings.
 tcMonoExpr (HsWith expr binds) res_ty
   = tcMonoExpr expr res_ty                     `thenTc` \ (expr', expr_lie) ->
     mapAndUnzipTc tcIPBind binds               `thenTc` \ (pairs, bind_lies) ->
-    tcSimplifyIPs (map fst binds) expr_lie     `thenTc` \ (expr_lie', dict_binds) ->
+
+       -- If the binding binds ?x = E, we  must now 
+       -- discharge any ?x constraints in expr_lie
+    tcSimplifyIPs (map fst pairs) expr_lie     `thenTc` \ (expr_lie', dict_binds) ->
     let
        binds' = [(instToId ip, rhs) | (ip,rhs) <- pairs]
        expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr'

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index d8c3194..5a4867a 100644 (file)
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -25,7 +25,7 @@ import TcHsSyn                ( TcExpr, TcId,
 import TcMonad
 import Inst            ( lookupInst, lookupSimpleInst, LookupInstResult(..),
                          tyVarsOfInst, predsOfInsts, predsOfInst,
-                         isDict, isClassDict, 
+                         isDict, isClassDict, instName,
                          isStdClassTyVarDict, isMethodFor,
                          instToId, tyVarsOfInsts,
                          instBindingRequired, instCanBeGeneralised,
@@ -234,7 +234,7 @@ However, we don't *need* to report ambiguity right away.  It'll always
 show up at the call site.... and eventually at main, which needs special
 treatment.  Nevertheless, reporting ambiguity promptly is an excellent thing.
 
-So heres the plan.  We WARN about probable ambiguity if
+So here's the plan.  We WARN about probable ambiguity if
 
        fv(Cq) is not a subset of  oclose(fv(T) union fv(G), C)
 
@@ -282,7 +282,7 @@ is a "bubble" that's a set of constraints
 Hence another idea.  To decide Q start with fv(T) and grow it
 by transitive closure in Cq (no functional dependencies involved).
 Now partition Cq using Q, leaving the definitely-ambiguous and probably-ok.
-The definitely-ambigous can then float out, and get smashed at top level
+The definitely-ambiguous can then float out, and get smashed at top level
 (which squashes out the constants, like Eq (T a) above)
 
 
@@ -685,28 +685,45 @@ When we have
        let ?x = R in B
 
 we must discharge all the ?x constraints from B.  We also do an improvement
-step; if we have ?x::t1 and ?x::t2 we must unify t1, t2.  No need to iterate, though.
+step; if we have ?x::t1 and ?x::t2 we must unify t1, t2.  
+
+Actually, the constraints from B might improve the types in ?x. For example
+
+       f :: (?x::Int) => Char -> Char
+       let ?x = 3 in f 'c'
+
+then the constraint (?x::Int) arising from the call to f will 
+force the binding for ?x to be of type Int.
 
 \begin{code}
-tcSimplifyIPs :: [Name]                -- The implicit parameters bound here
+tcSimplifyIPs :: [Inst]                -- The implicit parameters bound here
              -> LIE
              -> TcM (LIE, TcDictBinds)
-tcSimplifyIPs ip_names wanted_lie
-  = simpleReduceLoop doc try_me wanteds        `thenTc` \ (frees, binds, irreds) ->
-       -- The irreducible ones should be a subset of the implicit
-       -- parameters we provided
-    ASSERT( all here_ip irreds )
+tcSimplifyIPs given_ips wanted_lie
+  = simpl_loop given_ips wanteds       `thenTc` \ (frees, binds) ->
     returnTc (mkLIE frees, binds)
-    
   where
-    doc            = text "tcSimplifyIPs" <+> ppr ip_names
-    wanteds = lieToList wanted_lie
-    ip_set  = mkNameSet ip_names
-    here_ip ip = isDict ip && ip `instMentionsIPs` ip_set
-
+    doc             = text "tcSimplifyIPs" <+> ppr ip_names
+    wanteds  = lieToList wanted_lie
+    ip_names = map instName given_ips
+    ip_set   = mkNameSet ip_names
+  
        -- Simplify any methods that mention the implicit parameter
     try_me inst | inst `instMentionsIPs` ip_set = ReduceMe
                | otherwise                     = Free
+
+    simpl_loop givens wanteds
+      = mapNF_Tc zonkInst givens               `thenNF_Tc` \ givens' ->
+        mapNF_Tc zonkInst wanteds              `thenNF_Tc` \ wanteds' ->
+  
+        reduceContext doc try_me givens' wanteds'    `thenTc` \ (no_improvement, frees, binds, irreds) ->
+
+        if no_improvement then
+           ASSERT( null irreds )
+           returnTc (frees, binds)
+       else
+           simpl_loop givens' (irreds ++ frees)        `thenTc` \ (frees1, binds1) ->
+           returnTc (frees1, binds `AndMonoBinds` binds1)
 \end{code}