#endif /* GHCI */
import RnSource ( rnSrcDecls, findSplice )
-import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
+import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
rnMatchGroup, makeMiniFixityEnv)
import HsSyn
import TcRnMonad
import RnTypes ( rnHsTypeFVs, rnSplice, checkTH,
mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
import RnPat
-import DynFlags ( DynFlag(..) )
+import DynFlags
import BasicTypes ( FixityDirection(..) )
import PrelNames
rnExpr (HsLit lit@(HsString s))
= do {
- opt_OverloadedStrings <- doptM Opt_OverloadedStrings
+ opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
; if opt_OverloadedStrings then
rnExpr (HsOverLit (mkHsIsString s placeHolderType))
else -- Same as below
rnLExpr arg `thenM` \ (arg',fvArg) ->
return (HsApp fun' arg', fvFun `plusFV` fvArg)
-rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
- = do { (e1', fv_e1) <- rnLExpr e1
+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
; 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 (OpApp _ other_op _ _)
+ = failWith (vcat [ hang (ptext (sLit "Operator application with a non-variable operator:"))
+ 2 (ppr other_op)
+ , ptext (sLit "(Probably resulting from a Template Haskell splice)") ])
rnExpr (NegApp e _)
= rnLExpr e `thenM` \ (e', fv_e) ->
rnLExpr expr `thenM` \ (expr',fvExpr) ->
return (HsLet binds' expr', fvExpr)
-rnExpr (HsDo do_or_lc stmts body _)
- = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
- rnLExpr body
- ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
+rnExpr (HsDo do_or_lc stmts _)
+ = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ())
+ ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
rnExpr (ExplicitList _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
where
doc = text "In an expression type signature"
-rnExpr (HsIf p b1 b2)
- = rnLExpr p `thenM` \ (p', fvP) ->
- rnLExpr b1 `thenM` \ (b1', fvB1) ->
- rnLExpr b2 `thenM` \ (b2', fvB2) ->
- return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
+rnExpr (HsIf _ p b1 b2)
+ = do { (p', fvP) <- rnLExpr p
+ ; (b1', fvB1) <- rnLExpr b1
+ ; (b2', fvB2) <- rnLExpr b2
+ ; (mb_ite, fvITE) <- lookupIfThenElse
+ ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
rnExpr (HsType a)
= rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
-- infix form
rnExpr (HsArrForm op (Just _) [arg1, arg2])
= escapeArrowScope (rnLExpr op)
- `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
+ `thenM` \ (op',fv_op) ->
+ let L _ (HsVar op_name) = op' in
rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
convertOpFormsCmd (HsCase exp matches)
= HsCase exp (convertOpFormsMatch matches)
-convertOpFormsCmd (HsIf exp c1 c2)
- = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
+convertOpFormsCmd (HsIf f exp c1 c2)
+ = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
convertOpFormsCmd (HsLet binds cmd)
= HsLet binds (convertOpFormsLCmd cmd)
-convertOpFormsCmd (HsDo ctxt stmts body ty)
+convertOpFormsCmd (HsDo ctxt stmts body return_op ty)
= HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
- (convertOpFormsLCmd body) ty
+ (convertOpFormsLCmd body)
+ (convertOpFormsCmd return_op) ty
-- Anything else is unchanged. This includes HsArrForm (already done),
-- things with no sub-commands, and illegal commands (which will be
convertOpFormsStmt :: StmtLR id id -> StmtLR id id
convertOpFormsStmt (BindStmt pat cmd _ _)
= BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
-convertOpFormsStmt (ExprStmt cmd _ _)
- = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
+convertOpFormsStmt (ExprStmt cmd _ _ _)
+ = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType
convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
= stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
convertOpFormsStmt stmt = stmt
methodNamesCmd (HsPar c) = methodNamesLCmd c
-methodNamesCmd (HsIf _ c1 c2)
+methodNamesCmd (HsIf _ _ c1 c2)
= methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
methodNamesCmd (HsLet _ c) = methodNamesLCmd c
-methodNamesCmd (HsDo _ stmts body _)
+methodNamesCmd (HsDo _ stmts body _ _)
= methodNamesStmts stmts `plusFV` methodNamesLCmd body
methodNamesCmd (HsApp c _) = methodNamesLCmd c
methodNamesLStmt = methodNamesStmt . unLoc
methodNamesStmt :: StmtLR Name Name -> FreeVars
-methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
+methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd
methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
methodNamesStmt (LetStmt _) = emptyFVs
-methodNamesStmt (ParStmt _) = emptyFVs
+methodNamesStmt (ParStmt _ _ _ _) = emptyFVs
methodNamesStmt (TransformStmt {}) = emptyFVs
methodNamesStmt (GroupStmt {}) = emptyFVs
-- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
setStage thRnBrack $
rnSrcDecls group
- -- Discard the tcg_env; it contains only extra info about fixity
- ; return (DecBrG group', allUses (tcg_dus tcg_env)) }
+ -- Discard the tcg_env; it contains only extra info about fixity
+ ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
+ ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
\end{code}
%************************************************************************
\begin{code}
-rnStmts :: HsStmtContext Name -> [LStmt RdrName]
- -> RnM (thing, FreeVars)
- -> RnM (([LStmt Name], thing), FreeVars)
--- Variables bound by the Stmts, and mentioned in thing_inside,
--- do not appear in the result FreeVars
-
-rnStmts (MDoExpr _) stmts thing_inside = rnMDoStmts stmts thing_inside
-rnStmts ctxt stmts thing_inside = rnNormalStmts ctxt stmts (\ _ -> thing_inside)
-
-rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
+rnStmts :: HsStmtContext Name -> [LStmt RdrName]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt Name], thing), FreeVars)
-- Variables bound by the Stmts, and mentioned in thing_inside,
--
-- Renaming a single RecStmt can give a sequence of smaller Stmts
-rnNormalStmts _ [] thing_inside
- = do { (res, fvs) <- thing_inside []
- ; return (([], res), fvs) }
+rnStmts ctxt [] thing_inside
+ = do { addErr (ptext (sLit "Empty") <+> pprStmtContext ctxt)
+ ; (thing, fvs) <- thing_inside []
+ ; return (([], thing), fvs) }
+
+rnStmts MDoExpr stmts thing_inside -- Deal with mdo
+ = -- Behave like do { rec { ...all but last... }; last }
+ do { ((stmts1, (stmts2, thing)), fvs)
+ <- rnStmt MDoExpr (mkRecStmt all_but_last) $ \ bndrs ->
+ do { checkStmt MDoExpr True last_stmt
+ ; rnStmt MDoExpr last_stmt thing_inside }
+ ; return (((stmts1 ++ stmts2), thing), fvs) }
+ where
+ Just (all_but_last, last_stmt) = snocView stmts
-rnNormalStmts ctxt (stmt@(L loc _) : stmts) thing_inside
+rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside
+ | null stmts
+ = setSrcSpan loc $
+ do { let last_stmt = case stmt of
+ ExprStmt e _ _ _ -> LastStmt e noSyntaxExpr
+ ; checkStmt ctxt True {- last stmt -} stmt
+ ; rnStmt ctxt stmt thing_inside }
+
+ | otherwise
= do { ((stmts1, (stmts2, thing)), fvs)
- <- setSrcSpan loc $
- rnStmt ctxt stmt $ \ bndrs1 ->
- rnNormalStmts ctxt stmts $ \ bndrs2 ->
- thing_inside (bndrs1 ++ bndrs2)
+ <- setSrcSpan loc $
+ do { checkStmt ctxt False {- Not last -} stmt
+ ; rnStmt ctxt stmt $ \ bndrs1 ->
+ rnStmts ctxt stmts $ \ bndrs2 ->
+ thing_inside (bndrs1 ++ bndrs2) }
; return (((stmts1 ++ stmts2), thing), fvs) }
-
-rnStmt :: HsStmtContext Name -> LStmt RdrName
+----------------------
+rnStmt :: HsStmtContext Name
+ -> LStmt RdrName
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt Name], thing), FreeVars)
-- Variables bound by the Stmt, and mentioned in thing_inside,
-- do not appear in the result FreeVars
-rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
+rnStmt ctxt (L loc (LastStmt expr _)) thing_inside
+ = do { (expr', fv_expr) <- rnLExpr expr
+ ; (ret_op, fvs1) <- lookupSyntaxName returnMName
+ ; (thing, fvs3) <- thing_inside []
+ ; return (([L loc (LastStmt expr' ret_op)], thing),
+ fv_expr `plusFV` fvs1 `plusFV` fvs3) }
+
+rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside
= do { (expr', fv_expr) <- rnLExpr expr
; (then_op, fvs1) <- lookupSyntaxName thenMName
- ; (thing, fvs2) <- thing_inside []
- ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
- fv_expr `plusFV` fvs1 `plusFV` fvs2) }
+ ; (guard_op, fvs2) <- if isMonadCompExpr ctxt
+ then lookupSyntaxName guardMName
+ else return (noSyntaxExpr, emptyFVs)
+ ; (thing, fvs3) <- thing_inside []
+ ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing),
+ fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
- = do { (expr', fv_expr) <- rnLExpr expr
+ = do { checkBindStmt ctxt is_last
+ ; (expr', fv_expr) <- rnLExpr expr
-- The binders do not scope over the expression
; (bind_op, fvs1) <- lookupSyntaxName bindMName
; (fail_op, fvs2) <- lookupSyntaxName failMName
; return (([L loc (LetStmt binds')], thing), fvs) } }
rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
- = do { checkRecStmt ctxt
-
+ = do {
-- Step1: Bring all the binders of the mdo into scope
-- (Remember that this also removes the binders from the
-- finally-returned free-vars.)
-- 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 rec_stmts $ \ segs -> do
+ ; rnRecStmtsAndThen rec_stmts $ \ segs -> do
{ let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
emptyNameSet segs
; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
-rnStmt ctxt (L loc (ParStmt segs)) thing_inside
- = do { checkParStmt ctxt
- ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
- ; return (([L loc (ParStmt segs')], thing), fvs) }
-
-rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
- = do { checkTransformStmt ctxt
-
- ; (using', fvs1) <- rnLExpr using
+rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
+ = do { ((mzip_op, fvs1), (bind_op, fvs2), (return_op, fvs3)) <- if isMonadCompExpr ctxt
+ then (,,) <$> lookupSyntaxName mzipName
+ <*> lookupSyntaxName bindMName
+ <*> lookupSyntaxName returnMName
+ else return ( (noSyntaxExpr, emptyFVs)
+ , (noSyntaxExpr, emptyFVs)
+ , (noSyntaxExpr, emptyFVs) )
+ ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
+ ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
+ , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
+
+rnStmt ctxt (L loc (TransformStmt stmts _ using by _ _)) thing_inside
+ = do { (using', fvs1) <- rnLExpr using
; ((stmts', (by', used_bndrs, thing)), fvs2)
- <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
+ <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
do { (by', fvs_by) <- case by of
Nothing -> return (Nothing, emptyFVs)
Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = fvs_by `plusFV` fvs_thing
- used_bndrs = filter (`elemNameSet` fvs_thing) bndrs
+ used_bndrs = filter (`elemNameSet` fvs) bndrs
+ -- The paper (Fig 5) has a bug here; we must treat any free varaible of
+ -- the "thing inside", **or of the by-expression**, as used
; return ((by', used_bndrs, thing), fvs) }
- ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
- fvs1 `plusFV` fvs2) }
+ -- Lookup `(>>=)` and `fail` for monad comprehensions
+ ; ((return_op, fvs3), (bind_op, fvs4)) <-
+ if isMonadCompExpr ctxt
+ then (,) <$> lookupSyntaxName returnMName
+ <*> lookupSyntaxName bindMName
+ else return ( (noSyntaxExpr, emptyFVs)
+ , (noSyntaxExpr, emptyFVs) )
+
+ ; return (([L loc (TransformStmt stmts' used_bndrs using' by' return_op bind_op)], thing),
+ fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
-rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
- = do { checkTransformStmt ctxt
-
- -- Rename the 'using' expression in the context before the transform is begun
+rnStmt ctxt (L loc (GroupStmt stmts _ by using _ _ _)) thing_inside
+ = do { -- Rename the 'using' expression in the context before the transform is begun
; (using', fvs1) <- case using of
Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
- Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
- ; return (Right e', fvs) }
+ Right _
+ | isMonadCompExpr ctxt ->
+ do { (e', fvs) <- lookupSyntaxName groupMName
+ ; return (Right e', fvs) }
+ | otherwise ->
+ do { (e', fvs) <- lookupSyntaxName groupWithName
+ ; return (Right e', fvs) }
-- Rename the stmts and the 'by' expression
-- Keep track of the variables mentioned in the 'by' expression
; ((stmts', (by', used_bndrs, thing)), fvs2)
- <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
+ <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = fvs_by `plusFV` fvs_thing
used_bndrs = filter (`elemNameSet` fvs) bndrs
; return ((by', used_bndrs, thing), fvs) }
- ; let all_fvs = fvs1 `plusFV` fvs2
+ -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
+ ; ((return_op, fvs3), (bind_op, fvs4), (fmap_op, fvs5)) <-
+ if isMonadCompExpr ctxt
+ then (,,) <$> lookupSyntaxName returnMName
+ <*> lookupSyntaxName bindMName
+ <*> lookupSyntaxName fmapName
+ else return ( (noSyntaxExpr, emptyFVs)
+ , (noSyntaxExpr, emptyFVs)
+ , (noSyntaxExpr, emptyFVs) )
+
+ ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4
+ `plusFV` fvs5
bndr_map = used_bndrs `zip` used_bndrs
-- See Note [GroupStmt binder map] in HsExpr
; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
- ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
-
+ ; return (([L loc (GroupStmt stmts' bndr_map by' using' return_op bind_op fmap_op)], thing), all_fvs) }
type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
rn_segs env bndrs_so_far ((stmts,_) : segs)
= do { ((stmts', (used_bndrs, segs', thing)), fvs)
- <- rnNormalStmts ctxt stmts $ \ bndrs ->
+ <- rnStmts ctxt stmts $ \ bndrs ->
setLocalRdrEnv env $ do
{ ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
; let used_bndrs = filter (`elemNameSet` fvs) bndrs
stmts) -- Either Stmt or [Stmt]
-----------------------------------------------------
-
-rnMDoStmts :: [LStmt RdrName]
- -> RnM (thing, FreeVars)
- -> RnM (([LStmt Name], thing), FreeVars)
-rnMDoStmts stmts thing_inside
- = rn_rec_stmts_and_then stmts $ \ segs -> do
- { (thing, fvs_later) <- thing_inside
- ; let segs_w_fwd_refs = addFwdRefs segs
- grouped_segs = glomSegments segs_w_fwd_refs
- (stmts', fvs) = segsToStmts emptyRecStmt grouped_segs fvs_later
- ; return ((stmts', thing), fvs) }
-
----------------------------------------------
-
-- wrapper that does both the left- and right-hand sides
-rn_rec_stmts_and_then :: [LStmt RdrName]
+rnRecStmtsAndThen :: [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
+rnRecStmtsAndThen s cont
= do { -- (A) Make the mini fixity env for all of the stmts
fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
-- ...bring them and their fixities into scope
; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
+ -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
+ implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
; bindLocalNamesFV bound_names $
addLocalFixities fix_env bound_names $ do
-- (C) do the right-hand-sides and thing-inside
{ segs <- rn_rec_stmts bound_names new_lhs_and_fv
; (res, fvs) <- cont segs
- ; warnUnusedLocalBinds bound_names fvs
+ ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses)
; return (res, fvs) }}
-- get all the fixity decls in any Let stmt
-- so we don't bother to compute it accurately in the other cases
-> RnM [(LStmtLR Name RdrName, FreeVars)]
-rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
- -- this is actually correct
- emptyFVs)]
+rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c)) = return [(L loc (ExprStmt expr a b c),
+ -- this is actually correct
+ emptyFVs)]
rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
= do
= failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
- = do (_bound_names, binds') <- rnValBindsLHS fix_env binds
+ = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
return [(L loc (LetStmt (HsValBinds binds')),
-- Warning: this is bogus; see function invariant
emptyFVs
rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
= rn_rec_stmts_lhs fix_env stmts
-rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
+rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _)) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt" (ppr stmt)
rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
-- 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 _ (L loc (ExprStmt expr _ _)) _
+rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _
= rnLExpr expr `thenM` \ (expr', fvs) ->
lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
- L loc (ExprStmt expr' then_op placeHolderType))]
+ L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))]
rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
= rnLExpr expr `thenM` \ (expr', fv_expr) ->
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 (mkNameSet all_bndrs) binds'
- return [(duDefs du_binds, duUses du_binds,
- emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
+ -- fixities and unused are handled above in rnRecStmtsAndThen
+ rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
+ return [(duDefs du_binds, allUses du_binds,
+ emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
-- no RecStmt case becuase they get flattened above when doing the LHSes
rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
%************************************************************************
\begin{code}
-
----------------------
-- Checking when a particular Stmt is ok
-checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
-checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
-checkLetStmt _ctxt _binds = return ()
+checkStmt :: HsStmtContext Name
+ -> Bool -- True <=> this is the last Stmt in the sequence
+ -> LStmt RdrName
+ -> RnM ()
+checkStmt ctxt is_last (L _ stmt)
+ = do { dflags <- getDOpts
+ ; case okStmt dflags ctxt is_last stmt of
+ Nothing -> return ()
+ Just extr -> addErr (msg $$ extra) }
+ where
+ msg = ptext (sLit "Unexpected") <+> pprStmtCat stmt
+ <+> ptext (sLit "statement in") <+> pprStmtContext ctxt
+
+pprStmtCat :: Stmt a -> SDoc
+pprStmtCat (TransformStmt {}) = ptext (sLit "transform")
+pprStmtCat (GroupStmt {}) = ptext (sLit "group")
+pprStmtCat (LastStmt {}) = ptext (sLit "return expression")
+pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion")
+pprStmtCat (BindStmt {}) = ptext (sLit "binding")
+pprStmtCat (LetStmt {}) = ptext (sLit "let")
+pprStmtCat (RecStmt {}) = ptext (sLit "rec")
+pprStmtCat (ParStmt {}) = ptext (sLit "parallel")
+
+------------
+isOK, notOK :: Maybe SDoc
+isOK = Nothing
+notOK = Just empty
+
+okStmt, okDoStmt, okCompStmt :: DynFlags -> HsStmtContext Name -> Bool
+ -> Stmt RdrName -> Maybe SDoc
+-- Return Nothing if OK, (Just extra) if not ok
+-- The "extra" is an SDoc that is appended to an generic error message
+okStmt dflags GhciStmt is_last stmt
+ = case stmt of
+ ExprStmt {} -> isOK
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ _ -> notOK
+
+okStmt dflags (PatGuard {}) is_last stmt
+ = case stmt of
+ ExprStmt {} -> isOK
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ _ -> notOK
+
+okStmt dflags (ParStmtCtxt ctxt) is_last stmt
+ = case stmt of
+ LetStmt (HsIPBinds {}) -> notOK
+ _ -> okStmt dflags ctxt is_last stmt
+
+okStmt dflags (TransformStmtCtxt ctxt) is_last stmt
+ = okStmt dflags ctxt is_last stmt
+
+okStmt ctxt is_last stmt
+ | isDoExpr ctxt = okDoStmt ctxt is_last stmt
+ | isCompExpr ctxt = okCompStmt ctxt is_last stmt
+ | otherwise = pprPanic "okStmt" (pprStmtContext ctxt)
+
+----------------
+okDoStmt dflags ctxt is_last stmt
+ | is_last
+ = case stmt of
+ LastStmt {} -> isOK
+ _ -> Just (ptext (sLit "The last statement in") <+> what <+>
+ ptext (sLIt "construct must be an expression"))
+ where
+ what = case ctxt of
+ DoExpr -> ptext (sLit "a 'do'")
+ MDoExpr -> ptext (sLit "an 'mdo'")
+ _ -> panic "checkStmt"
+
+ | otherwise
+ = case stmt of
+ RecStmt {} -> isOK -- Shouldn't we test a flag?
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ ExprStmt {} -> isOK
+ _ -> notOK
+
+
+----------------
+okCompStmt dflags ctxt is_last stmt
+ | is_last
+ = case stmt of
+ LastStmt {} -> Nothing
+ -> pprPanic "Unexpected stmt" (ppr stmt) -- Not a user error
+
+ | otherwise
+ = case stmt of
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ ExprStmt {} -> isOK
+ RecStmt {} -> notOK
+ ParStmt {}
+ | dopt dflags Opt_ParallelListComp -> isOK
+ | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
+ TransformStmt {}
+ | dopt dflags Opt_transformListComp -> isOK
+ | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
+ GroupStmt {}
+ | dopt dflags Opt_transformListComp -> isOK
+ | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
+
+
+checkStmt :: HsStmtContext Name -> Stmt RdrName -> Maybe SDoc
+-- Non-last stmt
+
+checkStmt (ParStmtCtxt _) (HsIPBinds binds)
+ = Just (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
-- We do not allow implicit-parameter bindings in a parallel
-- list comprehension. I'm not sure what it might mean.
----------
-checkRecStmt :: HsStmtContext Name -> RnM ()
-checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
-checkRecStmt (DoExpr {}) = return () -- and in 'do'
-checkRecStmt ctxt = addErr msg
- where
- msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
+checkStmt ctxt (RecStmt {})
+ | not (isDoExpr ctxt)
+ = addErr (ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
---------
checkParStmt :: HsStmtContext Name -> RnM ()
checkParStmt _
- = do { parallel_list_comp <- doptM Opt_ParallelListComp
- ; checkErr parallel_list_comp msg }
+ = do { monad_comp <- xoptM Opt_MonadComprehensions
+ ; unless monad_comp $ do
+ { parallel_list_comp <- xoptM Opt_ParallelListComp
+ ; checkErr parallel_list_comp msg }
+ }
where
- msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
+ msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp or -XMonadComprehensions")
---------
checkTransformStmt :: HsStmtContext Name -> RnM ()
checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
-- desugarer will break when we come to operate on a parallel array
- = do { transform_list_comp <- doptM Opt_TransformListComp
+ = do { transform_list_comp <- xoptM Opt_TransformListComp
; checkErr transform_list_comp msg }
where
- msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
+ msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp or -XMonadComprehensions")
+checkTransformStmt MonadComp -- Monad comprehensions are always fine, since the
+ -- MonadComprehensions flag will already be turned on
+ = do { return () }
checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
checkTransformStmt ctxt = addErr msg
---------
checkTupleSection :: [HsTupArg RdrName] -> RnM ()
checkTupleSection args
- = do { tuple_section <- doptM Opt_TupleSections
+ = do { tuple_section <- xoptM Opt_TupleSections
; checkErr (all tupArgPresent args || tuple_section) msg }
where
msg = ptext (sLit "Illegal tuple section: use -XTupleSections")