[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.

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 54e776c..814fcb7 100644 (file)
--- 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 d3ede0e..41bf807 100644 (file)
--- 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 7aecdaa..6ac44b1 100644 (file)
--- 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 e2ba970..d4bd29b 100644 (file)
--- 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