- -- 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)
-
-rnStmt ctxt (ParStmt segs) thing_inside
- = do { parallel_list_comp <- doptM Opt_ParallelListComp
- ; checkM parallel_list_comp parStmtErr
- ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
- ; return ((ParStmt segs', 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:")
+ -- 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) }
+
+ -- 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 ->
+ 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
+ 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) }
+
+
+type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
+
+rnParallelStmts :: forall thing. HsStmtContext Name
+ -> [ParSeg RdrName]
+ -> ([Name] -> RnM (thing, FreeVars))
+ -> RnM (([ParSeg Name], thing), FreeVars)
+-- Note [Renaming parallel Stmts]
+rnParallelStmts ctxt segs thing_inside
+ = do { orig_lcl_env <- getLocalRdrEnv
+ ; rn_segs orig_lcl_env [] segs }
+ where
+ rn_segs :: LocalRdrEnv
+ -> [Name] -> [ParSeg RdrName]
+ -> RnM (([ParSeg Name], thing), FreeVars)
+ rn_segs _ bndrs_so_far []
+ = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
+ ; mapM_ dupErr dups
+ ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
+ ; return (([], thing), fvs) }
+
+ rn_segs env bndrs_so_far ((stmts,_) : segs)
+ = do { ((stmts', (used_bndrs, segs', thing)), fvs)
+ <- 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
+ ; return ((used_bndrs, segs', thing), fvs) }
+
+ ; let seg' = (stmts', used_bndrs)
+ ; return ((seg':segs', thing), fvs) }
+
+ cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
+ dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")