free variables.
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module RnExpr (
rnLExpr, rnExpr, rnStmts
) where
#include "HsVersions.h"
import RnSource ( rnSrcDecls, rnSplice, checkTH )
-import RnBinds ( rnLocalBindsAndThen, rnValBinds,
- rnMatchGroup, trimWith )
+import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
+ rnMatchGroup, makeMiniFixityEnv)
import HsSyn
-import RnHsSyn
import TcRnMonad
import RnEnv
+import HscTypes ( availNames )
import RnNames ( getLocalDeclBinders, extendRdrEnvRn )
-import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
- mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec,
- dupFieldErr, checkTupSize )
+import RnTypes ( rnHsTypeFVs,
+ mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
+import RnPat (rnOverLit, rnPatsAndThen_LocalRightwards, rnPat_LocalRec, localNameMaker,
+ rnLit,
+ rnHsRecFields_Con, rnHsRecFields_Update, checkTupSize)
import DynFlags ( DynFlag(..) )
import BasicTypes ( FixityDirection(..) )
import SrcLoc ( SrcSpan )
import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName,
loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
negateName, thenMName, bindMName, failMName )
-#if defined(GHCI) && defined(BREAKPOINT)
-import PrelNames ( breakpointJumpName, breakpointCondJumpName
- , undefined_RDR, breakpointIdKey, breakpointCondIdKey )
-import UniqFM ( eltsUFM )
-import DynFlags ( GhcMode(..) )
-import Name ( isTyVarName )
-#endif
+
import Name ( Name, nameOccName, nameIsLocalOrFrom )
import NameSet
+import UniqFM
import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals )
import LoadIface ( loadInterfaceForName )
import UniqFM ( isNullUFM )
import ListSetOps ( removeDups )
import Maybes ( expectJust )
import Outputable
-import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated )
+import SrcLoc ( Located(..), unLoc, getLoc )
import FastString
import List ( unzip4 )
rnExpr (HsVar v)
= do name <- lookupOccRn v
- localRdrEnv <- getLocalRdrEnv
- lclEnv <- getLclEnv
ignore_asserts <- doptM Opt_IgnoreAsserts
- ignore_breakpoints <- doptM Opt_IgnoreBreakpoints
- ghcMode <- getGhcMode
- let conds = [ (name `hasKey` assertIdKey
- && not ignore_asserts,
- do (e, fvs) <- mkAssertErrorExpr
- return (e, fvs `addOneFV` name))
-#if defined(GHCI) && defined(BREAKPOINT)
- , (name `hasKey` breakpointIdKey
- && not ignore_breakpoints
- && ghcMode == Interactive,
- do let isWantedName = not.isTyVarName
- (e, fvs) <- mkBreakpointExpr (filter isWantedName (eltsUFM localRdrEnv))
- return (e, fvs `addOneFV` name)
- )
- , (name `hasKey` breakpointCondIdKey
- && not ignore_breakpoints
- && ghcMode == Interactive,
- do let isWantedName = not.isTyVarName
- (e, fvs) <- mkBreakpointCondExpr (filter isWantedName (eltsUFM localRdrEnv))
- return (e, fvs `addOneFV` name)
- )
-#endif
- ]
- case lookup True conds of
- Just action -> action
- Nothing -> return (HsVar name, unitFV name)
+ 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) }
rnExpr (HsIPVar v)
= newIPNameRn v `thenM` \ name ->
returnM (HsIPVar name, emptyFVs)
+rnExpr (HsLit lit@(HsString s))
+ = do {
+ opt_OverloadedStrings <- doptM Opt_OverloadedStrings
+ ; if opt_OverloadedStrings then
+ rnExpr (HsOverLit (mkHsIsString s placeHolderType))
+ else -- Same as below
+ rnLit lit `thenM_`
+ returnM (HsLit lit, emptyFVs)
+ }
+
rnExpr (HsLit lit)
= rnLit lit `thenM_`
returnM (HsLit lit, emptyFVs)
rnExpr (HsSCC lbl expr)
= rnLExpr expr `thenM` \ (expr', fvs_expr) ->
returnM (HsSCC lbl expr', fvs_expr)
+rnExpr (HsTickPragma info expr)
+ = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
+ returnM (HsTickPragma info expr', fvs_expr)
rnExpr (HsLam matches)
= rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
rnExpr (ExplicitList _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
- returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
+ returnM (ExplicitList placeHolderType exps', fvs)
rnExpr (ExplicitPArr _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
returnM (ExplicitPArr placeHolderType exps', fvs)
rnExpr e@(ExplicitTuple exps boxity)
- = checkTupSize tup_size `thenM_`
+ = checkTupSize (length exps) `thenM_`
rnExprs exps `thenM` \ (exps', fvs) ->
- returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
- where
- tup_size = length exps
- tycon_name = tupleTyCon_name boxity tup_size
+ returnM (ExplicitTuple exps' boxity, fvs)
rnExpr (RecordCon con_id _ rbinds)
- = lookupLocatedOccRn con_id `thenM` \ conname ->
- rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
- returnM (RecordCon conname noPostTcExpr rbinds',
- fvRbinds `addOneFV` unLoc conname)
+ = do { conname <- lookupLocatedOccRn con_id
+ ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds
+ ; return (RecordCon conname noPostTcExpr rbinds',
+ fvRbinds `addOneFV` unLoc conname) }
-rnExpr (RecordUpd expr rbinds _ _)
- = rnLExpr expr `thenM` \ (expr', fvExpr) ->
- rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
- returnM (RecordUpd expr' rbinds' placeHolderType placeHolderType,
- fvExpr `plusFV` fvRbinds)
+rnExpr (RecordUpd expr rbinds _ _ _)
+ = do { (expr', fvExpr) <- rnLExpr expr
+ ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds
+ ; return (RecordUpd expr' rbinds' [] [] [],
+ fvExpr `plusFV` fvRbinds) }
rnExpr (ExprWithTySig expr pty)
- = rnLExpr expr `thenM` \ (expr', fvExpr) ->
- rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
- returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
+ = do { (pty', fvTy) <- rnHsTypeFVs doc pty
+ ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
+ rnLExpr expr
+ ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
where
doc = text "In an expression type signature"
\begin{code}
rnExpr (HsProc pat body)
= newArrowScope $
- rnPatsAndThen ProcExpr [pat] $ \ [pat'] ->
+ rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ ([pat'],_) ->
rnCmdTop body `thenM` \ (body',fvBody) ->
returnM (HsProc pat' body', fvBody)
returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
- -- HsCoerce
+ -- HsWrap
\end{code}
plusFVs [fvExpr1, fvExpr2, fvExpr3])
\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
-%* *
-%************************************************************************
-
-\begin{code}
-rnRbinds str rbinds
- = mappM_ field_dup_err dup_fields `thenM_`
- mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
- returnM (rbinds', fvRbind)
- where
- (_, dup_fields) = removeDups cmpLocated [ f | (f,_) <- rbinds ]
-
- field_dup_err dups = mappM_ (\f -> addLocErr f (dupFieldErr str)) dups
-
- rn_rbind (field, expr)
- = lookupLocatedGlobalOccRn field `thenM` \ fieldname ->
- rnLExpr expr `thenM` \ (expr', fvExpr) ->
- returnM ((fieldname, expr'), fvExpr `addOneFV` unLoc fieldname)
-\end{code}
-
%************************************************************************
%* *
Template Haskell brackets
rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr e', fvs) }
-rnBracket (PatBr p) = do { (p', fvs) <- rnLPat p
- ; return (PatBr p', fvs) }
+
+rnBracket (PatBr p) = do { addErr (ptext SLIT("Tempate Haskell pattern brackets are not supported yet"));
+ failM }
+
rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
; return (TypBr t', fvs) }
where
doc = ptext SLIT("In a Template-Haskell quoted type")
rnBracket (DecBr group)
- = do { gbl_env <- getGblEnv
-
- ; let gbl_env1 = gbl_env { tcg_mod = thFAKE }
- -- Note the 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.
+ = 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 {
- ; names <- getLocalDeclBinders gbl_env1 group
-
- ; let new_occs = map nameOccName names
- trimmed_rdr_env = hideSomeUnquals (tcg_rdr_env gbl_env) new_occs
-
- ; rdr_env' <- extendRdrEnvRn trimmed_rdr_env names
-- In this situation we want to *shadow* top-level bindings.
-- foo = 1
- -- bar = [d| 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 the call to hideSomeUnquals, which removes
- -- the unqualified bindings of things defined by the bracket
+ -- The shadowing is acheived by calling rnSrcDecls with True as the shadowing flag
+ ; (tcg_env, group') <- rnSrcDecls True group
- ; setGblEnv (gbl_env { tcg_rdr_env = rdr_env',
- tcg_dus = emptyDUs }) $ do
- -- The emptyDUs is so that we just collect uses for this group alone
-
- { (tcg_env, group') <- rnSrcDecls group
- -- Discard the tcg_env; it contains only extra info about fixity
+ -- Discard the tcg_env; it contains only extra info about fixity
; return (DecBr group', allUses (tcg_dus tcg_env)) } }
\end{code}
<- rnStmt ctxt stmt $
rnNormalStmts ctxt stmts thing_inside
; return (((L loc stmt' : stmts'), thing), fvs) }
-
+
+
rnStmt :: HsStmtContext Name -> Stmt RdrName
-> RnM (thing, FreeVars)
-> RnM ((Stmt Name, thing), FreeVars)
-- The binders do not scope over the expression
; (bind_op, fvs1) <- lookupSyntaxName bindMName
; (fail_op, fvs2) <- lookupSyntaxName failMName
- ; rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
+ ; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ ([pat'],_) -> do
{ (thing, fvs3) <- thing_inside
; return ((BindStmt pat' expr' bind_op fail_op, thing),
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
- -- fv_expr shouldn't really be filtered by the rnPatsAndThen
+ -- fv_expr shouldn't really be filtered by the rnPatsAndThen
-- but it does not matter because the names are unique
rnStmt ctxt (LetStmt binds) thing_inside
ok _ _ = True
rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
- = bindLocatedLocalsRn doc (collectLStmtsBinders rec_stmts) $ \ bndrs ->
- rn_rec_stmts bndrs rec_stmts `thenM` \ segs ->
+ =
+ rn_rec_stmts_and_then rec_stmts $ \ segs ->
thing_inside `thenM` \ (thing, fvs) ->
let
segs_w_fwd_refs = addFwdRefs segs
doc = text "In a recursive do statement"
rnStmt ctxt (ParStmt segs) thing_inside
- = do { opt_GlasgowExts <- doptM Opt_GlasgowExts
- ; checkM opt_GlasgowExts parStmtErr
+ = do { parallel_list_comp <- doptM Opt_ParallelListComp
+ ; checkM parallel_list_comp parStmtErr
; orig_lcl_env <- getLocalRdrEnv
; ((segs',thing), fvs) <- go orig_lcl_env [] segs
; return ((ParStmt segs', thing), fvs) }
----------------------------------------------------
+
rnMDoStmts :: [LStmt RdrName]
-> RnM (thing, FreeVars)
-> RnM (([LStmt Name], thing), FreeVars)
rnMDoStmts stmts thing_inside
- = -- Step1: bring all the binders of the mdo into scope
- -- Remember that this also removes the binders from the
- -- finally-returned free-vars
- bindLocatedLocalsRn doc (collectLStmtsBinders stmts) $ \ bndrs ->
- do {
- -- Step 2: Rename each individual stmt, making a
- -- singleton segment. At this stage the FwdRefs field
- -- isn't finished: it's empty for all except a BindStmt
- -- for which it's the fwd refs within the bind itself
- -- (This set may not be empty, because we're in a recursive
- -- context.)
- segs <- rn_rec_stmts bndrs stmts
+ = -- Step1: Bring all the binders of the mdo into scope
+ -- (Remember that this also removes the binders from the
+ -- finally-returned free-vars.)
+ -- And rename each individual stmt, making a
+ -- singleton segment. At this stage the FwdRefs field
+ -- isn't finished: it's empty for all except a BindStmt
+ -- for which it's the fwd refs within the bind itself
+ -- (This set may not be empty, because we're in a recursive
+ -- context.)
+ rn_rec_stmts_and_then stmts $ \ segs -> do {
; (thing, fvs_later) <- thing_inside
; let
- -- Step 3: Fill in the fwd refs.
+ -- Step 2: Fill in the fwd refs.
-- The segments are all singletons, but their fwd-ref
-- field mentions all the things used by the segment
-- that are bound after their use
segs_w_fwd_refs = addFwdRefs segs
- -- Step 4: Group together the segments to make bigger segments
+ -- Step 3: Group together the segments to make bigger segments
-- Invariant: in the result, no segment uses a variable
-- bound in a later segment
grouped_segs = glomSegments segs_w_fwd_refs
- -- Step 5: Turn the segments into Stmts
+ -- Step 4: Turn the segments into Stmts
-- Use RecStmt when and only when there are fwd refs
-- Also gather up the uses from the end towards the
-- start, so we can tell the RecStmt which things are
doc = text "In a recursive mdo-expression"
---------------------------------------------
-rn_rec_stmts :: [Name] -> [LStmt RdrName] -> RnM [Segment (LStmt Name)]
-rn_rec_stmts bndrs stmts = mappM (rn_rec_stmt bndrs) stmts `thenM` \ segs_s ->
- returnM (concat segs_s)
-----------------------------------------------------
-rn_rec_stmt :: [Name] -> LStmt RdrName -> RnM [Segment (LStmt Name)]
+-- wrapper that does both the left- and right-hand sides
+rn_rec_stmts_and_then :: [LStmt RdrName]
+ -- assumes that the FreeVars returned includes
+ -- the FreeVars of the Segments
+ -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+rn_rec_stmts_and_then s cont = do
+ -- (A) make the mini fixity env for all of the stmts
+ fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
+
+ -- (B) do the LHSes
+ new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
+
+ -- bring them and their fixities into scope
+ let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
+ bindLocalNamesFV_WithFixities bound_names fix_env $ do
+
+ -- (C) do the right-hand-sides and thing-inside
+ segs <- rn_rec_stmts bound_names new_lhs_and_fv
+ (result, result_fvs) <- cont segs
+
+ -- (D) warn about unusued binders
+ let unused_bndrs = [ b | b <- bound_names, not (b `elemNameSet` result_fvs)]
+ warnUnusedLocalBinds unused_bndrs
+
+ -- (E) return
+ return (result, result_fvs)
+
+
+-- get all the fixity decls in any Let stmt
+collectRecStmtsFixities l =
+ foldr (\ s -> \acc -> case s of
+ (L loc (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
+ foldr (\ sig -> \ acc -> case sig of
+ (L loc (FixSig s)) -> (L loc s) : acc
+ _ -> acc) acc sigs
+ _ -> acc) [] l
+
+-- left-hand sides
+
+rn_rec_stmt_lhs :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
+ -- these fixities need to be brought into scope with the names
+ -> LStmt RdrName
+ -- rename LHS, and return its FVs
+ -- Warning: we will only need the FreeVars below in the case of a BindStmt,
+ -- so we don't bother to compute it accurately in the other cases
+ -> RnM [(LStmtLR Name RdrName, FreeVars)]
+
+rn_rec_stmt_lhs fix_env (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
+ -- this is actually correct
+ emptyFVs)]
+
+rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
+ = do
+ -- should the ctxt be MDo instead?
+ (pat', fv_pat) <- rnPat_LocalRec fix_env pat
+ return [(L loc (BindStmt pat' expr a b),
+ fv_pat)]
+
+rn_rec_stmt_lhs fix_env (L loc (LetStmt binds@(HsIPBinds _)))
+ = do { addErr (badIpBinds (ptext SLIT("an mdo expression")) binds)
+ ; failM }
+
+rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
+ = do binds' <- rnValBindsLHS fix_env binds
+ return [(L loc (LetStmt (HsValBinds binds')),
+ -- Warning: this is bogus; see function invariant
+ emptyFVs
+ )]
+
+rn_rec_stmt_lhs fix_env (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
+ = rn_rec_stmts_lhs fix_env stmts
+
+rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
+ = pprPanic "rn_rec_stmt" (ppr stmt)
+
+rn_rec_stmts_lhs :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
+ -- these fixities need to be brought into scope with the names
+ -> [LStmt RdrName]
+ -> RnM [(LStmtLR Name RdrName, FreeVars)]
+rn_rec_stmts_lhs fix_env stmts =
+ let boundNames = collectLStmtsBinders stmts
+ doc = text "In a recursive mdo-expression"
+ in do
+ -- First do error checking: we need to check for dups here because we
+ -- don't bind all of the variables from the Stmt at once
+ -- with bindLocatedLocals.
+ checkDupNames doc boundNames
+ mappM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> returnM (concat ls)
+
+
+-- right-hand-sides
+
+rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
-- Rename a Stmt that is inside a RecStmt (or mdo)
-- Assumes all binders are already in scope
-- Turns each stmt into a singleton Stmt
-
-rn_rec_stmt all_bndrs (L loc (ExprStmt expr _ _))
- = rnLExpr expr `thenM` \ (expr', fvs) ->
+rn_rec_stmt all_bndrs (L loc (ExprStmt expr _ _)) _
+ = rnLExpr expr `thenM` \ (expr', fvs) ->
lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
returnM [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
L loc (ExprStmt expr' then_op placeHolderType))]
-rn_rec_stmt all_bndrs (L loc (BindStmt pat expr _ _))
+rn_rec_stmt all_bndrs (L loc (BindStmt pat' expr _ _)) fv_pat
= rnLExpr expr `thenM` \ (expr', fv_expr) ->
- rnLPat pat `thenM` \ (pat', fv_pat) ->
lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
let
returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
L loc (BindStmt pat' expr' bind_op fail_op))]
-rn_rec_stmt all_bndrs (L loc (LetStmt binds@(HsIPBinds _)))
+rn_rec_stmt all_bndrs (L loc (LetStmt binds@(HsIPBinds _))) _
= do { addErr (badIpBinds (ptext SLIT("an mdo expression")) binds)
; failM }
-rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds)))
- = rnValBinds (trimWith all_bndrs) binds `thenM` \ (binds', du_binds) ->
- returnM [(duDefs du_binds, duUses du_binds,
- emptyNameSet, L loc (LetStmt (HsValBinds 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'
+ returnM [(duDefs du_binds, duUses du_binds,
+ emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
-rn_rec_stmt all_bndrs (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
- = rn_rec_stmts all_bndrs stmts
+-- no RecStmt case becuase they get flattened above when doing the LHSes
+rn_rec_stmt all_bndrs stmt@(L loc (RecStmt stmts _ _ _ _)) _
+ = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
-rn_rec_stmt all_bndrs stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
- = pprPanic "rn_rec_stmt" (ppr stmt)
+rn_rec_stmt all_bndrs stmt@(L _ (ParStmt _)) _ -- Syntactically illegal in mdo
+ = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
+
+rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
+rn_rec_stmts bndrs stmts = mappM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s ->
+ returnM (concat segs_s)
---------------------------------------------
addFwdRefs :: [Segment a] -> [Segment a]
%************************************************************************
%* *
-\subsubsection{breakpoint utils}
+\subsubsection{Assertion utils}
%* *
%************************************************************************
\begin{code}
-#if defined(GHCI) && defined(BREAKPOINT)
-mkBreakpointExpr :: [Name] -> RnM (HsExpr Name, FreeVars)
-mkBreakpointExpr = mkBreakpointExpr' breakpointJumpName
-
-mkBreakpointCondExpr :: [Name] -> RnM (HsExpr Name, FreeVars)
-mkBreakpointCondExpr = mkBreakpointExpr' breakpointCondJumpName
-
-mkBreakpointExpr' :: Name -> [Name] -> RnM (HsExpr Name, FreeVars)
-mkBreakpointExpr' breakpointFunc scope
- = do sloc <- getSrcSpanM
- undef <- lookupOccRn undefined_RDR
- let inLoc = L sloc
- lHsApp x y = inLoc (HsApp x y)
- mkExpr fnName args = mkExpr' fnName (reverse args)
- mkExpr' fnName [] = inLoc (HsVar fnName)
- mkExpr' fnName (arg:args)
- = lHsApp (mkExpr' fnName args) (inLoc arg)
- expr = unLoc $ mkExpr breakpointFunc [mkScopeArg scope, HsVar undef, msg]
- mkScopeArg args = unLoc $ mkExpr undef (map HsVar args)
- msg = srcSpanLit sloc
- return (expr, emptyFVs)
-
-srcSpanLit :: SrcSpan -> HsExpr Name
-srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
-#endif
-
srcSpanPrimLit :: SrcSpan -> HsExpr Name
srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span))))
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Assertion utils}
-%* *
-%************************************************************************
-\begin{code}
mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
-- Return an expression for (assertError "Foo.hs:27")
mkAssertErrorExpr
nest 4 (ppr e)])
; return (EWildPat, emptyFVs) }
-parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))
+parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -XParallelListComp"))
badIpBinds what binds
= hang (ptext SLIT("Implicit-parameter bindings illegal in") <+> what)
2 (ppr binds)
\end{code}
+
+
projects / ghc-hetmet.git / blobdiff