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(..), opt_IgnoreAsserts )
-import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..),
- defaultFixity, negateFixity, compareFixity )
-import PrelNames ( hasKey, assertIdKey,
- foldrName, buildName,
- cCallableClassName, cReturnableClassName,
- enumClassName,
+import CmdLineOpts ( DynFlag(..) )
+import BasicTypes ( Fixity(..), FixityDirection(..), negateFixity, compareFixity )
+import PrelNames ( hasKey, assertIdKey, assertErrorName,
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 )
-import Util ( isSingleton, mapAndUnzip )
-import List ( intersectBy, unzip4 )
+import Util ( isSingleton )
+import List ( unzip4 )
import ListSetOps ( removeDups )
import Outputable
import SrcLoc ( noSrcLoc )
) `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
rnExpr (HsVar v)
= lookupOccRn v `thenM` \ name ->
- if name `hasKey` assertIdKey && not opt_IgnoreAsserts then
+ doptM Opt_IgnoreAsserts `thenM` \ ignore_asserts ->
+ if name `hasKey` assertIdKey && not ignore_asserts then
-- We expand it to (GHC.Err.assertError location_string)
mkAssertErrorExpr `thenM` \ (e, fvs) ->
returnM (e, fvs `addOneFV` name)
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 ->
-- 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)
= 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) ->
- 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) ->
checkSectionPrec InfixR section op' expr' `thenM_`
returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
-rnExpr (HsCCall fun args may_gc is_casm _)
- -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
- = rnExprs args `thenM` \ (args', fvs_args) ->
- returnM (HsCCall fun args' may_gc is_casm placeHolderType,
- fvs_args `plusFV` mkFVs [cCallableClassName,
- cReturnableClassName,
- ioDataConName])
-
rnExpr (HsCoreAnn ann expr)
= rnExpr expr `thenM` \ (expr', fvs_expr) ->
returnM (HsCoreAnn ann expr', fvs_expr)
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
- 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]
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 (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) ->
- returnM (PArrSeqIn new_seq,
- fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
+ returnM (PArrSeqIn new_seq, fvs)
\end{code}
These three are pattern syntax appearing in expressions.
\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)
convertOpFormsCmd :: HsCmd id -> HsCmd id
+convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsCmd c) e
+
convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
convertOpFormsCmd (OpApp c1 op fixity c2)
methodNamesCmd (HsDo sc stmts rbs ty loc) = methodNamesStmts stmts
+methodNamesCmd (HsApp c e) = methodNamesCmd c
+
methodNamesCmd (HsLam match) = methodNamesMatch match
methodNamesCmd (HsCase scrut matches loc)
%************************************************************************
\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) ->
= 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
-
- returnM (DecBr group', duUses dus `minusNameSet` duDefs dus)
+ let
+ dus = tcg_dus tcg_env
+ in
+ returnM (DecBr group', allUses dus)
\end{code}
%************************************************************************
-- 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)
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
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 ->
-- 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
+ unused_bndrs = filter (not . (`elemNameSet` fvs)) bndrs
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)
-
where
rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts
= 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
- =
-#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)
-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}
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"
expr = HsApp (HsVar assertErrorName) (HsLit msg)
msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
in
- returnM (expr, unitFV assertErrorName)
+ returnM (expr, emptyFVs)
\end{code}
%************************************************************************
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
projects / ghc-hetmet.git / blobdiff