summaryrefslogtreecommitdiff
path: root/compiler/rename
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2018-04-18 23:55:14 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2018-04-27 15:38:46 +0200
commitc3823cba2147c74b2c727b5458b9e95350496988 (patch)
treee9afa7f5fd6b1a3f2f1a2ee87d659342803e6a2d /compiler/rename
parent313720a453889ddd05da02f4f2c31eb3bc3734d2 (diff)
downloadhaskell-c3823cba2147c74b2c727b5458b9e95350496988.tar.gz
TTG : complete for balance of hsSyn AST
Summary: - remove PostRn/PostTc fields - remove the HsVect In/Out distinction for Type, Class and Instance - remove PlaceHolder in favour of NoExt - Simplify OutputableX constraint Updates haddock submodule Test Plan: ./validate Reviewers: goldfire, bgamari Subscribers: goldfire, thomie, mpickering, carter Differential Revision: https://phabricator.haskell.org/D4625
Diffstat (limited to 'compiler/rename')
-rw-r--r--compiler/rename/RnBinds.hs27
-rw-r--r--compiler/rename/RnExpr.hs152
-rw-r--r--compiler/rename/RnNames.hs71
-rw-r--r--compiler/rename/RnPat.hs10
-rw-r--r--compiler/rename/RnSource.hs259
-rw-r--r--compiler/rename/RnSplice.hs6
-rw-r--r--compiler/rename/RnTypes.hs39
7 files changed, 329 insertions, 235 deletions
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 4ce3a58539..d7790ca419 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -299,7 +299,7 @@ rnValBindsRHS ctxt (ValBinds _ mbinds sigs)
; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds
; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus
- ; let patsyn_fvs = foldr (unionNameSet . psb_fvs) emptyNameSet $
+ ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $
getPatSynBinds anal_binds
-- The uses in binds_w_dus for PatSynBinds do not include
-- variables used in the patsyn builders; see
@@ -705,11 +705,10 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
-- As well as dependency analysis, we need these for the
-- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
- bind' = bind{ psb_ext = noExt
- , psb_args = details'
+ bind' = bind{ psb_args = details'
, psb_def = pat'
, psb_dir = dir'
- , psb_fvs = fvs' }
+ , psb_ext = fvs' }
selector_names = case details' of
RecCon names ->
map (unLoc . recordPatSynSelectorId) names
@@ -1155,6 +1154,7 @@ rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })
; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
; return (mkMatchGroup origin new_ms, ms_fvs) }
+rnMatchGroup _ _ (XMatchGroup {}) = panic "rnMatchGroup"
rnMatch :: Outputable (body GhcPs) => HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
@@ -1174,8 +1174,9 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
(FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })
-> mf { mc_fun = L lf funid }
_ -> ctxt
- ; return (Match { m_ctxt = mf', m_pats = pats'
+ ; return (Match { m_ext = noExt, m_ctxt = mf', m_pats = pats'
, m_grhss = grhss'}, grhss_fvs ) }}
+rnMatch' _ _ (XMatch _) = panic "rnMatch'"
emptyCaseErr :: HsMatchContext Name -> SDoc
emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
@@ -1198,10 +1199,11 @@ rnGRHSs :: HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> GRHSs GhcPs (Located (body GhcPs))
-> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)
-rnGRHSs ctxt rnBody (GRHSs grhss (L l binds))
+rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))
= rnLocalBindsAndThen binds $ \ binds' _ -> do
(grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
- return (GRHSs grhss' (L l binds'), fvGRHSs)
+ return (GRHSs noExt grhss' (L l binds'), fvGRHSs)
+rnGRHSs _ _ (XGRHSs _) = panic "rnGRHSs"
rnGRHS :: HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
@@ -1213,7 +1215,7 @@ rnGRHS' :: HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> GRHS GhcPs (Located (body GhcPs))
-> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)
-rnGRHS' ctxt rnBody (GRHS guards rhs)
+rnGRHS' ctxt rnBody (GRHS _ guards rhs)
= do { pattern_guards_allowed <- xoptM LangExt.PatternGuards
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->
rnBody rhs
@@ -1221,14 +1223,15 @@ rnGRHS' ctxt rnBody (GRHS guards rhs)
; unless (pattern_guards_allowed || is_standard_guard guards')
(addWarn NoReason (nonStdGuardErr guards'))
- ; return (GRHS guards' rhs', fvs) }
+ ; return (GRHS noExt guards' rhs', fvs) }
where
-- Standard Haskell 1.4 guards are just a single boolean
-- expression, rather than a list of qualifiers as in the
-- Glasgow extension
- is_standard_guard [] = True
- is_standard_guard [L _ (BodyStmt _ _ _ _)] = True
- is_standard_guard _ = False
+ is_standard_guard [] = True
+ is_standard_guard [L _ (BodyStmt {})] = True
+ is_standard_guard _ = False
+rnGRHS' _ _ (XGRHS _) = panic "rnGRHS'"
{-
*********************************************************
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 4fe4102891..8478ab0322 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -594,16 +594,20 @@ methodNamesMatch (MG { mg_alts = L _ ms })
= plusFVs (map do_one ms)
where
do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss
+ do_one (L _ (XMatch _)) = panic "methodNamesMatch.XMatch"
+methodNamesMatch (XMatchGroup _) = panic "methodNamesMatch"
-------------------------------------------------
-- gaw 2004
methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
-methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
+methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
+methodNamesGRHSs (XGRHSs _) = panic "methodNamesGRHSs"
-------------------------------------------------
methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
-methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
+methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs
+methodNamesGRHS (L _ (XGRHS _)) = panic "methodNamesGRHS"
---------------------------------------------------
methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars
@@ -614,17 +618,18 @@ methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars
methodNamesLStmt = methodNamesStmt . unLoc
methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
-methodNamesStmt (LastStmt cmd _ _) = methodNamesLCmd cmd
-methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd
-methodNamesStmt (BindStmt _ cmd _ _ _) = methodNamesLCmd cmd
+methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd
+methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd
+methodNamesStmt (BindStmt _ _ cmd _ _) = methodNamesLCmd cmd
methodNamesStmt (RecStmt { recS_stmts = stmts }) =
methodNamesStmts stmts `addOneFV` loopAName
-methodNamesStmt (LetStmt {}) = emptyFVs
-methodNamesStmt (ParStmt {}) = emptyFVs
-methodNamesStmt (TransStmt {}) = emptyFVs
-methodNamesStmt ApplicativeStmt{} = emptyFVs
+methodNamesStmt (LetStmt {}) = emptyFVs
+methodNamesStmt (ParStmt {}) = emptyFVs
+methodNamesStmt (TransStmt {}) = emptyFVs
+methodNamesStmt ApplicativeStmt{} = emptyFVs
-- ParStmt and TransStmt can't occur in commands, but it's not
-- convenient to error here so we just do what's convenient
+methodNamesStmt (XStmtLR {}) = panic "methodNamesStmt"
{-
************************************************************************
@@ -823,14 +828,14 @@ rnStmt :: Outputable (body GhcPs)
-- Variables bound by the Stmt, and mentioned in thing_inside,
-- do not appear in the result FreeVars
-rnStmt ctxt rnBody (L loc (LastStmt body noret _)) thing_inside
+rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside
= do { (body', fv_expr) <- rnBody body
; (ret_op, fvs1) <- lookupStmtName ctxt returnMName
; (thing, fvs3) <- thing_inside []
- ; return (([(L loc (LastStmt body' noret ret_op), fv_expr)], thing),
- fv_expr `plusFV` fvs1 `plusFV` fvs3) }
+ ; return (([(L loc (LastStmt noExt body' noret ret_op), fv_expr)]
+ , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }
-rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
+rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside
= do { (body', fv_expr) <- rnBody body
; (then_op, fvs1) <- lookupStmtName ctxt thenMName
; (guard_op, fvs2) <- if isListCompExpr ctxt
@@ -840,11 +845,10 @@ rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
-- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
-- Here "gd" is a guard
; (thing, fvs3) <- thing_inside []
- ; return (([(L loc (BodyStmt body'
- then_op guard_op placeHolderType), fv_expr)], thing),
- fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
+ ; return ( ([(L loc (BodyStmt noExt body' then_op guard_op), fv_expr)]
+ , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
-rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside
+rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside
= do { (body', fv_expr) <- rnBody body
-- The binders do not scope over the expression
; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
@@ -866,17 +870,18 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside
; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
{ (thing, fvs3) <- thing_inside (collectPatBinders pat')
- ; return (( [( L loc (BindStmt pat' body' bind_op fail_op placeHolder)
+ ; return (( [( L loc (BindStmt noExt pat' body' bind_op fail_op)
, fv_expr )]
, thing),
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
-- fv_expr shouldn't really be filtered by the rnPatsAndThen
-- but it does not matter because the names are unique
-rnStmt _ _ (L loc (LetStmt (L l binds))) thing_inside
+rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside
= do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
{ (thing, fvs) <- thing_inside (collectLocalBinders binds')
- ; return (([(L loc (LetStmt (L l binds')), bind_fvs)], thing), fvs) } }
+ ; return ( ([(L loc (LetStmt noExt (L l binds')), bind_fvs)], thing)
+ , fvs) } }
rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
= do { (return_op, fvs1) <- lookupStmtName ctxt returnMName
@@ -908,12 +913,12 @@ rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
, fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
-rnStmt ctxt _ (L loc (ParStmt segs _ _ _)) thing_inside
+rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside
= do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName
; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
; (return_op, fvs3) <- lookupStmtName ctxt returnMName
; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
- ; return ( ([(L loc (ParStmt segs' mzip_op bind_op placeHolderType), fvs4)], thing)
+ ; return (([(L loc (ParStmt noExt segs' mzip_op bind_op), fvs4)], thing)
, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
@@ -946,15 +951,18 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
-- See Note [TransStmt binder map] in HsExpr
; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)
- ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
+ ; return (([(L loc (TransStmt { trS_ext = noExt
+ , trS_stmts = stmts', trS_bndrs = bndr_map
, trS_by = by', trS_using = using', trS_form = form
, trS_ret = return_op, trS_bind = bind_op
- , trS_bind_arg_ty = placeHolder
, trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
rnStmt _ _ (L _ ApplicativeStmt{}) _ =
panic "rnStmt: ApplicativeStmt"
+rnStmt _ _ (L _ XStmtLR{}) _ =
+ panic "rnStmt: XStmtLR"
+
rnParallelStmts :: forall thing. HsStmtContext Name
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
@@ -1099,7 +1107,7 @@ rnRecStmtsAndThen rnBody s cont
collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities l =
foldr (\ s -> \acc -> case s of
- (L _ (LetStmt (L _ (HsValBinds _ (ValBinds _ _ sigs))))) ->
+ (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) ->
foldr (\ sig -> \ acc -> case sig of
(L loc (FixSig _ s)) -> (L loc s) : acc
_ -> acc) acc sigs
@@ -1114,25 +1122,24 @@ rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
-- so we don't bother to compute it accurately in the other cases
-> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
-rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c))
- = return [(L loc (BodyStmt body a b c), emptyFVs)]
+rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))
+ = return [(L loc (BodyStmt noExt body a b), emptyFVs)]
-rn_rec_stmt_lhs _ (L loc (LastStmt body noret a))
- = return [(L loc (LastStmt body noret a), emptyFVs)]
+rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))
+ = return [(L loc (LastStmt noExt body noret a), emptyFVs)]
-rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b t))
+rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b))
= do
-- should the ctxt be MDo instead?
(pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
- return [(L loc (BindStmt pat' body a b t),
- fv_pat)]
+ return [(L loc (BindStmt noExt pat' body a b), fv_pat)]
-rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds {}))))
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))))
= failWith (badIpBinds (text "an mdo expression") binds)
-rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds x binds))))
+rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds))))
= do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
- return [(L loc (LetStmt (L l (HsValBinds x binds'))),
+ return [(L loc (LetStmt noExt (L l (HsValBinds x binds'))),
-- Warning: this is bogus; see function invariant
emptyFVs
)]
@@ -1150,10 +1157,12 @@ rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
= pprPanic "rn_rec_stmt" (ppr stmt)
-rn_rec_stmt_lhs _ (L _ (LetStmt (L _ (EmptyLocalBinds _))))
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))))
= panic "rn_rec_stmt LetStmt EmptyLocalBinds"
-rn_rec_stmt_lhs _ (L _ (LetStmt (L _ (XHsLocalBindsLR _))))
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))))
= panic "rn_rec_stmt LetStmt XHsLocalBindsLR"
+rn_rec_stmt_lhs _ (L _ (XStmtLR _))
+ = panic "rn_rec_stmt XStmtLR"
rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
-> [LStmt GhcPs body]
@@ -1178,19 +1187,19 @@ rn_rec_stmt :: (Outputable (body GhcPs)) =>
-- Rename a Stmt that is inside a RecStmt (or mdo)
-- Assumes all binders are already in scope
-- Turns each stmt into a singleton Stmt
-rn_rec_stmt rnBody _ (L loc (LastStmt body noret _), _)
+rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _)
= do { (body', fv_expr) <- rnBody body
; (ret_op, fvs1) <- lookupSyntaxName returnMName
; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
- L loc (LastStmt body' noret ret_op))] }
+ L loc (LastStmt noExt body' noret ret_op))] }
-rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
+rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)
= do { (body', fvs) <- rnBody body
; (then_op, fvs1) <- lookupSyntaxName thenMName
; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
- L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] }
+ L loc (BodyStmt noExt body' then_op noSyntaxExpr))] }
-rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat)
+rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)
= do { (body', fv_expr) <- rnBody body
; (bind_op, fvs1) <- lookupSyntaxName bindMName
@@ -1202,17 +1211,17 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat)
; let bndrs = mkNameSet (collectPatBinders pat')
fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
- L loc (BindStmt pat' body' bind_op fail_op placeHolder))] }
+ L loc (BindStmt noExt pat' body' bind_op fail_op))] }
-rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds {}))), _)
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)
= failWith (badIpBinds (text "an mdo expression") binds)
-rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds x binds'))), _)
+rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _)
= do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
-- fixities and unused are handled above in rnRecStmtsAndThen
; let fvs = allUses du_binds
; return [(duDefs du_binds, fvs, emptyNameSet,
- L loc (LetStmt (L l (HsValBinds x binds'))))] }
+ L loc (LetStmt noExt (L l (HsValBinds x binds'))))] }
-- no RecStmt case because they get flattened above when doing the LHSes
rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)
@@ -1224,15 +1233,18 @@ rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo
rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
-rn_rec_stmt _ _ (L _ (LetStmt (L _ (XHsLocalBindsLR _))), _)
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))), _)
= panic "rn_rec_stmt: LetStmt XHsLocalBindsLR"
-rn_rec_stmt _ _ (L _ (LetStmt (L _ (EmptyLocalBinds _))), _)
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)
= panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
= pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
+rn_rec_stmt _ _ stmt@(L _ (XStmtLR {}), _)
+ = pprPanic "rn_rec_stmt: XStmtLR" (ppr stmt)
+
rn_rec_stmts :: Outputable (body GhcPs) =>
(Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [Name]
@@ -1664,16 +1676,16 @@ stmtTreeToStmts
-- In the spec, but we do it here rather than in the desugarer,
-- because we need the typechecker to typecheck the <$> form rather than
-- the bind form, which would give rise to a Monad constraint.
-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt pat rhs _ _ _),_))
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ _), _))
tail _tail_fvs
| not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
-- See Note [ApplicativeDo and strict patterns]
- = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs False] False tail'
-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt rhs _ _ _),_))
+ = mkApplicativeStmt ctxt [ApplicativeArgOne noExt pat rhs False] False tail'
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
tail _tail_fvs
| (False,tail') <- needJoin monad_names tail
= mkApplicativeStmt ctxt
- [ApplicativeArgOne nlWildPatName rhs True] False tail'
+ [ApplicativeArgOne noExt nlWildPatName rhs True] False tail'
stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
return (s : tail, emptyNameSet)
@@ -1691,10 +1703,10 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
(stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
return (stmts, unionNameSets (fvs:fvss))
where
- stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt pat exp _ _ _), _)) =
- return (ApplicativeArgOne pat exp False, emptyFVs)
- stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt exp _ _ _), _)) =
- return (ApplicativeArgOne nlWildPatName exp True, emptyFVs)
+ stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _))
+ = return (ApplicativeArgOne noExt pat exp False, emptyFVs)
+ stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
+ return (ApplicativeArgOne noExt nlWildPatName exp True, emptyFVs)
stmtTreeArg ctxt tail_fvs tree = do
let stmts = flattenStmtTree tree
pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
@@ -1710,7 +1722,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
| otherwise -> do
(ret,fvs) <- lookupStmtNamePoly ctxt returnMName
return (HsApp noExt (noLoc ret) tup, fvs)
- return ( ApplicativeArgMany stmts' mb_ret pat
+ return ( ApplicativeArgMany noExt stmts' mb_ret pat
, fvs1 `plusFV` fvs2)
@@ -1764,7 +1776,7 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
pvars = mkNameSet (collectStmtBinders (unLoc stmt))
isStrictPatternBind :: ExprLStmt GhcRn -> Bool
- isStrictPatternBind (L _ (BindStmt pat _ _ _ _)) = isStrictPattern pat
+ isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat
isStrictPatternBind _ = False
{-
@@ -1852,9 +1864,9 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
-- strict patterns though; splitSegments expects that if we return Just
-- then we have actually done some splitting. Otherwise it will go into
-- an infinite loop (#14163).
- go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : rest)
+ go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest)
| isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)
- = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep)
+ = go lets ((L loc (BindStmt noExt pat body bind_op fail_op), fvs) : indep)
bndrs' rest
where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
-- If we encounter a LetStmt that doesn't depend on a BindStmt in this
@@ -1862,9 +1874,9 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
-- grouping more BindStmts.
-- TODO: perhaps we shouldn't do this if there are any strict bindings,
-- because we might be moving evaluation earlier.
- go lets indep bndrs ((L loc (LetStmt binds), fvs) : rest)
+ go lets indep bndrs ((L loc (LetStmt noExt binds), fvs) : rest)
| isEmptyNameSet (bndrs `intersectNameSet` fvs)
- = go ((L loc (LetStmt binds), fvs) : lets) indep bndrs rest
+ = go ((L loc (LetStmt noExt binds), fvs) : lets) indep bndrs rest
go _ [] _ _ = Nothing
go _ [_] _ _ = Nothing
go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
@@ -1897,10 +1909,9 @@ mkApplicativeStmt ctxt args need_join body_stmts
; return (Just join_op, fvs) }
else
return (Nothing, emptyNameSet)
- ; let applicative_stmt = noLoc $ ApplicativeStmt
+ ; let applicative_stmt = noLoc $ ApplicativeStmt noExt
(zip (fmap_op : repeat ap_op) args)
mb_join
- placeHolderType
; return ( applicative_stmt : body_stmts
, fvs1 `plusFV` fvs2 `plusFV` fvs3) }
@@ -1910,9 +1921,9 @@ needJoin :: MonadNames
-> [ExprLStmt GhcRn]
-> (Bool, [ExprLStmt GhcRn])
needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg
-needJoin monad_names [L loc (LastStmt e _ t)]
+needJoin monad_names [L loc (LastStmt _ e _ t)]
| Just arg <- isReturnApp monad_names e =
- (False, [L loc (LastStmt arg True t)])
+ (False, [L loc (LastStmt noExt arg True t)])
needJoin _monad_names stmts = (True, stmts)
-- | @Just e@, if the expression is @return e@ or @return $ e@,
@@ -1974,7 +1985,7 @@ checkLastStmt ctxt lstmt@(L loc stmt)
where
check_do -- Expect BodyStmt, and change it to LastStmt
= case stmt of
- BodyStmt e _ _ _ -> return (L loc (mkLastStmt e))
+ BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))
LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
-- LastStmt directly (unlike the parser)
_ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
@@ -2011,6 +2022,7 @@ pprStmtCat (LetStmt {}) = text "let"
pprStmtCat (RecStmt {}) = text "rec"
pprStmtCat (ParStmt {}) = text "parallel"
pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
+pprStmtCat (XStmtLR {}) = panic "pprStmtCat: XStmtLR"
------------
emptyInvalid :: Validity -- Payload is the empty document
@@ -2047,8 +2059,8 @@ okPatGuardStmt stmt
-------------
okParStmt dflags ctxt stmt
= case stmt of
- LetStmt (L _ (HsIPBinds {})) -> emptyInvalid
- _ -> okStmt dflags ctxt stmt
+ LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid
+ _ -> okStmt dflags ctxt stmt
----------------
okDoStmt dflags ctxt stmt
@@ -2077,6 +2089,7 @@ okCompStmt dflags _ stmt
RecStmt {} -> emptyInvalid
LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
ApplicativeStmt {} -> emptyInvalid
+ XStmtLR{} -> panic "okCompStmt"
----------------
okPArrStmt dflags _ stmt
@@ -2091,6 +2104,7 @@ okPArrStmt dflags _ stmt
RecStmt {} -> emptyInvalid
LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
ApplicativeStmt {} -> emptyInvalid
+ XStmtLR{} -> panic "okPArrStmt"
---------
checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 5458469c44..60f87fcd1f 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -261,7 +261,9 @@ Running generateModules from Trac #14693 with DEPTH=16, WIDTH=30 finishes in
rnImportDecl :: Module -> LImportDecl GhcPs
-> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)
rnImportDecl this_mod
- (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg
+ (L loc decl@(ImportDecl { ideclExt = noExt
+ , ideclName = loc_imp_mod_name
+ , ideclPkgQual = mb_pkg
, ideclSource = want_boot, ideclSafe = mod_safe
, ideclQualified = qual_only, ideclImplicit = implicit
, ideclAs = as_mod, ideclHiding = imp_details }))
@@ -370,10 +372,11 @@ rnImportDecl this_mod
_ -> return ()
)
- let new_imp_decl = L loc (decl { ideclSafe = mod_safe'
+ let new_imp_decl = L loc (decl { ideclExt = noExt, ideclSafe = mod_safe'
, ideclHiding = new_imp_details })
return (new_imp_decl, gbl_env, imports, mi_hpc iface)
+rnImportDecl _ (L _ (XImportDecl _)) = panic "rnImportDecl"
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
@@ -723,10 +726,10 @@ getLocalNonValBinders fixity_env
new_assoc _ (L _ (TyFamInstD {})) = return ([], [])
-- type instances don't bind new names
- new_assoc overload_ok (L _ (DataFamInstD d))
+ new_assoc overload_ok (L _ (DataFamInstD _ d))
= do { (avail, flds) <- new_di overload_ok Nothing d
; return ([avail], flds) }
- new_assoc overload_ok (L _ (ClsInstD (ClsInstDecl { cid_poly_ty = inst_ty
+ new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty
, cid_datafam_insts = adts })))
| Just (L loc cls_rdr) <- getLHsInstDeclClass_maybe inst_ty
= do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
@@ -736,6 +739,8 @@ getLocalNonValBinders fixity_env
| otherwise
= return ([], []) -- Do not crash on ill-formed instances
-- Eg instance !Show Int Trac #3811c
+ new_assoc _ (L _ (ClsInstD _ (XClsInstDecl _))) = panic "new_assoc"
+ new_assoc _ (L _ (XInstDecl _)) = panic "new_assoc"
new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs
-> RnM (AvailInfo, [(Name, [FieldLabel])])
@@ -749,10 +754,12 @@ getLocalNonValBinders fixity_env
-- main_name is not bound here!
fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds'
; return (avail, fld_env) }
+ new_di _ _ (DataFamInstDecl (XHsImplicitBndrs _)) = panic "new_di"
new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs
-> RnM (AvailInfo, [(Name, [FieldLabel])])
new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d
+getLocalNonValBinders _ (XHsGroup _) = panic "getLocalNonValBinders"
newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel
newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"
@@ -935,12 +942,12 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
-> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning])
lookup_ie ie = handle_bad_import $ do
case ie of
- IEVar (L l n) -> do
+ IEVar _ (L l n) -> do
(name, avail, _) <- lookup_name $ ieWrappedName n
- return ([(IEVar (L l (replaceWrappedName n name)),
+ return ([(IEVar noExt (L l (replaceWrappedName n name)),
trimAvail avail name)], [])
- IEThingAll (L l tc) -> do
+ IEThingAll _ (L l tc) -> do
(name, avail, mb_parent) <- lookup_name $ ieWrappedName tc
let warns = case avail of
Avail {} -- e.g. f(..)
@@ -956,7 +963,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
| otherwise
-> []
- renamed_ie = IEThingAll (L l (replaceWrappedName tc name))
+ renamed_ie = IEThingAll noExt (L l (replaceWrappedName tc name))
sub_avails = case avail of
Avail {} -> []
AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]
@@ -966,7 +973,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)
-- associated type
- IEThingAbs (L l tc')
+ IEThingAbs _ (L l tc')
| want_hiding -- hiding ( C )
-- Here the 'C' can be a data constructor
-- *or* a type/class, or even both
@@ -982,7 +989,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
return ([mkIEThingAbs tc' l nameAvail]
, [])
- IEThingWith (L l rdr_tc) wc rdr_ns' rdr_fs ->
+ IEThingWith _ (L l rdr_tc) wc rdr_ns' rdr_fs ->
ASSERT2(null rdr_fs, ppr rdr_fs) do
(name, AvailTC _ ns subflds, mb_parent)
<- lookup_name (ieWrappedName rdr_tc)
@@ -1000,8 +1007,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
case mb_parent of
-- non-associated ty/cls
Nothing
- -> return ([(IEThingWith (L l name') wc childnames'
- childflds,
+ -> return ([(IEThingWith noExt (L l name') wc childnames'
+ childflds,
AvailTC name (name:map unLoc childnames) (map unLoc childflds))],
[])
where name' = replaceWrappedName rdr_tc name
@@ -1009,10 +1016,10 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
-- childnames' = postrn_ies childnames
-- associated ty
Just parent
- -> return ([(IEThingWith (L l name') wc childnames'
+ -> return ([(IEThingWith noExt (L l name') wc childnames'
childflds,
AvailTC name (map unLoc childnames) (map unLoc childflds)),
- (IEThingWith (L l name') wc childnames'
+ (IEThingWith noExt (L l name') wc childnames'
childflds,
AvailTC parent [name] [])],
[])
@@ -1025,9 +1032,10 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
where
mkIEThingAbs tc l (n, av, Nothing )
- = (IEThingAbs (L l (replaceWrappedName tc n)), trimAvail av n)
+ = (IEThingAbs noExt (L l (replaceWrappedName tc n)), trimAvail av n)
mkIEThingAbs tc l (n, _, Just parent)
- = (IEThingAbs (L l (replaceWrappedName tc n)), AvailTC parent [n] [])
+ = (IEThingAbs noExt (L l (replaceWrappedName tc n))
+ , AvailTC parent [n] [])
handle_bad_import m = catchIELookup m $ \err -> case err of
BadImport | want_hiding -> return ([], [BadImportW])
@@ -1071,8 +1079,8 @@ gresFromIE decl_spec (L loc ie, avail)
= gresFromAvail prov_fn avail
where
is_explicit = case ie of
- IEThingAll (L _ name) -> \n -> n == ieWrappedName name
- _ -> \_ -> True
+ IEThingAll _ (L _ name) -> \n -> n == ieWrappedName name
+ _ -> \_ -> True
prov_fn name
= Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })
where
@@ -1328,13 +1336,13 @@ findImportUsage imports used_gres
_other -> emptyNameSet -- No explicit import list => no unused-name list
add_unused :: IE GhcRn -> NameSet -> NameSet
- add_unused (IEVar (L _ n)) acc
+ add_unused (IEVar _ (L _ n)) acc
= add_unused_name (ieWrappedName n) acc
- add_unused (IEThingAbs (L _ n)) acc
+ add_unused (IEThingAbs _ (L _ n)) acc
= add_unused_name (ieWrappedName n) acc
- add_unused (IEThingAll (L _ n)) acc
+ add_unused (IEThingAll _ (L _ n)) acc
= add_unused_all (ieWrappedName n) acc
- add_unused (IEThingWith (L _ p) wc ns fs) acc =
+ add_unused (IEThingWith _ (L _ p) wc ns fs) acc =
add_wc_all (add_unused_with (ieWrappedName p) xs acc)
where xs = map (ieWrappedName . unLoc) ns
++ map (flSelector . unLoc) fs
@@ -1358,6 +1366,7 @@ findImportUsage imports used_gres
-- If you use 'signum' from Num, then the user may well have
-- imported Num(signum). We don't want to complain that
-- Num is not itself mentioned. Hence the two cases in add_unused_with.
+ unused_decl (L _ (XImportDecl _)) = panic "unused_decl"
extendImportMap :: GlobalRdrElt -> ImportMap -> ImportMap
-- For each of a list of used GREs, find all the import decls that brought
@@ -1478,25 +1487,25 @@ printMinimalImports imports_w_usage
-- we want to say "T(..)", but if we're importing only a subset we want
-- to say "T(A,B,C)". So we have to find out what the module exports.
to_ie _ (Avail n)
- = [IEVar (to_ie_post_rn $ noLoc n)]
+ = [IEVar noExt (to_ie_post_rn $ noLoc n)]
to_ie _ (AvailTC n [m] [])
- | n==m = [IEThingAbs (to_ie_post_rn $ noLoc n)]
+ | n==m = [IEThingAbs noExt (to_ie_post_rn $ noLoc n)]
to_ie iface (AvailTC n ns fs)
= case [(xs,gs) | AvailTC x xs gs <- mi_exports iface
, x == n
, x `elem` xs -- Note [Partial export]
] of
- [xs] | all_used xs -> [IEThingAll (to_ie_post_rn $ noLoc n)]
+ [xs] | all_used xs -> [IEThingAll noExt (to_ie_post_rn $ noLoc n)]
| otherwise ->
- [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard
+ [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard
(map (to_ie_post_rn . noLoc) (filter (/= n) ns))
(map noLoc fs)]
-- Note [Overloaded field import]
_other | all_non_overloaded fs
- -> map (IEVar . to_ie_post_rn_var . noLoc) $ ns
+ -> map (IEVar noExt . to_ie_post_rn_var . noLoc) $ ns
++ map flSelector fs
| otherwise ->
- [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard
+ [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard
(map (to_ie_post_rn . noLoc) (filter (/= n) ns))
(map noLoc fs)]
where
@@ -1637,10 +1646,10 @@ dodgyMsg kind tc ie
quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",
text "but it has none" ]
-dodgyMsgInsert :: forall p . IdP p -> IE p
-dodgyMsgInsert tc = IEThingAll ii
+dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)
+dodgyMsgInsert tc = IEThingAll noExt ii
where
- ii :: LIEWrappedName (IdP p)
+ ii :: LIEWrappedName (IdP (GhcPass p))
ii = noLoc (IEName $ noLoc tc)
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 320a34b4bf..8f7c2e2309 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -471,19 +471,17 @@ rnPatAndThen mk (ConPatIn con stuff)
-- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
= case unLoc con == nameRdrName (dataConName nilDataCon) of
True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
- ; if ol_flag then rnPatAndThen mk (ListPat noExt []
- placeHolderType Nothing)
+ ; if ol_flag then rnPatAndThen mk (ListPat noExt [])
else rnConPatAndThen mk con stuff}
False -> rnConPatAndThen mk con stuff
-rnPatAndThen mk (ListPat x pats _ _)
+rnPatAndThen mk (ListPat _ pats)
= do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
; pats' <- rnLPatsAndThen mk pats
; case opt_OverloadedLists of
True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
- ; return (ListPat x pats' placeHolderType
- (Just (placeHolderType, to_list_name)))}
- False -> return (ListPat x pats' placeHolderType Nothing) }
+ ; return (ListPat (Just to_list_name) pats')}
+ False -> return (ListPat Nothing pats') }
rnPatAndThen mk (PArrPat x pats)
= do { pats' <- rnLPatsAndThen mk pats
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index d242ac08c6..065e72f202 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -198,7 +198,8 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
last_tcg_env <- getGblEnv ;
-- (I) Compute the results and return
- let {rn_group = HsGroup { hs_valds = rn_val_decls,
+ let {rn_group = HsGroup { hs_ext = noExt,
+ hs_valds = rn_val_decls,
hs_splcds = rn_splice_decls,
hs_tyclds = rn_tycl_decls,
hs_derivds = rn_deriv_decls,
@@ -230,6 +231,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
traceRn "finish Dus" (ppr src_dus ) ;
return (final_tcg_env, rn_group)
}}}}
+rnSrcDecls (XHsGroup _) = panic "rnSrcDecls"
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
-- This function could be defined lower down in the module hierarchy,
@@ -292,15 +294,16 @@ rnSrcWarnDecls bndr_set decls'
sig_ctxt = TopSigCtxt bndr_set
- rn_deprec (Warning rdr_names txt)
+ rn_deprec (Warning _ rdr_names txt)
-- ensures that the names are defined locally
= do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
rdr_names
; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
+ rn_deprec (XWarnDecl _) = panic "rnSrcWarnDecls"
what = text "deprecation"
- warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)
+ warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning _ ns _)) -> ns)
decls
findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]
@@ -325,13 +328,14 @@ dupWarnDecl (L loc _) rdr_name
-}
rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
-rnAnnDecl ann@(HsAnnotation s provenance expr)
+rnAnnDecl ann@(HsAnnotation _ s provenance expr)
= addErrCtxt (annCtxt ann) $
do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
; (expr', expr_fvs) <- setStage (Splice Untyped) $
rnLExpr expr
- ; return (HsAnnotation s provenance' expr',
+ ; return (HsAnnotation noExt s provenance' expr',
provenance_fvs `plusFV` expr_fvs) }
+rnAnnDecl (XAnnDecl _) = panic "rnAnnDecl"
rnAnnProvenance :: AnnProvenance RdrName
-> RnM (AnnProvenance Name, FreeVars)
@@ -348,11 +352,12 @@ rnAnnProvenance provenance = do
-}
rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
-rnDefaultDecl (DefaultDecl tys)
+rnDefaultDecl (DefaultDecl _ tys)
= do { (tys', fvs) <- rnLHsTypes doc_str tys
- ; return (DefaultDecl tys', fvs) }
+ ; return (DefaultDecl noExt tys', fvs) }
where
doc_str = DefaultDeclCtx
+rnDefaultDecl (XDefaultDecl _) = panic "rnDefaultDecl"
{-
*********************************************************
@@ -372,21 +377,23 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
; let unitId = thisPackage $ hsc_dflags topEnv
spec' = patchForeignImport unitId spec
- ; return (ForeignImport { fd_name = name', fd_sig_ty = ty'
- , fd_co = noForeignImportCoercionYet
+ ; return (ForeignImport { fd_i_ext = noExt
+ , fd_name = name', fd_sig_ty = ty'
, fd_fi = spec' }, fvs) }
rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
= do { name' <- lookupLocatedOccRn name
; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
- ; return (ForeignExport { fd_name = name', fd_sig_ty = ty'
- , fd_co = noForeignExportCoercionYet
+ ; return (ForeignExport { fd_e_ext = noExt
+ , fd_name = name', fd_sig_ty = ty'
, fd_fe = spec }
, fvs `addOneFV` unLoc name') }
-- NB: a foreign export is an *occurrence site* for name, so
-- we add it to the free-variable list. It might, for example,
-- be imported from another module
+rnHsForeignDecl (XForeignDecl _) = panic "rnHsForeignDecl"
+
-- | For Windows DLLs we need to know what packages imported symbols are from
-- to generate correct calls. Imported symbols are tagged with the current
-- package, so if they get inlined across a package boundry we'll still
@@ -420,17 +427,19 @@ patchCCallTarget unitId callTarget =
rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
= do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
- ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }
+ ; return (TyFamInstD { tfid_ext = noExt, tfid_inst = tfi' }, fvs) }
rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
= do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
- ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }
+ ; return (DataFamInstD { dfid_ext = noExt, dfid_inst = dfi' }, fvs) }
rnSrcInstDecl (ClsInstD { cid_inst = cid })
= do { traceRn "rnSrcIstDecl {" (ppr cid)
; (cid', fvs) <- rnClsInstDecl cid
; traceRn "rnSrcIstDecl end }" empty
- ; return (ClsInstD { cid_inst = cid' }, fvs) }
+ ; return (ClsInstD { cid_d_ext = noExt, cid_inst = cid' }, fvs) }
+
+rnSrcInstDecl (XInstDecl _) = panic "rnSrcInstDecl"
-- | Warn about non-canonical typeclass instance declarations
--
@@ -577,7 +586,7 @@ checkCanonicalInstances cls poly_ty mbinds = do
-- binding, and return @Just rhsName@ if this is the case
isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}
- | GRHSs [L _ (GRHS [] body)] lbinds <- grhss
+ | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss
, L _ (EmptyLocalBinds _) <- lbinds
, L _ (HsVar _ (L _ rhsName)) <- body = Just rhsName
isAliasMG _ = Nothing
@@ -660,7 +669,8 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
; let all_fvs = meth_fvs `plusFV` more_fvs
`plusFV` inst_fvs
- ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
+ ; return (ClsInstDecl { cid_ext = noExt
+ , cid_poly_ty = inst_ty', cid_binds = mbinds'
, cid_sigs = uprags', cid_tyfam_insts = ats'
, cid_overlap_mode = oflag
, cid_datafam_insts = adts' },
@@ -675,6 +685,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
-- the instance context after renaming. This is a bit
-- strange, but should not matter (and it would be more work
-- to remove the context).
+rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl"
rnFamInstEqn :: HsDocContext
-> Maybe (Name, [Name]) -- Nothing => not associated
@@ -758,14 +769,17 @@ rnFamInstEqn doc mb_cls rhs_kvars
all_fvs = fvs `addOneFV` unLoc tycon'
-- type instance => use, hence addOneFV
- ; return (HsIB { hsib_vars = all_ibs
- , hsib_closed = True
+ ; return (HsIB { hsib_ext = HsIBRn { hsib_vars = all_ibs
+ , hsib_closed = True }
, hsib_body
- = FamEqn { feqn_tycon = tycon'
+ = FamEqn { feqn_ext = noExt
+ , feqn_tycon = tycon'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = payload' } },
all_fvs) }
+rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = panic "rnFamInstEqn"
+rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = panic "rnFamInstEqn"
rnTyFamInstDecl :: Maybe (Name, [Name])
-> TyFamInstDecl GhcPs
@@ -781,6 +795,8 @@ rnTyFamInstEqn mb_cls eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
, feqn_rhs = rhs }})
= do { rhs_kvs <- extractHsTyRdrTyVarsKindVars rhs
; rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn }
+rnTyFamInstEqn _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"
+rnTyFamInstEqn _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"
rnTyFamDefltEqn :: Name
-> TyFamDefltEqn GhcPs
@@ -793,12 +809,14 @@ rnTyFamDefltEqn cls (FamEqn { feqn_tycon = tycon
; bindHsQTyVars ctx Nothing (Just cls) kvs tyvars $ \ tyvars' _ ->
do { tycon' <- lookupFamInstName (Just cls) tycon
; (rhs', fvs) <- rnLHsType ctx rhs
- ; return (FamEqn { feqn_tycon = tycon'
+ ; return (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tycon'
, feqn_pats = tyvars'
, feqn_fixity = fixity
, feqn_rhs = rhs' }, fvs) } }
where
ctx = TyFamilyCtx tycon
+rnTyFamDefltEqn _ (XFamEqn _) = panic "rnTyFamDefltEqn"
rnDataFamInstDecl :: Maybe (Name, [Name])
-> DataFamInstDecl GhcPs
@@ -810,6 +828,10 @@ rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
; (eqn', fvs) <-
rnFamInstEqn (TyDataCtx tycon) mb_cls rhs_kvs eqn rnDataDefn
; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
+rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn _)))
+ = panic "rnDataFamInstDecl"
+rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs _))
+ = panic "rnDataFamInstDecl"
-- Renaming of the associated types in instances.
@@ -937,14 +959,15 @@ Here 'k' is in scope in the kind signature, just like 'x'.
-}
rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
-rnSrcDerivDecl (DerivDecl ty deriv_strat overlap)
+rnSrcDerivDecl (DerivDecl _ ty deriv_strat overlap)
= do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
; deriv_strats_ok <- xoptM LangExt.DerivingStrategies
; unless standalone_deriv_ok (addErr standaloneDerivErr)
; failIfTc (isJust deriv_strat && not deriv_strats_ok) $
illegalDerivStrategyErr $ fmap unLoc deriv_strat
; (ty', fvs) <- rnHsSigWcType DerivDeclCtx ty
- ; return (DerivDecl ty' deriv_strat overlap, fvs) }
+ ; return (DerivDecl noExt ty' deriv_strat overlap, fvs) }
+rnSrcDerivDecl (XDerivDecl _) = panic "rnSrcDerivDecl"
standaloneDerivErr :: SDoc
standaloneDerivErr
@@ -960,12 +983,13 @@ standaloneDerivErr
-}
rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
-rnHsRuleDecls (HsRules src rules)
+rnHsRuleDecls (HsRules _ src rules)
= do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
- ; return (HsRules src rn_rules,fvs) }
+ ; return (HsRules noExt src rn_rules,fvs) }
+rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls"
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
-rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
+rnHsRuleDecl (HsRule _ rule_name act vars lhs rhs)
= do { let rdr_names_w_loc = map get_var vars
; checkDupRdrNames rdr_names_w_loc
; checkShadowedRdrNames rdr_names_w_loc
@@ -974,11 +998,14 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
do { (lhs', fv_lhs') <- rnLExpr lhs
; (rhs', fv_rhs') <- rnLExpr rhs
; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
- ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
+ ; return (HsRule (HsRuleRn fv_lhs' fv_rhs') rule_name act vars'
+ lhs' rhs',
fv_lhs' `plusFV` fv_rhs') } }
where
- get_var (L _ (RuleBndrSig v _)) = v
- get_var (L _ (RuleBndr v)) = v
+ get_var (L _ (RuleBndrSig _ v _)) = v
+ get_var (L _ (RuleBndr _ v)) = v
+ get_var (L _ (XRuleBndr _)) = panic "rnHsRuleDecl"
+rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl"
bindHsRuleVars :: RuleName -> [LRuleBndr GhcPs] -> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
@@ -989,14 +1016,14 @@ bindHsRuleVars rule_name vars names thing_inside
where
doc = RuleCtx rule_name
- go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
+ go (L l (RuleBndr _ (L loc _)) : vars) (n : ns) thing_inside
= go vars ns $ \ vars' ->
- thing_inside (L l (RuleBndr (L loc n)) : vars')
+ thing_inside (L l (RuleBndr noExt (L loc n)) : vars')
- go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
+ go (L l (RuleBndrSig _ (L loc _) bsig) : vars) (n : ns) thing_inside
= rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
go vars ns $ \ vars' ->
- thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
+ thing_inside (L l (RuleBndrSig noExt (L loc n) bsig') : vars')
go [] [] thing_inside = thing_inside []
go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
@@ -1090,44 +1117,41 @@ badRuleLhsErr name lhs bad_e
rnHsVectDecl :: VectDecl GhcPs -> RnM (VectDecl GhcRn, FreeVars)
-- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
-- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
-rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _ _)))
+rnHsVectDecl (HsVect _ s var rhs@(L _ (HsVar _ _)))
= do { var' <- lookupLocatedOccRn var
; (rhs', fv_rhs) <- rnLExpr rhs
- ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var')
+ ; return (HsVect noExt s var' rhs', fv_rhs `addOneFV` unLoc var')
}
-rnHsVectDecl (HsVect _ _var _rhs)
+rnHsVectDecl (HsVect _ _ _var _rhs)
= failWith $ vcat
[ text "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma"
, text "must be an identifier"
]
-rnHsVectDecl (HsNoVect s var)
+rnHsVectDecl (HsNoVect _ s var)
= do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names
- ; return (HsNoVect s var', unitFV (unLoc var'))
+ ; return (HsNoVect noExt s var', unitFV (unLoc var'))
}
-rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing)
+rnHsVectDecl (HsVectType (VectTypePR s tycon Nothing) isScalar)
= do { tycon' <- lookupLocatedOccRn tycon
- ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon'))
+ ; return ( HsVectType (VectTypePR s tycon' Nothing) isScalar
+ , unitFV (unLoc tycon'))
}
-rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon))
+rnHsVectDecl (HsVectType (VectTypePR s tycon (Just rhs_tycon)) isScalar)
= do { tycon' <- lookupLocatedOccRn tycon
; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
- ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon')
+ ; return ( HsVectType (VectTypePR s tycon' (Just rhs_tycon')) isScalar
, mkFVs [unLoc tycon', unLoc rhs_tycon'])
}
-rnHsVectDecl (HsVectTypeOut _ _ _)
- = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
-rnHsVectDecl (HsVectClassIn s cls)
+rnHsVectDecl (HsVectClass (VectClassPR s cls))
= do { cls' <- lookupLocatedOccRn cls
- ; return (HsVectClassIn s cls', unitFV (unLoc cls'))
+ ; return (HsVectClass (VectClassPR s cls'), unitFV (unLoc cls'))
}
-rnHsVectDecl (HsVectClassOut _)
- = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
-rnHsVectDecl (HsVectInstIn instTy)
+rnHsVectDecl (HsVectInst instTy)
= do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy
- ; return (HsVectInstIn instTy', fvs)
+ ; return (HsVectInst instTy', fvs)
}
-rnHsVectDecl (HsVectInstOut _)
- = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
+rnHsVectDecl (XVectDecl {})
+ = panic "RnSource.rnHsVectDecl: Unexpected 'XVectDecl'"
{- **************************************************************
* *
@@ -1291,7 +1315,8 @@ rnTyClDecls tycl_ds
first_group
| null init_inst_ds = []
- | otherwise = [TyClGroup { group_tyclds = []
+ | otherwise = [TyClGroup { group_ext = noExt
+ , group_tyclds = []
, group_roles = []
, group_instds = init_inst_ds }]
@@ -1322,7 +1347,8 @@ rnTyClDecls tycl_ds
bndrs = map (tcdName . unLoc) tycl_ds
(inst_ds, inst_map') = getInsts bndrs inst_map
(roles, role_env') = getRoleAnnots bndrs role_env
- group = TyClGroup { group_tyclds = tycl_ds
+ group = TyClGroup { group_ext = noExt
+ , group_tyclds = tycl_ds
, group_roles = roles
, group_instds = inst_ds }
@@ -1382,13 +1408,14 @@ rnRoleAnnots tc_names role_annots
; mapM_ dupRoleAnnotErr dup_annots
; mapM (wrapLocM rn_role_annot1) no_dups }
where
- rn_role_annot1 (RoleAnnotDecl tycon roles)
+ rn_role_annot1 (RoleAnnotDecl _ tycon roles)
= do { -- the name is an *occurrence*, but look it up only in the
-- decls defined in this group (see #10263)
tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)
(text "role annotation")
tycon
- ; return $ RoleAnnotDecl tycon' roles }
+ ; return $ RoleAnnotDecl noExt tycon' roles }
+ rn_role_annot1 (XRoleAnnotDecl _) = panic "rnRoleAnnots"
dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
dupRoleAnnotErr list
@@ -1506,7 +1533,7 @@ rnTyClDecl :: TyClDecl GhcPs
-- in a class decl
rnTyClDecl (FamDecl { tcdFam = decl })
= do { (decl', fvs) <- rnFamDecl Nothing decl
- ; return (FamDecl decl', fvs) }
+ ; return (FamDecl noExt decl', fvs) }
rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
tcdFixity = fixity, tcdRhs = rhs })
@@ -1518,7 +1545,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
do { (rhs', fvs) <- rnTySyn doc rhs
; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
, tcdFixity = fixity
- , tcdRhs = rhs', tcdFVs = fvs }, fvs) } }
+ , tcdRhs = rhs', tcdSExt = fvs }, fvs) } }
-- "data", "newtype" declarations
-- both top level and (for an associated type) in an instance decl
@@ -1537,8 +1564,8 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
, tcdFixity = fixity
- , tcdDataDefn = defn', tcdDataCusk = cusk
- , tcdFVs = fvs }, fvs) } }
+ , tcdDataDefn = defn'
+ , tcdDExt = DataDeclRn cusk fvs }, fvs) } }
rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
tcdTyVars = tyvars, tcdFixity = fixity,
@@ -1599,11 +1626,13 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
tcdTyVars = tyvars', tcdFixity = fixity,
tcdFDs = fds', tcdSigs = sigs',
tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
- tcdDocs = docs', tcdFVs = all_fvs },
+ tcdDocs = docs', tcdCExt = all_fvs },
all_fvs ) }
where
cls_doc = ClassDeclCtx lcls
+rnTyClDecl (XTyClDecl _) = panic "rnTyClDecl"
+
-- "type" and "type instance" declarations
rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnTySyn doc rhs = rnLHsType doc rhs
@@ -1634,7 +1663,8 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
con_fvs `plusFV` sig_fvs
- ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+ ; return ( HsDataDefn { dd_ext = noExt
+ , dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = context', dd_kindSig = m_sig'
, dd_cons = condecls'
, dd_derivs = derivs' }
@@ -1651,18 +1681,23 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
multipleDerivClausesErr
; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds
; return (L loc ds', fvs) }
+rnDataDefn _ (XHsDataDefn _) = panic "rnDataDefn"
rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause GhcPs
-> RnM (LHsDerivingClause GhcRn, FreeVars)
rnLHsDerivingClause deriv_strats_ok doc
- (L loc (HsDerivingClause { deriv_clause_strategy = dcs
+ (L loc (HsDerivingClause { deriv_clause_ext = noExt
+ , deriv_clause_strategy = dcs
, deriv_clause_tys = L loc' dct }))
= do { failIfTc (isJust dcs && not deriv_strats_ok) $
illegalDerivStrategyErr $ fmap unLoc dcs
; (dct', fvs) <- mapFvRn (rnHsSigType doc) dct
- ; return ( L loc (HsDerivingClause { deriv_clause_strategy = dcs
+ ; return ( L loc (HsDerivingClause { deriv_clause_ext = noExt
+ , deriv_clause_strategy = dcs
, deriv_clause_tys = L loc' dct' })
, fvs ) }
+rnLHsDerivingClause _ _ (L _ (XHsDerivingClause _))
+ = panic "rnLHsDerivingClause"
badGadtStupidTheta :: HsDocContext -> SDoc
badGadtStupidTheta _
@@ -1698,7 +1733,8 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
injectivity
; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
; (info', fv2) <- rn_info info
- ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
+ ; return (FamilyDecl { fdExt = noExt
+ , fdLName = tycon', fdTyVars = tyvars'
, fdFixity = fixity
, fdInfo = info', fdResultSig = res_sig'
, fdInjectivityAnn = injectivity' }
@@ -1715,16 +1751,17 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
= return (ClosedTypeFamily Nothing, emptyFVs)
rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
rn_info DataFamily = return (DataFamily, emptyFVs)
+rnFamDecl _ (XFamilyDecl _) = panic "rnFamDecl"
rnFamResultSig :: HsDocContext
-> FamilyResultSig GhcPs
-> RnM (FamilyResultSig GhcRn, FreeVars)
-rnFamResultSig _ NoSig
- = return (NoSig, emptyFVs)
-rnFamResultSig doc (KindSig kind)
+rnFamResultSig _ (NoSig _)
+ = return (NoSig noExt, emptyFVs)
+rnFamResultSig doc (KindSig _ kind)
= do { (rndKind, ftvs) <- rnLHsKind doc kind
- ; return (KindSig rndKind, ftvs) }
-rnFamResultSig doc (TyVarSig tvbndr)
+ ; return (KindSig noExt rndKind, ftvs) }
+rnFamResultSig doc (TyVarSig _ tvbndr)
= do { -- `TyVarSig` tells us that user named the result of a type family by
-- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
-- be sure that the supplied result name is not identical to an
@@ -1745,7 +1782,8 @@ rnFamResultSig doc (TyVarSig tvbndr)
; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for
-- scoping checks that are irrelevant here
tvbndr $ \ tvbndr' ->
- return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) }
+ return (TyVarSig noExt tvbndr', unitFV (hsLTyVarName tvbndr')) }
+rnFamResultSig _ (XFamilyResultSig _) = panic "rnFamResultSig"
-- Note [Renaming injectivity annotation]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1786,7 +1824,7 @@ rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in
-> LFamilyResultSig GhcRn -- ^ Result signature
-> LInjectivityAnn GhcPs -- ^ Injectivity annotation
-> RnM (LInjectivityAnn GhcRn)
-rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
+rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
(L srcSpan (InjectivityAnn injFrom injTo))
= do
{ (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
@@ -1897,7 +1935,8 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
[ text "ex_tvs:" <+> ppr ex_tvs
, text "new_ex_dqtvs':" <+> ppr new_ex_tvs ])
- ; return (decl { con_name = new_name, con_ex_tvs = new_ex_tvs
+ ; return (decl { con_ext = noExt
+ , con_name = new_name, con_ex_tvs = new_ex_tvs
, con_mb_cxt = new_context, con_args = new_args
, con_doc = mb_doc' },
all_fvs) }}
@@ -1945,17 +1984,21 @@ rnConDecl decl@(ConDeclGADT { con_names = names
-- See Note [GADT abstract syntax] in HsDecls
(PrefixCon arg_tys, final_res_ty)
- new_qtvs = HsQTvs { hsq_implicit = implicit_tkvs
- , hsq_explicit = explicit_tkvs
- , hsq_dependent = emptyNameSet }
+ new_qtvs = HsQTvs { hsq_ext = HsQTvsRn
+ { hsq_implicit = implicit_tkvs
+ , hsq_dependent = emptyNameSet }
+ , hsq_explicit = explicit_tkvs }
; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)
- ; return (decl { con_names = new_names
+ ; return (decl { con_g_ext = noExt, con_names = new_names
, con_qvars = new_qtvs, con_mb_cxt = new_cxt
, con_args = args', con_res_ty = res_ty'
, con_doc = mb_doc' },
all_fvs) } }
+rnConDecl (XConDecl _) = panic "rnConDecl"
+
+
rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMbContext _ Nothing = return (Nothing, emptyFVs)
@@ -2081,12 +2124,12 @@ add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]
-- #10047: Declaration QuasiQuoters are expanded immediately, without
-- causing a group split
-add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds
+add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds
= do { (ds', _) <- rnTopSpliceDecls qq
; addl gp (ds' ++ ds)
}
-add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
+add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds
= do { -- We've found a top-level splice. If it is an *implicit* one
-- (i.e. a naked top level expression)
case flag of
@@ -2101,7 +2144,7 @@ add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
$$ text "or top-level declaration expected."
-- Class declarations: pull out the fixity signatures to the top
-add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds
| isClassDecl d
= let fsigs = [ L l f | L l (FixSig _ f) <- tcdSigs d ] in
addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
@@ -2109,69 +2152,81 @@ add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
= addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
-- Signatures: fixity sigs go a different place than all others
-add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig _ f)) ds
+add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds
= addl (gp {hs_fixds = L l f : ts}) ds
-add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
+add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds
= addl (gp {hs_valds = add_sig (L l d) ts}) ds
-- Value declarations: use add_bind
-add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
+add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds
= addl (gp { hs_valds = add_bind (L l d) ts }) ds
-- Role annotations: added to the TyClGroup
-add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
+add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds
= addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
-- NB instance declarations go into TyClGroups. We throw them into the first
-- group, just as we do for the TyClD case. The renamer will go on to group
-- and order them later.
-add gp@(HsGroup {hs_tyclds = ts}) l (InstD d) ds
+add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds
= addl (gp { hs_tyclds = add_instd (L l d) ts }) ds
-- The rest are routine
-add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
+add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds
= addl (gp { hs_derivds = L l d : ts }) ds
-add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
+add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds
= addl (gp { hs_defds = L l d : ts }) ds
-add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
+add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds
= addl (gp { hs_fords = L l d : ts }) ds
-add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
+add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds
= addl (gp { hs_warnds = L l d : ts }) ds
-add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
+add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds
= addl (gp { hs_annds = L l d : ts }) ds
-add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
+add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds
= addl (gp { hs_ruleds = L l d : ts }) ds
-add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds
+add gp@(HsGroup {hs_vects = ts}) l (VectD _ d) ds
= addl (gp { hs_vects = L l d : ts }) ds
-add gp l (DocD d) ds
+add gp l (DocD _ d) ds
= addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
-
-add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
-add_tycld d [] = [TyClGroup { group_tyclds = [d]
- , group_roles = []
+add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = panic "RnSource.add"
+add (HsGroup {}) _ (XHsDecl _) _ = panic "RnSource.add"
+add (XHsGroup _) _ _ _ = panic "RnSource.add"
+
+add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+ -> [TyClGroup (GhcPass p)]
+add_tycld d [] = [TyClGroup { group_ext = noExt
+ , group_tyclds = [d]
+ , group_roles = []
, group_instds = []
}
]
add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
= ds { group_tyclds = d : tyclds } : dss
+add_tycld _ (XTyClGroup _: _) = panic "add_tycld"
-add_instd :: LInstDecl a -> [TyClGroup a] -> [TyClGroup a]
-add_instd d [] = [TyClGroup { group_tyclds = []
- , group_roles = []
+add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+ -> [TyClGroup (GhcPass p)]
+add_instd d [] = [TyClGroup { group_ext = noExt
+ , group_tyclds = []
+ , group_roles = []
, group_instds = [d]
}
]
add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
= ds { group_instds = d : instds } : dss
+add_instd _ (XTyClGroup _: _) = panic "add_instd"
-add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
-add_role_annot d [] = [TyClGroup { group_tyclds = []
- , group_roles = [d]
+add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+ -> [TyClGroup (GhcPass p)]
+add_role_annot d [] = [TyClGroup { group_ext = noExt
+ , group_tyclds = []
+ , group_roles = [d]
, group_instds = []
}
]
add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
= tycls { group_roles = d : roles } : rest
+add_role_annot _ (XTyClGroup _: _) = panic "add_role_annot"
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index fc7240ef44..19bf763f63 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -620,13 +620,15 @@ rnSplicePat splice
----------------------
rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
-rnSpliceDecl (SpliceDecl (L loc splice) flg)
+rnSpliceDecl (SpliceDecl _ (L loc splice) flg)
= rnSpliceGen run_decl_splice pend_decl_splice splice
where
pend_decl_splice rn_splice
- = (makePending UntypedDeclSplice rn_splice, SpliceDecl (L loc rn_splice) flg)
+ = ( makePending UntypedDeclSplice rn_splice
+ , SpliceDecl noExt (L loc rn_splice) flg)
run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)
+rnSpliceDecl (XSpliceDecl _) = panic "rnSpliceDecl"
rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
-- Declaration splice at the very top level of the module
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index c4ab448e61..b51a178e82 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -127,18 +127,23 @@ rn_hs_sig_wc_type always_bind_free_tvs ctxt
bind_free_tvs = always_bind_free_tvs || not (isLHsForAllTy hs_ty)
; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->
do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
- ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = ib_ty' }
+ ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }
ib_ty' = mk_implicit_bndrs vars hs_ty' fvs1
; (res, fvs2) <- thing_inside sig_ty'
; return (res, fvs1 `plusFV` fvs2) } }
+rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _
+ = panic "rn_hs_sig_wc_type"
+rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _
+ = panic "rn_hs_sig_wc_type"
rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
= do { free_vars <- extractFilteredRdrTyVars hs_ty
; (_, nwc_rdrs) <- partition_nwcs free_vars
; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
- ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = hs_ty' }
+ ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }
; return (sig_ty', fvs) }
+rnHsWcType _ (XHsWildCardBndrs _) = panic "rnHsWcType"
rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
@@ -297,6 +302,7 @@ rnHsSigType ctx (HsIB { hsib_body = hs_ty })
; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->
do { (body', fvs) <- rnLHsType ctx hs_ty
; return ( mk_implicit_bndrs vars body' fvs, fvs ) } }
+rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType"
rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables
-- E.g. f :: forall a. a->b
@@ -353,9 +359,10 @@ mk_implicit_bndrs :: [Name] -- implicitly bound
-> FreeVars -- FreeVars of payload
-> HsImplicitBndrs GhcRn a
mk_implicit_bndrs vars body fvs
- = HsIB { hsib_vars = vars
- , hsib_body = body
- , hsib_closed = nameSetAll (not . isTyVarName) (vars `delFVs` fvs) }
+ = HsIB { hsib_ext = HsIBRn
+ { hsib_vars = vars
+ , hsib_closed = nameSetAll (not . isTyVarName) (vars `delFVs` fvs) }
+ , hsib_body = body }
@@ -834,7 +841,7 @@ wildCardsAllowed env
HsTypeCtx {} -> True
_ -> False
-rnAnonWildCard :: RnM (HsWildCardInfo GhcRn)
+rnAnonWildCard :: RnM HsWildCardInfo
rnAnonWildCard
= do { loc <- getSrcSpanM
; uniq <- newUnique
@@ -948,9 +955,10 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->
do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)
; dep_bndr_nms <- mapM (lookupLocalOccRn . unLoc) dep_bndrs
- ; thing_inside (HsQTvs { hsq_implicit = implicit_kv_nms
- , hsq_explicit = rn_bndrs
- , hsq_dependent = mkNameSet dep_bndr_nms })
+ ; thing_inside (HsQTvs { hsq_ext = HsQTvsRn
+ { hsq_implicit = implicit_kv_nms
+ , hsq_dependent = mkNameSet dep_bndr_nms }
+ , hsq_explicit = rn_bndrs })
all_bound_on_lhs } }
where
@@ -1204,11 +1212,12 @@ rnConDeclFields ctxt fls fields
rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
-rnField fl_env env (L l (ConDeclField names ty haddock_doc))
+rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))
= do { let new_names = map (fmap lookupField) names
; (new_ty, fvs) <- rnLHsTyKi env ty
; new_haddock_doc <- rnMbLHsDoc haddock_doc
- ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
+ ; return (L l (ConDeclField noExt new_names new_ty new_haddock_doc)
+ , fvs) }
where
lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
lookupField (FieldOcc _ (L lr rdr)) = FieldOcc (flSelector fl) (L lr rdr)
@@ -1216,6 +1225,7 @@ rnField fl_env env (L l (ConDeclField names ty haddock_doc))
lbl = occNameFS $ rdrNameOcc rdr
fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
lookupField (XFieldOcc{}) = panic "rnField"
+rnField _ _ (L _ (XConDeclField _)) = panic "rnField"
{-
************************************************************************
@@ -1452,6 +1462,7 @@ checkPrecMatch op (MG { mg_alts = L _ ms })
-- but the second eqn has no args (an error, but not discovered
-- until the type checker). So we don't want to crash on the
-- second eqn.
+checkPrecMatch _ (XMatchGroup {}) = panic "checkPrecMatch"
checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
@@ -1756,8 +1767,8 @@ rmDupsInRdrTyVars (FKTV kis tys)
extractRdrKindSigVars :: LFamilyResultSig GhcPs -> RnM [Located RdrName]
extractRdrKindSigVars (L _ resultSig)
- | KindSig k <- resultSig = kindRdrNameFromSig k
- | TyVarSig (L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k
+ | KindSig _ k <- resultSig = kindRdrNameFromSig k
+ | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k
| otherwise = return []
where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k
@@ -1788,6 +1799,8 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
= extract_hs_tv_bndrs ex_tvs acc =<<
extract_mlctxt ctxt =<<
extract_ltys TypeLevel (hsConDeclArgTys args) emptyFKTV
+ extract_con (XConDecl { }) _ = panic "extractDataDefnKindVars"
+extractDataDefnKindVars (XHsDataDefn _) = panic "extractDataDefnKindVars"
extract_mlctxt :: Maybe (LHsContext GhcPs)
-> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
View Lorry Controller Status