Commit f1cc3eb9 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Refactor part of the renamer to fix Trac #3901

This one was bigger than I anticipated!  The problem was that were
were gathering the binders from a pattern before renaming -- but with
record wild-cards we don't know what variables are bound by C {..}
until after the renamer has filled in the "..".

So this patch does the following

* Change all the collect-X-Binders functions in HsUtils so that
  they expect to only be called *after* renaming.  That means they
  don't need to return [Located id] but just [id].  Which turned out
  to be a very worthwhile simplification all by itself.

* Refactor the renamer, and in ptic RnExpr.rnStmt, so that it
  doesn't need to use collectLStmtsBinders on pre-renamed Stmts.

* This in turn required me to understand how GroupStmt and
  TransformStmts were renamed.  Quite fiddly. I rewrote most of it;
  result is much shorter.

* In doing so I flattened HsExpr.GroupByClause into its parent
  GroupStmt, with trivial knock-on effects in other files.

Blargh.
parent 0a5613f4
......@@ -24,6 +24,7 @@ import HscTypes
import StaticFlags
import TyCon
import FiniteMap
import MonadUtils
import Maybes
import Data.Array
......@@ -290,7 +291,7 @@ addTickHsExpr (HsIf e1 e2 e3) =
(addTickLHsExprOptAlt True e2)
(addTickLHsExprOptAlt True e3)
addTickHsExpr (HsLet binds e) =
bindLocals (map unLoc $ collectLocalBinders binds) $
bindLocals (collectLocalBinders binds) $
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprNeverOrAlways e)
......@@ -398,7 +399,7 @@ addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
return $ GRHSs guarded' local_binds'
where
binders = map unLoc (collectLocalBinders local_binds)
binders = collectLocalBinders local_binds
addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
addTickGRHS isOneOfMany (GRHS stmts expr) = do
......@@ -420,7 +421,7 @@ addTickLStmts' isGuard lstmts res
a <- res
return (lstmts', a)
where
binders = map unLoc (collectLStmtsBinders lstmts)
binders = collectLStmtsBinders lstmts
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
addTickStmt _isGuard (BindStmt pat e bind fail) = do
......@@ -440,25 +441,21 @@ addTickStmt _isGuard (LetStmt binds) = do
addTickStmt isGuard (ParStmt pairs) = do
liftM ParStmt
(mapM (addTickStmtAndBinders isGuard) pairs)
addTickStmt isGuard (TransformStmt (stmts, ids) usingExpr maybeByExpr) = do
liftM3 TransformStmt
(addTickStmtAndBinders isGuard (stmts, ids))
addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr) = do
liftM4 TransformStmt
(addTickLStmts isGuard stmts)
(return ids)
(addTickLHsExprAlways usingExpr)
(addTickMaybeByLHsExpr maybeByExpr)
addTickStmt isGuard (GroupStmt (stmts, binderMap) groupByClause) = do
liftM2 GroupStmt
(addTickStmtAndBinders isGuard (stmts, binderMap))
(case groupByClause of
GroupByNothing usingExpr -> addTickLHsExprAlways usingExpr >>= (return . GroupByNothing)
GroupBySomething eitherUsingExpr byExpr -> do
eitherUsingExpr' <- mapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) eitherUsingExpr
byExpr' <- addTickLHsExprAlways byExpr
return $ GroupBySomething eitherUsingExpr' byExpr')
where
mapEitherM f g x = do
case x of
Left a -> f a >>= (return . Left)
Right b -> g b >>= (return . Right)
addTickStmt isGuard (GroupStmt stmts binderMap by using) = do
liftM4 GroupStmt
(addTickLStmts isGuard stmts)
(return binderMap)
(fmapMaybeM addTickLHsExprAlways by)
(fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using)
addTickStmt isGuard stmt@(RecStmt {})
= do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
......
......@@ -14,8 +14,7 @@ import Match
import DsUtils
import DsMonad
import HsSyn hiding (collectPatBinders, collectLocatedPatBinders, collectl,
collectPatsBinders, collectLocatedPatsBinders)
import HsSyn hiding (collectPatBinders, collectPatsBinders )
import TcHsSyn
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
......@@ -526,7 +525,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
let
defined_vars = mkVarSet (map unLoc (collectLocalBinders binds))
defined_vars = mkVarSet (collectLocalBinders binds)
local_vars' = local_vars `unionVarSet` defined_vars
(core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body
......@@ -633,7 +632,7 @@ dsCmdDo ids local_vars env_ids res_ty [] body
dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do
let
bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars
(core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
(core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body
......@@ -923,7 +922,7 @@ dsCmdStmts ids local_vars env_ids out_ids [stmt]
dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do
let
bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars
(core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
......@@ -963,10 +962,10 @@ leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
= let
defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet`
mkVarSet (map unLoc (collectLocalBinders binds))
mkVarSet (collectLocalBinders binds)
in
[(expr,
mkVarSet (map unLoc (collectLStmtsBinders stmts))
mkVarSet (collectLStmtsBinders stmts)
`unionVarSet` defined_vars)
| L _ (GRHS stmts expr) <- grhss]
\end{code}
......@@ -1009,6 +1008,8 @@ foldb f xs = foldb f (fold_pairs xs)
fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
\end{code}
Note [Dictionary binders in ConPatOut] See also same Note in HsUtils
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The following functions to collect value variables from patterns are
copied from HsUtils, with one change: we also collect the dictionary
bindings (pat_binds) from ConPatOut. We need them for cases like
......@@ -1029,29 +1030,24 @@ these bindings.
\begin{code}
collectPatBinders :: OutputableBndr a => LPat a -> [a]
collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
collectLocatedPatBinders :: OutputableBndr a => LPat a -> [Located a]
collectLocatedPatBinders pat = collectl pat []
collectPatBinders pat = collectl pat []
collectPatsBinders :: OutputableBndr a => [LPat a] -> [a]
collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
collectLocatedPatsBinders :: OutputableBndr a => [LPat a] -> [Located a]
collectLocatedPatsBinders pats = foldr collectl [] pats
collectPatsBinders pats = foldr collectl [] pats
---------------------
collectl :: OutputableBndr a => LPat a -> [Located a] -> [Located a]
collectl (L l pat) bndrs
collectl :: OutputableBndr a => LPat a -> [a] -> [a]
-- See Note [Dictionary binders in ConPatOut]
collectl (L _ pat) bndrs
= go pat
where
go (VarPat var) = L l var : bndrs
go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs
go (VarPat var) = var : bndrs
go (VarPatOut var bs) = var : collectHsBindsBinders bs
++ bndrs
go (WildPat _) = bndrs
go (LazyPat pat) = collectl pat bndrs
go (BangPat pat) = collectl pat bndrs
go (AsPat a pat) = a : collectl pat bndrs
go (AsPat (L _ a) pat) = a : collectl pat bndrs
go (ParPat pat) = collectl pat bndrs
go (ListPat pats _) = foldr collectl bndrs pats
......@@ -1060,11 +1056,11 @@ collectl (L l pat) bndrs
go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
go (ConPatOut {pat_args=ps, pat_binds=ds}) =
collectHsBindLocatedBinders ds
collectHsBindsBinders ds
++ foldr collectl bndrs (hsConPatArgs ps)
go (LitPat _) = bndrs
go (NPat _ _ _) = bndrs
go (NPlusKPat n _ _ _) = n : bndrs
go (NPlusKPat (L _ n) _ _ _) = n : bndrs
go (SigPatIn pat _) = collectl pat bndrs
go (SigPatOut pat _) = collectl pat bndrs
......
......@@ -38,8 +38,6 @@ import PrelInfo
import SrcLoc
import Outputable
import FastString
import Control.Monad ( liftM2 )
\end{code}
List comprehensions may be desugared in one of two ways: ``ordinary''
......@@ -95,7 +93,7 @@ dsInnerListComp (stmts, bndrs) = do
-- Given such a statement it gives you back an expression representing how to compute the transformed
-- list and the tuple that you need to bind from that list in order to proceed with your desugaring
dsTransformStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
dsTransformStmt (TransformStmt (stmts, binders) usingExpr maybeByExpr) = do
dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr) = do
(expr, binders_tuple_type) <- dsInnerListComp (stmts, binders)
usingExpr' <- dsLExpr usingExpr
......@@ -120,7 +118,7 @@ dsTransformStmt (TransformStmt (stmts, binders) usingExpr maybeByExpr) = do
-- Given such a statement it gives you back an expression representing how to compute the transformed
-- list and the tuple that you need to bind from that list in order to proceed with your desugaring
dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
dsGroupStmt (GroupStmt (stmts, binderMap) groupByClause) = do
dsGroupStmt (GroupStmt stmts binderMap by using) = do
let (fromBinders, toBinders) = unzip binderMap
fromBindersTypes = map idType fromBinders
......@@ -129,23 +127,19 @@ dsGroupStmt (GroupStmt (stmts, binderMap) groupByClause) = do
toBindersTupleType = mkBigCoreTupTy toBindersTypes
-- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
(expr, fromBindersTupleType) <- dsInnerListComp (stmts, fromBinders)
(expr, from_tup_ty) <- dsInnerListComp (stmts, fromBinders)
-- Work out what arguments should be supplied to that expression: i.e. is an extraction
-- function required? If so, create that desugared function and add to arguments
(usingExpr', usingArgs) <-
case groupByClause of
GroupByNothing usingExpr -> liftM2 (,) (dsLExpr usingExpr) (return [expr])
GroupBySomething usingExpr byExpr -> do
usingExpr' <- dsLExpr (either id noLoc usingExpr)
byExpr' <- dsLExpr byExpr
us <- newUniqueSupply
[fromBindersTuple] <- newSysLocalsDs [fromBindersTupleType]
let byExprWrapper = mkTupleCase us fromBinders byExpr' fromBindersTuple (Var fromBindersTuple)
return (usingExpr', [Lam fromBindersTuple byExprWrapper, expr])
usingExpr' <- dsLExpr (either id noLoc using)
usingArgs <- case by of
Nothing -> return [expr]
Just by_e -> do { by_e' <- dsLExpr by_e
; us <- newUniqueSupply
; [from_tup_id] <- newSysLocalsDs [from_tup_ty]
; let by_wrap = mkTupleCase us fromBinders by_e'
from_tup_id (Var from_tup_id)
; return [Lam from_tup_id by_wrap, expr] }
-- Create an unzip function for the appropriate arity and element types and find "map"
(unzip_fn, unzip_rhs) <- mkUnzipBind fromBindersTypes
......@@ -153,12 +147,12 @@ dsGroupStmt (GroupStmt (stmts, binderMap) groupByClause) = do
-- Generate the expressions to build the grouped list
let -- First we apply the grouping function to the inner list
inner_list_expr = mkApps usingExpr' ((Type fromBindersTupleType) : usingArgs)
inner_list_expr = mkApps usingExpr' ((Type from_tup_ty) : usingArgs)
-- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
-- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
-- the "b" to be a tuple of "to" lists!
unzipped_inner_list_expr = mkApps (Var map_id)
[Type (mkListTy fromBindersTupleType), Type toBindersTupleType, Var unzip_fn, inner_list_expr]
[Type (mkListTy from_tup_ty), Type toBindersTupleType, Var unzip_fn, inner_list_expr]
-- Then finally we bind the unzip function around that expression
bound_unzipped_inner_list_expr = Let (Rec [(unzip_fn, unzip_rhs)]) unzipped_inner_list_expr
......@@ -270,11 +264,11 @@ deListComp (LetStmt binds : quals) body list = do
core_rest <- deListComp quals body list
dsLocalBinds binds core_rest
deListComp (stmt@(TransformStmt _ _ _) : quals) body list = do
deListComp (stmt@(TransformStmt {}) : quals) body list = do
(inner_list_expr, pat) <- dsTransformStmt stmt
deBindComp pat inner_list_expr quals body list
deListComp (stmt@(GroupStmt _ _) : quals) body list = do
deListComp (stmt@(GroupStmt {}) : quals) body list = do
(inner_list_expr, pat) <- dsGroupStmt stmt
deBindComp pat inner_list_expr quals body list
......@@ -362,12 +356,12 @@ dfListComp c_id n_id (LetStmt binds : quals) body = do
core_rest <- dfListComp c_id n_id quals body
dsLocalBinds binds core_rest
dfListComp c_id n_id (stmt@(TransformStmt _ _ _) : quals) body = do
dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) body = do
(inner_list_expr, pat) <- dsTransformStmt stmt
-- Anyway, we bind the newly transformed list via the generic binding function
dfBindComp c_id n_id (pat, inner_list_expr) quals body
dfListComp c_id n_id (stmt@(GroupStmt _ _) : quals) body = do
dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) body = do
(inner_list_expr, pat) <- dsGroupStmt stmt
-- Anyway, we bind the newly grouped list via the generic binding function
dfBindComp c_id n_id (pat, inner_list_expr) quals body
......@@ -604,7 +598,7 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
--
dePArrComp (LetStmt ds : qs) body pa cea = do
mapP <- dsLookupGlobalId mapPName
let xs = map unLoc (collectLocalBinders ds)
let xs = collectLocalBinders ds
ty'cea = parrElemType cea
v <- newSysLocalDs ty'cea
clet <- dsLocalBinds ds (mkCoreTup (map Var xs))
......
......@@ -106,7 +106,7 @@ repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
repTopDs group
= do { let { bndrs = map unLoc (groupBinders group) } ;
= do { let { bndrs = groupBinders group } ;
ss <- mkGenSyms bndrs ;
-- Bind all the names mainly to avoid repeated use of explicit strings.
......@@ -135,13 +135,13 @@ repTopDs group
-- Do *not* gensym top-level binders
}
groupBinders :: HsGroup Name -> [Located Name]
groupBinders :: HsGroup Name -> [Name]
groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
hs_instds = inst_decls, hs_fords = foreign_decls })
-- Collect the binders of a Group
= collectHsValBinders val_decls ++
[n | d <- tycl_decls ++ assoc_tycl_decls, n <- tyClDeclNames (unLoc d)] ++
[n | L _ (ForeignImport n _ _) <- foreign_decls]
[n | d <- tycl_decls ++ assoc_tycl_decls, L _ n <- tyClDeclNames (unLoc d)] ++
[n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
where
assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls]
......@@ -317,7 +317,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
-- appear in the resulting data structure
do { cxt1 <- repContext cxt
; inst_ty1 <- repPredTy (HsClassP cls tys)
; ss <- mkGenSyms (collectHsBindBinders binds)
; ss <- mkGenSyms (collectHsBindsBinders binds)
; binds1 <- addBinds ss (rep_binds binds)
; ats1 <- repLAssocFamInst ats
; decls1 <- coreList decQTyConName (ats1 ++ binds1)
......@@ -900,7 +900,7 @@ repBinds EmptyLocalBinds
repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
repBinds (HsValBinds decs)
= do { let { bndrs = map unLoc (collectHsValBinders decs) }
= do { let { bndrs = collectHsValBinders decs }
-- No need to worrry about detailed scopes within
-- the binding group, because we are talking Names
-- here, so we can safely treat it as a mutually
......
......@@ -808,15 +808,6 @@ type LStmtLR idL idR = Located (StmtLR idL idR)
type Stmt id = StmtLR id id
data GroupByClause id
= GroupByNothing (LHsExpr id) -- Using expression, i.e.
-- "then group using f" ==> GroupByNothing f
| GroupBySomething (Either (LHsExpr id) (SyntaxExpr id)) (LHsExpr id)
-- "then group using f by e" ==> GroupBySomething (Left f) e
-- "then group by e" ==> GroupBySomething (Right _) e: in
-- this case the expression is filled
-- in by the renamer
-- The SyntaxExprs in here are used *only* for do-notation, which
-- has rebindable syntax. Otherwise they are unused.
data StmtLR idL idR
......@@ -838,16 +829,33 @@ data StmtLR idL idR
-- After renaming, the ids are the binders bound by the stmts and used
-- after them
| TransformStmt ([LStmt idL], [idR]) (LHsExpr idR) (Maybe (LHsExpr idR))
-- After renaming, the IDs are the binders occurring within this
-- transform statement that are used after it
-- "qs, then f by e" ==> TransformStmt (qs, binders) f (Just e)
-- "qs, then f" ==> TransformStmt (qs, binders) f Nothing
-- "qs, then f by e" ==> TransformStmt qs binders f (Just e)
-- "qs, then f" ==> TransformStmt qs binders f Nothing
| TransformStmt
[LStmt idL] -- Stmts are the ones to the left of the 'then'
[idR] -- After renaming, the IDs are the binders occurring
-- within this transform statement that are used after it
(LHsExpr idR) -- "then f"
(Maybe (LHsExpr idR)) -- "by e" (optional)
| GroupStmt ([LStmt idL], [(idR, idR)]) (GroupByClause idR)
-- After renaming, the IDs are the binders occurring within this
-- transform statement that are used after it which are paired with
-- the names which they group over in statements
| GroupStmt
[LStmt idL] -- Stmts to the *left* of the 'group'
-- which generates the tuples to be grouped
[(idR, idR)] -- After renaming, the IDs are the binders
-- occurring within this transform statement that
-- are used after it which are paired with the
-- names which they group over in statements
(Maybe (LHsExpr idR)) -- "by e" (optional)
(Either -- "using f"
(LHsExpr idR) -- Left f => explicit "using f"
(SyntaxExpr idR)) -- Right f => implicit; filled in with 'groupWith'
-- Recursive statement (see Note [RecStmt] below)
| RecStmt
......@@ -959,43 +967,57 @@ pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds]
pprStmt (ExprStmt expr _ _) = ppr expr
pprStmt (ParStmt stmtss) = hsep (map doStmts stmtss)
where doStmts stmts = ptext (sLit "| ") <> ppr stmts
pprStmt (TransformStmt (stmts, _) usingExpr maybeByExpr)
= (hsep [stmtsDoc, ptext (sLit "then"), ppr usingExpr, byExprDoc])
where stmtsDoc = interpp'SP stmts
byExprDoc = maybe empty (\byExpr -> hsep [ptext (sLit "by"), ppr byExpr]) maybeByExpr
pprStmt (GroupStmt (stmts, _) groupByClause) = (hsep [stmtsDoc, ptext (sLit "then group"), pprGroupByClause groupByClause])
where stmtsDoc = interpp'SP stmts
pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids, recS_later_ids = later_ids })
pprStmt (TransformStmt stmts _ using by)
= sep (ppr_lc_stmts stmts ++ [pprTransformStmt using by])
pprStmt (GroupStmt stmts _ by using)
= sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using])
pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
, recS_later_ids = later_ids })
= ptext (sLit "rec") <+>
vcat [ braces (vcat (map ppr segment))
, ifPprDebug (vcat [ ptext (sLit "rec_ids=") <> ppr rec_ids
, ptext (sLit "later_ids=") <> ppr later_ids])]
pprGroupByClause :: (OutputableBndr id) => GroupByClause id -> SDoc
pprGroupByClause (GroupByNothing usingExpr) = hsep [ptext (sLit "using"), ppr usingExpr]
pprGroupByClause (GroupBySomething eitherUsingExpr byExpr) = hsep [ptext (sLit "by"), ppr byExpr, usingExprDoc]
where usingExprDoc = either (\usingExpr -> hsep [ptext (sLit "using"), ppr usingExpr]) (const empty) eitherUsingExpr
pprTransformStmt :: OutputableBndr id => LHsExpr id -> Maybe (LHsExpr id) -> SDoc
pprTransformStmt using by = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)]
pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id)
-> Either (LHsExpr id) (SyntaxExpr is)
-> SDoc
pprGroupStmt by using
= sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ppr_using using)]
where
ppr_using (Right _) = empty
ppr_using (Left e) = ptext (sLit "using") <+> ppr e
pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc
pprBy Nothing = empty
pprBy (Just e) = ptext (sLit "by") <+> ppr e
pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body
pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body
pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body
pprDo ListComp stmts body = pprComp brackets stmts body
pprDo PArrComp stmts body = pprComp pa_brackets stmts body
pprDo ListComp stmts body = brackets $ pprComp stmts body
pprDo PArrComp stmts body = pa_brackets $ pprComp stmts body
pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
-- Print a bunch of do stmts, with explicit braces and semicolons,
-- so that we are not vulnerable to layout bugs
ppr_do_stmts stmts body
= lbrace <+> pprDeeperList vcat ([ ppr s <> semi | s <- stmts] ++ [ppr body])
= lbrace <+> pprDeeperList vcat ([ppr s <> semi | s <- stmts] ++ [ppr body])
<+> rbrace
pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc
pprComp brack quals body
= brack $
hang (ppr body <+> char '|')
4 (interpp'SP quals)
ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc]
ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts]
pprComp :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
pprComp quals body -- Prints: body | qual1, ..., qualn
= hang (ppr body <+> char '|') 2 (interpp'SP quals)
\end{code}
%************************************************************************
......@@ -1202,5 +1224,10 @@ pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <>
pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR)
=> HsStmtContext idL -> StmtLR idL idR -> SDoc
pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon)
4 (ppr stmt)
4 (ppr_stmt stmt)
where
-- For Group and Transform Stmts, don't print the nested stmts!
ppr_stmt (GroupStmt _ _ by using) = pprGroupStmt by using
ppr_stmt (TransformStmt _ _ using by) = pprTransformStmt using by
ppr_stmt stmt = pprStmt stmt
\end{code}
......@@ -195,7 +195,7 @@ data HsRecFields id arg -- A bunch of record fields
data HsRecField id arg = HsRecField {
hsRecFieldId :: Located id,
hsRecFieldArg :: arg,
hsRecFieldArg :: arg, -- Filled in by renamer
hsRecPun :: Bool -- Note [Punning]
}
......
This diff is collapsed.
......@@ -179,7 +179,7 @@ rnTopBinds :: HsValBinds RdrName
-> RnM (HsValBinds Name, DefUses)
rnTopBinds b =
do nl <- rnTopBindsLHS emptyFsEnv b
let bound_names = map unLoc (collectHsValBinders nl)
let bound_names = collectHsValBinders nl
bindLocalNames bound_names $ rnTopBindsRHS (mkNameSet bound_names) nl
......@@ -261,7 +261,7 @@ rnValBindsLHS fix_env binds
-- g = let f = ... in f
-- should.
; binds' <- rnValBindsLHSFromDoc (localRecNameMaker fix_env) binds
; let bound_names = map unLoc $ collectHsValBinders binds'
; let bound_names = collectHsValBinders binds'
; envs <- getRdrEnvs
; checkDupAndShadowedNames envs bound_names
; return (bound_names, binds') }
......@@ -276,7 +276,7 @@ rnValBindsLHSFromDoc topP (ValBindsIn mbinds sigs)
= do { mbinds' <- mapBagM (rnBindLHS topP doc) mbinds
; return $ ValBindsIn mbinds' sigs }
where
bndrs = collectHsBindBinders mbinds
bndrs = collectHsBindsBinders mbinds
doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs
rnValBindsLHSFromDoc _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
......
......@@ -26,8 +26,8 @@ module RnEnv (
bindTyVarsRn, extendTyVarEnvFVRn,
checkDupRdrNames, checkDupAndShadowedRdrNames,
checkDupAndShadowedNames,
mapFvRn, mapFvRnCPS,
checkDupNames, checkDupAndShadowedNames,
addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
warnUnusedMatches, warnUnusedModules, warnUnusedImports,
warnUnusedTopBinds, warnUnusedLocalBinds,
dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg
......@@ -989,11 +989,19 @@ checkShadowedOccs (global_env,local_env) loc_occs
\begin{code}
-- A useful utility
addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside
; return (res, fvs1 `plusFV` fvs2) }
mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn f xs = do stuff <- mapM f xs
case unzip stuff of
(ys, fvs_s) -> return (ys, plusFVs fvs_s)
mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)
mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }
-- because some of the rename functions are CPSed:
-- maps the function across the list from left to right;
-- collects all the free vars into one set
......
This diff is collapsed.
......@@ -233,7 +233,8 @@ rnPats ctxt pats thing_inside
rnPat :: HsMatchContext Name -- for error messages
-> LPat RdrName
-> (LPat Name -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-> RnM (a, FreeVars) -- Variables bound by pattern do not
-- appear in the result FreeVars
rnPat ctxt pat thing_inside
= rnPats ctxt [pat] (\[pat'] -> thing_inside pat')
......
......@@ -125,7 +125,7 @@ rnSrcDecls group@(HsGroup {hs_valds = val_decls,
-- It uses the fixity env from (A) to bind fixities for view patterns.
new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
-- bind the LHSes (and their fixities) in the global rdr environment
let { val_binders = map unLoc $ collectHsValBinders new_lhs ;
let { val_binders = collectHsValBinders new_lhs ;
val_bndr_set = mkNameSet val_binders ;
all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ;
val_avails = map Avail val_binders
......@@ -440,7 +440,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
-- The typechecker (not the renamer) checks that all
-- the bindings are for the right class
let
meth_names = collectHsBindLocatedBinders mbinds
meth_names = collectMethodBinders mbinds
(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
in
checkDupRdrNames meth_names `thenM_`
......@@ -478,7 +478,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
--
-- But the (unqualified) method names are in scope
let
binders = collectHsBindBinders mbinds'
binders = collectHsBindsBinders mbinds'
bndr_set = mkNameSet binders
in
bindLocalNames binders
......
......@@ -310,7 +310,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragFun
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
= let
bind_list = bagToList binds
binder_names = collectHsBindBinders binds
binder_names = collectHsBindsBinders binds
loc = getLoc (head bind_list)
-- TODO: location a bit awkward, but the mbinds have been
-- dependency analysed and may no longer be adjacent
......
......@@ -337,7 +337,7 @@ renameDeriv is_boot gen_binds insts
; let aux_binds = listToBag $ map (genAuxBind loc) $
rm_dups [] $ concat deriv_aux_binds
; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv (ValBindsIn aux_binds [])
; let aux_names = map unLoc (collectHsValBinders rn_aux_lhs)
; let aux_names = collectHsValBinders rn_aux_lhs
; bindLocalNames aux_names $
do { (rn_aux, dus_aux) <- rnTopBindsRHS (mkNameSet aux_names) rn_aux_lhs
......
......@@ -318,7 +318,7 @@ zonkValBinds env (ValBindsOut binds sigs)
zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env binds
= fixM (\ ~(_, new_binds) -> do
{ let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
{ let env1 = extendZonkEnv env (collectHsBindsBinders new_binds)
; binds' <- zonkMonoBinds env1 binds
; return (env1, binds') })
......@@ -351,7 +351,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
fixM (\ ~(new_val_binds, _) ->
let
env1 = extendZonkEnv env new_dicts
env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds)
env2 = extendZonkEnv env1 (collectHsBindsBinders new_val_binds)
in
zonkMonoBinds env2 val_binds `thenM` \ new_val_binds ->
mappM (zonkExport env2) exports `thenM` \ new_exports ->
......@@ -710,32 +710,21 @@ zonkStmt env (ExprStmt expr then_op ty)
zonkTcTypeToType env ty `thenM` \ new_ty ->
returnM (env, ExprStmt new_expr new_then new_ty)
zonkStmt env (TransformStmt (stmts, binders) usingExpr maybeByExpr)
zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr)
= do { (env', stmts') <- zonkStmts env stmts
; let binders' = zonkIdOccs env' binders
; usingExpr' <- zonkLExpr env' usingExpr
; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
; return (env', TransformStmt (stmts', binders') usingExpr' maybeByExpr') }
; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') }
zonkStmt env (GroupStmt (stmts, binderMap) groupByClause)
zonkStmt env (GroupStmt stmts binderMap by using)
= do { (env', stmts') <- zonkStmts env stmts
; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
; groupByClause' <-
case groupByClause of
GroupByNothing usingExpr -> (zonkLExpr env' usingExpr) >>= (return . GroupByNothing)
GroupBySomething eitherUsingExpr byExpr -> do
eitherUsingExpr' <- mapEitherM (zonkLExpr env') (zonkExpr env') eitherUsingExpr
byExpr' <- zonkLExpr env' byExpr
return $ GroupBySomething eitherUsingExpr' byExpr'
; by' <- fmapMaybeM (zonkLExpr env') by
; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using
; let env'' = extendZonkEnv env' (map snd binderMap')
; return (env'', GroupStmt (stmts', binderMap') groupByClause') }
; return (env'', GroupStmt stmts' binderMap' by' using') }
where
mapEitherM f g x = do
case x of
Left a -> f a >>= (return . Left)
Right b -> g b >>= (return . Right)
zonkBinderMapEntry env (oldBinder, newBinder) = do
let oldBinder' = zonkIdOcc env oldBinder
newBinder' <- zonkIdBndr env newBinder
......
......@@ -392,7 +392,7 @@ tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
; return (ids, pairs', thing) }
; return ( (stmts', ids) : pairs', thing ) }
tcLcStmt m_tc ctxt (TransformStmt (stmts, binders) usingExpr maybeByExpr) elt_ty thing_inside = do
tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr) elt_ty thing_inside = do
(stmts', (binders', usingExpr', maybeByExpr', thing)) <-
tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
let alphaListTy = mkTyConApp m_tc [alphaTy]
......@@ -414,46 +414,47 @@ tcLcStmt m_tc ctxt (TransformStmt (stmts, binders) usingExpr maybeByExpr) elt_ty
return (binders', usingExpr', maybeByExpr', thing)
return (TransformStmt (stmts', binders') usingExpr' maybeByExpr', thing)
return (TransformStmt stmts' binders' usingExpr' maybeByExpr', thing)
tcLcStmt m_tc ctxt (GroupStmt (stmts, bindersMap) groupByClause) elt_ty thing_inside = do
(stmts', (bindersMap', groupByClause', thing)) <-
tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside
= do { let (bndr_names, list_bndr_names) = unzip bindersMap
; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
let alphaListTy = mkTyConApp m_tc [alphaTy]
alphaListListTy = mkTyConApp m_tc [alphaListTy]
groupByClause' <-
case groupByClause of
GroupByNothing usingExpr ->
-- We must validate that usingExpr :: forall a. [a] -> [[a]]
tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
GroupBySomething eitherUsingExpr byExpr -> do
-- We must infer a type such that byExpr :: t
(byExpr', tTy) <- tcInferRhoNC byExpr
-- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
eitherUsingExpr' <-
case eitherUsingExpr of
Left usingExpr -> (tcPolyExpr usingExpr expectedUsingType) >>= (return . Left)
Right usingExpr -> (tcPolyExpr (noLoc usingExpr) expectedUsingType) >>= (return . Right . unLoc)
return $ GroupBySomething eitherUsingExpr' byExpr'
-- Find the IDs and types of all old binders
let (oldBinders, newBinders) = unzip bindersMap
oldBinders' <- tcLookupLocalIds oldBinders
(by', using_ty) <- case by of
Nothing -> -- check that using :: forall a. [a] -> [[a]]
return (Nothing, mkForAllTy alphaTyVar $
alphaListTy `mkFunTy` alphaListListTy)
Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
-- where by :: t
do { (by_e', t_ty) <- tcInferRhoNC by_e
; return (Just by_e', mkForAllTy alphaTyVar $
(alphaTy `mkFunTy` t_ty)
`mkFunTy` alphaListTy
`mkFunTy` alphaListListTy) }
-- Find the Ids (and hence types) of all old binders
bndr_ids <- tcLookupLocalIds bndr_names
return (bndr_ids, by', using_ty, elt_ty')
-- Ensure that every old binder of type b is linked up with its new binder which should have type [b]
let newBinders' = zipWith associateNewBinder oldBinders' newBinders
; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
bindersMap' = bndr_ids `zip` list_bndr_ids
-- Type check the thing in the environment with these new binders and return the result
thing <- tcExtendIdEnv newBinders' (thing_inside elt_ty')
return (zipEqual "tcLcStmt: Old and new binder lists were not of the same length" oldBinders' newBinders', groupByClause', thing)
return (GroupStmt (stmts', bindersMap') groupByClause', thing)
where
associateNewBinder :: TcId -> Name -> TcId
associateNewBinder oldBinder newBinder = mkLocalId newBinder (mkTyConApp m_tc [idType oldBinder])
; using' <- case using of
Left e -> do { e' <- tcPolyExpr e using_ty; return (Left e') }
Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }