X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnExpr.lhs;h=9b1f08e2dd02ce347e9df2f80d5b6418209f3a6f;hp=d1dd222be7a650b24a7f22952735c917c9d7945a;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=d76d9636aeebe933d160157331b8c8c0087e73ac diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index d1dd222..9b1f08e 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -25,7 +25,7 @@ import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, rnMatchGroup, makeMiniFixityEnv) import HsSyn import TcRnMonad -import TcEnv ( thRnBrack ) +import TcEnv ( thRnBrack, getHetMetLevel ) import RnEnv import RnTypes ( rnHsTypeFVs, rnSplice, checkTH, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) @@ -34,6 +34,7 @@ import DynFlags import BasicTypes ( FixityDirection(..) ) import PrelNames +import Var ( TyVar, varName ) import Name import NameSet import RdrName @@ -84,6 +85,13 @@ rnExprs ls = rnExprs' ls emptyUniqSet Variables. We look up the variable and return the resulting name. \begin{code} + +-- during the renamer phase we only care about the length of the +-- current HetMet level; the actual tyvars don't +-- matter, so we use bottoms for them +dummyTyVar :: TyVar +dummyTyVar = error "tried to force RnExpr.dummyTyVar" + rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) rnLExpr = wrapLocFstM rnExpr @@ -157,6 +165,21 @@ rnExpr (NegApp e _) mkNegAppRn e' neg_name `thenM` \ final_e -> return (final_e, fv_e `plusFV` fv_neg) +rnExpr (HsHetMetBrak c e) + = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = dummyTyVar:(tcl_hetMetLevel x) }) $ rnLExpr e + ; return (HsHetMetBrak c e', fv_e) + } +rnExpr (HsHetMetEsc c t e) + = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e + ; return (HsHetMetEsc c t e', fv_e) + } +rnExpr (HsHetMetCSP c e) + = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e + ; return (HsHetMetCSP c e', fv_e) + } + + + ------------------------------------------ -- Template Haskell extensions -- Don't ifdef-GHCI them because we want to fail gracefully @@ -440,8 +463,9 @@ convertOpFormsCmd (HsIf f exp c1 c2) convertOpFormsCmd (HsLet binds cmd) = HsLet binds (convertOpFormsLCmd cmd) -convertOpFormsCmd (HsDo ctxt stmts ty) - = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) ty +convertOpFormsCmd (HsDo DoExpr stmts ty) + = HsDo ArrowExpr (map (fmap convertOpFormsStmt) stmts) ty + -- Mark the HsDo as begin the body of an arrow command -- Anything else is unchanged. This includes HsArrForm (already done), -- things with no sub-commands, and illegal commands (which will be @@ -538,9 +562,8 @@ methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt _) = 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 +methodNamesStmt (TransStmt {}) = emptyFVs + -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error -- here so we just do what's convenient \end{code} @@ -583,14 +606,16 @@ rnArithSeq (FromThenTo expr1 expr2 expr3) \begin{code} rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars) -rnBracket (VarBr n) = do { name <- lookupOccRn n - ; this_mod <- getModule - ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the - do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the - ; return () } -- only way that is going to happen - ; return (VarBr name, unitFV name) } - where - msg = ptext (sLit "Need interface for Template Haskell quoted Name") +rnBracket (VarBr n) + = do { name <- lookupOccRn n + ; this_mod <- getModule + ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes + do { _ <- loadInterfaceForName msg name -- the home interface is loaded, and + ; return () } -- this is the only way that is going + -- to happen + ; return (VarBr name, unitFV name) } + where + msg = ptext (sLit "Need interface for Template Haskell quoted Name") rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e ; return (ExpBr e', fvs) } @@ -620,7 +645,8 @@ rnBracket (DecBrL decls) rnSrcDecls group -- 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)))) + ; 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" @@ -648,32 +674,22 @@ 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 { checkStmt MDoExpr True last_stmt - ; rnStmt MDoExpr last_stmt thing_inside } + 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 -rnStmts ctxt (lstmt@(L loc stmt) : lstmts) thing_inside +rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside | null lstmts = setSrcSpan loc $ - do { -- Turn a final ExprStmt into a LastStmt - -- This is the first place it's convenient to do this - -- (In principle the parser could do it, but it's - -- just not very convenient to do so.) - let stmt' | okEmpty ctxt - = lstmt - | otherwise - = case stmt of - ExprStmt e _ _ _ -> L loc (mkLastStmt e) - _ -> lstmt - ; checkStmt ctxt True {- last stmt -} stmt' - ; rnStmt ctxt stmt' thing_inside } + do { lstmt' <- checkLastStmt ctxt lstmt + ; rnStmt ctxt lstmt' thing_inside } | otherwise = do { ((stmts1, (stmts2, thing)), fvs) <- setSrcSpan loc $ - do { checkStmt ctxt False {- Not last -} lstmt + do { checkStmt ctxt lstmt ; rnStmt ctxt lstmt $ \ bndrs1 -> rnStmts ctxt lstmts $ \ bndrs2 -> thing_inside (bndrs1 ++ bndrs2) } @@ -687,19 +703,22 @@ rnStmt :: HsStmtContext Name -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars -rnStmt _ (L loc (LastStmt 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 [] + ; (ret_op, fvs1) <- lookupStmtName ctxt 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 - ; (guard_op, fvs2) <- if isMonadCompExpr ctxt - then lookupSyntaxName guardMName - else return (noSyntaxExpr, emptyFVs) + ; (then_op, fvs1) <- lookupStmtName ctxt thenMName + ; (guard_op, fvs2) <- if isListCompExpr ctxt + then lookupStmtName ctxt guardMName + else return (noSyntaxExpr, emptyFVs) + -- Only list/parr/monad comprehensions use 'guard' + -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] + -- Here "gd" is a guard ; (thing, fvs3) <- thing_inside [] ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } @@ -707,8 +726,8 @@ rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside = do { (expr', fv_expr) <- rnLExpr expr -- The binders do not scope over the expression - ; (bind_op, fvs1) <- lookupSyntaxName bindMName - ; (fail_op, fvs2) <- lookupSyntaxName failMName + ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName + ; (fail_op, fvs2) <- lookupStmtName ctxt failMName ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders pat') ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing), @@ -721,7 +740,7 @@ rnStmt _ (L loc (LetStmt binds)) thing_inside { (thing, fvs) <- thing_inside (collectLocalBinders binds') ; return (([L loc (LetStmt binds')], thing), fvs) } } -rnStmt _ (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside +rnStmt ctxt (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 @@ -737,9 +756,9 @@ rnStmt _ (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) emptyNameSet segs ; (thing, fvs_later) <- thing_inside bndrs - ; (return_op, fvs1) <- lookupSyntaxName returnMName - ; (mfix_op, fvs2) <- lookupSyntaxName mfixName - ; (bind_op, fvs3) <- lookupSyntaxName bindMName + ; (return_op, fvs1) <- lookupStmtName ctxt returnMName + ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName + ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName ; let -- Step 2: Fill in the fwd refs. -- The segments are all singletons, but their fwd-ref @@ -765,83 +784,50 @@ rnStmt _ (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 { ((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) ) + = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName + ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName ; ((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) - <- 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) 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) } - - -- 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 { grpS_stmts = stmts, grpS_by = by, grpS_explicit = explicit - , grpS_using = using })) thing_inside +rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form + , trS_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) } + (using', fvs1) <- case form of + GroupFormB -> do { (e,fvs) <- lookupStmtName ctxt groupMName + ; return (noLoc e, fvs) } + _ -> rnLExpr using -- Rename the stmts and the 'by' expression -- Keep track of the variables mentioned in the 'by' expression ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> + <- rnStmts (TransStmtCtxt 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 + -- 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) } -- 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 + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName + ; (fmap_op, fvs5) <- case form of + ThenForm -> return (noSyntaxExpr, emptyFVs) + _ -> lookupStmtName ctxt fmapName + + ; 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 + -- See Note [TransStmt binder map] in HsExpr ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map) - ; 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) } + ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map + , trS_by = by', trS_using = using', trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op })], thing), all_fvs) } type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts @@ -877,6 +863,27 @@ rnParallelStmts ctxt segs thing_inside cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:") <+> quotes (ppr (head vs))) + +lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) +-- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable +-- Neither is ArrowExpr, which has its own desugarer in DsArrows +lookupStmtName ctxt n + = case ctxt of + ListComp -> not_rebindable + PArrComp -> not_rebindable + ArrowExpr -> not_rebindable + PatGuard {} -> not_rebindable + + DoExpr -> rebindable + MDoExpr -> rebindable + MonadComp -> rebindable + GhciStmt -> rebindable -- I suppose? + + ParStmtCtxt c -> lookupStmtName c n -- Look inside to + TransStmtCtxt c -> lookupStmtName c n -- the parent context + where + rebindable = lookupSyntaxName n + not_rebindable = return (HsVar n, emptyFVs) \end{code} Note [Renaming parallel Stmts] @@ -988,10 +995,7 @@ rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec in 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 - = pprPanic "rn_rec_stmt" (ppr stmt) - -rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo +rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds)) @@ -1056,11 +1060,8 @@ rn_rec_stmt _ stmt@(L _ (RecStmt {})) _ rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) -rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt) - -rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt) +rn_rec_stmt _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _ = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" @@ -1211,24 +1212,53 @@ checkEmptyStmts :: HsStmtContext Name -> RnM () checkEmptyStmts ctxt = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) -okEmpty :: HsStmtContext Name -> Bool +okEmpty :: HsStmtContext a -> Bool okEmpty (PatGuard {}) = True okEmpty _ = False 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 +emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension") +emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'") +emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt ---------------------- +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 + ArrowExpr -> check_do + DoExpr -> check_do + MDoExpr -> check_do + _ -> check_other + where + 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 } + -- Checking when a particular Stmt is ok checkStmt :: HsStmtContext Name - -> Bool -- True <=> this is the last Stmt in the sequence -> LStmt RdrName -> RnM () -checkStmt ctxt is_last (L _ stmt) +checkStmt ctxt (L _ stmt) = do { dflags <- getDOpts - ; case okStmt dflags ctxt is_last stmt of + ; case okStmt dflags ctxt stmt of Nothing -> return () Just extra -> addErr (msg $$ extra) } where @@ -1236,8 +1266,7 @@ checkStmt ctxt is_last (L _ stmt) , ptext (sLit "in") <+> pprAStmtContext ctxt ] pprStmtCat :: Stmt a -> SDoc -pprStmtCat (TransformStmt {}) = ptext (sLit "transform") -pprStmtCat (GroupStmt {}) = ptext (sLit "group") +pprStmtCat (TransStmt {}) = ptext (sLit "transform") pprStmtCat (LastStmt {}) = ptext (sLit "return expression") pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion") pprStmtCat (BindStmt {}) = ptext (sLit "binding") @@ -1250,60 +1279,54 @@ isOK, notOK :: Maybe SDoc isOK = Nothing notOK = Just empty -okStmt, okDoStmt, okCompStmt :: DynFlags -> HsStmtContext Name -> Bool - -> Stmt RdrName -> Maybe SDoc +okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt + :: 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 + +okStmt dflags ctxt stmt + = case ctxt of + PatGuard {} -> okPatGuardStmt stmt + ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt + DoExpr -> okDoStmt dflags ctxt stmt + MDoExpr -> okDoStmt dflags ctxt stmt + ArrowExpr -> okDoStmt dflags ctxt stmt + GhciStmt -> okDoStmt dflags ctxt stmt + ListComp -> okCompStmt dflags ctxt stmt + MonadComp -> okCompStmt dflags ctxt stmt + PArrComp -> okPArrStmt dflags ctxt stmt + TransStmtCtxt ctxt -> okStmt dflags ctxt stmt + +------------- +okPatGuardStmt :: Stmt RdrName -> Maybe SDoc +okPatGuardStmt stmt = case stmt of ExprStmt {} -> isOK BindStmt {} -> isOK LetStmt {} -> isOK _ -> notOK -okStmt dflags (ParStmtCtxt ctxt) _ stmt +------------- +okParStmt dflags ctxt stmt = case stmt of LetStmt (HsIPBinds {}) -> notOK - _ -> okStmt dflags ctxt False stmt - -- NB: is_last=False in recursive - -- call; the branches of of a Par - -- not finish with a LastStmt - -okStmt dflags (TransformStmtCtxt ctxt) _ stmt - = okStmt dflags ctxt False stmt - -okStmt dflags ctxt is_last stmt - | isDoExpr ctxt = okDoStmt dflags ctxt is_last stmt - | isListCompExpr ctxt = okCompStmt dflags ctxt is_last stmt - | otherwise = pprPanic "okStmt" (pprStmtContext ctxt) + _ -> okStmt dflags ctxt stmt ---------------- -okDoStmt dflags ctxt is_last stmt - | is_last - = case stmt of - LastStmt {} -> isOK - _ -> Just (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt - <+> ptext (sLit "must be an expression")) - - | otherwise +okDoStmt dflags ctxt stmt = case stmt of - RecStmt {} + RecStmt {} | Opt_DoRec `xopt` dflags -> isOK - | otherwise -> Just (ptext (sLit "Use -XDoRec")) + | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec' + | otherwise -> Just (ptext (sLit "Use -XDoRec")) BindStmt {} -> isOK LetStmt {} -> isOK ExprStmt {} -> isOK _ -> notOK - ---------------- -okCompStmt dflags _ is_last stmt - | is_last - = case stmt of - LastStmt {} -> Nothing - _ -> pprPanic "Unexpected stmt" (ppr stmt) -- Not a user error - - | otherwise +okCompStmt dflags _ stmt = case stmt of BindStmt {} -> isOK LetStmt {} -> isOK @@ -1311,14 +1334,24 @@ okCompStmt dflags _ is_last stmt ParStmt {} | Opt_ParallelListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) - TransformStmt {} + TransStmt {} | 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 + LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) + +---------------- +okPArrStmt dflags _ stmt + = case stmt of + BindStmt {} -> isOK + LetStmt {} -> isOK + ExprStmt {} -> isOK + ParStmt {} + | Opt_ParallelListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) + TransStmt {} -> notOK + RecStmt {} -> notOK + LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) --------- checkTupleSection :: [HsTupArg RdrName] -> RnM ()