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

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]
}
......
......@@ -14,7 +14,51 @@ which deal with the intantiated versions are located elsewhere:
Id typecheck/TcHsSyn
\begin{code}
module HsUtils where
module HsUtils(
-- Terms
mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkMatch, mkHsLam,
mkHsWrap, mkLHsWrap, mkHsWrapCoI, coiToHsWrapper, mkHsDictLet,
mkHsOpApp, mkHsDo,
nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
-- Bindigns
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mk_FunBind,
-- Literals
mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
-- Patterns
mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, nlInfixConPat,
nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat,
-- Types
mkHsAppTy, userHsTyVarBndrs,
nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
-- Stmts
mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt,
mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
emptyRecStmt, mkRecStmt,
-- Template Haskell
unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsQuasiQuote, unqualQuasiQuote,
-- Flags
noRebindableInfo,
-- Collecting binders
collectLocalBinders, collectHsValBinders,
collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
collectPatBinders, collectPatsBinders,
collectLStmtsBinders, collectStmtsBinders,
collectLStmtBinders, collectStmtBinders,
collectSigTysFromPats, collectSigTysFromPat
) where
import HsBinds
import HsExpr
......@@ -135,10 +179,6 @@ mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
mkExprStmt :: LHsExpr idR -> StmtLR idL idR
mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
......@@ -158,12 +198,16 @@ mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
mkNPat lit neg = NPat lit neg noSyntaxExpr
mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
mkTransformStmt stmts usingExpr = TransformStmt (stmts, []) usingExpr Nothing
mkTransformByStmt stmts usingExpr byExpr = TransformStmt (stmts, []) usingExpr (Just byExpr)
mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing
mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr)
mkGroupUsingStmt stmts usingExpr = GroupStmt (stmts, []) (GroupByNothing usingExpr)
mkGroupByStmt stmts byExpr = GroupStmt (stmts, []) (GroupBySomething (Right noSyntaxExpr) byExpr)
mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt (stmts, []) (GroupBySomething (Left usingExpr) byExpr)
mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
mkGroupUsingStmt stmts usingExpr = GroupStmt stmts [] Nothing (Left usingExpr)
mkGroupByStmt stmts byExpr = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr)
mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr)
mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType
mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
......@@ -362,7 +406,7 @@ mkMatch pats expr binds
%************************************************************************
%* *
Collecting binders from HsBindGroups and HsBinds
Collecting binders
%* *
%************************************************************************
......@@ -376,126 +420,116 @@ where
it should return [x, y, f, a, b] (remember, order important).
Note [Collect binders only after renaming]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
These functions should only be used on HsSyn *after* the renamer,
to reuturn a [Name] or [Id]. Before renaming the record punning
and wild-card mechanism makes it hard to know what is bound.
So these functions should not be applied to (HsSyn RdrName)
\begin{code}
collectLocalBinders :: HsLocalBindsLR idL idR -> [Located idL]
----------------- Bindings --------------------------
collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
collectLocalBinders (HsIPBinds _) = []
collectLocalBinders EmptyLocalBinds = []
collectHsValBinders :: HsValBindsLR idL idR -> [Located idL]
collectHsValBinders (ValBindsIn binds _) = collectHsBindLocatedBinders binds
collectHsValBinders :: HsValBindsLR idL idR -> [idL]
collectHsValBinders (ValBindsIn binds _) = collectHsBindsBinders binds
collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
where
collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
collectAcc :: HsBindLR idL idR -> [Located idL] -> [Located idL]
collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
collectAcc (FunBind { fun_id = f }) acc = f : acc
collectAcc (VarBind { var_id = f }) acc = noLoc f : acc
collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
= [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
-- ++ foldr collectAcc acc binds
collect_one (_,binds) acc = collect_binds binds acc
collectHsBindBinders :: HsBindLR idL idR -> [idL]
collectHsBindBinders b = collect_bind b []
collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
collect_bind (PatBind { pat_lhs = p }) acc = collect_lpat p acc
collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
collect_bind (VarBind { var_id = f }) acc = f : acc
collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
= [dp | (_,dp,_,_) <- dbinds] ++ acc
-- ++ foldr collect_bind acc binds
-- I don't think we want the binders from the nested binds
-- The only time we collect binders from a typechecked
-- binding (hence see AbsBinds) is in zonking in TcHsSyn
collectHsBindBinders :: LHsBindsLR idL idR -> [idL]
collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)