[project @ 2000-02-23 19:41:50 by lewie]

Handle `with' more cleverly.  I was generating partially applied methods
for the case where the `with' expression was also overloaded, but this
was buggy, and completely unnecessary.  Instead, simply force the method
binding at the point of the `with' expression (we reap no benefits from
pushing the sharing further out anyway), and release the remainder of
the method's context into the LIE.

4 files changed, 41 insertions, 18 deletions

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 54e776c5cd..814fcb7ee4 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -25,7 +25,8 @@ module Id (
 	omitIfaceSigForId,
 	exportWithOrigOccName,
 	externallyVisibleId,
-	idFreeTyVars, 
+	idFreeTyVars,
+	isIP,
 
 	-- Inline pragma stuff
 	getInlinePragma, setInlinePragma, modifyInlinePragma, 
@@ -84,7 +85,8 @@ import IdInfo
 import Demand		( Demand, isStrict, wwLazy )
 import Name	 	( Name, OccName,
 			  mkSysLocalName, mkLocalName,
-			  isWiredInName, isUserExportedName
+			  isWiredInName, isUserExportedName,
+			  getOccName, isIPOcc
 			) 
 import OccName		( UserFS )
 import Const		( Con(..) )
@@ -273,6 +275,8 @@ omitIfaceSigForId id
 -- or an explicit user export.
 exportWithOrigOccName :: Id -> Bool
 exportWithOrigOccName id = omitIfaceSigForId id || isUserExportedId id
+
+isIP id = isIPOcc (getOccName id)
 \end{code}
 
 
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index d3ede0e290..41bf80701d 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -39,7 +39,7 @@ module Inst (
 import HsSyn	( HsLit(..), HsExpr(..) )
 import RnHsSyn	( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat )
 import TcHsSyn	( TcExpr, TcId, 
-		  mkHsTyApp, mkHsDictApp, zonkId
+		  mkHsTyApp, mkHsDictApp, mkHsDictLam, zonkId
 		)
 import TcMonad
 import TcEnv	( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
@@ -276,18 +276,24 @@ partitionLIEbyMeth pred lie
   = foldlTc (partMethod pred) (emptyLIE, emptyLIE) insts
   where insts = lieToList lie
 
-partMethod pred (ips, lie) m@(Method u id tys theta tau loc)
-  = if null ips_ then
+partMethod pred (ips, lie) d@(Dict _ p _)
+  = if pred p then
+	returnTc (consLIE d ips, lie)
+    else
+	returnTc (ips, consLIE d lie)
+
+partMethod pred (ips, lie) m@(Method u id tys theta tau loc@(_,sloc,_))
+  = let (ips_, theta_) = partition pred theta in
+    if null ips_ then
 	returnTc (ips, consLIE m lie)
     else if null theta_ then
 	returnTc (consLIE m ips, lie)
     else
-	newMethodWith id tys theta_ tau loc	    `thenTc` \ new_m2 ->
-	let id_m1 = instToIdBndr new_m2
-	    new_m1 = Method u id_m1 {- tys -} [] ips_ tau loc in
-	-- newMethodWith id_m1 tys ips_ tau loc	    `thenTc` \ new_m1 ->
-	returnTc (consLIE new_m1 ips, consLIE new_m2 lie)
-  where (ips_, theta_) = partition pred theta
+	zonkPreds theta_ `thenTc` \ theta_' ->
+	newDictsAtLoc loc theta_'	    `thenTc` \ (new_dicts, _) ->
+	returnTc (consLIE m ips,
+		  plusLIE (listToLIE new_dicts) lie)
+
 partMethod pred (ips, lie) inst@(LitInst u lit ty loc)
   = returnTc (ips, consLIE inst lie)
 
@@ -547,6 +553,7 @@ zonkInst (FunDep clas fds loc)
   = zonkFunDeps fds			`thenNF_Tc` \ fds' ->
     returnNF_Tc (FunDep clas fds' loc)
 
+zonkPreds preds = mapNF_Tc zonkPred preds
 zonkInsts insts = mapNF_Tc zonkInst insts
 
 zonkFunDeps fds = mapNF_Tc zonkFd fds
@@ -584,10 +591,12 @@ pprInst (LitInst u lit ty loc)
 
 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 
-pprInst (Method u id tys _ _ loc)
+pprInst m@(Method u id tys theta tau loc)
   = hsep [ppr id, ptext SLIT("at"), 
 	  brackets (interppSP tys),
-	  show_uniq u]
+	  ppr theta, ppr tau,
+	  show_uniq u,
+	  ppr (instToId m)]
 
 pprInst (FunDep clas fds loc)
   = hsep [ppr clas, ppr fds]
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 7aecdaaf81..6ac44b1235 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -9,7 +9,7 @@ module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where
 #include "HsVersions.h"
 
 import HsSyn		( HsExpr(..), HsLit(..), ArithSeqInfo(..), 
-			  HsBinds(..), Stmt(..), StmtCtxt(..),
+			  HsBinds(..), MonoBinds(..), Stmt(..), StmtCtxt(..),
 			  mkMonoBind, nullMonoBinds
 			)
 import RnHsSyn		( RenamedHsExpr, RenamedRecordBinds )
@@ -733,10 +733,13 @@ tcMonoExpr (HsWith expr binds) res_ty
     tcIPBinds binds			`thenTc` \ (binds', types, lie2) ->
     partitionLIEbyMeth isBound lie	`thenTc` \ (ips, lie') ->
     zonkLIE ips				`thenTc` \ ips' ->
-    tcSimplify (text "With!") (tyVarsOfLIE ips') ips' `thenTc` \ res@(_, dict_binds, _) ->
+    tcSimplify (text "tcMonoExpr With") (tyVarsOfLIE ips') ips'
+					`thenTc` \ res@(_, dict_binds, _) ->
     let expr'' = if nullMonoBinds dict_binds
 		 then expr'
-		 else HsLet (MonoBind dict_binds [] NonRecursive) expr' in
+		 else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive)
+			    expr'
+    in
     tcCheckIPBinds binds' types ips'	`thenTc_`
     returnTc (HsWith expr'' binds', lie' `plusLIE` lie2)
   where isBound p
@@ -744,6 +747,13 @@ tcMonoExpr (HsWith expr binds) res_ty
 	    Just n -> n `elem` names
 	    Nothing -> False
 	names = map fst binds
+	-- revBinds is used because tcSimplify outputs the bindings
+	-- out-of-order.  it's not a problem elsewhere because these
+	-- bindings are normally used in a recursive let
+	-- ZZ probably need to find a better solution
+	revBinds (b1 `AndMonoBinds` b2) =
+	    (revBinds b2) `AndMonoBinds` (revBinds b1)
+	revBinds b = b
 
 tcIPBinds ((name, expr) : binds)
   = newTyVarTy_OpenKind		`thenTc` \ ty ->
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index e2ba97018c..d4bd29b563 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -40,7 +40,7 @@ module TcHsSyn (
 import HsSyn	-- oodles of it
 
 -- others:
-import Id	( idName, idType, setIdType, omitIfaceSigForId, Id )
+import Id	( idName, idType, setIdType, omitIfaceSigForId, isIP, Id )
 import DataCon	( DataCon, splitProductType_maybe )	
 import TcEnv	( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
 		  ValueEnv, TcId, tcInstId
@@ -184,7 +184,7 @@ zonkIdBndr id
 
 zonkIdOcc :: TcId -> NF_TcM s Id
 zonkIdOcc id 
-  | not (isLocallyDefined id) || omitIfaceSigForId id
+  | not (isLocallyDefined id) || omitIfaceSigForId id || isIP id
 	-- The omitIfaceSigForId thing may look wierd but it's quite
 	-- sensible really.  We're avoiding looking up superclass selectors
 	-- and constructors; zonking them is a no-op anyway, and the