X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnExpr.lhs;h=71da0f11c87f6cd5d1cf98a7a1b6b0d1fa7af628;hp=ba6b0e0a29f6a2826d1629cfc022ba7bcfef5448;hb=a27c5f77da8b3b3f00f9902b69a504460f234e8c;hpb=7f2909e06884a04199131407c12ba179d5886f46 diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index ba6b0e0..71da0f1 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -23,6 +23,10 @@ module RnExpr ( #include "HsVersions.h" +#ifdef GHCI +import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr ) +#endif /* GHCI */ + import RnSource ( rnSrcDecls, rnSplice, checkTH ) import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, rnMatchGroup, makeMiniFixityEnv) @@ -30,38 +34,59 @@ import HsSyn import TcRnMonad import RnEnv import HscTypes ( availNames ) -import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) import RnTypes ( rnHsTypeFVs, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) -import RnPat (rnOverLit, rnPatsAndThen_LocalRightwards, rnBindPat, +import RnPat (rnQuasiQuote, rnOverLit, rnPatsAndThen_LocalRightwards, rnBindPat, localRecNameMaker, rnLit, rnHsRecFields_Con, rnHsRecFields_Update, checkTupSize) +import RdrName ( mkRdrUnqual ) 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 ) + negateName, thenMName, bindMName, failMName, groupWithName ) -import Name ( Name, nameOccName, nameIsLocalOrFrom ) +import Name ( Name, nameOccName, nameModule, nameIsLocalOrFrom ) import NameSet -import UniqFM +import LazyUniqFM import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals ) import LoadIface ( loadInterfaceForName ) -import UniqFM ( isNullUFM ) -import UniqSet ( emptyUniqSet ) +import UniqSet ( isEmptyUniqSet, emptyUniqSet ) import List ( nub ) import Util ( isSingleton ) import ListSetOps ( removeDups ) import Maybes ( expectJust ) import Outputable -import SrcLoc ( Located(..), unLoc, getLoc ) +import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) import FastString import List ( unzip4 ) +import Control.Monad \end{code} +\begin{code} +-- XXX +thenM :: Monad a => a b -> (b -> a c) -> a c +thenM = (>>=) + +thenM_ :: Monad a => a b -> a c -> a c +thenM_ = (>>) + +returnM :: Monad m => a -> m a +returnM = return + +mappM :: (Monad m) => (a -> m b) -> [a] -> m [b] +mappM = mapM + +mappM_ :: (Monad m) => (a -> m b) -> [a] -> m () +mappM_ = mapM_ + +checkM :: Monad m => Bool -> m () -> m () +checkM = unless +\end{code} + %************************************************************************ %* * \subsubsection{Expressions} @@ -85,7 +110,7 @@ rnExprs ls = rnExprs' ls emptyUniqSet returnM (expr':exprs', fvExprs) -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq -grubby_seqNameSet ns result | isNullUFM ns = result +grubby_seqNameSet ns result | isEmptyUniqSet ns = result | otherwise = result \end{code} @@ -174,6 +199,16 @@ rnExpr e@(HsSpliceE splice) = rnSplice splice `thenM` \ (splice', fvs) -> returnM (HsSpliceE splice', fvs) +#ifndef GHCI +rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e) +#else +rnExpr e@(HsQuasiQuoteE qq) + = rnQuasiQuote qq `thenM` \ (qq', fvs_qq) -> + runQuasiQuoteExpr qq' `thenM` \ (L _ expr') -> + rnExpr expr' `thenM` \ (expr'', fvs_expr) -> + returnM (expr'', fvs_qq `plusFV` fvs_expr) +#endif /* GHCI */ + rnExpr section@(SectionL expr op) = rnLExpr expr `thenM` \ (expr', fvs_expr) -> rnLExpr op `thenM` \ (op', fvs_op) -> @@ -277,6 +312,7 @@ We return a (bogus) EWildPat in each case. \begin{code} rnExpr e@EWildPat = patSynErr e rnExpr e@(EAsPat {}) = patSynErr e +rnExpr e@(EViewPat {}) = patSynErr e rnExpr e@(ELazyPat {}) = patSynErr e \end{code} @@ -375,7 +411,6 @@ convertOpFormsCmd (OpApp c1 op fixity c2) convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c) --- gaw 2004 convertOpFormsCmd (HsCase exp matches) = HsCase exp (convertOpFormsMatch matches) @@ -477,7 +512,9 @@ methodNamesStmt (RecStmt stmts _ _ _ _) = methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt b) = emptyFVs methodNamesStmt (ParStmt ss) = emptyFVs - -- ParStmt can't occur in commands, but it's not convenient to error +methodNamesStmt (TransformStmt _ _ _) = emptyFVs +methodNamesStmt (GroupStmt _ _) = emptyFVs + -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error -- here so we just do what's convenient \end{code} @@ -588,13 +625,12 @@ rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName] -- Implements nested scopes rnNormalStmts ctxt [] thing_inside - = do { (thing, fvs) <- thing_inside + = do { (thing, fvs) <- thing_inside ; return (([],thing), fvs) } rnNormalStmts ctxt (L loc stmt : stmts) thing_inside - = do { ((stmt', (stmts', thing)), fvs) - <- rnStmt ctxt stmt $ - rnNormalStmts ctxt stmts thing_inside + = do { ((stmt', (stmts', thing)), fvs) <- rnStmt ctxt stmt $ + rnNormalStmts ctxt stmts thing_inside ; return (((L loc stmt' : stmts'), thing), fvs) } @@ -621,86 +657,165 @@ rnStmt ctxt (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 (LetStmt binds) thing_inside - = do { checkErr (ok ctxt binds) - (badIpBinds (ptext SLIT("a parallel list comprehension:")) binds) - ; rnLocalBindsAndThen binds $ \ binds' -> do +rnStmt ctxt (LetStmt binds) thing_inside + = do { checkLetStmt ctxt binds + ; rnLocalBindsAndThen binds $ \binds' -> do { (thing, fvs) <- thing_inside - ; return ((LetStmt binds', thing), fvs) }} - where - -- We do not allow implicit-parameter bindings in a parallel - -- list comprehension. I'm not sure what it might mean. - ok (ParStmtCtxt _) (HsIPBinds _) = False - ok _ _ = True + ; return ((LetStmt binds', thing), fvs) } } rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside - = - rn_rec_stmts_and_then rec_stmts $ \ segs -> - thing_inside `thenM` \ (thing, fvs) -> - let - segs_w_fwd_refs = addFwdRefs segs - (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs - later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs) - fwd_vars = nameSetToList (plusFVs fs) - uses = plusFVs us - rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds - in - returnM ((rec_stmt, thing), uses `plusFV` fvs) - where - doc = text "In a recursive do statement" + = do { checkRecStmt ctxt + ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do + { (thing, fvs) <- thing_inside + ; let + segs_w_fwd_refs = addFwdRefs segs + (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs + later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs) + fwd_vars = nameSetToList (plusFVs fs) + uses = plusFVs us + rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds + ; return ((rec_stmt, thing), uses `plusFV` fvs) } } rnStmt ctxt (ParStmt segs) thing_inside - = do { parallel_list_comp <- doptM Opt_ParallelListComp - ; checkM parallel_list_comp parStmtErr - ; orig_lcl_env <- getLocalRdrEnv - ; ((segs',thing), fvs) <- go orig_lcl_env [] segs + = do { checkParStmt ctxt + ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside ; return ((ParStmt segs', thing), fvs) } + +rnStmt ctxt (TransformStmt (stmts, _) usingExpr maybeByExpr) thing_inside = do + checkTransformStmt ctxt + + (usingExpr', fv_usingExpr) <- rnLExpr usingExpr + ((stmts', binders, (maybeByExpr', thing)), fvs) <- + rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do + (maybeByExpr', fv_maybeByExpr) <- rnMaybeLExpr maybeByExpr + (thing, fv_thing) <- thing_inside + + return ((maybeByExpr', thing), fv_maybeByExpr `plusFV` fv_thing) + + return ((TransformStmt (stmts', binders) usingExpr' maybeByExpr', thing), fv_usingExpr `plusFV` fvs) where --- type ParSeg id = [([LStmt id], [id])] --- go :: NameSet -> [ParSeg RdrName] --- -> RnM (([ParSeg Name], thing), FreeVars) - - go orig_lcl_env bndrs [] - = do { let { (bndrs', dups) = removeDups cmpByOcc bndrs - ; inner_env = extendLocalRdrEnv orig_lcl_env bndrs' } - ; mappM dupErr dups - ; (thing, fvs) <- setLocalRdrEnv inner_env thing_inside - ; return (([], thing), fvs) } - - go orig_lcl_env bndrs_so_far ((stmts, _) : segs) - = do { ((stmts', (bndrs, segs', thing)), fvs) - <- rnNormalStmts par_ctxt stmts $ do - { -- Find the Names that are bound by stmts - lcl_env <- getLocalRdrEnv - ; let { rdr_bndrs = collectLStmtsBinders stmts - ; bndrs = map ( expectJust "rnStmt" - . lookupLocalRdrEnv lcl_env - . unLoc) rdr_bndrs - ; new_bndrs = nub bndrs ++ bndrs_so_far - -- The nub is because there might be shadowing - -- x <- e1; x <- e2 - -- So we'll look up (Unqual x) twice, getting - -- the second binding both times, which is the - } -- one we want - - -- Typecheck the thing inside, passing on all - -- the Names bound, but separately; revert the envt - ; ((segs', thing), fvs) <- setLocalRdrEnv orig_lcl_env $ - go orig_lcl_env new_bndrs segs - - -- Figure out which of the bound names are used - ; let used_bndrs = filter (`elemNameSet` fvs) bndrs - ; return ((used_bndrs, segs', thing), fvs) } - - ; let seg' = (stmts', bndrs) - ; return (((seg':segs'), thing), - delListFromNameSet fvs bndrs) } - - par_ctxt = ParStmtCtxt ctxt - - cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 - dupErr vs = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:") - <+> quotes (ppr (head vs))) + rnMaybeLExpr Nothing = return (Nothing, emptyFVs) + rnMaybeLExpr (Just expr) = do + (expr', fv_expr) <- rnLExpr expr + return (Just expr', fv_expr) + +rnStmt ctxt (GroupStmt (stmts, _) groupByClause) thing_inside = do + checkTransformStmt ctxt + + -- We must rename the using expression in the context before the transform is begun + groupByClauseAction <- + case groupByClause of + GroupByNothing usingExpr -> do + (usingExpr', fv_usingExpr) <- rnLExpr usingExpr + (return . return) (GroupByNothing usingExpr', fv_usingExpr) + GroupBySomething eitherUsingExpr byExpr -> do + (eitherUsingExpr', fv_eitherUsingExpr) <- + case eitherUsingExpr of + Right _ -> return (Right $ HsVar groupWithName, unitNameSet groupWithName) + Left usingExpr -> do + (usingExpr', fv_usingExpr) <- rnLExpr usingExpr + return (Left usingExpr', fv_usingExpr) + + return $ do + (byExpr', fv_byExpr) <- rnLExpr byExpr + return (GroupBySomething eitherUsingExpr' byExpr', fv_eitherUsingExpr `plusFV` fv_byExpr) + + -- We only use rnNormalStmtsAndFindUsedBinders to get unshadowed_bndrs, so + -- perhaps we could refactor this to use rnNormalStmts directly? + ((stmts', _, (groupByClause', usedBinderMap, thing)), fvs) <- + rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do + (groupByClause', fv_groupByClause) <- groupByClauseAction + + unshadowed_bndrs' <- mapM newLocalName unshadowed_bndrs + let binderMap = zip unshadowed_bndrs unshadowed_bndrs' + + -- Bind the "thing" inside a context where we have REBOUND everything + -- bound by the statements before the group. This is necessary since after + -- the grouping the same identifiers actually have different meanings + -- i.e. they refer to lists not singletons! + (thing, fv_thing) <- bindLocalNames unshadowed_bndrs' thing_inside + + -- We remove entries from the binder map that are not used in the thing_inside. + -- We can then use that usage information to ensure that the free variables do + -- not contain the things we just bound, but do contain the things we need to + -- make those bindings (i.e. the corresponding non-listy variables) + + -- Note that we also retain those entries which have an old binder in our + -- own free variables (the using or by expression). This is because this map + -- is reused in the desugarer to create the type to bind from the statements + -- that occur before this one. If the binders we need are not in the map, they + -- will never get bound into our desugared expression and hence the simplifier + -- crashes as we refer to variables that don't exist! + let usedBinderMap = filter + (\(old_binder, new_binder) -> + (new_binder `elemNameSet` fv_thing) || + (old_binder `elemNameSet` fv_groupByClause)) binderMap + (usedOldBinders, usedNewBinders) = unzip usedBinderMap + real_fv_thing = (delListFromNameSet fv_thing usedNewBinders) `plusFV` (mkNameSet usedOldBinders) + + return ((groupByClause', usedBinderMap, thing), fv_groupByClause `plusFV` real_fv_thing) + + traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr usedBinderMap) + return ((GroupStmt (stmts', usedBinderMap) groupByClause', thing), fvs) + +rnNormalStmtsAndFindUsedBinders :: HsStmtContext Name + -> [LStmt RdrName] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt Name], [Name], thing), FreeVars) +rnNormalStmtsAndFindUsedBinders ctxt stmts thing_inside = do + ((stmts', (used_bndrs, inner_thing)), fvs) <- rnNormalStmts ctxt stmts $ do + -- Find the Names that are bound by stmts that + -- by assumption we have just renamed + local_env <- getLocalRdrEnv + let + stmts_binders = collectLStmtsBinders stmts + bndrs = map (expectJust "rnStmt" + . lookupLocalRdrEnv local_env + . unLoc) stmts_binders + + -- If shadow, we'll look up (Unqual x) twice, getting + -- the second binding both times, which is the + -- one we want + unshadowed_bndrs = nub bndrs + + -- Typecheck the thing inside, passing on all + -- the Names bound before it for its information + (thing, fvs) <- thing_inside unshadowed_bndrs + + -- Figure out which of the bound names are used + -- after the statements we renamed + let used_bndrs = filter (`elemNameSet` fvs) bndrs + return ((used_bndrs, thing), fvs) + + -- Flatten the tuple returned by the above call a bit! + return ((stmts', used_bndrs, inner_thing), fvs) + + +rnParallelStmts ctxt segs thing_inside = do + orig_lcl_env <- getLocalRdrEnv + go orig_lcl_env [] segs + where + go orig_lcl_env bndrs [] = do + let (bndrs', dups) = removeDups cmpByOcc bndrs + inner_env = extendLocalRdrEnv orig_lcl_env bndrs' + + mappM dupErr dups + (thing, fvs) <- setLocalRdrEnv inner_env thing_inside + return (([], thing), fvs) + + go orig_lcl_env bndrs_so_far ((stmts, _) : segs) = do + ((stmts', bndrs, (segs', thing)), fvs) <- rnNormalStmtsAndFindUsedBinders ctxt stmts $ \new_bndrs -> do + -- Typecheck the thing inside, passing on all + -- the Names bound, but separately; revert the envt + setLocalRdrEnv orig_lcl_env $ do + go orig_lcl_env (new_bndrs ++ bndrs_so_far) segs + + let seg' = (stmts', bndrs) + return (((seg':segs'), thing), delListFromNameSet fvs bndrs) + + cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 + dupErr vs = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:") + <+> quotes (ppr (head vs))) \end{code} @@ -770,22 +885,22 @@ rn_rec_stmts_and_then :: [LStmt RdrName] -- 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) +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 + -- (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 $ - warnUnusedLocalBinds bound_names $ do - - -- (C) do the right-hand-sides and thing-inside - segs <- rn_rec_stmts bound_names new_lhs_and_fv - cont segs + -- ...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 + ; (res, fvs) <- cont segs + ; warnUnusedLocalBinds bound_names fvs + ; return (res, fvs) }} -- get all the fixity decls in any Let stmt collectRecStmtsFixities l = @@ -798,8 +913,7 @@ collectRecStmtsFixities 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 +rn_rec_stmt_lhs :: MiniFixityEnv -> LStmt RdrName -- rename LHS, and return its FVs -- Warning: we will only need the FreeVars below in the case of a BindStmt, @@ -833,9 +947,14 @@ rn_rec_stmt_lhs fix_env (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Re 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 + +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 + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmts_lhs :: MiniFixityEnv -> [LStmt RdrName] -> RnM [(LStmtLR Name RdrName, FreeVars)] rn_rec_stmts_lhs fix_env stmts = @@ -845,7 +964,7 @@ rn_rec_stmts_lhs fix_env stmts = -- 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 + checkDupRdrNames doc boundNames mappM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> returnM (concat ls) @@ -890,6 +1009,12 @@ rn_rec_stmt all_bndrs stmt@(L loc (RecStmt stmts _ _ _ _)) _ rn_rec_stmt all_bndrs stmt@(L _ (ParStmt _)) _ -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) +rn_rec_stmt all_bndrs stmt@(L _ (TransformStmt _ _ _)) _ -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt) + +rn_rec_stmt all_bndrs stmt@(L _ (GroupStmt _ _)) _ -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: GroupStmt" (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) @@ -1023,15 +1148,54 @@ mkAssertErrorExpr %************************************************************************ \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 () + -- 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' but only because of arrows: + -- proc x -> do { ...rec... } + -- We don't have enough context to distinguish this situation here + -- so we leave it to the type checker +checkRecStmt ctxt = addErr msg + where + msg = ptext SLIT("Illegal 'rec' stmt in") <+> pprStmtContext ctxt + +--------- +checkParStmt :: HsStmtContext Name -> RnM () +checkParStmt ctxt + = do { parallel_list_comp <- doptM Opt_ParallelListComp + ; checkErr parallel_list_comp msg } + where + msg = ptext SLIT("Illegal parallel list comprehension: use -XParallelListComp") + +--------- +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 + where + msg = ptext SLIT("Illegal transform or grouping in") <+> pprStmtContext ctxt + +--------- patSynErr e = do { addErr (sep [ptext SLIT("Pattern syntax in expression context:"), nest 4 (ppr e)]) ; return (EWildPat, emptyFVs) } -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} - -