Commit e87d56ce authored by lewie's avatar lewie
Browse files

[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.
parent b78eb7be
......@@ -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}
......
......@@ -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]
......
......@@ -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 ->
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment