X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnExpr.lhs;h=11d44e3bad8b0796c65daf1d977b2b4e2f6b702d;hp=a3698352e0aebc8289cce467be4152a8e346b122;hb=f6d254cccd3dc25fff9ff50c2e1bea52b10345e4;hpb=27286cf2ce6733cbbf008972c6bea30ea2e562ee diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index a369835..11d44e3 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -21,7 +21,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr ) #endif /* GHCI */ import RnSource ( rnSrcDecls, findSplice ) -import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, +import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, rnMatchGroup, makeMiniFixityEnv) import HsSyn import TcRnMonad @@ -40,7 +40,7 @@ import RdrName import LoadIface ( loadInterfaceForName ) import UniqSet import Data.List -import Util ( isSingleton ) +import Util ( isSingleton, snocView ) import ListSetOps ( removeDups ) import Outputable import SrcLoc @@ -110,7 +110,7 @@ rnExpr (HsIPVar v) 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 @@ -131,8 +131,8 @@ rnExpr (HsApp fun arg) 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 @@ -146,6 +146,10 @@ rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ 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 (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) -> @@ -220,10 +224,9 @@ rnExpr (HsLet binds expr) 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 ((), emptyFVs)) + ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } rnExpr (ExplicitList _ exps) = rnExprs exps `thenM` \ (exps', fvs) -> @@ -262,11 +265,12 @@ rnExpr (ExprWithTySig expr pty) 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) -> @@ -320,7 +324,8 @@ rnExpr (HsArrApp arrow arg _ ho rtl) -- 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) -> @@ -429,15 +434,14 @@ convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c) 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) - = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) - (convertOpFormsLCmd body) ty +convertOpFormsCmd (HsDo ctxt stmts ty) + = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) ty -- Anything else is unchanged. This includes HsArrForm (already done), -- things with no sub-commands, and illegal commands (which will be @@ -447,8 +451,8 @@ convertOpFormsCmd c = c 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 @@ -486,17 +490,13 @@ methodNamesCmd (HsArrForm {}) = emptyFVs 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 _) - = methodNamesStmts stmts `plusFV` methodNamesLCmd body - -methodNamesCmd (HsApp c _) = methodNamesLCmd c - -methodNamesCmd (HsLam match) = methodNamesMatch match +methodNamesCmd (HsLet _ c) = methodNamesLCmd c +methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts +methodNamesCmd (HsApp c _) = methodNamesLCmd c +methodNamesCmd (HsLam match) = methodNamesMatch match methodNamesCmd (HsCase _ matches) = methodNamesMatch matches `addOneFV` choiceAName @@ -532,11 +532,12 @@ methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars methodNamesLStmt = methodNamesStmt . unLoc methodNamesStmt :: StmtLR Name Name -> FreeVars -methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (LastStmt 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 @@ -632,48 +633,66 @@ rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" %************************************************************************ \begin{code} -rnStmts :: HsStmtContext Name -> [LStmt RdrName] - -> RnM (thing, FreeVars) - -> RnM (([LStmt Name], thing), FreeVars) +rnStmts :: HsStmtContext Name -> [LStmt RdrName] + -> ([Name] -> 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] - -> ([Name] -> 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 --- --- Renaming a single RecStmt can give a sequence of smaller Stmts +rnStmts ctxt [] thing_inside + = do { checkEmptyStmts 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 (noLoc $ mkRecStmt all_but_last) $ \ _ -> + do { last_stmt' <- checkLastStmt MDoExpr last_stmt + ; rnStmt MDoExpr last_stmt' thing_inside } + ; return (((stmts1 ++ stmts2), thing), fvs) } + where + Just (all_but_last, last_stmt) = snocView stmts -rnNormalStmts _ [] thing_inside - = do { (res, fvs) <- thing_inside [] - ; return (([], res), fvs) } +rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside + | null lstmts + = setSrcSpan loc $ + do { lstmt' <- checkLastStmt ctxt lstmt + ; rnStmt ctxt lstmt' thing_inside } -rnNormalStmts ctxt (stmt@(L loc _) : stmts) 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 lstmt + ; rnStmt ctxt lstmt $ \ bndrs1 -> + rnStmts ctxt lstmts $ \ 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 _ (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 @@ -687,15 +706,13 @@ rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique -rnStmt ctxt (L loc (LetStmt binds)) thing_inside - = do { checkLetStmt ctxt binds - ; rnLocalBindsAndThen binds $ \binds' -> do +rnStmt _ (L loc (LetStmt binds)) thing_inside + = do { rnLocalBindsAndThen binds $ \binds' -> do { (thing, fvs) <- thing_inside (collectLocalBinders binds') ; return (([L loc (LetStmt binds')], thing), fvs) } } -rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside - = do { checkRecStmt ctxt - +rnStmt _ (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside + = do { -- Step1: Bring all the binders of the mdo into scope -- (Remember that this also removes the binders from the -- finally-returned free-vars.) @@ -705,7 +722,7 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside -- 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 @@ -737,55 +754,84 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside ; 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 - ; (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) } +rnStmt ctxt (L loc (GroupStmt { grpS_stmts = stmts, grpS_by = by, grpS_explicit = explicit + , grpS_using = using })) thing_inside + = do { -- Rename the 'using' expression in the context before the transform is begun + let implicit_name | isMonadCompExpr ctxt = groupMName + | otherwise = groupWithName + ; (using', fvs1) <- if explicit + then rnLExpr using + else do { (e,fvs) <- lookupSyntaxName implicit_name + ; return (noLoc 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 { grpS_stmts = stmts', grpS_bndrs = bndr_map + , grpS_by = by', grpS_using = using', grpS_explicit = explicit + , grpS_ret = return_op, grpS_bind = bind_op + , grpS_fmap = fmap_op })], thing), all_fvs) } type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts @@ -809,7 +855,7 @@ rnParallelStmts ctxt segs thing_inside 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 @@ -857,28 +903,13 @@ type Segment stmts = (Defs, 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) @@ -887,13 +918,15 @@ rn_rec_stmts_and_then s cont -- ...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 @@ -915,9 +948,11 @@ rn_rec_stmt_lhs :: MiniFixityEnv -- 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), emptyFVs)] + +rn_rec_stmt_lhs _ (L loc (LastStmt expr a)) + = return [(L loc (LastStmt expr a), emptyFVs)] rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b)) = do @@ -930,7 +965,7 @@ rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _))) = 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 @@ -940,7 +975,7 @@ rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) 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 @@ -971,11 +1006,17 @@ rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt -- 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 (LastStmt expr _)) _ + = do { (expr', fv_expr) <- rnLExpr expr + ; (ret_op, fvs1) <- lookupSyntaxName returnMName + ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, + L loc (LastStmt expr' ret_op))] } + +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) -> @@ -993,8 +1034,8 @@ rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _ 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' + -- 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')))] @@ -1155,49 +1196,136 @@ program. %************************************************************************ \begin{code} +checkEmptyStmts :: HsStmtContext Name -> RnM () +-- We've seen an empty sequence of Stmts... is that ok? +checkEmptyStmts ctxt + = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) ----------------------- --- 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 () - -- We do not allow implicit-parameter bindings in a parallel - -- list comprehension. I'm not sure what it might mean. +okEmpty :: HsStmtContext a -> Bool +okEmpty (PatGuard {}) = True +okEmpty _ = False ---------- -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 +emptyErr :: HsStmtContext Name -> SDoc +emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension") +emptyErr (TransformStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'") +emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt ---------- -checkParStmt :: HsStmtContext Name -> RnM () -checkParStmt _ - = do { parallel_list_comp <- doptM Opt_ParallelListComp - ; checkErr parallel_list_comp msg } +---------------------- +checkLastStmt :: HsStmtContext Name + -> LStmt RdrName + -> RnM (LStmt RdrName) +checkLastStmt ctxt lstmt@(L loc stmt) + = case ctxt of + ListComp -> check_comp + MonadComp -> check_comp + PArrComp -> check_comp + DoExpr -> check_do + MDoExpr -> check_do + _ -> check_other where - msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp") + check_do -- Expect ExprStmt, and change it to LastStmt + = case stmt of + ExprStmt e _ _ _ -> return (L loc (mkLastStmt e)) + LastStmt {} -> return lstmt -- "Deriving" clauses may generate a + -- LastStmt directly (unlike the parser) + _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } + last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt + <+> ptext (sLit "must be an expression")) + + check_comp -- Expect LastStmt; this should be enforced by the parser! + = case stmt of + LastStmt {} -> return lstmt + _ -> pprPanic "checkLastStmt" (ppr lstmt) + + check_other -- Behave just as if this wasn't the last stmt + = do { checkStmt ctxt lstmt; return lstmt } ---------- -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 - ; checkErr transform_list_comp msg } - where - msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp") -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 +-- Checking when a particular Stmt is ok +checkStmt :: HsStmtContext Name + -> LStmt RdrName + -> RnM () +checkStmt ctxt (L _ stmt) + = do { dflags <- getDOpts + ; case okStmt dflags ctxt stmt of + Nothing -> return () + Just extra -> addErr (msg $$ extra) } where - msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt + msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement") + , ptext (sLit "in") <+> pprAStmtContext 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 + -> 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 _ (PatGuard {}) stmt + = case stmt of + ExprStmt {} -> isOK + BindStmt {} -> isOK + LetStmt {} -> isOK + _ -> notOK + +okStmt dflags (ParStmtCtxt ctxt) stmt + = case stmt of + LetStmt (HsIPBinds {}) -> notOK + _ -> okStmt dflags ctxt stmt + +okStmt dflags (TransformStmtCtxt ctxt) stmt + = okStmt dflags ctxt stmt + +okStmt dflags ctxt stmt + | isDoExpr ctxt = okDoStmt dflags ctxt stmt + | isListCompExpr ctxt = okCompStmt dflags ctxt stmt + | otherwise = pprPanic "okStmt" (pprStmtContext ctxt) + +---------------- +okDoStmt dflags _ stmt + = case stmt of + RecStmt {} + | Opt_DoRec `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XDoRec")) + BindStmt {} -> isOK + LetStmt {} -> isOK + ExprStmt {} -> isOK + _ -> notOK + + +---------------- +okCompStmt dflags _ stmt + = case stmt of + BindStmt {} -> isOK + LetStmt {} -> isOK + ExprStmt {} -> isOK + ParStmt {} + | Opt_ParallelListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) + TransformStmt {} + | Opt_TransformListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XTransformListComp")) + GroupStmt {} + | Opt_TransformListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XTransformListComp")) + LastStmt {} -> notOK + RecStmt {} -> notOK --------- 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")