rnMatchGroup, makeMiniFixityEnv)
import HsSyn
import TcRnMonad
+import TcEnv ( thRnBrack )
import RnEnv
import RnTypes ( rnHsTypeFVs,
mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
-import RnPat (rnQuasiQuote, rnOverLit, rnPatsAndThen_LocalRightwards, rnBindPat,
- localRecNameMaker, rnLit,
- rnHsRecFields_Con, rnHsRecFields_Update, checkTupSize)
+import RnPat
import DynFlags ( DynFlag(..) )
import BasicTypes ( FixityDirection(..) )
-import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName,
+import PrelNames ( hasKey, assertIdKey, assertErrorName,
loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
negateName, thenMName, bindMName, failMName, groupWithName )
let
acc' = acc `plusFV` fvExpr
in
- (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) ->
+ acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
returnM (expr':exprs', fvExprs)
-
--- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
-grubby_seqNameSet :: UniqSet Name -> a -> a
-grubby_seqNameSet ns result | isEmptyUniqSet ns = result
- | otherwise = result
\end{code}
Variables. We look up the variable and return the resulting name.
rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
+finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
+-- Separated from rnExpr because it's also used
+-- when renaming infix expressions
+-- See Note [Adding the implicit parameter to 'assert']
+finishHsVar name
+ = do { ignore_asserts <- doptM Opt_IgnoreAsserts
+ ; if ignore_asserts || not (name `hasKey` assertIdKey)
+ then return (HsVar name, unitFV name)
+ else do { e <- mkAssertErrorExpr
+ ; return (e, unitFV name) } }
+
rnExpr (HsVar v)
- = do name <- lookupOccRn v
- ignore_asserts <- doptM Opt_IgnoreAsserts
- finish_var ignore_asserts name
- where
- finish_var ignore_asserts name
- | ignore_asserts || not (name `hasKey` assertIdKey)
- = return (HsVar name, unitFV name)
- | otherwise
- = do { (e, fvs) <- mkAssertErrorExpr
- ; return (e, fvs `addOneFV` name) }
+ = do name <- lookupOccRn v
+ finishHsVar name
rnExpr (HsIPVar v)
= newIPNameRn v `thenM` \ name ->
rnLExpr arg `thenM` \ (arg',fvArg) ->
returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
-rnExpr (OpApp e1 op _ e2)
- = rnLExpr e1 `thenM` \ (e1', fv_e1) ->
- rnLExpr e2 `thenM` \ (e2', fv_e2) ->
- rnLExpr op `thenM` \ (op'@(L _ (HsVar op_name)), fv_op) ->
-
+rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
+ = do { (e1', fv_e1) <- rnLExpr e1
+ ; (e2', fv_e2) <- rnLExpr e2
+ ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
+ ; (op', fv_op) <- finishHsVar op_name
+ -- NB: op' is usually just a variable, but might be
+ -- an applicatoin (assert "Foo.hs:47")
-- Deal with fixity
-- When renaming code synthesised from "deriving" declarations
-- 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)
+ ; fixity <- lookupFixityRn op_name
+ ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
+ ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
rnExpr (NegApp e _)
= rnLExpr e `thenM` \ (e', fv_e) ->
mkNegAppRn e' neg_name `thenM` \ final_e ->
returnM (final_e, fv_e `plusFV` fv_neg)
-rnExpr (HsPar e)
- = rnLExpr e `thenM` \ (e', fvs_e) ->
- returnM (HsPar e', fvs_e)
-
+------------------------------------------
-- Template Haskell extensions
-- Don't ifdef-GHCI them because we want to fail gracefully
-- (not with an rnExpr crash) in a stage-1 compiler.
returnM (expr'', fvs_qq `plusFV` fvs_expr)
#endif /* GHCI */
-rnExpr section@(SectionL expr op)
- = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
- rnLExpr op `thenM` \ (op', fvs_op) ->
- checkSectionPrec InfixL section op' expr' `thenM_`
- returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
+---------------------------------------------
+-- Sections
+-- See Note [Parsing sections] in Parser.y.pp
+rnExpr (HsPar (L loc (section@(SectionL {}))))
+ = do { (section', fvs) <- rnSection section
+ ; return (HsPar (L loc section'), fvs) }
-rnExpr section@(SectionR op expr)
- = rnLExpr op `thenM` \ (op', fvs_op) ->
- rnLExpr expr `thenM` \ (expr', fvs_expr) ->
- checkSectionPrec InfixR section op' expr' `thenM_`
- returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
+rnExpr (HsPar (L loc (section@(SectionR {}))))
+ = do { (section', fvs) <- rnSection section
+ ; return (HsPar (L loc section'), fvs) }
+rnExpr (HsPar e)
+ = do { (e', fvs_e) <- rnLExpr e
+ ; return (HsPar e', fvs_e) }
+
+rnExpr expr@(SectionL {})
+ = do { addErr (sectionErr expr); rnSection expr }
+rnExpr expr@(SectionR {})
+ = do { addErr (sectionErr expr); rnSection expr }
+
+---------------------------------------------
rnExpr (HsCoreAnn ann expr)
= rnLExpr expr `thenM` \ (expr', fvs_expr) ->
returnM (HsCoreAnn ann expr', fvs_expr)
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
-- HsWrap
-\end{code}
+----------------------
+-- See Note [Parsing sections] in Parser.y.pp
+rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
+rnSection section@(SectionR op expr)
+ = do { (op', fvs_op) <- rnLExpr op
+ ; (expr', fvs_expr) <- rnLExpr expr
+ ; checkSectionPrec InfixR section op' expr'
+ ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
+
+rnSection section@(SectionL expr op)
+ = do { (expr', fvs_expr) <- rnLExpr expr
+ ; (op', fvs_op) <- rnLExpr op
+ ; checkSectionPrec InfixL section op' expr'
+ ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
+
+rnSection other = pprPanic "rnSection" (ppr other)
+\end{code}
%************************************************************************
%* *
rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr e', fvs) }
-rnBracket (PatBr _) = do { addErr (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"));
- failM }
-
+rnBracket (PatBr _) = failWith (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
; return (TypBr t', fvs) }
where
rnBracket (DecBr group)
= do { gbl_env <- getGblEnv
- ; let new_gbl_env = gbl_env { -- Set the module to thFAKE. The top-level names from the bracketed
- -- declarations will go into the name cache, and we don't want them to
- -- confuse the Names for the current module.
- -- By using a pretend module, thFAKE, we keep them safely out of the way.
- tcg_mod = thFAKE,
-
- -- The emptyDUs is so that we just collect uses for this group alone
- -- in the call to rnSrcDecls below
- tcg_dus = emptyDUs }
- ; setGblEnv new_gbl_env $ do {
-
- -- In this situation we want to *shadow* top-level bindings.
- -- foo = 1
- -- bar = [d| foo = 1 |]
- -- If we don't shadow, we'll get an ambiguity complaint when we do
- -- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo'
- --
- -- Furthermore, arguably if the splice does define foo, that should hide
- -- any foo's further out
- --
- -- The shadowing is acheived by calling rnSrcDecls with True as the shadowing flag
- ; (tcg_env, group') <- rnSrcDecls True group
+ ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
+ -- The emptyDUs is so that we just collect uses for this
+ -- group alone in the call to rnSrcDecls below
+ ; (tcg_env, group') <- setGblEnv new_gbl_env $
+ setStage thRnBrack $
+ rnSrcDecls group
-- Discard the tcg_env; it contains only extra info about fixity
- ; return (DecBr group', allUses (tcg_dus tcg_env)) } }
+ ; return (DecBr group', allUses (tcg_dus tcg_env)) }
\end{code}
%************************************************************************
fv_pat)]
rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
- = do { addErr (badIpBinds (ptext (sLit "an mdo expression")) binds)
- ; failM }
+ = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
= do binds' <- rnValBindsLHS fix_env binds
L loc (BindStmt pat' expr' bind_op fail_op))]
rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
- = do { addErr (badIpBinds (ptext (sLit "an mdo expression")) binds)
- ; failM }
+ = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
(binds', du_binds) <-
-- fixities and unused are handled above in rn_rec_stmts_and_then
- rnValBindsRHS all_bndrs binds'
+ rnValBindsRHS (mkNameSet all_bndrs) binds'
returnM [(duDefs du_binds, duUses du_binds,
emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
srcSpanPrimLit :: SrcSpan -> HsExpr Name
srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span))))
-mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
+mkAssertErrorExpr :: RnM (HsExpr Name)
-- Return an expression for (assertError "Foo.hs:27")
mkAssertErrorExpr
= getSrcSpanM `thenM` \ sloc ->
- let
- expr = HsApp (L sloc (HsVar assertErrorName))
- (L sloc (srcSpanPrimLit sloc))
- in
- returnM (expr, emptyFVs)
+ return (HsApp (L sloc (HsVar assertErrorName))
+ (L sloc (srcSpanPrimLit sloc)))
\end{code}
+Note [Adding the implicit parameter to 'assert']
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
+By doing this in the renamer we allow the typechecker to just see the
+expanded application and do the right thing. But it's not really
+the Right Thing because there's no way to "undo" if you want to see
+the original source code. We'll have fix this in due course, when
+we care more about being able to reconstruct the exact original
+program.
+
%************************************************************************
%* *
\subsubsection{Errors}
msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
---------
+sectionErr :: HsExpr RdrName -> SDoc
+sectionErr expr
+ = hang (ptext (sLit "A section must be enclosed in parentheses"))
+ 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
+
patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
nest 4 (ppr e)])
projects / ghc-hetmet.git / blobdiff