projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2003-11-06 17:09:50 by simonpj]
[ghc-hetmet.git]
/
ghc
/
compiler
/
rename
/
RnExpr.lhs
diff --git
a/ghc/compiler/rename/RnExpr.lhs
b/ghc/compiler/rename/RnExpr.lhs
index
131a66c
..
0b78b1a
100644
(file)
--- a/
ghc/compiler/rename/RnExpr.lhs
+++ b/
ghc/compiler/rename/RnExpr.lhs
@@
-28,28
+28,22
@@
import RdrHsSyn
import RnHsSyn
import TcRnMonad
import RnEnv
import RnHsSyn
import TcRnMonad
import RnEnv
+import OccName ( plusOccEnv )
import RnNames ( importsFromLocalDecls )
import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize )
import CmdLineOpts ( DynFlag(..) )
import RnNames ( importsFromLocalDecls )
import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize )
import CmdLineOpts ( DynFlag(..) )
-import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..),
- defaultFixity, negateFixity, compareFixity )
-import PrelNames ( hasKey, assertIdKey,
- foldrName, buildName,
- enumClassName,
+import BasicTypes ( Fixity(..), FixityDirection(..), negateFixity, compareFixity )
+import PrelNames ( hasKey, assertIdKey, assertErrorName,
loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
- splitName, fstName, sndName, ioDataConName,
- replicatePName, mapPName, filterPName,
- crossPName, zipPName, toPName,
- enumFromToPName, enumFromThenToPName, assertErrorName,
negateName, monadNames, mfixName )
import Name ( Name, nameOccName )
import NameSet
import UnicodeUtil ( stringToUtf8 )
import UniqFM ( isNullUFM )
import UniqSet ( emptyUniqSet )
negateName, monadNames, mfixName )
import Name ( Name, nameOccName )
import NameSet
import UnicodeUtil ( stringToUtf8 )
import UniqFM ( isNullUFM )
import UniqSet ( emptyUniqSet )
-import Util ( isSingleton, mapAndUnzip )
-import List ( intersectBy, unzip4 )
+import Util ( isSingleton )
+import List ( unzip4 )
import ListSetOps ( removeDups )
import Outputable
import SrcLoc ( noSrcLoc )
import ListSetOps ( removeDups )
import Outputable
import SrcLoc ( noSrcLoc )
@@
-81,8
+75,8
@@
rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
-- Now the main event
) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
-- Now the main event
- rnPatsAndThen ctxt pats $ \ pats' ->
- rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
+ rnPatsAndThen ctxt True pats $ \ pats' ->
+ rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
-- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
-- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
@@
-172,13
+166,8
@@
rnExpr (HsVar v)
returnM (HsVar name, unitFV name)
rnExpr (HsIPVar v)
returnM (HsVar name, unitFV name)
rnExpr (HsIPVar v)
- = newIPName v `thenM` \ name ->
- let
- fvs = case name of
- Linear _ -> mkFVs [splitName, fstName, sndName]
- Dupable _ -> emptyFVs
- in
- returnM (HsIPVar name, fvs)
+ = newIPNameRn v `thenM` \ name ->
+ returnM (HsIPVar name, emptyFVs)
rnExpr (HsLit lit)
= litFVs lit `thenM` \ fvs ->
rnExpr (HsLit lit)
= litFVs lit `thenM` \ fvs ->
@@
-204,15
+193,11
@@
rnExpr (OpApp e1 op _ e2)
-- Deal with fixity
-- When renaming code synthesised from "deriving" declarations
-- Deal with fixity
-- When renaming code synthesised from "deriving" declarations
- -- we're in Interface mode, and we should ignore fixity; assume
- -- that the deriving code generator got the association correct
- -- Don't even look up the fixity when in interface mode
- getModeRn `thenM` \ mode ->
- (if isInterfaceMode mode
- then returnM (OpApp e1' op' defaultFixity e2')
- else lookupFixityRn op_name `thenM` \ fixity ->
- mkOpAppRn e1' op' fixity e2'
- ) `thenM` \ final_e ->
+ -- we used to avoid fixity stuff, but we can't easily tell any
+ -- more, so I've removed the test. Adding HsPars in TcGenDeriv
+ -- should prevent bad things happening.
+ lookupFixityRn op_name `thenM` \ fixity ->
+ mkOpAppRn e1' op' fixity e2' `thenM` \ final_e ->
returnM (final_e,
fv_e1 `plusFV` fv_op `plusFV` fv_e2)
returnM (final_e,
fv_e1 `plusFV` fv_op `plusFV` fv_e2)
@@
-234,20
+219,14
@@
rnExpr e@(HsBracket br_body loc)
= addSrcLoc loc $
checkTH e "bracket" `thenM_`
rnBracket br_body `thenM` \ (body', fvs_e) ->
= addSrcLoc loc $
checkTH e "bracket" `thenM_`
rnBracket br_body `thenM` \ (body', fvs_e) ->
- returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName)
+ returnM (HsBracket body' loc, fvs_e)
rnExpr e@(HsSplice n splice loc)
= addSrcLoc loc $
checkTH e "splice" `thenM_`
newLocalsRn [(n,loc)] `thenM` \ [n'] ->
rnExpr splice `thenM` \ (splice', fvs_e) ->
rnExpr e@(HsSplice n splice loc)
= addSrcLoc loc $
checkTH e "splice" `thenM_`
newLocalsRn [(n,loc)] `thenM` \ [n'] ->
rnExpr splice `thenM` \ (splice', fvs_e) ->
- returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName)
-
-rnExpr e@(HsReify (Reify flavour name))
- = checkTH e "reify" `thenM_`
- lookupGlobalOccRn name `thenM` \ name' ->
- -- For now, we can only reify top-level things
- returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName)
+ returnM (HsSplice n' splice' loc, fvs_e)
rnExpr section@(SectionL expr op)
= rnExpr expr `thenM` \ (expr', fvs_expr) ->
rnExpr section@(SectionL expr op)
= rnExpr expr `thenM` \ (expr', fvs_expr) ->
@@
-294,13
+273,8
@@
rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) ->
returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType src_loc,
lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) ->
returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType src_loc,
- fvs `plusFV` implicit_fvs do_or_lc `plusFV` monad_fvs)
+ fvs `plusFV` monad_fvs)
where
where
- implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName]
- implicit_fvs ListComp = mkFVs [foldrName, buildName]
- implicit_fvs DoExpr = emptyFVs
- implicit_fvs MDoExpr = emptyFVs
-
syntax_names = case do_or_lc of
DoExpr -> monadNames
MDoExpr -> monadNames ++ [mfixName]
syntax_names = case do_or_lc of
DoExpr -> monadNames
MDoExpr -> monadNames ++ [mfixName]
@@
-312,8
+286,7
@@
rnExpr (ExplicitList _ exps)
rnExpr (ExplicitPArr _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
rnExpr (ExplicitPArr _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
- returnM (ExplicitPArr placeHolderType exps',
- fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
+ returnM (ExplicitPArr placeHolderType exps', fvs)
rnExpr e@(ExplicitTuple exps boxity)
= checkTupSize tup_size `thenM_`
rnExpr e@(ExplicitTuple exps boxity)
= checkTupSize tup_size `thenM_`
@@
-355,12
+328,11
@@
rnExpr (HsType a)
rnExpr (ArithSeqIn seq)
= rnArithSeq seq `thenM` \ (new_seq, fvs) ->
rnExpr (ArithSeqIn seq)
= rnArithSeq seq `thenM` \ (new_seq, fvs) ->
- returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
+ returnM (ArithSeqIn new_seq, fvs)
rnExpr (PArrSeqIn seq)
= rnArithSeq seq `thenM` \ (new_seq, fvs) ->
rnExpr (PArrSeqIn seq)
= rnArithSeq seq `thenM` \ (new_seq, fvs) ->
- returnM (PArrSeqIn new_seq,
- fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
+ returnM (PArrSeqIn new_seq, fvs)
\end{code}
These three are pattern syntax appearing in expressions.
\end{code}
These three are pattern syntax appearing in expressions.
@@
-387,8
+359,8
@@
rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
\begin{code}
rnExpr (HsProc pat body src_loc)
= addSrcLoc src_loc $
\begin{code}
rnExpr (HsProc pat body src_loc)
= addSrcLoc src_loc $
- rnPatsAndThen ProcExpr [pat] $ \ [pat'] ->
- rnCmdTop body `thenM` \ (body',fvBody) ->
+ rnPatsAndThen ProcExpr True [pat] $ \ [pat'] ->
+ rnCmdTop body `thenM` \ (body',fvBody) ->
returnM (HsProc pat' body' src_loc, fvBody)
rnExpr (HsArrApp arrow arg _ ho rtl srcloc)
returnM (HsProc pat' body' src_loc, fvBody)
rnExpr (HsArrApp arrow arg _ ho rtl srcloc)
@@
-647,6
+619,8
@@
rnRbinds str rbinds
%************************************************************************
\begin{code}
%************************************************************************
\begin{code}
+rnBracket (VarBr n) = lookupOccRn n `thenM` \ name ->
+ returnM (VarBr name, unitFV name)
rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) ->
returnM (ExpBr e', fvs)
rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) ->
rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) ->
returnM (ExpBr e', fvs)
rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) ->
@@
-659,12
+633,19
@@
rnBracket (DecBr group)
= importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
-- Discard avails (not useful here)
= importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
-- Discard avails (not useful here)
- updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
+ updGblEnv (\gbl -> gbl { tcg_rdr_env = tcg_rdr_env gbl `plusOccEnv` rdr_env}) $
+ -- Notice plusOccEnv, not plusGlobalRdrEnv. In this situation we want
+ -- to *shadow* top-level bindings. E.g.
+ -- foo = 1
+ -- bar = [d| foo = 1|]
+ -- So we drop down to plusOccEnv. (Perhaps there should be a fn in RdrName.)
- rnSrcDecls group `thenM` \ (tcg_env, group', dus) ->
+ rnSrcDecls group `thenM` \ (tcg_env, group') ->
-- Discard the tcg_env; it contains only extra info about fixity
-- Discard the tcg_env; it contains only extra info about fixity
-
- returnM (DecBr group', duUses dus `minusNameSet` duDefs dus)
+ let
+ dus = tcg_dus tcg_env
+ in
+ returnM (DecBr group', allUses dus)
\end{code}
%************************************************************************
\end{code}
%************************************************************************
@@
-687,8
+668,8
@@
rnNormalStmts ctxt [] = returnM ([], emptyFVs)
-- Happens at the end of the sub-lists of a ParStmts
rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
-- Happens at the end of the sub-lists of a ParStmts
rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
- = addSrcLoc src_loc $
- rnExpr expr `thenM` \ (expr', fv_expr) ->
+ = addSrcLoc src_loc $
+ rnExpr expr `thenM` \ (expr', fv_expr) ->
rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
returnM (ExprStmt expr' placeHolderType src_loc : stmts',
fv_expr `plusFV` fvs)
rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
returnM (ExprStmt expr' placeHolderType src_loc : stmts',
fv_expr `plusFV` fvs)
@@
-703,8
+684,14
@@
rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
rnExpr expr `thenM` \ (expr', fv_expr) ->
-- The binders do not scope over the expression
rnExpr expr `thenM` \ (expr', fv_expr) ->
-- The binders do not scope over the expression
- rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] ->
- rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
+ let
+ reportUnused =
+ case ctxt of
+ ParStmtCtxt{} -> False
+ _ -> True
+ in
+ rnPatsAndThen (StmtCtxt ctxt) reportUnused [pat] $ \ [pat'] ->
+ rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
returnM (BindStmt pat' expr' src_loc : stmts',
fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by
-- the rnPatsAndThen, but it does not matter
returnM (BindStmt pat' expr' src_loc : stmts',
fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by
-- the rnPatsAndThen, but it does not matter
@@
-717,8
+704,8
@@
rnNormalStmts ctxt (LetStmt binds : stmts)
where
-- We do not allow implicit-parameter bindings in a parallel
-- list comprehension. I'm not sure what it might mean.
where
-- We do not allow implicit-parameter bindings in a parallel
-- list comprehension. I'm not sure what it might mean.
- ok (ParStmtCtxt _) (IPBinds _ _) = False
- ok _ _ = True
+ ok (ParStmtCtxt _) (IPBinds _) = False
+ ok _ _ = True
rnNormalStmts ctxt (ParStmt stmtss : stmts)
= doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
rnNormalStmts ctxt (ParStmt stmtss : stmts)
= doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
@@
-735,13
+722,16
@@
rnNormalStmts ctxt (ParStmt stmtss : stmts)
-- shadow the next; e.g. x <- xs; x <- ys
rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
-- shadow the next; e.g. x <- xs; x <- ys
rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
- -- Cut down the exported binders to just the ones neede in the body
+ -- Cut down the exported binders to just the ones needed in the body
let
used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
let
used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
+ unused_bndrs = filter (not . (`elemNameSet` fvs)) bndrs
in
in
+ -- With processing of the branches and the tail of comprehension done,
+ -- we can finally compute&report any unused ParStmt binders.
+ warnUnusedMatches unused_bndrs `thenM_`
returnM (ParStmt (stmtss' `zip` used_bndrs_s) : stmts',
fv_stmtss `plusFV` fvs)
returnM (ParStmt (stmtss' `zip` used_bndrs_s) : stmts',
fv_stmtss `plusFV` fvs)
-
where
rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts
where
rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts
@@
-1038,16
+1028,13
@@
right_op_ok fix1 other
= True
-- Parser initially makes negation bind more tightly than any other operator
= True
-- Parser initially makes negation bind more tightly than any other operator
+-- And "deriving" code should respect this (use HsPar if not)
mkNegAppRn neg_arg neg_name
mkNegAppRn neg_arg neg_name
- =
-#ifdef DEBUG
- getModeRn `thenM` \ mode ->
- ASSERT( not_op_app mode neg_arg )
-#endif
+ = ASSERT( not_op_app neg_arg )
returnM (NegApp neg_arg neg_name)
returnM (NegApp neg_arg neg_name)
-not_op_app SourceMode (OpApp _ _ _ _) = False
-not_op_app mode other = True
+not_op_app (OpApp _ _ _ _) = False
+not_op_app other = True
\end{code}
\begin{code}
\end{code}
\begin{code}
@@
-1058,12
+1045,9
@@
checkPrecMatch False fn match
checkPrecMatch True op (Match (p1:p2:_) _ _)
-- True indicates an infix lhs
checkPrecMatch True op (Match (p1:p2:_) _ _)
-- True indicates an infix lhs
- = getModeRn `thenM` \ mode ->
- -- See comments with rnExpr (OpApp ...)
- if isInterfaceMode mode
- then returnM ()
- else checkPrec op p1 False `thenM_`
- checkPrec op p2 True
+ = -- See comments with rnExpr (OpApp ...) about "deriving"
+ checkPrec op p1 False `thenM_`
+ checkPrec op p2 True
checkPrecMatch True op _ = panic "checkPrecMatch"
checkPrecMatch True op _ = panic "checkPrecMatch"
@@
-1120,7
+1104,7
@@
mkAssertErrorExpr
expr = HsApp (HsVar assertErrorName) (HsLit msg)
msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
in
expr = HsApp (HsVar assertErrorName) (HsLit msg)
msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
in
- returnM (expr, unitFV assertErrorName)
+ returnM (expr, emptyFVs)
\end{code}
%************************************************************************
\end{code}
%************************************************************************
@@
-1159,7
+1143,7
@@
checkTH e what -- Raise an error in a stage-1 compiler
nest 2 (ppr e)])
#endif
nest 2 (ppr e)])
#endif
-parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglagow-exts"))
+parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))
badIpBinds binds
= hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4
badIpBinds binds
= hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4