Fix Trac #2188: scoping in TH declarations quotes
[ghc-hetmet.git] / compiler / rename / RnExpr.lhs
index ba6b0e0..71da0f1 100644 (file)
@@ -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}
-
-