summaryrefslogtreecommitdiff
path: root/compiler/rename
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2018-04-01 21:33:53 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2018-04-09 21:29:05 +0200
commit1aa1d405d8212a99ac24dcfd48024a17c3ffd296 (patch)
treedfb9cc90fce7e4a42fd4ca9024477b3d58b60ac5 /compiler/rename
parent48f55e764bb41848cff759fbea3211d8a0bbfd5b (diff)
downloadhaskell-1aa1d405d8212a99ac24dcfd48024a17c3ffd296.tar.gz
Restore Trees That Grow reverted commits
The following commits were reverted prior to the release of GHC 8.4.1, because the time to derive Data instances was too long [1]. 438dd1cbba13d35f3452b4dcef3f94ce9a216905 Phab:D4147 e3ec2e7ae94524ebd111963faf34b84d942265b4 Phab:D4177 47ad6578ea460999b53eb4293c3a3b3017a56d65 Phab:D4186 The work is continuing, as the minimum bootstrap compiler is now GHC 8.2.1, and this allows Plan B[2] for instances to be used. This will land in a following commit. Updates Haddock submodule [1] https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/Instances [2] https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/Instances#PLANB
Diffstat (limited to 'compiler/rename')
-rw-r--r--compiler/rename/RnBinds.hs14
-rw-r--r--compiler/rename/RnEnv.hs4
-rw-r--r--compiler/rename/RnExpr.hs321
-rw-r--r--compiler/rename/RnFixity.hs5
-rw-r--r--compiler/rename/RnNames.hs8
-rw-r--r--compiler/rename/RnPat.hs101
-rw-r--r--compiler/rename/RnSource.hs29
-rw-r--r--compiler/rename/RnSplice.hs101
-rw-r--r--compiler/rename/RnSplice.hs-boot4
-rw-r--r--compiler/rename/RnTypes.hs337
10 files changed, 478 insertions, 446 deletions
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index dc6c946f17..c54c734dce 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -183,10 +183,10 @@ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs
-> RnM (HsValBinds GhcRn, DefUses)
-- A hs-boot file has no bindings.
-- Return a single HsBindGroup with empty binds and renamed signatures
-rnTopBindsBoot bound_names (ValBindsIn mbinds sigs)
+rnTopBindsBoot bound_names (ValBinds _ mbinds sigs)
= do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs
- ; return (ValBindsOut [] sigs', usesOnly fvs) }
+ ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }
rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)
{-
@@ -274,9 +274,9 @@ rnLocalValBindsLHS fix_env binds
rnValBindsLHS :: NameMaker
-> HsValBinds GhcPs
-> RnM (HsValBindsLR GhcRn GhcPs)
-rnValBindsLHS topP (ValBindsIn mbinds sigs)
+rnValBindsLHS topP (ValBinds x mbinds sigs)
= do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds
- ; return $ ValBindsIn mbinds' sigs }
+ ; return $ ValBinds x mbinds' sigs }
where
bndrs = collectHsBindsBinders mbinds
doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs
@@ -291,7 +291,7 @@ rnValBindsRHS :: HsSigCtxt
-> HsValBindsLR GhcRn GhcPs
-> RnM (HsValBinds GhcRn, DefUses)
-rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
+rnValBindsRHS ctxt (ValBinds _ mbinds sigs)
= do { (sigs', sig_fvs) <- renameSigs ctxt sigs
; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds
; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus
@@ -311,7 +311,7 @@ rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
-- so that the binders are removed from
-- the uses in the sigs
- ; return (ValBindsOut anal_binds sigs', valbind'_dus) }
+ ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) }
rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
@@ -336,7 +336,7 @@ rnLocalValBindsAndThen
:: HsValBinds GhcPs
-> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
-rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
+rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside
= do { -- (A) Create the local fixity environment
new_fixities <- makeMiniFixityEnv [L loc sig
| L loc (FixSig sig) <- sigs]
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 600b5649ca..5873c6ff16 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -1558,10 +1558,10 @@ lookupSyntaxNames :: [Name] -- Standard names
lookupSyntaxNames std_names
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if not rebindable_on then
- return (map (HsVar . noLoc) std_names, emptyFVs)
+ return (map (HsVar noExt . noLoc) std_names, emptyFVs)
else
do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names
- ; return (map (HsVar . noLoc) usr_names, mkFVs usr_names) } }
+ ; return (map (HsVar noExt . noLoc) usr_names, mkFVs usr_names) } }
-- Error messages
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index ced46a367e..ec2b09f80d 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -95,7 +95,7 @@ finishHsVar (L l name)
= do { this_mod <- getModule
; when (nameIsLocalOrFrom this_mod name) $
checkThLocalName name
- ; return (HsVar (L l name), unitFV name) }
+ ; return (HsVar noExt (L l name), unitFV name) }
rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar v
@@ -107,13 +107,13 @@ rnUnboundVar v
; uv <- if startsWithUnderscore occ
then return (TrueExprHole occ)
else OutOfScope occ <$> getGlobalRdrEnv
- ; return (HsUnboundVar uv, emptyFVs) }
+ ; return (HsUnboundVar noExt uv, emptyFVs) }
else -- Fail immediately (qualified name)
do { n <- reportUnboundName v
- ; return (HsVar (noLoc n), emptyFVs) } }
+ ; return (HsVar noExt (noLoc n), emptyFVs) } }
-rnExpr (HsVar (L l v))
+rnExpr (HsVar _ (L l v))
= do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields
; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
; case mb_name of {
@@ -121,58 +121,57 @@ rnExpr (HsVar (L l v))
Just (Left name)
| name == nilDataConName -- Treat [] as an ExplicitList, so that
-- OverloadedLists works correctly
- -> rnExpr (ExplicitList placeHolderType Nothing [])
+ -> rnExpr (ExplicitList noExt Nothing [])
| otherwise
-> finishHsVar (L l name) ;
Just (Right [s]) ->
- return ( HsRecFld (ambiguousFieldOcc (FieldOcc (L l v) s))
- , unitFV s) ;
+ return ( HsRecFld noExt (Unambiguous s (L l v) ), unitFV s) ;
Just (Right fs@(_:_:_)) ->
- return ( HsRecFld (Ambiguous (L l v) PlaceHolder)
+ return ( HsRecFld noExt (Ambiguous noExt (L l v))
, mkFVs fs);
Just (Right []) -> panic "runExpr/HsVar" } }
-rnExpr (HsIPVar v)
- = return (HsIPVar v, emptyFVs)
+rnExpr (HsIPVar x v)
+ = return (HsIPVar x v, emptyFVs)
-rnExpr (HsOverLabel _ v)
+rnExpr (HsOverLabel x _ v)
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if rebindable_on
then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))
- ; return (HsOverLabel (Just fromLabel) v, unitFV fromLabel) }
- else return (HsOverLabel Nothing v, emptyFVs) }
+ ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) }
+ else return (HsOverLabel x Nothing v, emptyFVs) }
-rnExpr (HsLit lit@(HsString src s))
+rnExpr (HsLit x lit@(HsString src s))
= do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
; if opt_OverloadedStrings then
- rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
+ rnExpr (HsOverLit x (mkHsIsString src s))
else do {
; rnLit lit
- ; return (HsLit (convertLit lit), emptyFVs) } }
+ ; return (HsLit x (convertLit lit), emptyFVs) } }
-rnExpr (HsLit lit)
+rnExpr (HsLit x lit)
= do { rnLit lit
- ; return (HsLit (convertLit lit), emptyFVs) }
+ ; return (HsLit x(convertLit lit), emptyFVs) }
-rnExpr (HsOverLit lit)
+rnExpr (HsOverLit x lit)
= do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]
; case mb_neg of
- Nothing -> return (HsOverLit lit', fvs)
- Just neg -> return ( HsApp (noLoc neg) (noLoc (HsOverLit lit'))
+ Nothing -> return (HsOverLit x lit', fvs)
+ Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit'))
, fvs ) }
-rnExpr (HsApp fun arg)
+rnExpr (HsApp x fun arg)
= do { (fun',fvFun) <- rnLExpr fun
; (arg',fvArg) <- rnLExpr arg
- ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
+ ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
-rnExpr (HsAppType fun arg)
+rnExpr (HsAppType arg fun)
= do { (fun',fvFun) <- rnLExpr fun
; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
- ; return (HsAppType fun' arg', fvFun `plusFV` fvArg) }
+ ; return (HsAppType arg' fun', fvFun `plusFV` fvArg) }
-rnExpr (OpApp e1 op _ e2)
+rnExpr (OpApp _ e1 op e2)
= do { (e1', fv_e1) <- rnLExpr e1
; (e2', fv_e2) <- rnLExpr e2
; (op', fv_op) <- rnLExpr op
@@ -183,15 +182,15 @@ rnExpr (OpApp e1 op _ e2)
-- more, so I've removed the test. Adding HsPars in TcGenDeriv
-- should prevent bad things happening.
; fixity <- case op' of
- L _ (HsVar (L _ n)) -> lookupFixityRn n
- L _ (HsRecFld f) -> lookupFieldFixityRn f
+ L _ (HsVar _ (L _ n)) -> lookupFixityRn n
+ L _ (HsRecFld _ f) -> lookupFieldFixityRn f
_ -> return (Fixity NoSourceText minPrecedence InfixL)
-- c.f. lookupFixity for unbound
; final_e <- mkOpAppRn e1' op' fixity e2'
; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
-rnExpr (NegApp e _)
+rnExpr (NegApp _ e _)
= do { (e', fv_e) <- rnLExpr e
; (neg_name, fv_neg) <- lookupSyntaxName negateName
; final_e <- mkNegAppRn e' neg_name
@@ -201,24 +200,24 @@ rnExpr (NegApp e _)
-- Template Haskell extensions
-- Don't ifdef-GHCI them because we want to fail gracefully
-- (not with an rnExpr crash) in a stage-1 compiler.
-rnExpr e@(HsBracket br_body) = rnBracket e br_body
+rnExpr e@(HsBracket _ br_body) = rnBracket e br_body
-rnExpr (HsSpliceE splice) = rnSpliceExpr splice
+rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice
---------------------------------------------
-- Sections
-- See Note [Parsing sections] in Parser.y
-rnExpr (HsPar (L loc (section@(SectionL {}))))
+rnExpr (HsPar x (L loc (section@(SectionL {}))))
= do { (section', fvs) <- rnSection section
- ; return (HsPar (L loc section'), fvs) }
+ ; return (HsPar x (L loc section'), fvs) }
-rnExpr (HsPar (L loc (section@(SectionR {}))))
+rnExpr (HsPar x (L loc (section@(SectionR {}))))
= do { (section', fvs) <- rnSection section
- ; return (HsPar (L loc section'), fvs) }
+ ; return (HsPar x (L loc section'), fvs) }
-rnExpr (HsPar e)
+rnExpr (HsPar x e)
= do { (e', fvs_e) <- rnLExpr e
- ; return (HsPar e', fvs_e) }
+ ; return (HsPar x e', fvs_e) }
rnExpr expr@(SectionL {})
= do { addErr (sectionErr expr); rnSection expr }
@@ -226,71 +225,72 @@ rnExpr expr@(SectionR {})
= do { addErr (sectionErr expr); rnSection expr }
---------------------------------------------
-rnExpr (HsCoreAnn src ann expr)
+rnExpr (HsCoreAnn x src ann expr)
= do { (expr', fvs_expr) <- rnLExpr expr
- ; return (HsCoreAnn src ann expr', fvs_expr) }
+ ; return (HsCoreAnn x src ann expr', fvs_expr) }
-rnExpr (HsSCC src lbl expr)
+rnExpr (HsSCC x src lbl expr)
= do { (expr', fvs_expr) <- rnLExpr expr
- ; return (HsSCC src lbl expr', fvs_expr) }
-rnExpr (HsTickPragma src info srcInfo expr)
+ ; return (HsSCC x src lbl expr', fvs_expr) }
+rnExpr (HsTickPragma x src info srcInfo expr)
= do { (expr', fvs_expr) <- rnLExpr expr
- ; return (HsTickPragma src info srcInfo expr', fvs_expr) }
+ ; return (HsTickPragma x src info srcInfo expr', fvs_expr) }
-rnExpr (HsLam matches)
+rnExpr (HsLam x matches)
= do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
- ; return (HsLam matches', fvMatch) }
+ ; return (HsLam x matches', fvMatch) }
-rnExpr (HsLamCase matches)
+rnExpr (HsLamCase x matches)
= do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
- ; return (HsLamCase matches', fvs_ms) }
+ ; return (HsLamCase x matches', fvs_ms) }
-rnExpr (HsCase expr matches)
+rnExpr (HsCase x expr matches)
= do { (new_expr, e_fvs) <- rnLExpr expr
; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
- ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
+ ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }
-rnExpr (HsLet (L l binds) expr)
+rnExpr (HsLet x (L l binds) expr)
= rnLocalBindsAndThen binds $ \binds' _ -> do
{ (expr',fvExpr) <- rnLExpr expr
- ; return (HsLet (L l binds') expr', fvExpr) }
+ ; return (HsLet x (L l binds') expr', fvExpr) }
-rnExpr (HsDo do_or_lc (L l stmts) _)
+rnExpr (HsDo x do_or_lc (L l stmts))
= do { ((stmts', _), fvs) <-
rnStmtsWithPostProcessing do_or_lc rnLExpr
postProcessStmtsForApplicativeDo stmts
(\ _ -> return ((), emptyFVs))
- ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) }
+ ; return ( HsDo x do_or_lc (L l stmts'), fvs ) }
-rnExpr (ExplicitList _ _ exps)
+rnExpr (ExplicitList x _ exps)
= do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
; (exps', fvs) <- rnExprs exps
; if opt_OverloadedLists
then do {
; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
- ; return (ExplicitList placeHolderType (Just from_list_n_name) exps'
+ ; return (ExplicitList x (Just from_list_n_name) exps'
, fvs `plusFV` fvs') }
else
- return (ExplicitList placeHolderType Nothing exps', fvs) }
+ return (ExplicitList x Nothing exps', fvs) }
-rnExpr (ExplicitPArr _ exps)
+rnExpr (ExplicitPArr x exps)
= do { (exps', fvs) <- rnExprs exps
- ; return (ExplicitPArr placeHolderType exps', fvs) }
+ ; return (ExplicitPArr x exps', fvs) }
-rnExpr (ExplicitTuple tup_args boxity)
+rnExpr (ExplicitTuple x tup_args boxity)
= do { checkTupleSection tup_args
; checkTupSize (length tup_args)
; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
- ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
+ ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) }
where
- rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e
- ; return (L l (Present e'), fvs) }
- rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
+ rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e
+ ; return (L l (Present x e'), fvs) }
+ rnTupArg (L l (Missing _)) = return (L l (Missing noExt)
, emptyFVs)
+ rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg"
-rnExpr (ExplicitSum alt arity expr _)
+rnExpr (ExplicitSum x alt arity expr)
= do { (expr', fvs) <- rnLExpr expr
- ; return (ExplicitSum alt arity expr' PlaceHolder, fvs) }
+ ; return (ExplicitSum x alt arity expr', fvs) }
rnExpr (RecordCon { rcon_con_name = con_id
, rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
@@ -298,53 +298,53 @@ rnExpr (RecordCon { rcon_con_name = con_id
; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
; (flds', fvss) <- mapAndUnzipM rn_field flds
; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
- ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds'
- , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
+ ; return (RecordCon { rcon_ext = noExt
+ , rcon_con_name = con_lname, rcon_flds = rec_binds' }
, fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
where
- mk_hs_var l n = HsVar (L l n)
+ mk_hs_var l n = HsVar noExt (L l n)
rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
= do { (expr', fvExpr) <- rnLExpr expr
; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
- ; return (RecordUpd { rupd_expr = expr', rupd_flds = rbinds'
- , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder
- , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder }
+ ; return (RecordUpd { rupd_ext = noExt, rupd_expr = expr'
+ , rupd_flds = rbinds' }
, fvExpr `plusFV` fvRbinds) }
-rnExpr (ExprWithTySig expr pty)
+rnExpr (ExprWithTySig pty expr)
= do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty
; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
rnLExpr expr
- ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
+ ; return (ExprWithTySig pty' expr', fvExpr `plusFV` fvTy) }
-rnExpr (HsIf _ p b1 b2)
+rnExpr (HsIf x _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
; (b1', fvB1) <- rnLExpr b1
; (b2', fvB2) <- rnLExpr b2
; (mb_ite, fvITE) <- lookupIfThenElse
- ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
+ ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
-rnExpr (HsMultiIf _ty alts)
+rnExpr (HsMultiIf x alts)
= do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
-- ; return (HsMultiIf ty alts', fvs) }
- ; return (HsMultiIf placeHolderType alts', fvs) }
+ ; return (HsMultiIf x alts', fvs) }
-rnExpr (ArithSeq _ _ seq)
+rnExpr (ArithSeq x _ seq)
= do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
; (new_seq, fvs) <- rnArithSeq seq
; if opt_OverloadedLists
then do {
; (from_list_name, fvs') <- lookupSyntaxName fromListName
- ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }
+ ; return (ArithSeq x (Just from_list_name) new_seq
+ , fvs `plusFV` fvs') }
else
- return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
+ return (ArithSeq x Nothing new_seq, fvs) }
-rnExpr (PArrSeq _ seq)
+rnExpr (PArrSeq x seq)
= do { (new_seq, fvs) <- rnArithSeq seq
- ; return (PArrSeq noPostTcExpr new_seq, fvs) }
+ ; return (PArrSeq x new_seq, fvs) }
{-
These three are pattern syntax appearing in expressions.
@@ -352,7 +352,7 @@ Since all the symbols are reservedops we can simply reject them.
We return a (bogus) EWildPat in each case.
-}
-rnExpr EWildPat = return (hsHoleExpr, emptyFVs) -- "_" is just a hole
+rnExpr (EWildPat _) = return (hsHoleExpr, emptyFVs) -- "_" is just a hole
rnExpr e@(EAsPat {})
= do { opt_TypeApplications <- xoptM LangExt.TypeApplications
; let msg | opt_TypeApplications
@@ -407,11 +407,11 @@ rnExpr e@(HsStatic _ expr) = do
************************************************************************
-}
-rnExpr (HsProc pat body)
+rnExpr (HsProc x pat body)
= newArrowScope $
rnPat ProcExpr pat $ \ pat' -> do
{ (body',fvBody) <- rnCmdTop body
- ; return (HsProc pat' body', fvBody) }
+ ; return (HsProc x pat' body', fvBody) }
-- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.
rnExpr e@(HsArrApp {}) = arrowFail e
@@ -420,8 +420,8 @@ rnExpr e@(HsArrForm {}) = arrowFail e
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
-- HsWrap
-hsHoleExpr :: HsExpr id
-hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_"))
+hsHoleExpr :: HsExpr (GhcPass id)
+hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
arrowFail e
@@ -434,17 +434,17 @@ arrowFail e
----------------------
-- See Note [Parsing sections] in Parser.y
rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-rnSection section@(SectionR op expr)
+rnSection section@(SectionR x op expr)
= do { (op', fvs_op) <- rnLExpr op
; (expr', fvs_expr) <- rnLExpr expr
; checkSectionPrec InfixR section op' expr'
- ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
+ ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) }
-rnSection section@(SectionL expr op)
+rnSection section@(SectionL x expr op)
= do { (expr', fvs_expr) <- rnLExpr expr
; (op', fvs_op) <- rnLExpr op
; checkSectionPrec InfixL section op' expr'
- ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
+ ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) }
rnSection other = pprPanic "rnSection" (ppr other)
@@ -466,26 +466,26 @@ rnCmdArgs (arg:args)
rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop = wrapLocFstM rnCmdTop'
where
- rnCmdTop' (HsCmdTop cmd _ _ _)
+ rnCmdTop' (HsCmdTop _ cmd)
= do { (cmd', fvCmd) <- rnLCmd cmd
; let cmd_names = [arrAName, composeAName, firstAName] ++
nameSetElemsStable (methodNamesCmd (unLoc cmd'))
-- Generate the rebindable syntax for the monad
; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
- ; return (HsCmdTop cmd' placeHolderType placeHolderType
- (cmd_names `zip` cmd_names'),
+ ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',
fvCmd `plusFV` cmd_fvs) }
+ rnCmdTop' (XCmdTop{}) = panic "rnCmdTop"
rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd = wrapLocFstM rnCmd
rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
-rnCmd (HsCmdArrApp arrow arg _ ho rtl)
+rnCmd (HsCmdArrApp x arrow arg ho rtl)
= do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
; (arg',fvArg) <- rnLExpr arg
- ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,
+ ; return (HsCmdArrApp x arrow' arg' ho rtl,
fvArrow `plusFV` fvArg) }
where
select_arrow_scope tc = case ho of
@@ -498,9 +498,9 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl)
-- inside 'arrow'. In the higher-order case (-<<), they are.
-- infix form
-rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
+rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])
= do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
- ; let L _ (HsVar (L _ op_name)) = op'
+ ; let L _ (HsVar _ (L _ op_name)) = op'
; (arg1',fv_arg1) <- rnCmdTop arg1
; (arg2',fv_arg2) <- rnCmdTop arg2
-- Deal with fixity
@@ -508,47 +508,48 @@ rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
; final_e <- mkOpFormRn arg1' op' fixity arg2'
; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
-rnCmd (HsCmdArrForm op f fixity cmds)
+rnCmd (HsCmdArrForm x op f fixity cmds)
= do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
; (cmds',fvCmds) <- rnCmdArgs cmds
- ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) }
+ ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) }
-rnCmd (HsCmdApp fun arg)
+rnCmd (HsCmdApp x fun arg)
= do { (fun',fvFun) <- rnLCmd fun
; (arg',fvArg) <- rnLExpr arg
- ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }
+ ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }
-rnCmd (HsCmdLam matches)
+rnCmd (HsCmdLam x matches)
= do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
- ; return (HsCmdLam matches', fvMatch) }
+ ; return (HsCmdLam x matches', fvMatch) }
-rnCmd (HsCmdPar e)
+rnCmd (HsCmdPar x e)
= do { (e', fvs_e) <- rnLCmd e
- ; return (HsCmdPar e', fvs_e) }
+ ; return (HsCmdPar x e', fvs_e) }
-rnCmd (HsCmdCase expr matches)
+rnCmd (HsCmdCase x expr matches)
= do { (new_expr, e_fvs) <- rnLExpr expr
; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
- ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
+ ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }
-rnCmd (HsCmdIf _ p b1 b2)
+rnCmd (HsCmdIf x _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
; (b1', fvB1) <- rnLCmd b1
; (b2', fvB2) <- rnLCmd b2
; (mb_ite, fvITE) <- lookupIfThenElse
- ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
+ ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
-rnCmd (HsCmdLet (L l binds) cmd)
+rnCmd (HsCmdLet x (L l binds) cmd)
= rnLocalBindsAndThen binds $ \ binds' _ -> do
{ (cmd',fvExpr) <- rnLCmd cmd
- ; return (HsCmdLet (L l binds') cmd', fvExpr) }
+ ; return (HsCmdLet x (L l binds') cmd', fvExpr) }
-rnCmd (HsCmdDo (L l stmts) _)
+rnCmd (HsCmdDo x (L l stmts))
= do { ((stmts', _), fvs) <-
rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
- ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) }
+ ; return ( HsCmdDo x (L l stmts'), fvs ) }
rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)
+rnCmd cmd@(XCmd {}) = pprPanic "rnCmd" (ppr cmd)
---------------------------------------------------
type CmdNeeds = FreeVars -- Only inhabitants are
@@ -560,26 +561,28 @@ methodNamesLCmd = methodNamesCmd . unLoc
methodNamesCmd :: HsCmd GhcRn -> CmdNeeds
-methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)
= emptyFVs
-methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)
= unitFV appAName
methodNamesCmd (HsCmdArrForm {}) = emptyFVs
-methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd
+methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd
-methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
+methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c
-methodNamesCmd (HsCmdIf _ _ c1 c2)
+methodNamesCmd (HsCmdIf _ _ _ c1 c2)
= methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
-methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c
-methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts
-methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c
-methodNamesCmd (HsCmdLam match) = methodNamesMatch match
+methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c
+methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts
+methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c
+methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match
-methodNamesCmd (HsCmdCase _ matches)
+methodNamesCmd (HsCmdCase _ _ matches)
= methodNamesMatch matches `addOneFV` choiceAName
+methodNamesCmd (XCmd {}) = panic "methodNamesCmd"
+
--methodNamesCmd _ = emptyFVs
-- Other forms can't occur in commands, but it's not convenient
-- to error here so we just do what's convenient.
@@ -863,7 +866,7 @@ 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 pat' body' bind_op fail_op placeHolder)
, fv_expr )]
, thing),
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
@@ -946,7 +949,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
; return (([(L loc (TransStmt { 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_bind_arg_ty = placeHolder
, trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
rnStmt _ _ (L _ ApplicativeStmt{}) _ =
@@ -971,7 +974,7 @@ rnParallelStmts ctxt return_op segs thing_inside
; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
; return (([], thing), fvs) }
- rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs)
+ rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)
= do { ((stmts', (used_bndrs, segs', thing)), fvs)
<- rnStmts ctxt rnLExpr stmts $ \ bndrs ->
setLocalRdrEnv env $ do
@@ -979,8 +982,9 @@ rnParallelStmts ctxt return_op segs thing_inside
; let used_bndrs = filter (`elemNameSet` fvs) bndrs
; return ((used_bndrs, segs', thing), fvs) }
- ; let seg' = ParStmtBlock stmts' used_bndrs return_op
+ ; let seg' = ParStmtBlock x stmts' used_bndrs return_op
; return ((seg':segs', thing), fvs) }
+ rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts"
cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
@@ -1000,12 +1004,12 @@ lookupStmtNamePoly ctxt name
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if rebindable_on
then do { fm <- lookupOccRn (nameRdrName name)
- ; return (HsVar (noLoc fm), unitFV fm) }
+ ; return (HsVar noExt (noLoc fm), unitFV fm) }
else not_rebindable }
| otherwise
= not_rebindable
where
- not_rebindable = return (HsVar (noLoc name), emptyFVs)
+ not_rebindable = return (HsVar noExt (noLoc name), emptyFVs)
-- | Is this a context where we respect RebindableSyntax?
-- but ListComp/PArrComp are never rebindable
@@ -1095,7 +1099,7 @@ rnRecStmtsAndThen rnBody s cont
collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities l =
foldr (\ s -> \acc -> case s of
- (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) ->
+ (L _ (LetStmt (L _ (HsValBinds (ValBinds _ _ sigs))))) ->
foldr (\ sig -> \ acc -> case sig of
(L loc (FixSig s)) -> (L loc s) : acc
_ -> acc) acc sigs
@@ -1196,7 +1200,7 @@ 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 pat' body' bind_op fail_op placeHolder))] }
rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _)
= failWith (badIpBinds (text "an mdo expression") binds)
@@ -1700,7 +1704,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
return (unLoc tup, emptyNameSet)
| otherwise -> do
(ret,fvs) <- lookupStmtNamePoly ctxt returnMName
- return (HsApp (noLoc ret) tup, fvs)
+ return (HsApp noExt (noLoc ret) tup, fvs)
return ( ApplicativeArgMany stmts' mb_ret pat
, fvs1 `plusFV` fvs2)
@@ -1786,25 +1790,24 @@ can do with the rest of the statements in the same "do" expression.
isStrictPattern :: LPat id -> Bool
isStrictPattern (L _ pat) =
case pat of
- WildPat{} -> False
- VarPat{} -> False
- LazyPat{} -> False
- AsPat _ p -> isStrictPattern p
- ParPat p -> isStrictPattern p
- ViewPat _ p _ -> isStrictPattern p
- SigPatIn p _ -> isStrictPattern p
- SigPatOut p _ -> isStrictPattern p
- BangPat{} -> True
- ListPat{} -> True
- TuplePat{} -> True
- SumPat{} -> True
- PArrPat{} -> True
- ConPatIn{} -> True
- ConPatOut{} -> True
- LitPat{} -> True
- NPat{} -> True
- NPlusKPat{} -> True
- SplicePat{} -> True
+ WildPat{} -> False
+ VarPat{} -> False
+ LazyPat{} -> False
+ AsPat _ _ p -> isStrictPattern p
+ ParPat _ p -> isStrictPattern p
+ ViewPat _ _ p -> isStrictPattern p
+ SigPat _ p -> isStrictPattern p
+ BangPat{} -> True
+ ListPat{} -> True
+ TuplePat{} -> True
+ SumPat{} -> True
+ PArrPat{} -> True
+ ConPatIn{} -> True
+ ConPatOut{} -> True
+ LitPat{} -> True
+ NPat{} -> True
+ NPlusKPat{} -> True
+ SplicePat{} -> True
_otherwise -> panic "isStrictPattern"
isLetStmt :: LStmt a b -> Bool
@@ -1912,15 +1915,15 @@ needJoin _monad_names stmts = (True, stmts)
isReturnApp :: MonadNames
-> LHsExpr GhcRn
-> Maybe (LHsExpr GhcRn)
-isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr
+isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr
isReturnApp monad_names (L _ e) = case e of
- OpApp l op _ r | is_return l, is_dollar op -> Just r
- HsApp f arg | is_return f -> Just arg
+ OpApp _ l op r | is_return l, is_dollar op -> Just r
+ HsApp _ f arg | is_return f -> Just arg
_otherwise -> Nothing
where
- is_var f (L _ (HsPar e)) = is_var f e
- is_var f (L _ (HsAppType e _)) = is_var f e
- is_var f (L _ (HsVar (L _ r))) = f r
+ is_var f (L _ (HsPar _ e)) = is_var f e
+ is_var f (L _ (HsAppType _ e)) = is_var f e
+ is_var f (L _ (HsVar _ (L _ r))) = f r
-- TODO: I don't know how to get this right for rebindable syntax
is_var _ _ = False
@@ -2102,7 +2105,7 @@ patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars)
patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:",
nest 4 (ppr e)] $$
explanation)
- ; return (EWildPat, emptyFVs) }
+ ; return (EWildPat noExt, emptyFVs) }
badIpBinds :: Outputable a => SDoc -> a -> SDoc
badIpBinds what binds
diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs
index b1305f55f3..f1bfb380a5 100644
--- a/compiler/rename/RnFixity.hs
+++ b/compiler/rename/RnFixity.hs
@@ -179,9 +179,9 @@ lookupTyFixityRn (L _ n) = lookupFixityRn n
-- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are
-- multiple possible selectors with different fixities, generate an error.
lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity
-lookupFieldFixityRn (Unambiguous (L _ rdr) n)
+lookupFieldFixityRn (Unambiguous n (L _ rdr))
= lookupFixityRn' n (rdrNameOcc rdr)
-lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr
+lookupFieldFixityRn (Ambiguous _ (L _ rdr)) = get_ambiguous_fixity rdr
where
get_ambiguous_fixity :: RdrName -> RnM Fixity
get_ambiguous_fixity rdr_name = do
@@ -209,3 +209,4 @@ lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr
format_ambig (elt, fix) = hang (ppr fix)
2 (pprNameProvenance elt)
+lookupFieldFixityRn (XAmbiguousFieldOcc{}) = panic "lookupFieldFixityRn"
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index af00056271..0f6f3a1327 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -659,7 +659,7 @@ getLocalNonValBinders fixity_env
; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])
; return (envs, new_bndrs) } }
where
- ValBindsIn _val_binds val_sigs = binds
+ ValBinds _ _val_binds val_sigs = binds
for_hs_bndrs :: [Located RdrName]
for_hs_bndrs = hsForeignDeclsBinders foreign_decls
@@ -712,10 +712,11 @@ getLocalNonValBinders fixity_env
find_con_decl_flds (L _ x)
= map find_con_decl_fld (cd_fld_names x)
- find_con_decl_fld (L _ (FieldOcc (L _ rdr) _))
+ find_con_decl_fld (L _ (FieldOcc _ (L _ rdr)))
= expectJust "getLocalNonValBinders/find_con_decl_fld" $
find (\ fl -> flLabel fl == lbl) flds
where lbl = occNameFS (rdrNameOcc rdr)
+ find_con_decl_fld (L _ (XFieldOcc _)) = panic "getLocalNonValBinders"
new_assoc :: Bool -> LInstDecl GhcPs
-> RnM ([AvailInfo], [(Name, [FieldLabel])])
@@ -755,7 +756,8 @@ getLocalNonValBinders fixity_env
newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel
newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"
-newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _))
+newRecordSelector _ _ (L _ (XFieldOcc _)) = panic "newRecordSelector"
+newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld)))
= do { selName <- newTopSrcBinder $ L loc $ field
; return $ qualFieldLbl { flSelector = selName } }
where
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 31b23634dd..320a34b4bf 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -11,6 +11,8 @@ free variables.
-}
{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
module RnPat (-- main entry points
rnPat, rnPats, rnBindPat, rnPatAndThen,
@@ -383,17 +385,20 @@ rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
-rnPatAndThen _ (WildPat _) = return (WildPat placeHolderType)
-rnPatAndThen mk (ParPat pat) = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') }
-rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') }
-rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') }
-rnPatAndThen mk (VarPat (L l rdr)) = do { loc <- liftCps getSrcSpanM
- ; name <- newPatName mk (L loc rdr)
- ; return (VarPat (L l name)) }
+rnPatAndThen _ (WildPat _) = return (WildPat noExt)
+rnPatAndThen mk (ParPat x pat) = do { pat' <- rnLPatAndThen mk pat
+ ; return (ParPat x pat') }
+rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat
+ ; return (LazyPat x pat') }
+rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat
+ ; return (BangPat x pat') }
+rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM
+ ; name <- newPatName mk (L loc rdr)
+ ; return (VarPat x (L l name)) }
-- we need to bind pattern variables for view pattern expressions
-- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
-rnPatAndThen mk (SigPatIn pat sig)
+rnPatAndThen mk (SigPat sig pat )
-- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is
-- important to rename its type signature _before_ renaming the rest of the
-- pattern, so that type variables are first bound by the _outermost_ pattern
@@ -405,21 +410,21 @@ rnPatAndThen mk (SigPatIn pat sig)
-- ~~~~~~~~~~~~~~~^ the same `a' then used here
= do { sig' <- rnHsSigCps sig
; pat' <- rnLPatAndThen mk pat
- ; return (SigPatIn pat' sig') }
+ ; return (SigPat sig' pat' ) }
-rnPatAndThen mk (LitPat lit)
+rnPatAndThen mk (LitPat x lit)
| HsString src s <- lit
= do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
; if ovlStr
then rnPatAndThen mk
- (mkNPat (noLoc (mkHsIsString src s placeHolderType))
+ (mkNPat (noLoc (mkHsIsString src s))
Nothing)
else normal_lit }
| otherwise = normal_lit
where
- normal_lit = do { liftCps (rnLit lit); return (LitPat (convertLit lit)) }
+ normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }
-rnPatAndThen _ (NPat (L l lit) mb_neg _eq _)
+rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
= do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
; mb_neg' -- See Note [Negative zero]
<- let negative = do { (neg, fvs) <- lookupSyntaxName negateName
@@ -431,9 +436,9 @@ rnPatAndThen _ (NPat (L l lit) mb_neg _eq _)
(Nothing, Nothing) -> positive
(Just _ , Just _ ) -> positive
; eq' <- liftCpsFV $ lookupSyntaxName eqName
- ; return (NPat (L l lit') mb_neg' eq' placeHolderType) }
+ ; return (NPat x (L l lit') mb_neg' eq') }
-rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _)
+rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ )
= do { new_name <- newPatName mk rdr
; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
-- We skip negateName as
@@ -441,16 +446,16 @@ rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _)
-- sense in n + k patterns
; minus <- liftCpsFV $ lookupSyntaxName minusName
; ge <- liftCpsFV $ lookupSyntaxName geName
- ; return (NPlusKPat (L (nameSrcSpan new_name) new_name)
- (L l lit') lit' ge minus placeHolderType) }
+ ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name)
+ (L l lit') lit' ge minus) }
-- The Report says that n+k patterns must be in Integral
-rnPatAndThen mk (AsPat rdr pat)
+rnPatAndThen mk (AsPat x rdr pat)
= do { new_name <- newPatLName mk rdr
; pat' <- rnLPatAndThen mk pat
- ; return (AsPat new_name pat') }
+ ; return (AsPat x new_name pat') }
-rnPatAndThen mk p@(ViewPat expr pat _ty)
+rnPatAndThen mk p@(ViewPat x expr pat)
= do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
; checkErr vp_flag (badViewPat p) }
-- Because of the way we're arranging the recursive calls,
@@ -459,45 +464,46 @@ rnPatAndThen mk p@(ViewPat expr pat _ty)
; pat' <- rnLPatAndThen mk pat
-- Note: at this point the PreTcType in ty can only be a placeHolder
-- ; return (ViewPat expr' pat' ty) }
- ; return (ViewPat expr' pat' placeHolderType) }
+ ; return (ViewPat x expr' pat') }
rnPatAndThen mk (ConPatIn con stuff)
-- rnConPatAndThen takes care of reconstructing the pattern
-- 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 [] placeHolderType Nothing)
+ ; if ol_flag then rnPatAndThen mk (ListPat noExt []
+ placeHolderType Nothing)
else rnConPatAndThen mk con stuff}
False -> rnConPatAndThen mk con stuff
-rnPatAndThen mk (ListPat pats _ _)
+rnPatAndThen mk (ListPat x 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 pats' placeHolderType
+ ; return (ListPat x pats' placeHolderType
(Just (placeHolderType, to_list_name)))}
- False -> return (ListPat pats' placeHolderType Nothing) }
+ False -> return (ListPat x pats' placeHolderType Nothing) }
-rnPatAndThen mk (PArrPat pats _)
+rnPatAndThen mk (PArrPat x pats)
= do { pats' <- rnLPatsAndThen mk pats
- ; return (PArrPat pats' placeHolderType) }
+ ; return (PArrPat x pats') }
-rnPatAndThen mk (TuplePat pats boxed _)
+rnPatAndThen mk (TuplePat x pats boxed)
= do { liftCps $ checkTupSize (length pats)
; pats' <- rnLPatsAndThen mk pats
- ; return (TuplePat pats' boxed []) }
+ ; return (TuplePat x pats' boxed) }
-rnPatAndThen mk (SumPat pat alt arity _)
+rnPatAndThen mk (SumPat x pat alt arity)
= do { pat <- rnLPatAndThen mk pat
- ; return (SumPat pat alt arity PlaceHolder)
+ ; return (SumPat x pat alt arity)
}
-- If a splice has been run already, just rename the result.
-rnPatAndThen mk (SplicePat (HsSpliced mfs (HsSplicedPat pat)))
- = SplicePat . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat
+rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat)))
+ = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat
-rnPatAndThen mk (SplicePat splice)
+rnPatAndThen mk (SplicePat _ splice)
= do { eith <- liftCpsFV $ rnSplicePat splice
; case eith of -- See Note [rnSplicePat] in RnSplice
Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed
@@ -540,7 +546,7 @@ rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd })
; flds' <- mapM rn_field (flds `zip` [1..])
; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
where
- mkVarPat l n = VarPat (L l n)
+ mkVarPat l n = VarPat noExt (L l n)
rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n')
(hsRecFieldArg fld)
; return (L l (fld { hsRecFieldArg = arg' })) }
@@ -602,7 +608,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg)
-> RnM (LHsRecField GhcRn (Located arg))
rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl
- = L loc (FieldOcc (L ll lbl) _)
+ = L loc (FieldOcc _ (L ll lbl))
, hsRecFieldArg = arg
, hsRecPun = pun }))
= do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl
@@ -613,9 +619,11 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; return (L loc (mk_arg loc arg_rdr)) }
else return arg
; return (L l (HsRecField { hsRecFieldLbl
- = L loc (FieldOcc (L ll lbl) sel)
+ = L loc (FieldOcc sel (L ll lbl))
, hsRecFieldArg = arg'
, hsRecPun = pun })) }
+ rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _))
+ = panic "rnHsRecFields"
rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat
-> Maybe Name -- The constructor (Nothing for an
@@ -656,7 +664,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; addUsedGREs dot_dot_gres
; return [ L loc (HsRecField
- { hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel)
+ { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr))
, hsRecFieldArg = L loc (mk_arg loc arg_rdr)
, hsRecPun = False })
| fl <- dot_dot_fields
@@ -764,7 +772,7 @@ rnHsRecUpdFields flds
then do { checkErr pun_ok (badPun (L loc lbl))
-- Discard any module qualifier (#11662)
; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
- ; return (L loc (HsVar (L loc arg_rdr))) }
+ ; return (L loc (HsVar noExt (L loc arg_rdr))) }
else return arg
; (arg'', fvs) <- rnLExpr arg'
@@ -774,10 +782,10 @@ rnHsRecUpdFields flds
Right _ -> fvs
lbl' = case sel of
Left sel_name ->
- L loc (Unambiguous (L loc lbl) sel_name)
+ L loc (Unambiguous sel_name (L loc lbl))
Right [sel_name] ->
- L loc (Unambiguous (L loc lbl) sel_name)
- Right _ -> L loc (Ambiguous (L loc lbl) PlaceHolder)
+ L loc (Unambiguous sel_name (L loc lbl))
+ Right _ -> L loc (Ambiguous noExt (L loc lbl))
; return (L l (HsRecField { hsRecFieldLbl = lbl'
, hsRecFieldArg = arg''
@@ -798,7 +806,7 @@ getFieldLbls :: [LHsRecField id arg] -> [RdrName]
getFieldLbls flds
= map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
-getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName]
+getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
needFlagDotDot :: HsRecFieldContext -> SDoc
@@ -882,11 +890,10 @@ rnOverLit origLit
; (SyntaxExpr { syn_expr = from_thing_name }, fvs1)
<- lookupSyntaxName std_name
; let rebindable = case from_thing_name of
- HsVar (L _ v) -> v /= std_name
- _ -> panic "rnOverLit"
+ HsVar _ (L _ v) -> v /= std_name
+ _ -> panic "rnOverLit"
; let lit' = lit { ol_witness = from_thing_name
- , ol_rebindable = rebindable
- , ol_type = placeHolderType }
+ , ol_ext = rebindable }
; if isNegativeZeroOverLit lit'
then do { (SyntaxExpr { syn_expr = negate_name }, fvs2)
<- lookupSyntaxName negateName
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index d0ff52714d..31caffee80 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -581,7 +581,7 @@ checkCanonicalInstances cls poly_ty mbinds = do
isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}
| GRHSs [L _ (GRHS [] body)] lbinds <- grhss
, L _ EmptyLocalBinds <- lbinds
- , L _ (HsVar (L _ rhsName)) <- body = Just rhsName
+ , L _ (HsVar _ (L _ rhsName)) <- body = Just rhsName
isAliasMG _ = Nothing
-- got "lhs = rhs" but expected something different
@@ -1038,10 +1038,11 @@ validRuleLhs foralls lhs
where
checkl (L _ e) = check e
- check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
- check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
- check (HsAppType e _) = checkl e
- check (HsVar (L _ v)) | v `notElem` foralls = Nothing
+ check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1
+ `mplus` checkl_e e2
+ check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2
+ check (HsAppType _ e) = checkl e
+ check (HsVar _ (L _ v)) | v `notElem` foralls = Nothing
check other = Just other -- Failure
-- Check an argument
@@ -1077,7 +1078,7 @@ badRuleLhsErr name lhs bad_e
text "LHS must be of form (f e1 .. en) where f is not forall'd"
where
err = case bad_e of
- HsUnboundVar uv -> text "Not in scope:" <+> ppr uv
+ HsUnboundVar _ uv -> text "Not in scope:" <+> ppr uv
_ -> text "Illegal expression:" <+> ppr bad_e
{-
@@ -1091,7 +1092,7 @@ 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')
@@ -2003,7 +2004,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
where
new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
- new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds
+ new_ps (ValBinds _ binds _) = foldrBagM new_ps' [] binds
new_ps _ = panic "new_ps"
new_ps' :: LHsBindLR GhcPs GhcPs
@@ -2016,7 +2017,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
bnd_name <- newTopSrcBinder (L bind_loc n)
let rnames = map recordPatSynSelectorId as
mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs
- mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)
+ mkFieldOcc (L l name) = L l (FieldOcc noExt (L l name))
field_occs = map mkFieldOcc rnames
flds <- mapM (newRecordSelector False [bnd_name]) field_occs
return ((bnd_name, flds): names)
@@ -2175,9 +2176,9 @@ add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
= tycls { group_roles = d : roles } : rest
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
-add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
-add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
+add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
+add_bind _ (XValBindsLR {}) = panic "RdrHsSyn:add_bind"
-add_sig :: LSig a -> HsValBinds a -> HsValBinds a
-add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
-add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
+add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
+add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)
+add_sig _ (XValBindsLR {}) = panic "RdrHsSyn:add_sig"
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index 36b1eda140..fc7240ef44 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -18,7 +18,6 @@ import NameSet
import HsSyn
import RdrName
import TcRnMonad
-import Kind
import RnEnv
import RnUtils ( HsDocContext(..), newLocalBndrRn )
@@ -103,7 +102,7 @@ rnBracket e br_body
; (body', fvs_e) <-
setStage (Brack cur_stage RnPendingTyped) $
rn_bracket cur_stage br_body
- ; return (HsBracket body', fvs_e) }
+ ; return (HsBracket noExt body', fvs_e) }
False -> do { traceRn "Renaming untyped TH bracket" empty
; ps_var <- newMutVar []
@@ -111,11 +110,11 @@ rnBracket e br_body
setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
rn_bracket cur_stage br_body
; pendings <- readMutVar ps_var
- ; return (HsRnBracketOut body' pendings, fvs_e) }
+ ; return (HsRnBracketOut noExt body' pendings, fvs_e) }
}
rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)
-rn_bracket outer_stage br@(VarBr flg rdr_name)
+rn_bracket outer_stage br@(VarBr x flg rdr_name)
= do { name <- lookupOccRn rdr_name
; this_mod <- getModule
@@ -137,17 +136,18 @@ rn_bracket outer_stage br@(VarBr flg rdr_name)
(quotedNameStageErr br) }
}
}
- ; return (VarBr flg name, unitFV name) }
+ ; return (VarBr x flg name, unitFV name) }
-rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e
- ; return (ExpBr e', fvs) }
+rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e
+ ; return (ExpBr x e', fvs) }
-rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
+rn_bracket _ (PatBr x p)
+ = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)
-rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t
- ; return (TypBr t', fvs) }
+rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t
+ ; return (TypBr x t', fvs) }
-rn_bracket _ (DecBrL decls)
+rn_bracket _ (DecBrL x decls)
= do { group <- groupDecls decls
; gbl_env <- getGblEnv
; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
@@ -159,7 +159,7 @@ rn_bracket _ (DecBrL decls)
-- Discard the tcg_env; it contains only extra info about fixity
; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$
ppr (duUses (tcg_dus tcg_env)))
- ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
+ ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }
where
groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls decls
@@ -173,10 +173,12 @@ rn_bracket _ (DecBrL decls)
}
}}
-rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG"
+rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"
-rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e
- ; return (TExpBr e', fvs) }
+rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e
+ ; return (TExpBr x e', fvs) }
+
+rn_bracket _ (XBracket {}) = panic "rn_bracket: unexpected XBracket"
quotationCtxtDoc :: HsBracket GhcPs -> SDoc
quotationCtxtDoc br_body
@@ -294,10 +296,11 @@ runRnSplice flavour run_meta ppr_res splice
= do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)
; let the_expr = case splice' of
- HsUntypedSplice _ _ e -> e
- HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str
- HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice)
- HsSpliced {} -> pprPanic "runRnSplice" (ppr splice)
+ HsUntypedSplice _ _ _ e -> e
+ HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str
+ HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice)
+ HsSpliced {} -> pprPanic "runRnSplice" (ppr splice)
+ XSplice {} -> pprPanic "runRnSplice" (ppr splice)
-- Typecheck the expression
; meta_exp_ty <- tcMetaTy meta_ty_name
@@ -335,14 +338,16 @@ runRnSplice flavour run_meta ppr_res splice
makePending :: UntypedSpliceFlavour
-> HsSplice GhcRn
-> PendingRnSplice
-makePending flavour (HsUntypedSplice _ n e)
+makePending flavour (HsUntypedSplice _ _ n e)
= PendingRnSplice flavour n e
-makePending flavour (HsQuasiQuote n quoter q_span quote)
+makePending flavour (HsQuasiQuote _ n quoter q_span quote)
= PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)
makePending _ splice@(HsTypedSplice {})
= pprPanic "makePending" (ppr splice)
makePending _ splice@(HsSpliced {})
= pprPanic "makePending" (ppr splice)
+makePending _ splice@(XSplice {})
+ = pprPanic "makePending" (ppr splice)
------------------
mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
@@ -350,13 +355,13 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
-- Return the expression (quoter "...quote...")
-- which is what we must run in a quasi-quote
mkQuasiQuoteExpr flavour quoter q_span quote
- = L q_span $ HsApp (L q_span $
- HsApp (L q_span (HsVar (L q_span quote_selector)))
+ = L q_span $ HsApp noExt (L q_span $
+ HsApp noExt (L q_span (HsVar noExt (L q_span quote_selector)))
quoterExpr)
quoteExpr
where
- quoterExpr = L q_span $! HsVar $! (L q_span quoter)
- quoteExpr = L q_span $! HsLit $! HsString NoSourceText quote
+ quoterExpr = L q_span $! HsVar noExt $! (L q_span quoter)
+ quoteExpr = L q_span $! HsLit noExt $! HsString NoSourceText quote
quote_selector = case flavour of
UntypedExpSplice -> quoteExpName
UntypedPatSplice -> quotePatName
@@ -366,21 +371,21 @@ mkQuasiQuoteExpr flavour quoter q_span quote
---------------------
rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars)
-- Not exported...used for all
-rnSplice (HsTypedSplice hasParen splice_name expr)
+rnSplice (HsTypedSplice x hasParen splice_name expr)
= do { checkTH expr "Template Haskell typed splice"
; loc <- getSrcSpanM
; n' <- newLocalBndrRn (L loc splice_name)
; (expr', fvs) <- rnLExpr expr
- ; return (HsTypedSplice hasParen n' expr', fvs) }
+ ; return (HsTypedSplice x hasParen n' expr', fvs) }
-rnSplice (HsUntypedSplice hasParen splice_name expr)
+rnSplice (HsUntypedSplice x hasParen splice_name expr)
= do { checkTH expr "Template Haskell untyped splice"
; loc <- getSrcSpanM
; n' <- newLocalBndrRn (L loc splice_name)
; (expr', fvs) <- rnLExpr expr
- ; return (HsUntypedSplice hasParen n' expr', fvs) }
+ ; return (HsUntypedSplice x hasParen n' expr', fvs) }
-rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
+rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)
= do { checkTH quoter "Template Haskell quasi-quote"
; loc <- getSrcSpanM
; splice_name' <- newLocalBndrRn (L loc splice_name)
@@ -391,9 +396,11 @@ rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
; when (nameIsLocalOrFrom this_mod quoter') $
checkThLocalName quoter'
- ; return (HsQuasiQuote splice_name' quoter' q_loc quote, unitFV quoter') }
+ ; return (HsQuasiQuote x splice_name' quoter' q_loc quote
+ , unitFV quoter') }
rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)
+rnSplice splice@(XSplice {}) = pprPanic "rnSplice" (ppr splice)
---------------------
rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
@@ -402,7 +409,7 @@ rnSpliceExpr splice
where
pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)
pend_expr_splice rn_splice
- = (makePending UntypedExpSplice rn_splice, HsSpliceE rn_splice)
+ = (makePending UntypedExpSplice rn_splice, HsSpliceE noExt rn_splice)
run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
run_expr_splice rn_splice
@@ -415,7 +422,7 @@ rnSpliceExpr splice
, isLocalGRE gre]
lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
- ; return (HsSpliceE rn_splice, lcl_names `plusFV` gbl_names) }
+ ; return (HsSpliceE noExt rn_splice, lcl_names `plusFV` gbl_names) }
| otherwise -- Run it here, see Note [Running splices in the Renamer]
= do { traceRn "rnSpliceExpr: untyped expression splice" empty
@@ -423,8 +430,8 @@ rnSpliceExpr splice
runRnSplice UntypedExpSplice runMetaE ppr rn_splice
; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
-- See Note [Delaying modFinalizers in untyped splices].
- ; return ( HsPar $ HsSpliceE
- . HsSpliced (ThModFinalizers mod_finalizers)
+ ; return ( HsPar noExt $ HsSpliceE noExt
+ . HsSpliced noExt (ThModFinalizers mod_finalizers)
. HsSplicedExpr <$>
lexpr3
, fvs)
@@ -521,13 +528,13 @@ References:
-}
----------------------
-rnSpliceType :: HsSplice GhcPs -> PostTc GhcRn Kind
- -> RnM (HsType GhcRn, FreeVars)
-rnSpliceType splice k
+rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
+rnSpliceType splice
= rnSpliceGen run_type_splice pend_type_splice splice
where
pend_type_splice rn_splice
- = (makePending UntypedTypeSplice rn_splice, HsSpliceTy rn_splice k)
+ = ( makePending UntypedTypeSplice rn_splice
+ , HsSpliceTy noExt rn_splice)
run_type_splice rn_splice
= do { traceRn "rnSpliceType: untyped type splice" empty
@@ -537,8 +544,8 @@ rnSpliceType splice k
; checkNoErrs $ rnLHsType doc hs_ty2 }
-- checkNoErrs: see Note [Renamer errors]
-- See Note [Delaying modFinalizers in untyped splices].
- ; return ( HsParTy $ flip HsSpliceTy k
- . HsSpliced (ThModFinalizers mod_finalizers)
+ ; return ( HsParTy noExt $ HsSpliceTy noExt
+ . HsSpliced noExt (ThModFinalizers mod_finalizers)
. HsSplicedTy <$>
hs_ty3
, fvs
@@ -594,17 +601,18 @@ rnSplicePat splice
= rnSpliceGen run_pat_splice pend_pat_splice splice
where
pend_pat_splice rn_splice
- = (makePending UntypedPatSplice rn_splice, Right (SplicePat rn_splice))
+ = (makePending UntypedPatSplice rn_splice
+ , Right (SplicePat noExt rn_splice))
run_pat_splice rn_splice
= do { traceRn "rnSplicePat: untyped pattern splice" empty
; (pat, mod_finalizers) <-
runRnSplice UntypedPatSplice runMetaP ppr rn_splice
-- See Note [Delaying modFinalizers in untyped splices].
- ; return ( Left $ ParPat $ SplicePat
- . HsSpliced (ThModFinalizers mod_finalizers)
- . HsSplicedPat <$>
- pat
+ ; return ( Left $ ParPat noExt $ (SplicePat noExt)
+ . HsSpliced noExt (ThModFinalizers mod_finalizers)
+ . HsSplicedPat <$>
+ pat
, emptyFVs
) }
-- Wrap the result of the quasi-quoter in parens so that we don't
@@ -687,6 +695,7 @@ spliceCtxt splice
HsTypedSplice {} -> text "typed splice:"
HsQuasiQuote {} -> text "quasi-quotation:"
HsSpliced {} -> text "spliced expression:"
+ XSplice {} -> text "spliced expression:"
-- | The splice data to be logged
data SpliceInfo
diff --git a/compiler/rename/RnSplice.hs-boot b/compiler/rename/RnSplice.hs-boot
index d8f0f1fc7f..7844acd2c9 100644
--- a/compiler/rename/RnSplice.hs-boot
+++ b/compiler/rename/RnSplice.hs-boot
@@ -4,11 +4,9 @@ import GhcPrelude
import HsSyn
import TcRnMonad
import NameSet
-import Kind
-rnSpliceType :: HsSplice GhcPs -> PostTc GhcRn Kind
- -> RnM (HsType GhcRn, FreeVars)
+rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn)
, FreeVars )
rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 55b9fd549f..0aada39bd4 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -163,24 +163,27 @@ rnWcBody ctxt nwc_rdrs hs_ty
rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body })
= bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' ->
do { (hs_body', fvs) <- rn_lty env hs_body
- ; return (HsForAllTy { hst_bndrs = tvs', hst_body = hs_body' }, fvs) }
+ ; return (HsForAllTy { hst_xforall = noExt, hst_bndrs = tvs'
+ , hst_body = hs_body' }, fvs) }
rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt, hst_body = hs_ty })
| Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
- , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
+ , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last
= do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
; wc' <- setSrcSpan lx $
- do { checkExtraConstraintWildCard env hs_ctxt1 wc
- ; rnAnonWildCard wc }
+ do { checkExtraConstraintWildCard env hs_ctxt1
+ ; rnAnonWildCard }
; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
- ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
+ ; return (HsQualTy { hst_xqual = noExt
+ , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
, fvs1 `plusFV` fvs2) }
| otherwise
= do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
- ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
+ ; return (HsQualTy { hst_xqual = noExt
+ , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
, fvs1 `plusFV` fvs2) }
rn_ty env hs_ty = rnHsTyKi env hs_ty
@@ -188,13 +191,12 @@ rnWcBody ctxt nwc_rdrs hs_ty
rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
-checkExtraConstraintWildCard
- :: RnTyKiEnv -> HsContext GhcPs -> HsWildCardInfo GhcPs -> RnM ()
+checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
-- Rename the extra-constraint spot in a type signature
-- (blah, _) => type
-- Check that extra-constraints are allowed at all, and
-- if so that it's an anonymous wildcard
-checkExtraConstraintWildCard env hs_ctxt wc
+checkExtraConstraintWildCard env hs_ctxt
= checkWildCard env mb_bad
where
mb_bad | not (extraConstraintWildCardsAllowed env)
@@ -214,7 +216,7 @@ checkExtraConstraintWildCard env hs_ctxt wc
| otherwise
= Nothing
- base_msg = text "Extra-constraint wildcard" <+> quotes (ppr wc)
+ base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard
<+> text "not allowed"
deriv_decl_msg
@@ -523,43 +525,44 @@ rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau })
; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
Nothing tyvars $ \ tyvars' ->
do { (tau', fvs) <- rnLHsTyKi env tau
- ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body = tau' }
+ ; return ( HsForAllTy { hst_xforall = noExt, hst_bndrs = tyvars'
+ , hst_body = tau' }
, fvs) } }
rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
= do { checkTypeInType env ty -- See Note [QualTy in kinds]
; (ctxt', fvs1) <- rnTyKiContext env lctxt
; (tau', fvs2) <- rnLHsTyKi env tau
- ; return (HsQualTy { hst_ctxt = ctxt', hst_body = tau' }
+ ; return (HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
+ , hst_body = tau' }
, fvs1 `plusFV` fvs2) }
-rnHsTyKi env (HsTyVar ip (L loc rdr_name))
+rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))
= do { name <- rnTyVar env rdr_name
- ; return (HsTyVar ip (L loc name), unitFV name) }
+ ; return (HsTyVar noExt ip (L loc name), unitFV name) }
-rnHsTyKi env ty@(HsOpTy ty1 l_op ty2)
+rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)
= setSrcSpan (getLoc l_op) $
do { (l_op', fvs1) <- rnHsTyOp env ty l_op
; fix <- lookupTyFixityRn l_op'
; (ty1', fvs2) <- rnLHsTyKi env ty1
; (ty2', fvs3) <- rnLHsTyKi env ty2
- ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2)
+ ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 l_op' t2)
(unLoc l_op') fix ty1' ty2'
; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
-rnHsTyKi env (HsParTy ty)
+rnHsTyKi env (HsParTy _ ty)
= do { (ty', fvs) <- rnLHsTyKi env ty
- ; return (HsParTy ty', fvs) }
+ ; return (HsParTy noExt ty', fvs) }
-rnHsTyKi env (HsBangTy b ty)
+rnHsTyKi env (HsBangTy _ b ty)
= do { (ty', fvs) <- rnLHsTyKi env ty
- ; return (HsBangTy b ty', fvs) }
-
-rnHsTyKi env ty@(HsRecTy flds)
+ ; return (HsBangTy noExt b ty', fvs) }
+rnHsTyKi env ty@(HsRecTy _ flds)
= do { let ctxt = rtke_ctxt env
; fls <- get_fields ctxt
; (flds', fvs) <- rnConDeclFields ctxt fls flds
- ; return (HsRecTy flds', fvs) }
+ ; return (HsRecTy noExt flds', fvs) }
where
get_fields (ConDeclCtx names)
= concatMapM (lookupConstructorFields . unLoc) names
@@ -568,7 +571,7 @@ rnHsTyKi env ty@(HsRecTy flds)
2 (ppr ty))
; return [] }
-rnHsTyKi env (HsFunTy ty1 ty2)
+rnHsTyKi env (HsFunTy _ ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
-- Might find a for-all as the arg of a function type
; (ty2', fvs2) <- rnLHsTyKi env ty2
@@ -576,58 +579,58 @@ rnHsTyKi env (HsFunTy ty1 ty2)
-- when we find return :: forall m. Monad m -> forall a. a -> m a
-- Check for fixity rearrangements
- ; res_ty <- mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
+ ; res_ty <- mkHsOpTyRn (HsFunTy noExt) funTyConName funTyFixity ty1' ty2'
; return (res_ty, fvs1 `plusFV` fvs2) }
-rnHsTyKi env listTy@(HsListTy ty)
+rnHsTyKi env listTy@(HsListTy _ ty)
= do { data_kinds <- xoptM LangExt.DataKinds
; when (not data_kinds && isRnKindLevel env)
(addErr (dataKindsErr env listTy))
; (ty', fvs) <- rnLHsTyKi env ty
- ; return (HsListTy ty', fvs) }
+ ; return (HsListTy noExt ty', fvs) }
-rnHsTyKi env t@(HsKindSig ty k)
+rnHsTyKi env t@(HsKindSig _ ty k)
= do { checkTypeInType env t
; kind_sigs_ok <- xoptM LangExt.KindSignatures
; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
; (ty', fvs1) <- rnLHsTyKi env ty
; (k', fvs2) <- rnLHsTyKi (env { rtke_level = KindLevel }) k
- ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
+ ; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) }
-rnHsTyKi env t@(HsPArrTy ty)
+rnHsTyKi env t@(HsPArrTy _ ty)
= do { notInKinds env t
; (ty', fvs) <- rnLHsTyKi env ty
- ; return (HsPArrTy ty', fvs) }
+ ; return (HsPArrTy noExt ty', fvs) }
-- Unboxed tuples are allowed to have poly-typed arguments. These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsTyKi env tupleTy@(HsTupleTy tup_con tys)
+rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys)
= do { data_kinds <- xoptM LangExt.DataKinds
; when (not data_kinds && isRnKindLevel env)
(addErr (dataKindsErr env tupleTy))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
- ; return (HsTupleTy tup_con tys', fvs) }
+ ; return (HsTupleTy noExt tup_con tys', fvs) }
-rnHsTyKi env sumTy@(HsSumTy tys)
+rnHsTyKi env sumTy@(HsSumTy _ tys)
= do { data_kinds <- xoptM LangExt.DataKinds
; when (not data_kinds && isRnKindLevel env)
(addErr (dataKindsErr env sumTy))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
- ; return (HsSumTy tys', fvs) }
+ ; return (HsSumTy noExt tys', fvs) }
-- Ensure that a type-level integer is nonnegative (#8306, #8412)
-rnHsTyKi env tyLit@(HsTyLit t)
+rnHsTyKi env tyLit@(HsTyLit _ t)
= do { data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env tyLit))
; when (negLit t) (addErr negLitErr)
; checkTypeInType env tyLit
- ; return (HsTyLit t, emptyFVs) }
+ ; return (HsTyLit noExt t, emptyFVs) }
where
negLit (HsStrTy _ _) = False
negLit (HsNumTy _ i) = i < 0
negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
-rnHsTyKi env overall_ty@(HsAppsTy tys)
+rnHsTyKi env overall_ty@(HsAppsTy _ tys)
= do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions
let (non_syms, syms) = splitHsAppsTy tys
@@ -655,7 +658,7 @@ rnHsTyKi env overall_ty@(HsAppsTy tys)
(non_syms1 : non_syms2 : non_syms) (L loc star : ops)
| star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey
= deal_with_star acc1 acc2
- ((non_syms1 ++ L loc (HsTyVar NotPromoted (L loc star))
+ ((non_syms1 ++ L loc (HsTyVar noExt NotPromoted (L loc star))
: non_syms2) : non_syms)
ops
deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops)
@@ -676,60 +679,60 @@ rnHsTyKi env overall_ty@(HsAppsTy tys)
build_res_ty (arg1 : args) (op1 : ops)
= do { rhs <- build_res_ty args ops
; fix <- lookupTyFixityRn op1
- ; res <-
- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 op1 t2) (unLoc op1) fix arg1 rhs
+ ; res <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 op1 t2) (unLoc op1)
+ fix arg1 rhs
; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs)
; return (L loc res)
}
build_res_ty [arg] [] = return arg
build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty)
-rnHsTyKi env (HsAppTy ty1 ty2)
+rnHsTyKi env (HsAppTy _ ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
- ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }
+ ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }
-rnHsTyKi env t@(HsIParamTy n ty)
+rnHsTyKi env t@(HsIParamTy _ n ty)
= do { notInKinds env t
; (ty', fvs) <- rnLHsTyKi env ty
- ; return (HsIParamTy n ty', fvs) }
+ ; return (HsIParamTy noExt n ty', fvs) }
-rnHsTyKi env t@(HsEqTy ty1 ty2)
+rnHsTyKi env t@(HsEqTy _ ty1 ty2)
= do { checkTypeInType env t
; (ty1', fvs1) <- rnLHsTyKi env ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
- ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
+ ; return (HsEqTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }
-rnHsTyKi _ (HsSpliceTy sp k)
- = rnSpliceType sp k
+rnHsTyKi _ (HsSpliceTy _ sp)
+ = rnSpliceType sp
-rnHsTyKi env (HsDocTy ty haddock_doc)
+rnHsTyKi env (HsDocTy _ ty haddock_doc)
= do { (ty', fvs) <- rnLHsTyKi env ty
; haddock_doc' <- rnLHsDoc haddock_doc
- ; return (HsDocTy ty' haddock_doc', fvs) }
+ ; return (HsDocTy noExt ty' haddock_doc', fvs) }
-rnHsTyKi _ (HsCoreTy ty)
- = return (HsCoreTy ty, emptyFVs)
+rnHsTyKi _ (XHsType (NHsCoreTy ty))
+ = return (XHsType (NHsCoreTy ty), emptyFVs)
-- The emptyFVs probably isn't quite right
-- but I don't think it matters
-rnHsTyKi env ty@(HsExplicitListTy ip k tys)
+rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
= do { checkTypeInType env ty
; data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env ty))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
- ; return (HsExplicitListTy ip k tys', fvs) }
+ ; return (HsExplicitListTy noExt ip tys', fvs) }
-rnHsTyKi env ty@(HsExplicitTupleTy kis tys)
+rnHsTyKi env ty@(HsExplicitTupleTy _ tys)
= do { checkTypeInType env ty
; data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env ty))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
- ; return (HsExplicitTupleTy kis tys', fvs) }
+ ; return (HsExplicitTupleTy noExt tys', fvs) }
-rnHsTyKi env (HsWildCardTy wc)
- = do { checkAnonWildCard env wc
- ; wc' <- rnAnonWildCard wc
+rnHsTyKi env (HsWildCardTy _)
+ = do { checkAnonWildCard env
+ ; wc' <- rnAnonWildCard
; return (HsWildCardTy wc', emptyFVs) }
-- emptyFVs: this occurrence does not refer to a
-- user-written binding site, so don't treat
@@ -776,21 +779,22 @@ checkWildCard env (Just doc)
checkWildCard _ Nothing
= return ()
-checkAnonWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs -> RnM ()
+checkAnonWildCard :: RnTyKiEnv -> RnM ()
-- Report an error if an anonymous wildcard is illegal here
-checkAnonWildCard env wc
+checkAnonWildCard env
= checkWildCard env mb_bad
where
mb_bad :: Maybe SDoc
mb_bad | not (wildCardsAllowed env)
- = Just (notAllowed (ppr wc))
+ = Just (notAllowed pprAnonWildCard)
| otherwise
= case rtke_what env of
RnTypeBody -> Nothing
RnConstraint -> Just constraint_msg
RnTopConstraint -> Just constraint_msg
- constraint_msg = hang (notAllowed (ppr wc) <+> text "in a constraint")
+ constraint_msg = hang
+ (notAllowed pprAnonWildCard <+> text "in a constraint")
2 hint_msg
hint_msg = vcat [ text "except as the last top-level constraint of a type signature"
, nest 2 (text "e.g f :: (Eq a, _) => blah") ]
@@ -826,8 +830,8 @@ wildCardsAllowed env
HsTypeCtx {} -> True
_ -> False
-rnAnonWildCard :: HsWildCardInfo GhcPs -> RnM (HsWildCardInfo GhcRn)
-rnAnonWildCard (AnonWildCard _)
+rnAnonWildCard :: RnM (HsWildCardInfo GhcRn)
+rnAnonWildCard
= do { loc <- getSrcSpanM
; uniq <- newUnique
; let name = mkInternalName uniq (mkTyVarOcc "_") loc
@@ -1069,20 +1073,23 @@ bindLHsTyVarBndr :: HsDocContext
-> LHsTyVarBndr GhcPs
-> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
-bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar lrdr@(L lv _))) thing_inside
+bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar x lrdr@(L lv _))) thing_inside
= do { nm <- newTyVarNameRn mb_assoc lrdr
; bindLocalNamesFV [nm] $
- thing_inside (L loc (UserTyVar (L lv nm))) }
+ thing_inside (L loc (UserTyVar x (L lv nm))) }
-bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar lrdr@(L lv _) kind)) thing_inside
+bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind))
+ thing_inside
= do { sig_ok <- xoptM LangExt.KindSignatures
; unless sig_ok (badKindSigErr doc kind)
; (kind', fvs1) <- rnLHsKind doc kind
; tv_nm <- newTyVarNameRn mb_assoc lrdr
; (b, fvs2) <- bindLocalNamesFV [tv_nm] $
- thing_inside (L loc (KindedTyVar (L lv tv_nm) kind'))
+ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind'))
; return (b, fvs1 `plusFV` fvs2) }
+bindLHsTyVarBndr _ _ (L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr"
+
newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
newTyVarNameRn mb_assoc (L loc rdr)
= do { rdr_env <- getLocalRdrEnv
@@ -1099,44 +1106,46 @@ collectAnonWildCards lty = go lty
where
go (L _ ty) = case ty of
HsWildCardTy (AnonWildCard (L _ wc)) -> [wc]
- HsAppsTy tys -> gos (mapMaybe (prefix_types_only . unLoc) tys)
- HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2
- HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2
- HsListTy ty -> go ty
- HsPArrTy ty -> go ty
- HsTupleTy _ tys -> gos tys
- HsSumTy tys -> gos tys
- HsOpTy ty1 _ ty2 -> go ty1 `mappend` go ty2
- HsParTy ty -> go ty
- HsIParamTy _ ty -> go ty
- HsEqTy ty1 ty2 -> go ty1 `mappend` go ty2
- HsKindSig ty kind -> go ty `mappend` go kind
- HsDocTy ty _ -> go ty
- HsBangTy _ ty -> go ty
- HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds
- HsExplicitListTy _ _ tys -> gos tys
- HsExplicitTupleTy _ tys -> gos tys
+ HsAppsTy _ tys -> gos (mapMaybe (prefix_types_only . unLoc) tys)
+ HsAppTy _ ty1 ty2 -> go ty1 `mappend` go ty2
+ HsFunTy _ ty1 ty2 -> go ty1 `mappend` go ty2
+ HsListTy _ ty -> go ty
+ HsPArrTy _ ty -> go ty
+ HsTupleTy _ _ tys -> gos tys
+ HsSumTy _ tys -> gos tys
+ HsOpTy _ ty1 _ ty2 -> go ty1 `mappend` go ty2
+ HsParTy _ ty -> go ty
+ HsIParamTy _ _ ty -> go ty
+ HsEqTy _ ty1 ty2 -> go ty1 `mappend` go ty2
+ HsKindSig _ ty kind -> go ty `mappend` go kind
+ HsDocTy _ ty _ -> go ty
+ HsBangTy _ _ ty -> go ty
+ HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds
+ HsExplicitListTy _ _ tys -> gos tys
+ HsExplicitTupleTy _ tys -> gos tys
HsForAllTy { hst_bndrs = bndrs
, hst_body = ty } -> collectAnonWildCardsBndrs bndrs
`mappend` go ty
HsQualTy { hst_ctxt = L _ ctxt
, hst_body = ty } -> gos ctxt `mappend` go ty
- HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _ -> go $ L noSrcSpan ty
+ HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty
HsSpliceTy{} -> mempty
- HsCoreTy{} -> mempty
HsTyLit{} -> mempty
HsTyVar{} -> mempty
+ XHsType{} -> mempty
gos = mconcat . map go
- prefix_types_only (HsAppPrefix ty) = Just ty
- prefix_types_only (HsAppInfix _) = Nothing
+ prefix_types_only (HsAppPrefix _ ty) = Just ty
+ prefix_types_only (HsAppInfix _ _) = Nothing
+ prefix_types_only (XAppType _) = Nothing
collectAnonWildCardsBndrs :: [LHsTyVarBndr GhcRn] -> [Name]
collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs
where
- go (UserTyVar _) = []
- go (KindedTyVar _ ki) = collectAnonWildCards ki
+ go (UserTyVar _ _) = []
+ go (KindedTyVar _ _ ki) = collectAnonWildCards ki
+ go (XTyVarBndr{}) = []
{-
*********************************************************
@@ -1171,10 +1180,11 @@ rnField fl_env env (L l (ConDeclField names ty haddock_doc))
; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
where
lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
- lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl)
+ lookupField (FieldOcc _ (L lr rdr)) = FieldOcc (flSelector fl) (L lr rdr)
where
lbl = occNameFS $ rdrNameOcc rdr
fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
+ lookupField (XFieldOcc{}) = panic "rnField"
{-
************************************************************************
@@ -1208,15 +1218,15 @@ mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
-> RnM (HsType GhcRn)
-mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExt ty21 op2 ty22))
= do { fix2 <- lookupTyFixityRn op2
; mk_hs_op_ty mk1 pp_op1 fix1 ty1
- (\t1 t2 -> HsOpTy t1 op2 t2)
+ (\t1 t2 -> HsOpTy noExt t1 op2 t2)
(unLoc op2) fix2 ty21 ty22 loc2 }
-mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22))
= mk_hs_op_ty mk1 pp_op1 fix1 ty1
- HsFunTy funTyConName funTyFixity ty21 ty22 loc2
+ (HsFunTy noExt) funTyConName funTyFixity ty21 ty22 loc2
mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
= return (mk1 ty1 ty2)
@@ -1247,38 +1257,38 @@ mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged
-> RnM (HsExpr GhcRn)
-- (e11 `op1` e12) `op2` e2
-mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
+mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
- return (OpApp e1 op2 fix2 e2)
+ return (OpApp fix2 e1 op2 e2)
| associate_right = do
new_e <- mkOpAppRn e12 op2 fix2 e2
- return (OpApp e11 op1 fix1 (L loc' new_e))
+ return (OpApp fix1 e11 op1 (L loc' new_e))
where
loc'= combineLocs e12 e2
(nofix_error, associate_right) = compareFixity fix1 fix2
---------------------------
-- (- neg_arg) `op` e2
-mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
+mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2
| nofix_error
= do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)
- return (OpApp e1 op2 fix2 e2)
+ return (OpApp fix2 e1 op2 e2)
| associate_right
= do new_e <- mkOpAppRn neg_arg op2 fix2 e2
- return (NegApp (L loc' new_e) neg_name)
+ return (NegApp noExt (L loc' new_e) neg_name)
where
loc' = combineLocs neg_arg e2
(nofix_error, associate_right) = compareFixity negateFixity fix2
---------------------------
-- e1 `op` - neg_arg
-mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
+mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right
| not associate_right -- We *want* right association
= do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)
- return (OpApp e1 op1 fix1 e2)
+ return (OpApp fix1 e1 op1 e2)
where
(_, associate_right) = compareFixity fix1 negateFixity
@@ -1288,7 +1298,7 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
= ASSERT2( right_op_ok fix (unLoc e2),
ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
)
- return (OpApp e1 op fix e2)
+ return (OpApp fix e1 op e2)
----------------------------
@@ -1308,16 +1318,16 @@ instance Outputable OpName where
get_op :: LHsExpr GhcRn -> OpName
-- An unbound name could be either HsVar or HsUnboundVar
-- See RnExpr.rnUnboundVar
-get_op (L _ (HsVar (L _ n))) = NormalOp n
-get_op (L _ (HsUnboundVar uv)) = UnboundOp uv
-get_op (L _ (HsRecFld fld)) = RecFldOp fld
-get_op other = pprPanic "get_op" (ppr other)
+get_op (L _ (HsVar _ (L _ n))) = NormalOp n
+get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv
+get_op (L _ (HsRecFld _ fld)) = RecFldOp fld
+get_op other = pprPanic "get_op" (ppr other)
-- Parser left-associates everything, but
-- derived instances may have correctly-associated things to
-- in the right operand. So we just check that the right operand is OK
right_op_ok :: Fixity -> HsExpr GhcRn -> Bool
-right_op_ok fix1 (OpApp _ _ fix2 _)
+right_op_ok fix1 (OpApp fix2 _ _ _)
= not error_please && associate_right
where
(error_please, associate_right) = compareFixity fix1 fix2
@@ -1326,14 +1336,15 @@ right_op_ok _ _
-- Parser initially makes negation bind more tightly than any other operator
-- And "deriving" code should respect this (use HsPar if not)
-mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
+mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)
+ -> RnM (HsExpr (GhcPass id))
mkNegAppRn neg_arg neg_name
= ASSERT( not_op_app (unLoc neg_arg) )
- return (NegApp neg_arg neg_name)
+ return (NegApp noExt neg_arg neg_name)
not_op_app :: HsExpr id -> Bool
-not_op_app (OpApp _ _ _ _) = False
-not_op_app _ = True
+not_op_app (OpApp {}) = False
+not_op_app _ = True
---------------------------
mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged
@@ -1342,25 +1353,24 @@ mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged
-> RnM (HsCmd GhcRn)
-- (e11 `op1` e12) `op2` e2
-mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1)
- [a11,a12])) _ _ _))
+mkOpFormRn a1@(L loc (HsCmdTop _ (L _ (HsCmdArrForm x op1 f (Just fix1)
+ [a11,a12]))))
op2 fix2 a2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
- return (HsCmdArrForm op2 f (Just fix2) [a1, a2])
+ return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])
| associate_right
= do new_c <- mkOpFormRn a12 op2 fix2 a2
- return (HsCmdArrForm op1 f (Just fix1)
- [a11, L loc (HsCmdTop (L loc new_c)
- placeHolderType placeHolderType [])])
+ return (HsCmdArrForm noExt op1 f (Just fix1)
+ [a11, L loc (HsCmdTop [] (L loc new_c))])
-- TODO: locs are wrong
where
(nofix_error, associate_right) = compareFixity fix1 fix2
-- Default case
mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
- = return (HsCmdArrForm op Infix (Just fix) [arg1, arg2])
+ = return (HsCmdArrForm noExt op Infix (Just fix) [arg1, arg2])
--------------------------------------
@@ -1438,8 +1448,8 @@ checkSectionPrec :: FixityDirection -> HsExpr GhcPs
-> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()
checkSectionPrec direction section op arg
= case unLoc arg of
- OpApp _ op' fix _ -> go_for_it (get_op op') fix
- NegApp _ _ -> go_for_it NegateOp negateFixity
+ OpApp fix _ op' _ -> go_for_it (get_op op') fix
+ NegApp _ _ _ -> go_for_it NegateOp negateFixity
_ -> return ()
where
op_name = get_op op
@@ -1725,7 +1735,7 @@ 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
+ | TyVarSig (L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k
| otherwise = return []
where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k
@@ -1785,43 +1795,43 @@ extract_lty :: TypeOrKind -> LHsType GhcPs
-> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
extract_lty t_or_k (L _ ty) acc
= case ty of
- HsTyVar _ ltv -> extract_tv t_or_k ltv acc
- HsBangTy _ ty -> extract_lty t_or_k ty acc
- HsRecTy flds -> foldrM (extract_lty t_or_k
- . cd_fld_type . unLoc) acc
- flds
- HsAppsTy tys -> extract_apps t_or_k tys acc
- HsAppTy ty1 ty2 -> extract_lty t_or_k ty1 =<<
- extract_lty t_or_k ty2 acc
- HsListTy ty -> extract_lty t_or_k ty acc
- HsPArrTy ty -> extract_lty t_or_k ty acc
- HsTupleTy _ tys -> extract_ltys t_or_k tys acc
- HsSumTy tys -> extract_ltys t_or_k tys acc
- HsFunTy ty1 ty2 -> extract_lty t_or_k ty1 =<<
- extract_lty t_or_k ty2 acc
- HsIParamTy _ ty -> extract_lty t_or_k ty acc
- HsEqTy ty1 ty2 -> extract_lty t_or_k ty1 =<<
- extract_lty t_or_k ty2 acc
- HsOpTy ty1 tv ty2 -> extract_tv t_or_k tv =<<
- extract_lty t_or_k ty1 =<<
- extract_lty t_or_k ty2 acc
- HsParTy ty -> extract_lty t_or_k ty acc
- HsCoreTy {} -> return acc -- The type is closed
- HsSpliceTy {} -> return acc -- Type splices mention no tvs
- HsDocTy ty _ -> extract_lty t_or_k ty acc
- HsExplicitListTy _ _ tys -> extract_ltys t_or_k tys acc
- HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc
- HsTyLit _ -> return acc
- HsKindSig ty ki -> extract_lty t_or_k ty =<<
- extract_lkind ki acc
+ HsTyVar _ _ ltv -> extract_tv t_or_k ltv acc
+ HsBangTy _ _ ty -> extract_lty t_or_k ty acc
+ HsRecTy _ flds -> foldrM (extract_lty t_or_k
+ . cd_fld_type . unLoc) acc
+ flds
+ HsAppsTy _ tys -> extract_apps t_or_k tys acc
+ HsAppTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<<
+ extract_lty t_or_k ty2 acc
+ HsListTy _ ty -> extract_lty t_or_k ty acc
+ HsPArrTy _ ty -> extract_lty t_or_k ty acc
+ HsTupleTy _ _ tys -> extract_ltys t_or_k tys acc
+ HsSumTy _ tys -> extract_ltys t_or_k tys acc
+ HsFunTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<<
+ extract_lty t_or_k ty2 acc
+ HsIParamTy _ _ ty -> extract_lty t_or_k ty acc
+ HsEqTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<<
+ extract_lty t_or_k ty2 acc
+ HsOpTy _ ty1 tv ty2 -> extract_tv t_or_k tv =<<
+ extract_lty t_or_k ty1 =<<
+ extract_lty t_or_k ty2 acc
+ HsParTy _ ty -> extract_lty t_or_k ty acc
+ HsSpliceTy {} -> return acc -- Type splices mention no tvs
+ HsDocTy _ ty _ -> extract_lty t_or_k ty acc
+ HsExplicitListTy _ _ tys -> extract_ltys t_or_k tys acc
+ HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc
+ HsTyLit _ _ -> return acc
+ HsKindSig _ ty ki -> extract_lty t_or_k ty =<<
+ extract_lkind ki acc
HsForAllTy { hst_bndrs = tvs, hst_body = ty }
- -> extract_hs_tv_bndrs tvs acc =<<
- extract_lty t_or_k ty emptyFKTV
+ -> extract_hs_tv_bndrs tvs acc =<<
+ extract_lty t_or_k ty emptyFKTV
HsQualTy { hst_ctxt = ctxt, hst_body = ty }
- -> extract_lctxt t_or_k ctxt =<<
- extract_lty t_or_k ty acc
+ -> extract_lctxt t_or_k ctxt =<<
+ extract_lty t_or_k ty acc
+ XHsType {} -> return acc
-- We deal with these separately in rnLHsTypeWithWildCards
- HsWildCardTy {} -> return acc
+ HsWildCardTy {} -> return acc
extract_apps :: TypeOrKind
-> [LHsAppType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
@@ -1829,8 +1839,9 @@ extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
extract_app :: TypeOrKind -> LHsAppType GhcPs
-> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
-extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k tv acc
-extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc
+extract_app t_or_k (L _ (HsAppInfix _ tv)) acc = extract_tv t_or_k tv acc
+extract_app t_or_k (L _ (HsAppPrefix _ ty)) acc = extract_lty t_or_k ty acc
+extract_app _ (L _ (XAppType _ )) _ = panic "extract_app"
extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
-> FreeKiTyVarsWithDups -- Free in body
@@ -1878,7 +1889,7 @@ extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> RnM [Located RdrName]
-- the function returns [k1,k2], even though k1 is bound here
extract_hs_tv_bndrs_kvs tv_bndrs
= do { fktvs <- foldrM extract_lkind emptyFKTV
- [k | L _ (KindedTyVar _ k) <- tv_bndrs]
+ [k | L _ (KindedTyVar _ _ k) <- tv_bndrs]
; return (freeKiTyVarsKindVars fktvs) }
-- There will /be/ no free tyvars!
View Lorry Controller Status