summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/deSugar/Check.hs61
-rw-r--r--compiler/deSugar/Coverage.hs218
-rw-r--r--compiler/deSugar/DsArrows.hs80
-rw-r--r--compiler/deSugar/DsExpr.hs122
-rw-r--r--compiler/deSugar/DsGRHSs.hs15
-rw-r--r--compiler/deSugar/DsListComp.hs20
-rw-r--r--compiler/deSugar/DsMeta.hs194
-rw-r--r--compiler/deSugar/DsUtils.hs63
-rw-r--r--compiler/deSugar/Match.hs107
-rw-r--r--compiler/deSugar/MatchLit.hs35
-rw-r--r--compiler/deSugar/PmExpr.hs39
-rw-r--r--compiler/hsSyn/Convert.hs256
-rw-r--r--compiler/hsSyn/HsBinds.hs133
-rw-r--r--compiler/hsSyn/HsDecls.hs206
-rw-r--r--compiler/hsSyn/HsExpr.hs941
-rw-r--r--compiler/hsSyn/HsExpr.hs-boot48
-rw-r--r--compiler/hsSyn/HsExtension.hs559
-rw-r--r--compiler/hsSyn/HsLit.hs71
-rw-r--r--compiler/hsSyn/HsPat.hs290
-rw-r--r--compiler/hsSyn/HsPat.hs-boot8
-rw-r--r--compiler/hsSyn/HsSyn.hs7
-rw-r--r--compiler/hsSyn/HsTypes.hs490
-rw-r--r--compiler/hsSyn/HsUtils.hs439
-rw-r--r--compiler/hsSyn/PlaceHolder.hs21
-rw-r--r--compiler/main/HscStats.hs2
-rw-r--r--compiler/main/InteractiveEval.hs5
-rw-r--r--compiler/parser/Parser.y256
-rw-r--r--compiler/parser/RdrHsSyn.hs250
-rw-r--r--compiler/rename/RnBinds.hs14
-rw-r--r--compiler/rename/RnEnv.hs4
-rw-r--r--compiler/rename/RnExpr.hs325
-rw-r--r--compiler/rename/RnFixity.hs5
-rw-r--r--compiler/rename/RnNames.hs20
-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
-rw-r--r--compiler/typecheck/Inst.hs22
-rw-r--r--compiler/typecheck/TcAnnotations.hs3
-rw-r--r--compiler/typecheck/TcArrows.hs53
-rw-r--r--compiler/typecheck/TcBinds.hs19
-rw-r--r--compiler/typecheck/TcDeriv.hs2
-rw-r--r--compiler/typecheck/TcEnv.hs6
-rw-r--r--compiler/typecheck/TcExpr.hs243
-rw-r--r--compiler/typecheck/TcGenDeriv.hs25
-rw-r--r--compiler/typecheck/TcGenFunctor.hs1
-rw-r--r--compiler/typecheck/TcHsSyn.hs335
-rw-r--r--compiler/typecheck/TcHsType.hs79
-rw-r--r--compiler/typecheck/TcInstDcls.hs17
-rw-r--r--compiler/typecheck/TcMatches.hs30
-rw-r--r--compiler/typecheck/TcPat.hs81
-rw-r--r--compiler/typecheck/TcPatSyn.hs160
-rw-r--r--compiler/typecheck/TcRnDriver.hs39
-rw-r--r--compiler/typecheck/TcRnTypes.hs91
-rw-r--r--compiler/typecheck/TcSplice.hs29
-rw-r--r--compiler/typecheck/TcTyClsDecls.hs12
-rw-r--r--compiler/typecheck/TcTyDecls.hs15
-rw-r--r--ghc/GHCi/UI.hs4
-rw-r--r--ghc/GHCi/UI/Info.hs12
-rw-r--r--testsuite/tests/ghc-api/annotations/parseTree.hs6
-rw-r--r--testsuite/tests/ghc-api/annotations/stringSource.hs6
-rw-r--r--testsuite/tests/ghc-api/annotations/t11430.hs2
-rw-r--r--testsuite/tests/parser/should_compile/DumpParsedAst.stderr36
-rw-r--r--testsuite/tests/parser/should_compile/DumpRenamedAst.stderr142
-rw-r--r--testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr73
-rw-r--r--testsuite/tests/parser/should_compile/T14189.stderr13
-rw-r--r--testsuite/tests/perf/haddock/all.T5
-rw-r--r--testsuite/tests/quasiquotation/T7918.hs6
-rw-r--r--utils/ghctags/Main.hs25
m---------utils/haddock0
71 files changed, 4398 insertions, 3070 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index d49a5c3ab8..ae1de7716d 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -675,12 +675,12 @@ truePattern = nullaryConPattern (RealDataCon trueDataCon)
-- | A fake guard pattern (True <- _) used to represent cases we cannot handle
fake_pat :: Pattern
fake_pat = PmGrd { pm_grd_pv = [truePattern]
- , pm_grd_expr = PmExprOther EWildPat }
+ , pm_grd_expr = PmExprOther (EWildPat noExt) }
{-# INLINE fake_pat #-}
-- | Check whether a guard pattern is generated by the checker (unhandled)
isFakeGuard :: [Pattern] -> PmExpr -> Bool
-isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat)
+isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _))
| c == trueDataCon = True
| otherwise = False
isFakeGuard _pats _e = False
@@ -723,25 +723,25 @@ mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }
translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec
translatePat fam_insts pat = case pat of
- WildPat ty -> mkPmVars [ty]
- VarPat id -> return [PmVar (unLoc id)]
- ParPat p -> translatePat fam_insts (unLoc p)
- LazyPat _ -> mkPmVars [hsPatType pat] -- like a variable
+ WildPat ty -> mkPmVars [ty]
+ VarPat _ id -> return [PmVar (unLoc id)]
+ ParPat _ p -> translatePat fam_insts (unLoc p)
+ LazyPat _ _ -> mkPmVars [hsPatType pat] -- like a variable
-- ignore strictness annotations for now
- BangPat p -> translatePat fam_insts (unLoc p)
+ BangPat _ p -> translatePat fam_insts (unLoc p)
- AsPat lid p -> do
+ AsPat _ lid p -> do
-- Note [Translating As Patterns]
ps <- translatePat fam_insts (unLoc p)
let [e] = map vaToPmExpr (coercePatVec ps)
g = PmGrd [PmVar (unLoc lid)] e
return (ps ++ [g])
- SigPatOut p _ty -> translatePat fam_insts (unLoc p)
+ SigPat _ty p -> translatePat fam_insts (unLoc p)
-- See Note [Translate CoPats]
- CoPat wrapper p ty
+ CoPat _ wrapper p ty
| isIdHsWrapper wrapper -> translatePat fam_insts p
| WpCast co <- wrapper, isReflexiveCo co -> translatePat fam_insts p
| otherwise -> do
@@ -751,26 +751,26 @@ translatePat fam_insts pat = case pat of
return [xp,g]
-- (n + k) ===> x (True <- x >= k) (n <- x-k)
- NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty
+ NPlusKPat ty (L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
-- (fun -> pat) ===> x (pat <- fun x)
- ViewPat lexpr lpat arg_ty -> do
+ ViewPat arg_ty lexpr lpat -> do
ps <- translatePat fam_insts (unLoc lpat)
-- See Note [Guards and Approximation]
case all cantFailPattern ps of
True -> do
(xp,xe) <- mkPmId2Forms arg_ty
- let g = mkGuard ps (HsApp lexpr xe)
+ let g = mkGuard ps (HsApp noExt lexpr xe)
return [xp,g]
False -> mkCanFailPmPat arg_ty
-- list
- ListPat ps ty Nothing -> do
+ ListPat _ ps ty Nothing -> do
foldr (mkListPatVec ty) [nilPattern ty]
<$> translatePatVec fam_insts (map unLoc ps)
-- overloaded list
- ListPat lpats elem_ty (Just (pat_ty, _to_list))
+ ListPat x lpats elem_ty (Just (pat_ty, _to_list))
| Just e_ty <- splitListTyConApp_maybe pat_ty
, (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty
-- elem_ty is frequently something like
@@ -779,7 +779,7 @@ translatePat fam_insts pat = case pat of
-- We have to ensure that the element types are exactly the same.
-- Otherwise, one may give an instance IsList [Int] (more specific than
-- the default IsList [a]) with a different implementation for `toList'
- translatePat fam_insts (ListPat lpats e_ty Nothing)
+ translatePat fam_insts (ListPat x lpats e_ty Nothing)
-- See Note [Guards and Approximation]
| otherwise -> mkCanFailPmPat pat_ty
@@ -799,26 +799,27 @@ translatePat fam_insts pat = case pat of
, pm_con_dicts = dicts
, pm_con_args = args }]
- NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty
+ NPat ty (L _ ol) mb_neg _eq -> translateNPat fam_insts ol mb_neg ty
- LitPat lit
+ LitPat _ lit
-- If it is a string then convert it to a list of characters
| HsString src s <- lit ->
foldr (mkListPatVec charTy) [nilPattern charTy] <$>
- translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s))
+ translatePatVec fam_insts
+ (map (LitPat noExt . HsChar src) (unpackFS s))
| otherwise -> return [mkLitPattern lit]
- PArrPat ps ty -> do
+ PArrPat ty ps -> do
tidy_ps <- translatePatVec fam_insts (map unLoc ps)
let fake_con = RealDataCon (parrFakeCon (length ps))
return [vanillaConPattern fake_con [ty] (concat tidy_ps)]
- TuplePat ps boxity tys -> do
+ TuplePat tys ps boxity -> do
tidy_ps <- translatePatVec fam_insts (map unLoc ps)
let tuple_con = RealDataCon (tupleDataCon boxity (length ps))
return [vanillaConPattern tuple_con tys (concat tidy_ps)]
- SumPat p alt arity ty -> do
+ SumPat ty p alt arity -> do
tidy_p <- translatePat fam_insts (unLoc p)
let sum_con = RealDataCon (sumDataCon alt arity)
return [vanillaConPattern sum_con ty tidy_p]
@@ -827,23 +828,23 @@ translatePat fam_insts pat = case pat of
-- Not supposed to happen
ConPatIn {} -> panic "Check.translatePat: ConPatIn"
SplicePat {} -> panic "Check.translatePat: SplicePat"
- SigPatIn {} -> panic "Check.translatePat: SigPatIn"
+ XPat {} -> panic "Check.translatePat: XPat"
-- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)
translateNPat :: FamInstEnvs
-> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> Type
-> DsM PatVec
-translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty
+translateNPat fam_insts (OverLit (OverLitTc False ty) val _ ) mb_neg outer_ty
| not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
- = translatePat fam_insts (LitPat (HsString src s))
+ = translatePat fam_insts (LitPat noExt (HsString src s))
| not type_change, isIntTy ty, HsIntegral i <- val
= translatePat fam_insts
- (LitPat $ case mb_neg of
- Nothing -> HsInt def i
- Just _ -> HsInt def (negateIntegralLit i))
+ (LitPat noExt $ case mb_neg of
+ Nothing -> HsInt noExt i
+ Just _ -> HsInt noExt (negateIntegralLit i))
| not type_change, isWordTy ty, HsIntegral i <- val
= translatePat fam_insts
- (LitPat $ case mb_neg of
+ (LitPat noExt $ case mb_neg of
Nothing -> HsWordPrim (il_text i) (il_value i)
Just _ -> let ni = negateIntegralLit i in
HsWordPrim (il_text ni) (il_value ni))
@@ -1216,7 +1217,7 @@ mkPmId ty = getUniqueM >>= \unique ->
mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)
mkPmId2Forms ty = do
x <- mkPmId ty
- return (PmVar x, noLoc (HsVar (noLoc x)))
+ return (PmVar x, noLoc (HsVar noExt (noLoc x)))
-- ----------------------------------------------------------------------------
-- * Converting between Value Abstractions, Patterns and PmExpr
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 862e564aed..5bdff0fe67 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -459,15 +459,15 @@ addTickLHsExprNever (L pos e0) = do
-- general heuristic: expressions which do not denote values are good
-- break points
isGoodBreakExpr :: HsExpr GhcTc -> Bool
-isGoodBreakExpr (HsApp {}) = True
-isGoodBreakExpr (HsAppTypeOut {}) = True
-isGoodBreakExpr (OpApp {}) = True
-isGoodBreakExpr _other = False
+isGoodBreakExpr (HsApp {}) = True
+isGoodBreakExpr (HsAppType {}) = True
+isGoodBreakExpr (OpApp {}) = True
+isGoodBreakExpr _other = False
isCallSite :: HsExpr GhcTc -> Bool
-isCallSite HsApp{} = True
-isCallSite HsAppTypeOut{} = True
-isCallSite OpApp{} = True
+isCallSite HsApp{} = True
+isCallSite HsAppType{} = True
+isCallSite OpApp{} = True
isCallSite _ = False
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
@@ -489,55 +489,58 @@ addBinTickLHsExpr boxLabel (L pos e0)
-- in the addTickLHsExpr family of functions.)
addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e
-addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
-addTickHsExpr e@(HsConLikeOut con)
+addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
+addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
+addTickHsExpr e@(HsConLikeOut _ con)
| Just id <- conLikeWrapId_maybe con = do freeVar id; return e
-addTickHsExpr e@(HsIPVar _) = return e
-addTickHsExpr e@(HsOverLit _) = return e
-addTickHsExpr e@(HsOverLabel{}) = return e
-addTickHsExpr e@(HsLit _) = return e
-addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
-addTickHsExpr (HsLamCase mgs) = liftM HsLamCase (addTickMatchGroup True mgs)
-addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1)
- (addTickLHsExpr e2)
-addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)
- (return ty)
-
-addTickHsExpr (OpApp e1 e2 fix e3) =
+addTickHsExpr e@(HsIPVar {}) = return e
+addTickHsExpr e@(HsOverLit {}) = return e
+addTickHsExpr e@(HsOverLabel{}) = return e
+addTickHsExpr e@(HsLit {}) = return e
+addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)
+ (addTickMatchGroup True matchgroup)
+addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x)
+ (addTickMatchGroup True mgs)
+addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1)
+ (addTickLHsExpr e2)
+addTickHsExpr (HsAppType ty e) = liftM2 HsAppType (return ty)
+ (addTickLHsExprNever e)
+
+
+addTickHsExpr (OpApp fix e1 e2 e3) =
liftM4 OpApp
+ (return fix)
(addTickLHsExpr e1)
(addTickLHsExprNever e2)
- (return fix)
(addTickLHsExpr e3)
-addTickHsExpr (NegApp e neg) =
- liftM2 NegApp
+addTickHsExpr (NegApp x e neg) =
+ liftM2 (NegApp x)
(addTickLHsExpr e)
(addTickSyntaxExpr hpcSrcSpan neg)
-addTickHsExpr (HsPar e) =
- liftM HsPar (addTickLHsExprEvalInner e)
-addTickHsExpr (SectionL e1 e2) =
- liftM2 SectionL
+addTickHsExpr (HsPar x e) =
+ liftM (HsPar x) (addTickLHsExprEvalInner e)
+addTickHsExpr (SectionL x e1 e2) =
+ liftM2 (SectionL x)
(addTickLHsExpr e1)
(addTickLHsExprNever e2)
-addTickHsExpr (SectionR e1 e2) =
- liftM2 SectionR
+addTickHsExpr (SectionR x e1 e2) =
+ liftM2 (SectionR x)
(addTickLHsExprNever e1)
(addTickLHsExpr e2)
-addTickHsExpr (ExplicitTuple es boxity) =
- liftM2 ExplicitTuple
+addTickHsExpr (ExplicitTuple x es boxity) =
+ liftM2 (ExplicitTuple x)
(mapM addTickTupArg es)
(return boxity)
-addTickHsExpr (ExplicitSum tag arity e ty) = do
+addTickHsExpr (ExplicitSum ty tag arity e) = do
e' <- addTickLHsExpr e
- return (ExplicitSum tag arity e' ty)
-addTickHsExpr (HsCase e mgs) =
- liftM2 HsCase
+ return (ExplicitSum ty tag arity e')
+addTickHsExpr (HsCase x e mgs) =
+ liftM2 (HsCase x)
(addTickLHsExpr e) -- not an EvalInner; e might not necessarily
-- be evaluated.
(addTickMatchGroup False mgs)
-addTickHsExpr (HsIf cnd e1 e2 e3) =
- liftM3 (HsIf cnd)
+addTickHsExpr (HsIf x cnd e1 e2 e3) =
+ liftM3 (HsIf x cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsExprOptAlt True e2)
(addTickLHsExprOptAlt True e3)
@@ -545,14 +548,14 @@ addTickHsExpr (HsMultiIf ty alts)
= do { let isOneOfMany = case alts of [_] -> False; _ -> True
; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
; return $ HsMultiIf ty alts' }
-addTickHsExpr (HsLet (L l binds) e) =
+addTickHsExpr (HsLet x (L l binds) e) =
bindLocals (collectLocalBinders binds) $
- liftM2 (HsLet . L l)
+ liftM2 (HsLet x . L l)
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprLetBody e)
-addTickHsExpr (HsDo cxt (L l stmts) srcloc)
+addTickHsExpr (HsDo srcloc cxt (L l stmts))
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
- ; return (HsDo cxt (L l stmts') srcloc) }
+ ; return (HsDo srcloc cxt (L l stmts')) }
where
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
@@ -582,12 +585,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
; flds' <- mapM addTickHsRecField flds
; return (expr { rupd_expr = e', rupd_flds = flds' }) }
-addTickHsExpr (ExprWithTySig e ty) =
+addTickHsExpr (ExprWithTySig ty e) =
liftM2 ExprWithTySig
- (addTickLHsExprNever e) -- No need to tick the inner expression
- -- for expressions with signatures
(return ty)
-addTickHsExpr (ArithSeq ty wit arith_seq) =
+ (addTickLHsExprNever e) -- No need to tick the inner expression
+ -- for expressions with signatures
+addTickHsExpr (ArithSeq ty wit arith_seq) =
liftM3 ArithSeq
(return ty)
(addTickWit wit)
@@ -597,26 +600,26 @@ addTickHsExpr (ArithSeq ty wit arith_seq) =
return (Just fl')
-- We might encounter existing ticks (multiple Coverage passes)
-addTickHsExpr (HsTick t e) =
- liftM (HsTick t) (addTickLHsExprNever e)
-addTickHsExpr (HsBinTick t0 t1 e) =
- liftM (HsBinTick t0 t1) (addTickLHsExprNever e)
+addTickHsExpr (HsTick x t e) =
+ liftM (HsTick x t) (addTickLHsExprNever e)
+addTickHsExpr (HsBinTick x t0 t1 e) =
+ liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
-addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do
+addTickHsExpr (HsTickPragma _ _ _ _ (L pos e0)) = do
e2 <- allocTickBox (ExpBox False) False False pos $
addTickHsExpr e0
return $ unLoc e2
-addTickHsExpr (PArrSeq ty arith_seq) =
+addTickHsExpr (PArrSeq ty arith_seq) =
liftM2 PArrSeq
(return ty)
(addTickArithSeqInfo arith_seq)
-addTickHsExpr (HsSCC src nm e) =
- liftM3 HsSCC
+addTickHsExpr (HsSCC x src nm e) =
+ liftM3 (HsSCC x)
(return src)
(return nm)
(addTickLHsExpr e)
-addTickHsExpr (HsCoreAnn src nm e) =
- liftM3 HsCoreAnn
+addTickHsExpr (HsCoreAnn x src nm e) =
+ liftM3 (HsCoreAnn x)
(return src)
(return nm)
(addTickLHsExpr e)
@@ -624,27 +627,23 @@ addTickHsExpr e@(HsBracket {}) = return e
addTickHsExpr e@(HsTcBracketOut {}) = return e
addTickHsExpr e@(HsRnBracketOut {}) = return e
addTickHsExpr e@(HsSpliceE {}) = return e
-addTickHsExpr (HsProc pat cmdtop) =
- liftM2 HsProc
+addTickHsExpr (HsProc x pat cmdtop) =
+ liftM2 (HsProc x)
(addTickLPat pat)
(liftL (addTickHsCmdTop) cmdtop)
-addTickHsExpr (HsWrap w e) =
- liftM2 HsWrap
+addTickHsExpr (HsWrap x w e) =
+ liftM2 (HsWrap x)
(return w)
(addTickHsExpr e) -- Explicitly no tick on inside
-addTickHsExpr (ExprWithTySigOut e ty) =
- liftM2 ExprWithTySigOut
- (addTickLHsExprNever e) -- No need to tick the inner expression
- (return ty) -- for expressions with signatures
-
-- Others should never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
-addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e
- ; return (L l (Present e')) }
+addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e
+ ; return (L l (Present x e')) }
addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
+addTickTupArg (L _ (XTupArg _)) = panic "addTickTupArg"
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
@@ -762,8 +761,8 @@ addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprRHS e
addTickApplicativeArg
- :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
- -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
+ :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
+ -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
addTickApplicativeArg isGuard (op, arg) =
liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
where
@@ -780,11 +779,12 @@ addTickApplicativeArg isGuard (op, arg) =
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
-> TM (ParStmtBlock GhcTc GhcTc)
-addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
- liftM3 ParStmtBlock
+addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
+ liftM3 (ParStmtBlock x)
(addTickLStmts isGuard stmts)
(return ids)
(addTickSyntaxExpr hpcSrcSpan returnExpr)
+addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"
addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds (HsValBinds binds) =
@@ -795,15 +795,17 @@ addTickHsLocalBinds (HsIPBinds binds) =
(addTickHsIPBinds binds)
addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds
-addTickHsValBinds :: HsValBindsLR GhcTc a -> TM (HsValBindsLR GhcTc b)
-addTickHsValBinds (ValBindsOut binds sigs) =
- liftM2 ValBindsOut
+addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
+ -> TM (HsValBindsLR GhcTc (GhcPass b))
+addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
+ b <- liftM2 NValBinds
(mapM (\ (rec,binds') ->
liftM2 (,)
(return rec)
(addTickLHsBinds binds'))
binds)
(return sigs)
+ return $ XValBindsLR b
addTickHsValBinds _ = panic "addTickHsValBinds"
addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
@@ -828,12 +830,11 @@ addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
addTickLPat pat = return pat
addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
-addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
- liftM4 HsCmdTop
+addTickHsCmdTop (HsCmdTop x cmd) =
+ liftM2 HsCmdTop
+ (return x)
(addTickLHsCmd cmd)
- (return tys)
- (return ty)
- (return syntaxtable)
+addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop"
addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd (L pos c0) = do
@@ -841,10 +842,10 @@ addTickLHsCmd (L pos c0) = do
return $ L pos c1
addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
-addTickHsCmd (HsCmdLam matchgroup) =
- liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
-addTickHsCmd (HsCmdApp c e) =
- liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
+addTickHsCmd (HsCmdLam x matchgroup) =
+ liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
+addTickHsCmd (HsCmdApp x c e) =
+ liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
{-
addTickHsCmd (OpApp e1 c2 fix c3) =
liftM4 OpApp
@@ -853,41 +854,43 @@ addTickHsCmd (OpApp e1 c2 fix c3) =
(return fix)
(addTickLHsCmd c3)
-}
-addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
-addTickHsCmd (HsCmdCase e mgs) =
- liftM2 HsCmdCase
+addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)
+addTickHsCmd (HsCmdCase x e mgs) =
+ liftM2 (HsCmdCase x)
(addTickLHsExpr e)
(addTickCmdMatchGroup mgs)
-addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
- liftM3 (HsCmdIf cnd)
+addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
+ liftM3 (HsCmdIf x cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2)
(addTickLHsCmd c3)
-addTickHsCmd (HsCmdLet (L l binds) c) =
+addTickHsCmd (HsCmdLet x (L l binds) c) =
bindLocals (collectLocalBinders binds) $
- liftM2 (HsCmdLet . L l)
+ liftM2 (HsCmdLet x . L l)
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
-addTickHsCmd (HsCmdDo (L l stmts) srcloc)
+addTickHsCmd (HsCmdDo srcloc (L l stmts))
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
- ; return (HsCmdDo (L l stmts') srcloc) }
+ ; return (HsCmdDo srcloc (L l stmts')) }
-addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) =
+addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) =
liftM5 HsCmdArrApp
+ (return arr_ty)
(addTickLHsExpr e1)
(addTickLHsExpr e2)
(return ty1)
- (return arr_ty)
(return lr)
-addTickHsCmd (HsCmdArrForm e f fix cmdtop) =
- liftM4 HsCmdArrForm
+addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
+ liftM4 (HsCmdArrForm x)
(addTickLHsExpr e)
(return f)
(return fix)
(mapM (liftL (addTickHsCmdTop)) cmdtop)
-addTickHsCmd (HsCmdWrap w cmd)
- = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd)
+addTickHsCmd (HsCmdWrap x w cmd)
+ = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd)
+
+addTickHsCmd e@(XCmd {}) = pprPanic "addTickHsCmd" (ppr e)
-- Others should never happen in a command context.
--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
@@ -1167,7 +1170,7 @@ allocTickBox boxLabel countEntries topOnly pos m =
(fvs, e) <- getFreeVars m
env <- getEnv
tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
- return (L pos (HsTick tickish (L pos e)))
+ return (L pos (HsTick noExt tickish (L pos e)))
) (do
e <- m
return (L pos e)
@@ -1253,13 +1256,14 @@ mkBinTickBoxHpc boxLabel pos e =
c = tickBoxCount st
mes = mixEntries st
in
- ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e
- -- notice that F and T are reversed,
- -- because we are building the list in
- -- reverse...
- , noFVs
- , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
- )
+ ( L pos $ HsTick noExt (HpcTick (this_mod env) c)
+ $ L pos $ HsBinTick noExt (c+1) (c+2) e
+ -- notice that F and T are reversed,
+ -- because we are building the list in
+ -- reverse...
+ , noFVs
+ , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
+ )
mkHpcPos :: SrcSpan -> HpcPos
mkHpcPos pos@(RealSrcSpan s)
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
index 24d7d8a61c..61dc7c5b5b 100644
--- a/compiler/deSugar/DsArrows.hs
+++ b/compiler/deSugar/DsArrows.hs
@@ -313,7 +313,7 @@ dsProcExpr
:: LPat GhcTc
-> LHsCmdTop GhcTc
-> DsM CoreExpr
-dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
+dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
(meth_binds, meth_ids) <- mkCmdEnv ids
let locals = mkVarSet (collectPatBinders pat)
(core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
@@ -328,6 +328,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
(Lam var match_code)
core_cmd
return (mkLets meth_binds proc_code)
+dsProcExpr _ (L _ XCmdTop{}) = panic "dsProcExpr"
{-
Translation of a command judgement of the form
@@ -363,7 +364,7 @@ dsCmd :: DsCmdEnv -- arrow combinators
-- ---> premap (\ ((xs), _stk) -> arg) fun
dsCmd ids local_vars stack_ty res_ty
- (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)
+ (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)
env_ids = do
let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -388,7 +389,7 @@ dsCmd ids local_vars stack_ty res_ty
-- ---> premap (\ ((xs), _stk) -> (fun, arg)) app
dsCmd ids local_vars stack_ty res_ty
- (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)
+ (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _)
env_ids = do
let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -416,7 +417,7 @@ dsCmd ids local_vars stack_ty res_ty
--
-- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
-dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
core_arg <- dsLExpr arg
let
arg_ty = exprType core_arg
@@ -449,7 +450,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
dsCmd ids local_vars stack_ty res_ty
- (HsCmdLam (MG { mg_alts = L _ [L _ (Match { m_pats = pats
+ (HsCmdLam _ (MG { mg_alts = L _ [L _ (Match { m_pats = pats
, m_grhss = GRHSs [L _ (GRHS [] body)] _ })] }))
env_ids = do
let pat_vars = mkVarSet (collectPatsBinders pats)
@@ -479,7 +480,7 @@ dsCmd ids local_vars stack_ty res_ty
return (do_premap ids in_ty in_ty' res_ty select_code core_body,
free_vars `udfmMinusUFM` getUniqSet pat_vars)
-dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
+dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids
= dsLCmd ids local_vars stack_ty res_ty cmd env_ids
-- D, xs |- e :: Bool
@@ -492,7 +493,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
-- if e then Left ((xs1),stk) else Right ((xs2),stk))
-- (c1 ||| c2)
-dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
+dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
env_ids = do
core_cond <- dsLExpr cond
(core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
@@ -553,8 +554,8 @@ case bodies, containing the following fields:
-}
dsCmd ids local_vars stack_ty res_ty
- (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys
- , mg_origin = origin }))
+ (HsCmdCase _ exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys
+ , mg_origin = origin }))
env_ids = do
stack_id <- newSysLocalDs stack_ty
@@ -575,10 +576,12 @@ dsCmd ids local_vars stack_ty res_ty
left_con <- dsLookupDataCon leftDataConName
right_con <- dsLookupDataCon rightDataConName
let
- left_id = HsConLikeOut (RealDataCon left_con)
- right_id = HsConLikeOut (RealDataCon right_con)
- left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
- right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
+ left_id = HsConLikeOut noExt (RealDataCon left_con)
+ right_id = HsConLikeOut noExt (RealDataCon right_con)
+ left_expr ty1 ty2 e = noLoc $ HsApp noExt
+ (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
+ right_expr ty1 ty2 e = noLoc $ HsApp noExt
+ (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
-- Prefix each tuple with a distinct series of Left's and Right's,
-- in a balanced way, keeping track of the types.
@@ -597,9 +600,10 @@ dsCmd ids local_vars stack_ty res_ty
(_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
in_ty = envStackType env_ids stack_ty
- core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches'
- , mg_arg_tys = arg_tys
- , mg_res_ty = sum_ty, mg_origin = origin }))
+ core_body <- dsExpr (HsCase noExt exp
+ (MG { mg_alts = L l matches'
+ , mg_arg_tys = arg_tys
+ , mg_res_ty = sum_ty, mg_origin = origin }))
-- Note that we replace the HsCase result type by sum_ty,
-- which is the type of matches'
@@ -613,7 +617,8 @@ dsCmd ids local_vars stack_ty res_ty
--
-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
-dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
+ env_ids = do
let
defined_vars = mkVarSet (collectLocalBinders binds)
local_vars' = defined_vars `unionVarSet` local_vars
@@ -638,7 +643,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids
--
-- ---> premap (\ (env,stk) -> env) c
-dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do
+dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts))
+ env_ids = do
putSrcSpanDs loc $
dsNoLevPoly stmts_ty
(text "In the do-command:" <+> ppr do_block)
@@ -658,14 +664,14 @@ dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) e
-- -----------------------------------
-- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn
-dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do
+dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
let env_ty = mkBigCoreVarTupTy env_ids
core_op <- dsLExpr op
(core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
return (mkApps (App core_op (Type env_ty)) core_args,
unionDVarSets fv_sets)
-dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do
(core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
core_wrap <- dsHsWrapper wrap
return (core_wrap core_cmd, env_ids')
@@ -682,7 +688,8 @@ dsTrimCmdArg
-> LHsCmdTop GhcTc -- command argument to desugar
-> DsM (CoreExpr, -- desugared expression
DIdSet) -- subset of local vars that occur free
-dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
+dsTrimCmdArg local_vars env_ids
+ (L _ (HsCmdTop (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
(meth_binds, meth_ids) <- mkCmdEnv ids
(core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
stack_id <- newSysLocalDs stack_ty
@@ -693,6 +700,7 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
arg_code = if env_ids' == env_ids then core_cmd else
do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
return (mkLets meth_binds arg_code, free_vars)
+dsTrimCmdArg _ _ (L _ XCmdTop{}) = panic "dsTrimCmdArg"
-- Given D; xs |-a c : stk --> t, builds c with xs fed back.
-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
@@ -1187,31 +1195,31 @@ collectl :: LPat GhcTc -> [Id] -> [Id]
collectl (L _ pat) bndrs
= go pat
where
- go (VarPat (L _ var)) = var : bndrs
+ go (VarPat _ (L _ var)) = var : bndrs
go (WildPat _) = bndrs
- go (LazyPat pat) = collectl pat bndrs
- go (BangPat pat) = collectl pat bndrs
- go (AsPat (L _ a) pat) = a : collectl pat bndrs
- go (ParPat pat) = collectl pat bndrs
+ go (LazyPat _ pat) = collectl pat bndrs
+ go (BangPat _ pat) = collectl pat bndrs
+ go (AsPat _ (L _ a) pat) = a : collectl pat bndrs
+ go (ParPat _ pat) = collectl pat bndrs
- go (ListPat pats _ _) = foldr collectl bndrs pats
- go (PArrPat pats _) = foldr collectl bndrs pats
- go (TuplePat pats _ _) = foldr collectl bndrs pats
- go (SumPat pat _ _ _) = collectl pat bndrs
+ go (ListPat _ pats _ _) = foldr collectl bndrs pats
+ go (PArrPat _ pats) = foldr collectl bndrs pats
+ go (TuplePat _ pats _) = foldr collectl bndrs pats
+ go (SumPat _ pat _ _) = collectl pat bndrs
go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
go (ConPatOut {pat_args=ps, pat_binds=ds}) =
collectEvBinders ds
++ foldr collectl bndrs (hsConPatArgs ps)
- go (LitPat _) = bndrs
+ go (LitPat _ _) = bndrs
go (NPat {}) = bndrs
- go (NPlusKPat (L _ n) _ _ _ _ _) = n : bndrs
+ go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
- go (SigPatIn pat _) = collectl pat bndrs
- go (SigPatOut pat _) = collectl pat bndrs
- go (CoPat _ pat _) = collectl (noLoc pat) bndrs
- go (ViewPat _ pat _) = collectl pat bndrs
+ go (SigPat _ pat) = collectl pat bndrs
+ go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
+ go (ViewPat _ _ pat) = collectl pat bndrs
go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
+ go p@(XPat {}) = pprPanic "collectl/go" (ppr p)
collectEvBinders :: TcEvBinds -> [Id]
collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 635a9c6137..bba301c7ac 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -78,8 +78,9 @@ dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body
-------------------------
-- caller sets location
dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
-dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn"
+dsValBinds (XValBindsLR (NValBinds binds _)) body
+ = foldrM ds_val_bind body binds
+dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
-------------------------
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
@@ -249,17 +250,18 @@ dsExpr = ds_expr False
ds_expr :: Bool -- are we directly inside an HsWrap?
-- See Wrinkle in Note [Detecting forced eta expansion]
-> HsExpr GhcTc -> DsM CoreExpr
-ds_expr _ (HsPar e) = dsLExpr e
-ds_expr _ (ExprWithTySigOut e _) = dsLExpr e
-ds_expr w (HsVar (L _ var)) = dsHsVar w var
+ds_expr _ (HsPar _ e) = dsLExpr e
+ds_expr _ (ExprWithTySig _ e) = dsLExpr e
+ds_expr w (HsVar _ (L _ var)) = dsHsVar w var
ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
-ds_expr w (HsConLikeOut con) = dsConLike w con
-ds_expr _ (HsIPVar _) = panic "dsExpr: HsIPVar"
+ds_expr w (HsConLikeOut _ con) = dsConLike w con
+ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar"
ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel"
-ds_expr _ (HsLit lit) = dsLit (convertLit lit)
-ds_expr _ (HsOverLit lit) = dsOverLit lit
+ds_expr _ (HsLit _ lit) = dsLit (convertLit lit)
+ds_expr _ (HsOverLit _ lit) = dsOverLit lit
+ds_expr _ (XExpr {}) = panic "dsExpr: XExpr"
-ds_expr _ (HsWrap co_fn e)
+ds_expr _ (HsWrap _ co_fn e)
= do { e' <- ds_expr True e
; wrap' <- dsHsWrapper co_fn
; dflags <- getDynFlags
@@ -269,7 +271,7 @@ ds_expr _ (HsWrap co_fn e)
; warnAboutIdentities dflags e' wrapped_ty
; return wrapped_e }
-ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i })))
+ds_expr _ (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
neg_expr)
= do { expr' <- putSrcSpanDs loc $ do
{ dflags <- getDynFlags
@@ -278,23 +280,23 @@ ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i })))
; dsOverLit' dflags lit }
; dsSyntaxExpr neg_expr [expr'] }
-ds_expr _ (NegApp expr neg_expr)
+ds_expr _ (NegApp _ expr neg_expr)
= do { expr' <- dsLExpr expr
; dsSyntaxExpr neg_expr [expr'] }
-ds_expr _ (HsLam a_Match)
+ds_expr _ (HsLam _ a_Match)
= uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
-ds_expr _ (HsLamCase matches)
+ds_expr _ (HsLamCase _ matches)
= do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
; return $ Lam discrim_var matching_code }
-ds_expr _ e@(HsApp fun arg)
+ds_expr _ e@(HsApp _ fun arg)
= do { fun' <- dsLExpr fun
; dsWhenNoErrs (dsLExprNoLP arg)
(\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
-ds_expr _ (HsAppTypeOut e _)
+ds_expr _ (HsAppType _ e)
-- ignore type arguments here; they're in the wrappers instead at this point
= dsLExpr e
@@ -338,19 +340,19 @@ If \tr{expr} is actually just a variable, say, then the simplifier
will sort it out.
-}
-ds_expr _ e@(OpApp e1 op _ e2)
+ds_expr _ e@(OpApp _ e1 op e2)
= -- for the type of y, we need the type of op's 2nd argument
do { op' <- dsLExpr op
; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
(\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
-ds_expr _ (SectionL expr op) -- Desugar (e !) to ((!) e)
+ds_expr _ (SectionL _ expr op) -- Desugar (e !) to ((!) e)
= do { op' <- dsLExpr op
; dsWhenNoErrs (dsLExprNoLP expr)
(\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
-ds_expr _ e@(SectionR op expr) = do
+ds_expr _ e@(SectionR _ op expr) = do
core_op <- dsLExpr op
-- for the type of x, we need the type of op's 2nd argument
let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
@@ -361,31 +363,32 @@ ds_expr _ e@(SectionR op expr) = do
Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
core_op [Var x_id, Var y_id]))
-ds_expr _ (ExplicitTuple tup_args boxity)
+ds_expr _ (ExplicitTuple _ tup_args boxity)
= do { let go (lam_vars, args) (L _ (Missing ty))
-- For every missing expression, we need
-- another lambda in the desugaring.
= do { lam_var <- newSysLocalDsNoLP ty
; return (lam_var : lam_vars, Var lam_var : args) }
- go (lam_vars, args) (L _ (Present expr))
+ go (lam_vars, args) (L _ (Present _ expr))
-- Expressions that are present don't generate
-- lambdas, just arguments.
= do { core_expr <- dsLExprNoLP expr
; return (lam_vars, core_expr : args) }
+ go _ (L _ (XTupArg {})) = panic "ds_expr"
; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
-- The reverse is because foldM goes left-to-right
(\(lam_vars, args) -> mkCoreLams lam_vars $
mkCoreTupBoxity boxity args) }
-ds_expr _ (ExplicitSum alt arity expr types)
+ds_expr _ (ExplicitSum types alt arity expr)
= do { dsWhenNoErrs (dsLExprNoLP expr)
(\core_expr -> mkCoreConApps (sumDataCon alt arity)
(map (Type . getRuntimeRep) types ++
map Type types ++
[core_expr]) ) }
-ds_expr _ (HsSCC _ cc expr@(L loc _)) = do
+ds_expr _ (HsSCC _ _ cc expr@(L loc _)) = do
dflags <- getDynFlags
if gopt Opt_SccProfilingOn dflags
then do
@@ -396,31 +399,31 @@ ds_expr _ (HsSCC _ cc expr@(L loc _)) = do
<$> dsLExpr expr
else dsLExpr expr
-ds_expr _ (HsCoreAnn _ _ expr)
+ds_expr _ (HsCoreAnn _ _ _ expr)
= dsLExpr expr
-ds_expr _ (HsCase discrim matches)
+ds_expr _ (HsCase _ discrim matches)
= do { core_discrim <- dsLExpr discrim
; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
; return (bindNonRec discrim_var core_discrim matching_code) }
-- Pepe: The binds are in scope in the body but NOT in the binding group
-- This is to avoid silliness in breakpoints
-ds_expr _ (HsLet binds body) = do
+ds_expr _ (HsLet _ binds body) = do
body' <- dsLExpr body
dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
-ds_expr _ (HsDo ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty
-ds_expr _ (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts)
-ds_expr _ (HsDo DoExpr (L _ stmts) _) = dsDo stmts
-ds_expr _ (HsDo GhciStmtCtxt (L _ stmts) _) = dsDo stmts
-ds_expr _ (HsDo MDoExpr (L _ stmts) _) = dsDo stmts
-ds_expr _ (HsDo MonadComp (L _ stmts) _) = dsMonadComp stmts
-
-ds_expr _ (HsIf mb_fun guard_expr then_expr else_expr)
+ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
+ds_expr _ (HsDo _ PArrComp (L _ stmts)) = dsPArrComp (map unLoc stmts)
+ds_expr _ (HsDo _ DoExpr (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
+
+ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
; b1 <- dsLExpr then_expr
; b2 <- dsLExpr else_expr
@@ -453,7 +456,7 @@ ds_expr _ (ExplicitList elt_ty wit xs)
-- We desugar [:x1, ..., xn:] as
-- singletonP x1 +:+ ... +:+ singletonP xn
--
-ds_expr _ (ExplicitPArr ty []) = do
+ds_expr _ (ExplicitPArr ty []) = do
emptyP <- dsDPHBuiltin emptyPVar
return (Var emptyP `App` Type ty)
ds_expr _ (ExplicitPArr ty xs) = do
@@ -535,8 +538,9 @@ We also handle @C{}@ as valid construction syntax for an unlabelled
constructor @C@, setting all of @C@'s fields to bottom.
-}
-ds_expr _ (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds
- , rcon_con_like = con_like })
+ds_expr _ (RecordCon { rcon_flds = rbinds
+ , rcon_ext = RecordConTc { rcon_con_expr = con_expr
+ , rcon_con_like = con_like }})
= do { con_expr' <- dsExpr con_expr
; let
(arg_tys, _) = tcSplitFunTys (exprType con_expr')
@@ -595,9 +599,11 @@ So we need to cast (T a Int) to (T a b). Sigh.
-}
ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
- , rupd_cons = cons_to_upd
- , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys
- , rupd_wrap = dict_req_wrap } )
+ , rupd_ext = RecordUpdTc
+ { rupd_cons = cons_to_upd
+ , rupd_in_tys = in_inst_tys
+ , rupd_out_tys = out_inst_tys
+ , rupd_wrap = dict_req_wrap }} )
| null fields
= dsLExpr record_expr
| otherwise
@@ -661,7 +667,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
mk_val_arg fl pat_arg_id
= nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
- inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut con)
+ inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con)
-- Reconstruct with the WrapId so that unpacking happens
-- The order here is because of the order in `TcPatSyn`.
wrap = mkWpEvVarApps theta_vars <.>
@@ -713,16 +719,16 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
-- Template Haskell stuff
-ds_expr _ (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
-ds_expr _ (HsTcBracketOut x ps) = dsBracket x ps
-ds_expr _ (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
+ds_expr _ (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut"
+ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps
+ds_expr _ (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
-- Arrow notation extension
-ds_expr _ (HsProc pat cmd) = dsProcExpr pat cmd
+ds_expr _ (HsProc _ pat cmd) = dsProcExpr pat cmd
-- Hpc Support
-ds_expr _ (HsTick tickish e) = do
+ds_expr _ (HsTick _ tickish e) = do
e' <- dsLExpr e
return (Tick tickish e')
@@ -733,20 +739,19 @@ ds_expr _ (HsTick tickish e) = do
-- (did you go here: YES or NO), but will effect accurate
-- tick counting.
-ds_expr _ (HsBinTick ixT ixF e) = do
+ds_expr _ (HsBinTick _ ixT ixF e) = do
e2 <- dsLExpr e
do { ASSERT(exprType e2 `eqType` boolTy)
mkBinaryTickBox ixT ixF e2
}
-ds_expr _ (HsTickPragma _ _ _ expr) = do
+ds_expr _ (HsTickPragma _ _ _ _ expr) = do
dflags <- getDynFlags
if gopt Opt_Hpc dflags
then panic "dsExpr:HsTickPragma"
else dsLExpr expr
-- HsSyn constructs that just shouldn't be here:
-ds_expr _ (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig"
ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket"
ds_expr _ (HsArrApp {}) = panic "dsExpr:HsArrApp"
ds_expr _ (HsArrForm {}) = panic "dsExpr:HsArrForm"
@@ -754,7 +759,6 @@ ds_expr _ (EWildPat {}) = panic "dsExpr:EWildPat"
ds_expr _ (EAsPat {}) = panic "dsExpr:EAsPat"
ds_expr _ (EViewPat {}) = panic "dsExpr:EViewPat"
ds_expr _ (ELazyPat {}) = panic "dsExpr:ELazyPat"
-ds_expr _ (HsAppType {}) = panic "dsExpr:HsAppType" -- removed by typechecker
ds_expr _ (HsDo {}) = panic "dsExpr:HsDo"
ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld"
@@ -933,9 +937,9 @@ dsDo stmts
; rhss' <- sequence rhss
- ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty
+ ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)
- ; let fun = L noSrcSpan $ HsLam $
+ ; let fun = L noSrcSpan $ HsLam noExt $
MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
body']
, mg_arg_tys = arg_tys
@@ -967,15 +971,15 @@ dsDo stmts
later_pats = rec_tup_pats
rets = map noLoc rec_rets
mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
- mfix_arg = noLoc $ HsLam
+ mfix_arg = noLoc $ HsLam noExt
(MG { mg_alts = noLoc [mkSimpleMatch
LambdaExpr
[mfix_pat] body]
, mg_arg_tys = [tup_ty], mg_res_ty = body_ty
, mg_origin = Generated })
- mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
- body = noLoc $ HsDo
- DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty
+ mfix_pat = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats
+ body = noLoc $ HsDo body_ty
+ DoExpr (noLoc (rec_stmts ++ [ret_stmt]))
ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
ret_stmt = noLoc $ mkLastStmt ret_app
-- This LastStmt will be desugared with dsDo,
@@ -1137,9 +1141,9 @@ we're not directly in an HsWrap, reject.
checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()
checkForcedEtaExpansion expr ty
| Just var <- case expr of
- HsVar (L _ var) -> Just var
- HsConLikeOut (RealDataCon dc) -> Just (dataConWrapId dc)
- _ -> Nothing
+ HsVar _ (L _ var) -> Just var
+ HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)
+ _ -> Nothing
, let bad_tys = badUseOfLevPolyPrimop var ty
, not (null bad_tys)
= levPolyPrimopErr var ty bad_tys
diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs
index d521f537e5..4296630ba6 100644
--- a/compiler/deSugar/DsGRHSs.hs
+++ b/compiler/deSugar/DsGRHSs.hs
@@ -136,24 +136,25 @@ isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-- * Trivial wappings of these
-- The arguments to Just are any HsTicks that we have found,
-- because we still want to tick then, even it they are always evaluated.
-isTrueLHsExpr (L _ (HsVar (L _ v))) | v `hasKey` otherwiseIdKey
- || v `hasKey` getUnique trueDataConId
- = Just return
+isTrueLHsExpr (L _ (HsVar _ (L _ v))) | v `hasKey` otherwiseIdKey
+ || v `hasKey` getUnique trueDataConId
+ = Just return
-- trueDataConId doesn't have the same unique as trueDataCon
-isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return
-isTrueLHsExpr (L _ (HsTick tickish e))
+isTrueLHsExpr (L _ (HsConLikeOut _ con))
+ | con `hasKey` getUnique trueDataCon = Just return
+isTrueLHsExpr (L _ (HsTick _ tickish e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do wrapped <- ticks x
return (Tick tickish wrapped))
-- This encodes that the result is constant True for Hpc tick purposes;
-- which is specifically what isTrueLHsExpr is trying to find out.
-isTrueLHsExpr (L _ (HsBinTick ixT _ e))
+isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do e <- ticks x
this_mod <- getModule
return (Tick (HpcTick this_mod ixT) e))
-isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e
+isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e
isTrueLHsExpr _ = Nothing
{-
diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs
index fea637fafe..860c1baa14 100644
--- a/compiler/deSugar/DsListComp.hs
+++ b/compiler/deSugar/DsListComp.hs
@@ -82,7 +82,7 @@ dsListComp lquals res_ty = do
-- of that comprehension that we need in the outer comprehension into such an expression
-- and the type of the elements that it outputs (tuples of binders)
dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type)
-dsInnerListComp (ParStmtBlock stmts bndrs _)
+dsInnerListComp (ParStmtBlock _ stmts bndrs _)
= do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
list_ty = mkListTy bndrs_tuple_type
@@ -90,6 +90,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _)
; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
; return (expr, bndrs_tuple_type) }
+dsInnerListComp (XParStmtBlock{}) = panic "dsInnerListComp"
-- This function factors out commonality between the desugaring strategies for GroupStmt.
-- Given such a statement it gives you back an expression representing how to compute the transformed
@@ -105,7 +106,8 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM
to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
-- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
- (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr)
+ (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExt stmts
+ from_bndrs noSyntaxExpr)
-- Work out what arguments should be supplied to that expression: i.e. is an extraction
-- function required? If so, create that desugared function and add to arguments
@@ -253,7 +255,7 @@ deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
quals list }
where
- bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]
+ bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs]
-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
pat = mkBigLHsPatTupId pats
@@ -623,13 +625,15 @@ dePArrParComp qss quals = do
deParStmt [] =
-- empty parallel statement lists have no source representation
panic "DsListComp.dePArrComp: Empty parallel list comprehension"
- deParStmt (ParStmtBlock qs xs _:qss) = do -- first statement
+ deParStmt (ParStmtBlock _ qs xs _:qss) = do -- first statement
let res_expr = mkLHsVarTuple xs
cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
parStmts qss (mkLHsVarPatTup xs) cqs
+ deParStmt (XParStmtBlock{}:_) = panic "dePArrParComp"
---
parStmts [] pa cea = return (pa, cea)
- parStmts (ParStmtBlock qs xs _:qss) pa cea = do -- subsequent statements (zip'ed)
+ parStmts (ParStmtBlock _ qs xs _:qss) pa cea = do
+ -- subsequent statements (zip'ed)
zipP <- dsDPHBuiltin zipPVar
let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]
ty'cea = parrElemType cea
@@ -638,6 +642,7 @@ dePArrParComp qss quals = do
let ty'cqs = parrElemType cqs
cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
parStmts qss pa' cea'
+ parStmts (XParStmtBlock{}:_) _ _ = panic "dePArrParComp"
-- generate Core corresponding to `\p -> e'
--
@@ -777,7 +782,7 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
; mzip_op' <- dsExpr mzip_op
; let -- The pattern variables
- pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks]
+ pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks]
-- Pattern with tuples of variables
-- [v1,v2,v3] => (v1, (v2, v3))
pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
@@ -788,9 +793,10 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
where
- ds_inner (ParStmtBlock stmts bndrs return_op)
+ ds_inner (ParStmtBlock _ stmts bndrs return_op)
= do { exp <- dsInnerMonadComp stmts bndrs return_op
; return (exp, mkBigCoreVarTupTy bndrs) }
+ ds_inner (XParStmtBlock{}) = panic "dsMcStmt"
dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 2a181e8d16..c910fbf15b 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -77,13 +77,14 @@ dsBracket brack splices
where
new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
- do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
- do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
- do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 }
- do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
- do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
- do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL"
- do_brack (TExpBr e) = do { MkC e1 <- repLE e ; return e1 }
+ do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
+ do_brack (ExpBr _ e) = do { MkC e1 <- repLE e ; return e1 }
+ do_brack (PatBr _ p) = do { MkC p1 <- repTopP p ; return p1 }
+ do_brack (TypBr _ t) = do { MkC t1 <- repLTy t ; return t1 }
+ do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
+ do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL"
+ do_brack (TExpBr _ e) = do { MkC e1 <- repLE e ; return e1 }
+ do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"
{- -------------- Examples --------------------
@@ -198,8 +199,8 @@ hsSigTvBinders binds
get_scoped_tvs _ = []
sigs = case binds of
- ValBindsIn _ sigs -> sigs
- ValBindsOut _ sigs -> sigs
+ ValBinds _ _ sigs -> sigs
+ XValBindsLR (NValBinds _ sigs) -> sigs
{- Notes
@@ -695,7 +696,7 @@ repBangTy ty = do
rep2 bangTypeName [b, t]
where
(su', ss', ty') = case ty of
- L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)
+ L _ (HsBangTy _ (HsSrcBang _ su ss) ty) -> (su, ss, ty)
_ -> (NoSrcUnpack, NoSrcStrict, ty)
-------------------------------------------------------
@@ -917,18 +918,20 @@ addTyClTyVarBinds tvs m
--
repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
-> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
-repTyVarBndrWithKind (L _ (UserTyVar _)) nm
+repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm
= repPlainTV nm
-repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm
= repLTy ki >>= repKindedTV nm
+repTyVarBndrWithKind (L _ (XTyVarBndr{})) _ = panic "repTyVarBndrWithKind"
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
-repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
- ; repPlainTV nm' }
-repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
- ; ki' <- repLTy ki
- ; repKindedTV nm' ki' }
+repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )= do { nm' <- lookupBinder nm
+ ; repPlainTV nm' }
+repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) = do { nm' <- lookupBinder nm
+ ; ki' <- repLTy ki
+ ; repKindedTV nm' ki' }
+repTyVarBndr (L _ (XTyVarBndr{})) = panic "repTyVarBndr"
-- represent a type context
--
@@ -1000,7 +1003,7 @@ repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
repTy ty@(HsForAllTy {}) = repForall ty
repTy ty@(HsQualTy {}) = repForall ty
-repTy (HsTyVar _ (L _ n))
+repTy (HsTyVar _ _ (L _ n))
| isLiftedTypeKindTyConName n = repTStar
| n `hasKey` constraintKindTyConKey = repTConstraint
| isTvOcc occ = do tv1 <- lookupOcc n
@@ -1013,47 +1016,47 @@ repTy (HsTyVar _ (L _ n))
where
occ = nameOccName n
-repTy (HsAppTy f a) = do
+repTy (HsAppTy _ f a) = do
f1 <- repLTy f
a1 <- repLTy a
repTapp f1 a1
-repTy (HsFunTy f a) = do
+repTy (HsFunTy _ f a) = do
f1 <- repLTy f
a1 <- repLTy a
tcon <- repArrowTyCon
repTapps tcon [f1, a1]
-repTy (HsListTy t) = do
+repTy (HsListTy _ t) = do
t1 <- repLTy t
tcon <- repListTyCon
repTapp tcon t1
-repTy (HsPArrTy t) = do
+repTy (HsPArrTy _ t) = do
t1 <- repLTy t
- tcon <- repTy (HsTyVar NotPromoted
+ tcon <- repTy (HsTyVar noExt NotPromoted
(noLoc (tyConName parrTyCon)))
repTapp tcon t1
-repTy (HsTupleTy HsUnboxedTuple tys) = do
+repTy (HsTupleTy _ HsUnboxedTuple tys) = do
tys1 <- repLTys tys
tcon <- repUnboxedTupleTyCon (length tys)
repTapps tcon tys1
-repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys
+repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys
tcon <- repTupleTyCon (length tys)
repTapps tcon tys1
-repTy (HsSumTy tys) = do tys1 <- repLTys tys
+repTy (HsSumTy _ tys) = do tys1 <- repLTys tys
tcon <- repUnboxedSumTyCon (length tys)
repTapps tcon tys1
-repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
+repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
`nlHsAppTy` ty2)
-repTy (HsParTy t) = repLTy t
-repTy (HsEqTy t1 t2) = do
+repTy (HsParTy _ t) = repLTy t
+repTy (HsEqTy _ t1 t2) = do
t1' <- repLTy t1
t2' <- repLTy t2
eq <- repTequality
repTapps eq [t1', t2']
-repTy (HsKindSig t k) = do
+repTy (HsKindSig _ t k) = do
t1 <- repLTy t
k1 <- repLTy k
repTSig t1 k1
-repTy (HsSpliceTy splice _) = repSplice splice
+repTy (HsSpliceTy _ splice) = repSplice splice
repTy (HsExplicitListTy _ _ tys) = do
tys1 <- repLTys tys
repTPromotedList tys1
@@ -1061,9 +1064,9 @@ repTy (HsExplicitTupleTy _ tys) = do
tys1 <- repLTys tys
tcon <- repPromotedTupleTyCon (length tys)
repTapps tcon tys1
-repTy (HsTyLit lit) = do
- lit' <- repTyLit lit
- repTLit lit'
+repTy (HsTyLit _ lit) = do
+ lit' <- repTyLit lit
+ repTLit lit'
repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
repTy ty = notHandled "Exotic form of type" (ppr ty)
@@ -1097,10 +1100,11 @@ repRole (L _ Nothing) = rep2 inferRName []
repSplice :: HsSplice GhcRn -> DsM (Core a)
-- See Note [How brackets and nested splices are handled] in TcSplice
-- We return a CoreExpr of any old type; the context should know
-repSplice (HsTypedSplice _ n _) = rep_splice n
-repSplice (HsUntypedSplice _ n _) = rep_splice n
-repSplice (HsQuasiQuote n _ _ _) = rep_splice n
-repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e)
+repSplice (HsTypedSplice _ _ n _) = rep_splice n
+repSplice (HsUntypedSplice _ _ n _) = rep_splice n
+repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n
+repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e)
+repSplice e@(XSplice {}) = pprPanic "repSplice" (ppr e)
rep_splice :: Name -> DsM (Core a)
rep_splice splice_name
@@ -1125,7 +1129,7 @@ repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
repLE (L loc e) = putSrcSpanDs loc (repE e)
repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
-repE (HsVar (L _ x)) =
+repE (HsVar _ (L _ x)) =
do { mb_val <- dsLookupMetaEnv x
; case mb_val of
Nothing -> do { str <- globalVar x
@@ -1133,45 +1137,46 @@ repE (HsVar (L _ x)) =
Just (DsBound y) -> repVarOrCon x (coreVar y)
Just (DsSplice e) -> do { e' <- dsExpr e
; return (MkC e') } }
-repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
-repE (HsOverLabel _ s) = repOverLabel s
+repE e@(HsIPVar {}) = notHandled "Implicit parameters" (ppr e)
+repE (HsOverLabel _ _ s) = repOverLabel s
-repE e@(HsRecFld f) = case f of
- Unambiguous _ x -> repE (HsVar (noLoc x))
+repE e@(HsRecFld _ f) = case f of
+ Unambiguous x _ -> repE (HsVar noExt (noLoc x))
Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e)
+ XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e)
-- Remember, we're desugaring renamer output here, so
-- HsOverlit can definitely occur
-repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
-repE (HsLit l) = do { a <- repLiteral l; repLit a }
-repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m
-repE (HsLamCase (MG { mg_alts = L _ ms }))
+repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
+repE (HsLit _ l) = do { a <- repLiteral l; repLit a }
+repE (HsLam _ (MG { mg_alts = L _ [m] })) = repLambda m
+repE (HsLamCase _ (MG { mg_alts = L _ ms }))
= do { ms' <- mapM repMatchTup ms
; core_ms <- coreList matchQTyConName ms'
; repLamCase core_ms }
-repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
-repE (HsAppType e t) = do { a <- repLE e
+repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b}
+repE (HsAppType t e) = do { a <- repLE e
; s <- repLTy (hswc_body t)
; repAppType a s }
-repE (OpApp e1 op _ e2) =
+repE (OpApp _ e1 op e2) =
do { arg1 <- repLE e1;
arg2 <- repLE e2;
the_op <- repLE op ;
repInfixApp arg1 the_op arg2 }
-repE (NegApp x _) = do
+repE (NegApp _ x _) = do
a <- repLE x
negateVar <- lookupOcc negateName >>= repVar
negateVar `repApp` a
-repE (HsPar x) = repLE x
-repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
-repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
-repE (HsCase e (MG { mg_alts = L _ ms }))
+repE (HsPar _ x) = repLE x
+repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
+repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
+repE (HsCase _ e (MG { mg_alts = L _ ms }))
= do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
; core_ms2 <- coreList matchQTyConName ms2
; repCaseE arg core_ms2 }
-repE (HsIf _ x y z) = do
+repE (HsIf _ _ x y z) = do
a <- repLE x
b <- repLE y
c <- repLE z
@@ -1180,13 +1185,13 @@ repE (HsMultiIf _ alts)
= do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
; expr' <- repMultiIf (nonEmptyCoreList alts')
; wrapGenSyms (concat binds) expr' }
-repE (HsLet (L _ bs) e) = do { (ss,ds) <- repBinds bs
+repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs
; e2 <- addBinds ss (repLE e)
; z <- repLetE ds e2
; wrapGenSyms ss z }
-- FIXME: I haven't got the types here right yet
-repE e@(HsDo ctxt (L _ sts) _)
+repE e@(HsDo _ ctxt (L _ sts))
| case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
= do { (ss,zs) <- repLSts sts;
e' <- repDoE (nonEmptyCoreList zs);
@@ -1202,13 +1207,13 @@ repE e@(HsDo ctxt (L _ sts) _)
repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
-repE e@(ExplicitTuple es boxed)
+repE e@(ExplicitTuple _ es boxed)
| not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
- | isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }
- | otherwise = do { xs <- repLEs [e | L _ (Present e) <- es]
- ; repUnboxedTup xs }
+ | isBoxed boxed = do { xs <- repLEs [e | L _ (Present _ e) <- es]; repTup xs }
+ | otherwise = do { xs <- repLEs [e | L _ (Present _ e) <- es]
+ ; repUnboxedTup xs }
-repE (ExplicitSum alt arity e _)
+repE (ExplicitSum _ alt arity e)
= do { e1 <- repLE e
; repUnboxedSum e1 alt arity }
@@ -1221,7 +1226,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
fs <- repUpdFields flds;
repRecUpd x fs }
-repE (ExprWithTySig e ty)
+repE (ExprWithTySig ty e)
= do { e1 <- repLE e
; t1 <- repHsSigWcType ty
; repSigExp e1 t1 }
@@ -1243,9 +1248,9 @@ repE (ArithSeq _ _ aseq) =
ds3 <- repLE e3
repFromThenTo ds1 ds2 ds3
-repE (HsSpliceE splice) = repSplice splice
+repE (HsSpliceE _ splice) = repSplice splice
repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC
-repE (HsUnboundVar uv) = do
+repE (HsUnboundVar _ uv) = do
occ <- occNameLit (unboundVarOcc uv)
sname <- repNameS occ
repUnboundVar sname
@@ -1254,7 +1259,6 @@ repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
-repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)
repE e = notHandled "Expression form" (ppr e)
-----------------------------------------------------------------------------
@@ -1318,7 +1322,7 @@ repUpdFields = repList fieldExpQTyConName rep_fld
where
rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
- Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name)
+ Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
; e <- repLE (hsRecFieldArg fld)
; repFieldExp fn e }
_ -> notHandled "Ambiguous record updates" (ppr fld)
@@ -1382,10 +1386,11 @@ repSts (ParStmt stmt_blocks _ _ _ : ss) =
where
rep_stmt_block :: ParStmtBlock GhcRn GhcRn
-> DsM ([GenSymBind], Core [TH.StmtQ])
- rep_stmt_block (ParStmtBlock stmts _ _) =
+ rep_stmt_block (ParStmtBlock _ stmts _ _) =
do { (ss1, zs) <- repSts (map unLoc stmts)
; zs1 <- coreList stmtQTyConName zs
; return (ss1, zs1) }
+ rep_stmt_block (XParStmtBlock{}) = panic "repSts"
repSts [LastStmt e _ _]
= do { e2 <- repLE e
; z <- repNoBindSt e2
@@ -1420,12 +1425,12 @@ repBinds (HsValBinds decs)
rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-- Assumes: all the binders of the binding are already in the meta-env
-rep_val_binds (ValBindsOut binds sigs)
+rep_val_binds (XValBindsLR (NValBinds binds sigs))
= do { core1 <- rep_binds' (unionManyBags (map snd binds))
; core2 <- rep_sigs' sigs
; return (core1 ++ core2) }
-rep_val_binds (ValBindsIn _ _)
- = panic "rep_val_binds: ValBindsIn"
+rep_val_binds (ValBinds _ _ _)
+ = panic "rep_val_binds: ValBinds"
rep_binds :: LHsBinds GhcRn -> DsM [Core TH.DecQ]
rep_binds binds = do { binds_w_locs <- rep_binds' binds
@@ -1611,19 +1616,23 @@ repLP :: LPat GhcRn -> DsM (Core TH.PatQ)
repLP (L _ p) = repP p
repP :: Pat GhcRn -> DsM (Core TH.PatQ)
-repP (WildPat _) = repPwild
-repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
-repP (VarPat (L _ x)) = do { x' <- lookupBinder x; repPvar x' }
-repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
-repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
-repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
-repP (ParPat p) = repLP p
-repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs }
-repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p}
-repP (TuplePat ps boxed _)
+repP (WildPat _) = repPwild
+repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 }
+repP (VarPat _ (L _ x)) = do { x' <- lookupBinder x; repPvar x' }
+repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 }
+repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 }
+repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p
+ ; repPaspat x' p1 }
+repP (ParPat _ p) = repLP p
+repP (ListPat _ ps _ Nothing) = do { qs <- repLPs ps; repPlist qs }
+repP (ListPat x ps ty1 (Just (_,e))) = do { p <- repP (ListPat x ps ty1 Nothing)
+ ; e' <- repE (syn_expr e)
+ ; repPview e' p}
+repP (TuplePat _ ps boxed)
| isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
| otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
-repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity }
+repP (SumPat _ p alt arity) = do { p1 <- repLP p
+ ; repPunboxedSum p1 alt arity }
repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc
; case details of
@@ -1640,13 +1649,13 @@ repP (ConPatIn dc details)
; MkC p <- repLP (hsRecFieldArg fld)
; rep2 fieldPatName [v,p] }
-repP (NPat (L _ l) Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
-repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
-repP p@(NPat _ (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
-repP (SigPatIn p t) = do { p' <- repLP p
- ; t' <- repLTy (hsSigWcType t)
- ; repPsig p' t' }
-repP (SplicePat splice) = repSplice splice
+repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
+repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
+repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
+repP (SigPat t p) = do { p' <- repLP p
+ ; t' <- repLTy (hsSigWcType t)
+ ; repPsig p' t' }
+repP (SplicePat _ splice) = repSplice splice
repP other = notHandled "Exotic pattern" (ppr other)
@@ -2197,7 +2206,7 @@ repConstr (RecCon (L _ ips)) resTy cons
rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a)
- rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n)
+ rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n)
; MkC ty <- repBangTy t
; rep2 varBangTypeName [v,ty] }
@@ -2357,7 +2366,7 @@ mk_integer i = do integer_ty <- lookupType integerTyConName
mk_rational :: FractionalLit -> DsM (HsLit GhcRn)
mk_rational r = do rat_ty <- lookupType rationalTyConName
- return $ HsRat def r rat_ty
+ return $ HsRat noExt r rat_ty
mk_string :: FastString -> DsM (HsLit GhcRn)
mk_string s = return $ HsString noSourceText s
@@ -2370,6 +2379,7 @@ repOverloadedLiteral (OverLit { ol_val = val})
-- The type Rational will be in the environment, because
-- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
-- and rationalL is sucked in when any TH stuff is used
+repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral"
mk_lit :: OverLitVal -> DsM (HsLit GhcRn)
mk_lit (HsIntegral i) = mk_integer (il_value i)
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index 3748193a19..f4fe8de227 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -9,6 +9,8 @@ This module exports some utility functions of no great interest.
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
-- | Utility functions for constructing Core syntax, principally for desugaring
module DsUtils (
@@ -117,13 +119,13 @@ selectMatchVars :: [Pat GhcTc] -> DsM [Id]
selectMatchVars ps = mapM selectMatchVar ps
selectMatchVar :: Pat GhcTc -> DsM Id
-selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (VarPat var) = return (localiseId (unLoc var))
+selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat)
+selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat)
+selectMatchVar (ParPat _ pat) = selectMatchVar (unLoc pat)
+selectMatchVar (VarPat _ var) = return (localiseId (unLoc var))
-- Note [Localise pattern binders]
-selectMatchVar (AsPat var _) = return (unLoc var)
-selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat)
+selectMatchVar (AsPat _ var _) = return (unLoc var)
+selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat)
-- OK, better make up one...
{-
@@ -736,7 +738,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
-- and all the desugared binds
mkSelectorBinds ticks pat val_expr
- | L _ (VarPat (L _ v)) <- pat' -- Special case (A)
+ | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A)
= return (v, [(v, val_expr)])
| is_flat_prod_lpat pat' -- Special case (B)
@@ -783,17 +785,17 @@ mkSelectorBinds ticks pat val_expr
strip_bangs :: LPat a -> LPat a
-- Remove outermost bangs and parens
-strip_bangs (L _ (ParPat p)) = strip_bangs p
-strip_bangs (L _ (BangPat p)) = strip_bangs p
-strip_bangs lp = lp
+strip_bangs (L _ (ParPat _ p)) = strip_bangs p
+strip_bangs (L _ (BangPat _ p)) = strip_bangs p
+strip_bangs lp = lp
is_flat_prod_lpat :: LPat a -> Bool
is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)
is_flat_prod_pat :: Pat a -> Bool
-is_flat_prod_pat (ParPat p) = is_flat_prod_lpat p
-is_flat_prod_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
-is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps})
+is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p
+is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
+is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps})
| RealDataCon con <- pcon
, isProductTyCon (dataConTyCon con)
= all is_triv_lpat (hsConPatArgs ps)
@@ -803,10 +805,10 @@ is_triv_lpat :: LPat a -> Bool
is_triv_lpat p = is_triv_pat (unLoc p)
is_triv_pat :: Pat a -> Bool
-is_triv_pat (VarPat _) = True
-is_triv_pat (WildPat _) = True
-is_triv_pat (ParPat p) = is_triv_lpat p
-is_triv_pat _ = False
+is_triv_pat (VarPat {}) = True
+is_triv_pat (WildPat{}) = True
+is_triv_pat (ParPat _ p) = is_triv_lpat p
+is_triv_pat _ = False
{- *********************************************************************
@@ -828,7 +830,7 @@ mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
-- A vanilla tuple pattern simply gets its type from its sub-patterns
-mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
+mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
@@ -983,8 +985,8 @@ mkBinaryTickBox ixT ixF e = do
-- pat => !pat -- when -XStrict
-- pat => pat -- otherwise
decideBangHood :: DynFlags
- -> LPat id -- ^ Original pattern
- -> LPat id -- Pattern with bang if necessary
+ -> LPat GhcTc -- ^ Original pattern
+ -> LPat GhcTc -- Pattern with bang if necessary
decideBangHood dflags lpat
| not (xopt LangExt.Strict dflags)
= lpat
@@ -993,19 +995,20 @@ decideBangHood dflags lpat
where
go lp@(L l p)
= case p of
- ParPat p -> L l (ParPat (go p))
- LazyPat lp' -> lp'
- BangPat _ -> lp
- _ -> L l (BangPat lp)
+ ParPat x p -> L l (ParPat x (go p))
+ LazyPat _ lp' -> lp'
+ BangPat _ _ -> lp
+ _ -> L l (BangPat noExt lp)
-- | Unconditionally make a 'Pat' strict.
-addBang :: LPat id -- ^ Original pattern
- -> LPat id -- ^ Banged pattern
+addBang :: LPat GhcTc -- ^ Original pattern
+ -> LPat GhcTc -- ^ Banged pattern
addBang = go
where
go lp@(L l p)
= case p of
- ParPat p -> L l (ParPat (go p))
- LazyPat lp' -> L l (BangPat lp')
- BangPat _ -> lp
- _ -> L l (BangPat lp)
+ ParPat x p -> L l (ParPat x (go p))
+ LazyPat _ lp' -> L l (BangPat noExt lp')
+ -- Should we bring the extension value over?
+ BangPat _ _ -> lp
+ _ -> L l (BangPat noExt lp)
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 7a3ee6853c..4cb8bf35ba 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -251,7 +251,7 @@ matchBangs [] _ _ = panic "matchBangs"
matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
-- Apply the coercion to the match variable and then match that
matchCoercion (var:vars) ty (eqns@(eqn1:_))
- = do { let CoPat co pat _ = firstPat eqn1
+ = do { let CoPat _ co pat _ = firstPat eqn1
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var pat_ty'
; match_result <- match (var':vars) ty $
@@ -267,7 +267,7 @@ matchView (var:vars) ty (eqns@(eqn1:_))
= do { -- we could pass in the expr from the PgView,
-- but this needs to extract the pat anyway
-- to figure out the type of the fresh variable
- let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
+ let ViewPat _ viewExpr (L _ pat) = firstPat eqn1
-- do the rest of the compilation
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var pat_ty'
@@ -284,7 +284,7 @@ matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
-- Since overloaded list patterns are treated as view patterns,
-- the code is roughly the same as for matchView
- = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1
+ = do { let ListPat _ _ elt_ty (Just (_,e)) = firstPat eqn1
; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand
; match_result <- match (var':vars) ty $
map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
@@ -299,13 +299,13 @@ decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
decomposeFirstPat _ _ = panic "decomposeFirstPat"
getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
-getCoPat (CoPat _ pat _) = pat
+getCoPat (CoPat _ _ pat _) = pat
getCoPat _ = panic "getCoPat"
-getBangPat (BangPat pat ) = unLoc pat
+getBangPat (BangPat _ pat ) = unLoc pat
getBangPat _ = panic "getBangPat"
-getViewPat (ViewPat _ pat _) = unLoc pat
+getViewPat (ViewPat _ _ pat) = unLoc pat
getViewPat _ = panic "getViewPat"
-getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing
+getOLPat (ListPat x pats ty (Just _)) = ListPat x pats ty Nothing
getOLPat _ = panic "getOLPat"
{-
@@ -398,19 +398,19 @@ tidy1 :: Id -- The Id being scrutinised
-- It eliminates many pattern forms (as-patterns, variable patterns,
-- list patterns, etc) and returns any created bindings in the wrapper.
-tidy1 v (ParPat pat) = tidy1 v (unLoc pat)
-tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)
-tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)
-tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p
+tidy1 v (ParPat _ pat) = tidy1 v (unLoc pat)
+tidy1 v (SigPat _ pat) = tidy1 v (unLoc pat)
+tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)
+tidy1 v (BangPat _ (L l p)) = tidy_bang_pat v l p
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
-tidy1 v (VarPat (L _ var))
+tidy1 v (VarPat _ (L _ var))
= return (wrapBind var v, WildPat (idType var))
-- case v of { x@p -> mr[] }
-- = case v of { p -> let x=v in mr[] }
-tidy1 v (AsPat (L _ var) pat)
+tidy1 v (AsPat _ (L _ var) pat)
= do { (wrap, pat') <- tidy1 v (unLoc pat)
; return (wrapBind var v . wrap, pat') }
@@ -425,7 +425,7 @@ tidy1 v (AsPat (L _ var) pat)
The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
-}
-tidy1 v (LazyPat pat)
+tidy1 v (LazyPat _ pat)
-- This is a convenient place to check for unlifted types under a lazy pattern.
-- Doing this check during type-checking is unsatisfactory because we may
-- not fully know the zonked types yet. We sure do here.
@@ -441,7 +441,7 @@ tidy1 v (LazyPat pat)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
; return (mkCoreLets sel_binds, WildPat (idType v)) }
-tidy1 _ (ListPat pats ty Nothing)
+tidy1 _ (ListPat _ pats ty Nothing)
= return (idDsWrapper, unLoc list_ConPat)
where
list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
@@ -450,29 +450,29 @@ tidy1 _ (ListPat pats ty Nothing)
-- Introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
-tidy1 _ (PArrPat pats ty)
+tidy1 _ (PArrPat ty pats)
= return (idDsWrapper, unLoc parrConPat)
where
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]
-tidy1 _ (TuplePat pats boxity tys)
+tidy1 _ (TuplePat tys pats boxity)
= return (idDsWrapper, unLoc tuple_ConPat)
where
arity = length pats
tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
-tidy1 _ (SumPat pat alt arity tys)
+tidy1 _ (SumPat tys pat alt arity)
= return (idDsWrapper, unLoc sum_ConPat)
where
sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys
-- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ (LitPat lit)
+tidy1 _ (LitPat _ lit)
= return (idDsWrapper, tidyLitPat lit)
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ (NPat (L _ lit) mb_neg eq ty)
+tidy1 _ (NPat ty (L _ lit) mb_neg eq)
= return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty)
-- Everything else goes through unchanged...
@@ -484,13 +484,14 @@ tidy1 _ non_interesting_pat
tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
-- Discard par/sig under a bang
-tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p
-tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p
+tidy_bang_pat v _ (ParPat _ (L l p)) = tidy_bang_pat v l p
+tidy_bang_pat v _ (SigPat _ (L l p)) = tidy_bang_pat v l p
-- Push the bang-pattern inwards, in the hope that
-- it may disappear next time
-tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p)))
-tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)
+tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (L l (BangPat noExt p)))
+tidy_bang_pat v l (CoPat x w p t)
+ = tidy1 v (CoPat x w (BangPat noExt (L l p)) t)
-- Discard bang around strict pattern
tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p
@@ -526,7 +527,7 @@ tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
--
-- NB: SigPatIn, ConPatIn should not happen
-tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
+tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (L l p))
-------------------
push_bang_into_newtype_arg :: SrcSpan
@@ -537,15 +538,16 @@ push_bang_into_newtype_arg :: SrcSpan
-- We are transforming !(N p) into (N !p)
push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
= ASSERT( null args)
- PrefixCon [L l (BangPat arg)]
+ PrefixCon [L l (BangPat noExt arg)]
push_bang_into_newtype_arg l _ty (RecCon rf)
| HsRecFields { rec_flds = L lf fld : flds } <- rf
, HsRecField { hsRecFieldArg = arg } <- fld
= ASSERT( null flds)
- RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] })
+ RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg
+ = L l (BangPat noExt arg) })] })
push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
| HsRecFields { rec_flds = [] } <- rf
- = PrefixCon [L l (BangPat (noLoc (WildPat ty)))]
+ = PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))]
push_bang_into_newtype_arg _ _ cd
= pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
@@ -975,18 +977,18 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
-- real comparison is on HsExpr's
-- strip parens
- exp (HsPar (L _ e)) e' = exp e e'
- exp e (HsPar (L _ e')) = exp e e'
+ exp (HsPar _ (L _ e)) e' = exp e e'
+ exp e (HsPar _ (L _ e')) = exp e e'
-- because the expressions do not necessarily have the same type,
-- we have to compare the wrappers
- exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
- exp (HsVar i) (HsVar i') = i == i'
- exp (HsConLikeOut c) (HsConLikeOut c') = c == c'
+ exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'
+ exp (HsVar _ i) (HsVar _ i') = i == i'
+ exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'
-- the instance for IPName derives using the id, so this works if the
-- above does
- exp (HsIPVar i) (HsIPVar i') = i == i'
- exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x'
- exp (HsOverLit l) (HsOverLit l') =
+ exp (HsIPVar _ i) (HsIPVar _ i') = i == i'
+ exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x'
+ exp (HsOverLit _ l) (HsOverLit _ l') =
-- Overloaded lits are equal if they have the same type
-- and the data is the same.
-- this is coarser than comparing the SyntaxExpr's in l and l',
@@ -994,20 +996,20 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-- because these expressions get written as a bunch of different variables
-- (presumably to improve sharing)
eqType (overLitType l) (overLitType l') && l == l'
- exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
+ exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
-- the fixities have been straightened out by now, so it's safe
-- to ignore them?
- exp (OpApp l o _ ri) (OpApp l' o' _ ri') =
+ exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
lexp l l' && lexp o o' && lexp ri ri'
- exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n'
- exp (SectionL e1 e2) (SectionL e1' e2') =
+ exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
+ exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
lexp e1 e1' && lexp e2 e2'
- exp (SectionR e1 e2) (SectionR e1' e2') =
+ exp (SectionR _ e1 e2) (SectionR _ e1' e2') =
lexp e1 e1' && lexp e2 e2'
- exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
+ exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
eq_list tup_arg es1 es2
- exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e'
- exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
+ exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
+ exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') =
lexp e e' && lexp e1 e1' && lexp e2 e2'
-- Enhancement: could implement equality for more expressions
@@ -1029,8 +1031,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
wrap res_wrap1 res_wrap2
---------
- tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2
- tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
+ tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2
+ tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
tup_arg _ _ = False
---------
@@ -1071,7 +1073,7 @@ patGroup _ (ConPatOut { pat_con = L _ con
| PatSynCon psyn <- con = PgSyn psyn tys
patGroup _ (WildPat {}) = PgAny
patGroup _ (BangPat {}) = PgBang
-patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =
+patGroup _ (NPat _ (L _ OverLit {ol_val=oval}) mb_neg _) =
case (oval, isJust mb_neg) of
(HsIntegral i, False) -> PgN (fromInteger (il_value i))
(HsIntegral i, True ) -> PgN (-fromInteger (il_value i))
@@ -1079,14 +1081,15 @@ patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =
(HsFractional r, True ) -> PgN (-fl_value r)
(HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
PgOverS s
-patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) =
+patGroup _ (NPlusKPat _ _ (L _ OverLit {ol_val=oval}) _ _ _) =
case oval of
HsIntegral i -> PgNpK (il_value i)
_ -> pprPanic "patGroup NPlusKPat" (ppr oval)
-patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern
-patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))
-patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList
-patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit)
+patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p)
+ -- Type of innelexp pattern
+patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p))
+patGroup _ (ListPat _ _ _ (Just _)) = PgOverloadedList
+patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit)
patGroup _ pat = pprPanic "patGroup" (ppr pat)
{-
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
index 355927deef..c7bff64ff3 100644
--- a/compiler/deSugar/MatchLit.hs
+++ b/compiler/deSugar/MatchLit.hs
@@ -102,6 +102,8 @@ dsLit (HsRat _ (FL _ _ val) ty) = do
(head (tyConDataCons tycon), i_ty)
x -> pprPanic "dsLit" (ppr x)
+dsLit (XLit x) = pprPanic "dsLit" (ppr x)
+
dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
dsOverLit lit = do { dflags <- getDynFlags
; warnAboutOverflowedLiterals dflags lit
@@ -110,12 +112,12 @@ dsOverLit lit = do { dflags <- getDynFlags
dsOverLit' :: DynFlags -> HsOverLit GhcTc -> DsM CoreExpr
-- Post-typechecker, the HsExpr field of an OverLit contains
-- (an expression for) the literal value itself
-dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
- , ol_witness = witness, ol_type = ty })
+dsOverLit' dflags (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
+ , ol_witness = witness })
| not rebindable
, Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut]
| otherwise = dsExpr witness
-
+dsOverLit' _ XOverLit{} = panic "dsOverLit'"
{-
Note [Literal short cut]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -239,14 +241,14 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
-- See if the expression is an Integral literal
-- Remember to look through automatically-added tick-boxes! (Trac #8384)
-getLHsIntegralLit (L _ (HsPar e)) = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsTick _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsBinTick _ _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
+getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
getLHsIntegralLit _ = Nothing
getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
-getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })
+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
| Just tc <- tyConAppTyCon_maybe ty
= Just (il_value i, tyConName tc)
getIntegralLit _ = Nothing
@@ -273,7 +275,7 @@ tidyLitPat (HsString src s)
(mkNilPat charTy) (unpackFS s)
-- The stringTy is the type of the whole pattern, not
-- the type to instantiate (:) or [] with!
-tidyLitPat lit = LitPat lit
+tidyLitPat lit = LitPat noExt lit
----------------
tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat
@@ -284,7 +286,7 @@ tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat
-> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
-> Type
-> Pat GhcTc
-tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
+tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
-- False: Take short cuts only if the literal is not using rebindable syntax
--
-- Once that is settled, look for cases where the type of the
@@ -313,7 +315,8 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
type_change = not (outer_ty `eqType` ty)
mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
- mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
+ mk_con_pat con lit
+ = unLoc (mkPrefixConPat con [noLoc $ LitPat noExt lit] [])
mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
@@ -327,7 +330,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
_ -> Nothing
tidyNPat _ over_lit mb_neg eq outer_ty
- = NPat (noLoc over_lit) mb_neg eq outer_ty
+ = NPat outer_ty (noLoc over_lit) mb_neg eq
{-
************************************************************************
@@ -361,7 +364,7 @@ matchLiterals (var:vars) ty sub_groups
match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
match_group eqns
= do dflags <- getDynFlags
- let LitPat hs_lit = firstPat (head eqns)
+ let LitPat _ hs_lit = firstPat (head eqns)
match_result <- match vars ty (shiftEqns eqns)
return (hsLitKey dflags hs_lit, match_result)
@@ -409,7 +412,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal
- = do { let NPat (L _ lit) mb_neg eq_chk _ = firstPat eqn1
+ = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
; lit_expr <- dsOverLit lit
; neg_lit <- case mb_neg of
Nothing -> return lit_expr
@@ -440,7 +443,7 @@ We generate:
matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- All NPlusKPats, for the *same* literal k
matchNPlusKPats (var:vars) ty (eqn1:eqns)
- = do { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1
+ = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus = firstPat eqn1
; lit1_expr <- dsOverLit lit1
; lit2_expr <- dsOverLit lit2
; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr]
@@ -452,7 +455,7 @@ matchNPlusKPats (var:vars) ty (eqn1:eqns)
adjustMatchResult (foldr1 (.) wraps) $
match_result) }
where
- shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats })
+ shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
= (wrapBind n n1, eqn { eqn_pats = pats })
-- The wrapBind is a no-op for the first equation
shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs
index aa1bc814c5..f008a31d4b 100644
--- a/compiler/deSugar/PmExpr.hs
+++ b/compiler/deSugar/PmExpr.hs
@@ -236,32 +236,32 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e
hsExprToPmExpr :: HsExpr GhcTc -> PmExpr
-hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x))
-hsExprToPmExpr (HsConLikeOut c) = PmExprVar (conLikeName c)
-hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit)
-hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit)
+hsExprToPmExpr (HsVar _ x) = PmExprVar (idName (unLoc x))
+hsExprToPmExpr (HsConLikeOut _ c) = PmExprVar (conLikeName c)
+hsExprToPmExpr (HsOverLit _ olit) = PmExprLit (PmOLit False olit)
+hsExprToPmExpr (HsLit _ lit) = PmExprLit (PmSLit lit)
-hsExprToPmExpr e@(NegApp _ neg_e)
+hsExprToPmExpr e@(NegApp _ _ neg_e)
| PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e
= PmExprLit (PmOLit True ol)
| otherwise = PmExprOther e
-hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
+hsExprToPmExpr (HsPar _ (L _ e)) = hsExprToPmExpr e
-hsExprToPmExpr e@(ExplicitTuple ps boxity)
+hsExprToPmExpr e@(ExplicitTuple _ ps boxity)
| all tupArgPresent ps = mkPmExprData tuple_con tuple_args
| otherwise = PmExprOther e
where
tuple_con = tupleDataCon boxity (length ps)
- tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ]
+ tuple_args = [ lhsExprToPmExpr e | L _ (Present _ e) <- ps ]
-hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems)
+hsExprToPmExpr e@(ExplicitList _ mb_ol elems)
| Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)
| otherwise = PmExprOther e {- overloaded list: No PmExprApp -}
where
cons x xs = mkPmExprData consDataCon [x,xs]
nil = mkPmExprData nilDataCon []
-hsExprToPmExpr (ExplicitPArr _elem_ty elems)
+hsExprToPmExpr (ExplicitPArr _ elems)
= mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
@@ -272,16 +272,15 @@ hsExprToPmExpr (ExplicitPArr _elem_ty elems)
-- con <- dsLookupDataCon (unLoc c)
-- args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds)
-- return (PmExprCon con args)
-hsExprToPmExpr e@(RecordCon _ _ _ _) = PmExprOther e
-
-hsExprToPmExpr (HsTick _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsBinTick _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsTickPragma _ _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsSCC _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsCoreAnn _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (ExprWithTySig e _) = lhsExprToPmExpr e
-hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e
-hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e
+hsExprToPmExpr e@(RecordCon {}) = PmExprOther e
+
+hsExprToPmExpr (HsTick _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsBinTick _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsTickPragma _ _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsSCC _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsCoreAnn _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (ExprWithTySig _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsWrap _ _ e) = hsExprToPmExpr e
hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
synExprToPmExpr :: SyntaxExpr GhcTc -> PmExpr
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 4336243e91..f20abab5b9 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -8,6 +8,7 @@ This module converts Template Haskell syntax into HsSyn
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
convertToHsType,
@@ -213,7 +214,7 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs)
; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
, tcdDataDefn = defn
- , tcdDataCusk = PlaceHolder
+ , tcdDataCusk = placeHolder
, tcdFVs = placeHolderNames }) }
cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
@@ -229,7 +230,7 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
, tcdDataDefn = defn
- , tcdDataCusk = PlaceHolder
+ , tcdDataCusk = placeHolder
, tcdFVs = placeHolderNames }) }
cvtDec (ClassD ctxt cl tvs fds decs)
@@ -541,7 +542,8 @@ cvtConstr (RecGadtC c varstrtys ty)
= do { c' <- mapM cNameL c
; ty' <- cvtType ty
; rec_flds <- mapM cvt_id_arg varstrtys
- ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
+ ; let rec_ty = noLoc (HsFunTy noExt
+ (noLoc $ HsRecTy noExt rec_flds) ty')
; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
@@ -560,7 +562,7 @@ cvt_arg (Bang su ss, ty)
; ty' <- wrap_apps ty''
; let su' = cvtSrcUnpackedness su
; let ss' = cvtSrcStrictness ss
- ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' }
+ ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }
cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
cvt_id_arg (i, str, ty)
@@ -568,7 +570,7 @@ cvt_id_arg (i, str, ty)
; ty' <- cvt_arg (str,ty)
; return $ noLoc (ConDeclField
{ cd_fld_names
- = [L li $ FieldOcc (L li i') PlaceHolder]
+ = [L li $ FieldOcc noExt (L li i')]
, cd_fld_type = ty'
, cd_fld_doc = Nothing}) }
@@ -753,7 +755,7 @@ cvtLocalDecs doc ds
; let (binds, prob_sigs) = partitionWith is_bind ds'
; let (sigs, bads) = partitionWith is_sig prob_sigs
; unless (null bads) (failWith (mkBadDecMsg doc bads))
- ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
+ ; return (HsValBinds (ValBinds noExt (listToBag binds) sigs)) }
cvtClause :: HsMatchContext RdrName
-> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
@@ -772,77 +774,89 @@ cvtClause ctxt (Clause ps body wheres)
cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
cvtl e = wrapL (cvt e)
where
- cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
- cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') }
+ cvt (VarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
+ cvt (ConE s) = do { s' <- cName s; return $ HsVar noExt (noLoc s') }
cvt (LitE l)
- | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
- | otherwise = do { l' <- cvtLit l; return $ HsLit l' }
+ | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit noExt l' }
+ | otherwise = do { l' <- cvtLit l; return $ HsLit noExt l' }
cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
- ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
+ ; return $ HsApp noExt (mkLHsPar x')
+ (mkLHsPar y')}
cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y
- ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
+ ; return $ HsApp noExt (mkLHsPar x')
+ (mkLHsPar y')}
cvt (AppTypeE e t) = do { e' <- cvtl e
; t' <- cvtType t
; tp <- wrap_apps t'
- ; return $ HsAppType e' $ mkHsWildCardBndrs tp }
+ ; return $ HsAppType (mkHsWildCardBndrs tp) e' }
cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its
-- own expression to avoid pretty-printing
-- oddities that can result from zero-argument
-- lambda expressions. See #13856.
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
- ; return $ HsLam (mkMatchGroup FromSource
+ ; return $ HsLam noExt (mkMatchGroup FromSource
[mkSimpleMatch LambdaExpr ps' e'])}
cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms
- ; return $ HsLamCase (mkMatchGroup FromSource ms')
+ ; return $ HsLamCase noExt
+ (mkMatchGroup FromSource ms')
}
- cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
+ cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar noExt e' }
-- Note [Dropping constructors]
-- Singleton tuples treated like nothing (just parens)
cvt (TupE es) = do { es' <- mapM cvtl es
- ; return $ ExplicitTuple (map (noLoc . Present) es')
- Boxed }
+ ; return $ ExplicitTuple noExt
+ (map (noLoc . (Present noExt)) es')
+ Boxed }
cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
- ; return $ ExplicitTuple
- (map (noLoc . Present) es') Unboxed }
+ ; return $ ExplicitTuple noExt
+ (map (noLoc . (Present noExt)) es')
+ Unboxed }
cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
; unboxedSumChecks alt arity
- ; return $ ExplicitSum
- alt arity e' placeHolderType }
+ ; return $ ExplicitSum noExt
+ alt arity e'}
cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
- ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
+ ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' }
cvt (MultiIfE alts)
| null alts = failWith (text "Multi-way if-expression with no alternatives")
| otherwise = do { alts' <- mapM cvtpair alts
- ; return $ HsMultiIf placeHolderType alts' }
+ ; return $ HsMultiIf noExt alts' }
cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds
- ; e' <- cvtl e; return $ HsLet (noLoc ds') e' }
+ ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'}
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
- ; return $ HsCase e' (mkMatchGroup FromSource ms') }
+ ; return $ HsCase noExt e'
+ (mkMatchGroup FromSource ms') }
cvt (DoE ss) = cvtHsDo DoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss
- cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
+ cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
+ ; return $ ArithSeq noExt Nothing dd' }
cvt (ListE xs)
- | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
+ | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s)
+ ; return (HsLit noExt l') }
-- Note [Converting strings]
| otherwise = do { xs' <- mapM cvtl xs
- ; return $ ExplicitList placeHolderType Nothing xs'
+ ; return $ ExplicitList noExt Nothing xs'
}
-- Infix expressions
cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
- ; wrapParL HsPar $
- OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
+ ; wrapParL (HsPar noExt) $
+ OpApp noExt (mkLHsPar x') s'
+ (mkLHsPar y') }
-- Parenthesise both arguments and result,
-- to ensure this operator application does
-- does not get re-associated
-- See Note [Operator association]
cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
- ; wrapParL HsPar $ SectionR s' y' }
+ ; wrapParL (HsPar noExt)
+ $ SectionR noExt s' y' }
-- See Note [Sections in HsSyn] in HsExpr
cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
- ; wrapParL HsPar $ SectionL x' s' }
+ ; wrapParL (HsPar noExt)
+ $ SectionL noExt x' s' }
- cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }
+ cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s
+ ; return $ HsPar noExt s' }
-- Can I indicate this is an infix thing?
-- Note [Dropping constructors]
@@ -852,9 +866,9 @@ cvtl e = wrapL (cvt e)
_ -> mkLHsPar x'
; cvtOpApp x'' s y } -- Note [Converting UInfix]
- cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' }
+ cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExt e' }
cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
- ; return $ ExprWithTySig e' (mkLHsSigWcType t') }
+ ; return $ ExprWithTySig (mkLHsSigWcType t') e' }
cvt (RecConE c flds) = do { c' <- cNameL c
; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
@@ -863,9 +877,9 @@ cvtl e = wrapL (cvt e)
<- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
flds
; return $ mkRdrRecordUpd e' flds' }
- cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e
- cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
- cvt (LabelE s) = do { return $ HsOverLabel Nothing (fsLit s) }
+ cvt (StaticE e) = fmap (HsStatic noExt) $ cvtl e
+ cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
+ cvt (LabelE s) = do { return $ HsOverLabel noExt Nothing (fsLit s) }
{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -956,7 +970,7 @@ cvtOpApp x op1 (UInfixE y op2 z)
cvtOpApp x op y
= do { op' <- cvtl op
; y' <- cvtl y
- ; return (OpApp x op' undefined y') }
+ ; return (OpApp noExt x op' y') }
-------------------------------------
-- Do notation and statements
@@ -973,7 +987,7 @@ cvtHsDo do_or_lc stmts
L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
_ -> failWith (bad_last last')
- ; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType }
+ ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }
where
bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon
, nest 2 $ Outputable.ppr stmt
@@ -988,8 +1002,9 @@ cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt
cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds
; returnL $ LetStmt (noLoc ds') }
cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType }
- where
- cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
+ where
+ cvt_one ds = do { ds' <- cvtStmts ds
+ ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }
cvtMatch :: HsMatchContext RdrName
-> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
@@ -1015,13 +1030,13 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
cvtOverLit (IntegerL i)
- = do { force i; return $ mkHsIntegral (mkIntegralLit i) placeHolderType}
+ = do { force i; return $ mkHsIntegral (mkIntegralLit i) }
cvtOverLit (RationalL r)
- = do { force r; return $ mkHsFractional (mkFractionalLit r) placeHolderType}
+ = do { force r; return $ mkHsFractional (mkFractionalLit r) }
cvtOverLit (StringL s)
= do { let { s' = mkFastString s }
; force s'
- ; return $ mkHsIsString (quotedSourceText s) s' placeHolderType
+ ; return $ mkHsIsString (quotedSourceText s) s'
}
cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
-- An Integer is like an (overloaded) '3' in a Haskell source program
@@ -1052,9 +1067,9 @@ cvtLit :: Lit -> CvtM (HsLit GhcPs)
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i }
cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w }
cvtLit (FloatPrimL f)
- = do { force f; return $ HsFloatPrim def (mkFractionalLit f) }
+ = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) }
cvtLit (DoublePrimL f)
- = do { force f; return $ HsDoublePrim def (mkFractionalLit f) }
+ = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) }
cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c }
cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c }
cvtLit (StringL s) = do { let { s' = mkFastString s }
@@ -1083,40 +1098,46 @@ cvtp (TH.LitP l)
; return (mkNPat (noLoc l') Nothing) }
-- Not right for negative patterns;
-- need to think about that!
- | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
-cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat (noLoc s') }
-cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
-cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] }
-cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
+ | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExt l' }
+cvtp (TH.VarP s) = do { s' <- vName s
+ ; return $ Hs.VarPat noExt (noLoc s') }
+cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat noExt p' }
+ -- Note [Dropping constructors]
+cvtp (TupP ps) = do { ps' <- cvtPats ps
+ ; return $ TuplePat noExt ps' Boxed }
+cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps
+ ; return $ TuplePat noExt ps' Unboxed }
cvtp (UnboxedSumP p alt arity)
= do { p' <- cvtPat p
; unboxedSumChecks alt arity
- ; return $ SumPat p' alt arity placeHolderType }
+ ; return $ SumPat noExt p' alt arity }
cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps
; pps <- mapM wrap_conpat ps'
; return $ ConPatIn s' (PrefixCon pps) }
cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
- ; wrapParL ParPat $
+ ; wrapParL (ParPat noExt) $
ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
-- See Note [Operator association]
cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
cvtp (ParensP p) = do { p' <- cvtPat p;
; case p' of -- may be wrapped ConPatIn
(L _ (ParPat {})) -> return $ unLoc p'
- _ -> return $ ParPat p' }
-cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
-cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
-cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
-cvtp TH.WildP = return $ WildPat placeHolderType
+ _ -> return $ ParPat noExt p' }
+cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExt p' }
+cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExt p' }
+cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p
+ ; return $ AsPat noExt s' p' }
+cvtp TH.WildP = return $ WildPat noExt
cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
; return $ ConPatIn c'
$ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps) = do { ps' <- cvtPats ps
- ; return $ ListPat ps' placeHolderType Nothing }
+ ; return
+ $ ListPat noExt ps' placeHolderType Nothing }
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
- ; return $ SigPatIn p' (mkLHsSigWcType t') }
+ ; return $ SigPat (mkLHsSigWcType t') p' }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
- ; return $ ViewPat e' p' placeHolderType }
+ ; return $ ViewPat noExt e' p'}
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (s,p)
@@ -1127,9 +1148,9 @@ cvtPatFld (s,p)
, hsRecPun = False}) }
wrap_conpat :: Hs.LPat GhcPs -> CvtM (Hs.LPat GhcPs)
-wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat p
+wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat noExt p
wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p
-wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat p
+wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat noExt p
wrap_conpat p = return p
{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
@@ -1155,11 +1176,11 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
cvt_tv (TH.PlainTV nm)
= do { nm' <- tNameL nm
- ; returnL $ UserTyVar nm' }
+ ; returnL $ UserTyVar noExt nm' }
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tNameL nm
; ki' <- cvtKind ki
- ; returnL $ KindedTyVar nm' ki' }
+ ; returnL $ KindedTyVar noExt nm' ki' }
cvtRole :: TH.Role -> Maybe Coercion.Role
cvtRole TH.NominalR = Just Coercion.Nominal
@@ -1196,17 +1217,18 @@ cvtTypeKind ty_str ty
| tys' `lengthIs` n -- Saturated
-> if n==1 then return (head tys') -- Singleton tuples treated
-- like nothing (ie just parens)
- else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')
+ else returnL (HsTupleTy noExt
+ HsBoxedOrConstraintTuple tys')
| n == 1
-> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
| otherwise
- -> mk_apps (HsTyVar NotPromoted
+ -> mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
UnboxedTupleT n
| tys' `lengthIs` n -- Saturated
- -> returnL (HsTupleTy HsUnboxedTuple tys')
+ -> returnL (HsTupleTy noExt HsUnboxedTuple tys')
| otherwise
- -> mk_apps (HsTyVar NotPromoted
+ -> mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName (tupleTyCon Unboxed n)))) tys'
UnboxedSumT n
| n < 2
@@ -1215,28 +1237,31 @@ cvtTypeKind ty_str ty
, nest 2 $
text "Sums must have an arity of at least 2" ]
| tys' `lengthIs` n -- Saturated
- -> returnL (HsSumTy tys')
+ -> returnL (HsSumTy noExt tys')
| otherwise
- -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n))))
+ -> mk_apps (HsTyVar noExt NotPromoted
+ (noLoc (getRdrName (sumTyCon n))))
tys'
ArrowT
| [x',y'] <- tys' -> do
case x' of
- (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy x')
- ; returnL (HsFunTy x'' y') }
- _ -> returnL (HsFunTy x' y')
+ (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy noExt x')
+ ; returnL (HsFunTy noExt x'' y') }
+ _ -> returnL (HsFunTy noExt x' y')
| otherwise ->
- mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon)))
+ mk_apps (HsTyVar noExt NotPromoted
+ (noLoc (getRdrName funTyCon)))
tys'
ListT
- | [x'] <- tys' -> returnL (HsListTy x')
+ | [x'] <- tys' -> returnL (HsListTy noExt x')
| otherwise ->
- mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon)))
+ mk_apps (HsTyVar noExt NotPromoted
+ (noLoc (getRdrName listTyCon)))
tys'
VarT nm -> do { nm' <- tNameL nm
- ; mk_apps (HsTyVar NotPromoted nm') tys' }
+ ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }
ConT nm -> do { nm' <- tconName nm
- ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
+ ; mk_apps (HsTyVar noExt NotPromoted (noLoc nm')) tys'}
ForallT tvs cxt ty
| null tys'
@@ -1252,11 +1277,11 @@ cvtTypeKind ty_str ty
SigT ty ki
-> do { ty' <- cvtType ty
; ki' <- cvtKind ki
- ; mk_apps (HsKindSig ty' ki') tys'
+ ; mk_apps (HsKindSig noExt ty' ki') tys'
}
LitT lit
- -> returnL (HsTyLit (cvtTyLit lit))
+ -> returnL (HsTyLit noExt (cvtTyLit lit))
WildCardT
-> mk_apps mkAnonWildCardTy tys'
@@ -1265,7 +1290,7 @@ cvtTypeKind ty_str ty
-> do { s' <- tconName s
; t1' <- cvtType t1
; t2' <- cvtType t2
- ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2']
+ ; mk_apps (HsTyVar noExt NotPromoted (noLoc s')) [t1', t2']
}
UInfixT t1 s t2
@@ -1277,46 +1302,46 @@ cvtTypeKind ty_str ty
ParensT t
-> do { t' <- cvtType t
- ; returnL $ HsParTy t'
+ ; returnL $ HsParTy noExt t'
}
PromotedT nm -> do { nm' <- cName nm
- ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
+ ; mk_apps (HsTyVar noExt NotPromoted
+ (noLoc nm')) tys' }
-- Promoted data constructor; hence cName
PromotedTupleT n
| n == 1
-> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
| m == n -- Saturated
- -> do { let kis = replicate m placeHolderKind
- ; returnL (HsExplicitTupleTy kis tys')
- }
+ -> returnL (HsExplicitTupleTy noExt tys')
where
m = length tys'
PromotedNilT
- -> returnL (HsExplicitListTy Promoted placeHolderKind [])
+ -> returnL (HsExplicitListTy noExt Promoted [])
PromotedConsT -- See Note [Representing concrete syntax in types]
-- in Language.Haskell.TH.Syntax
- | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys'
- -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2))
+ | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys'
+ -> returnL (HsExplicitListTy noExt ip (ty1:tys2))
| otherwise
- -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon)))
+ -> mk_apps (HsTyVar noExt NotPromoted
+ (noLoc (getRdrName consDataCon)))
tys'
StarT
- -> returnL (HsTyVar NotPromoted (noLoc
+ -> returnL (HsTyVar noExt NotPromoted (noLoc
(getRdrName liftedTypeKindTyCon)))
ConstraintT
- -> returnL (HsTyVar NotPromoted
+ -> returnL (HsTyVar noExt NotPromoted
(noLoc (getRdrName constraintKindTyCon)))
EqualityT
- | [x',y'] <- tys' -> returnL (HsEqTy x' y')
+ | [x',y'] <- tys' -> returnL (HsEqTy noExt x' y')
| otherwise ->
- mk_apps (HsTyVar NotPromoted
+ mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName eqPrimTyCon))) tys'
_ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
@@ -1328,15 +1353,15 @@ mk_apps head_ty [] = returnL head_ty
mk_apps head_ty (ty:tys) =
do { head_ty' <- returnL head_ty
; p_ty <- add_parens ty
- ; mk_apps (HsAppTy head_ty' p_ty) tys }
+ ; mk_apps (HsAppTy noExt head_ty' p_ty) tys }
where
-- See Note [Adding parens for splices]
add_parens t
- | isCompoundHsType t = returnL (HsParTy t)
+ | isCompoundHsType t = returnL (HsParTy noExt t)
| otherwise = return t
wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs)
-wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t)
+wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t)
wrap_apps t = return t
-- ---------------------------------------------------------------------
@@ -1367,7 +1392,7 @@ mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)
go arg ret_ty = do { ret_ty_l <- returnL ret_ty
- ; return (HsFunTy arg ret_ty_l) }
+ ; return (HsFunTy noExt arg ret_ty_l) }
split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType GhcPs])
split_ty_app ty = go ty []
@@ -1385,17 +1410,17 @@ cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
cvtOpAppT :: LHsType GhcPs -> RdrName -> LHsType GhcPs -> LHsType GhcPs
cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)
= L (combineSrcSpans loc1 loc2) $
- HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2')
+ HsAppsTy noExt (t1' ++ [noLoc $ HsAppInfix noExt (noLoc op)] ++ t2')
where
- t1' | L _ (HsAppsTy t1s) <- t1
+ t1' | L _ (HsAppsTy _ t1s) <- t1
= t1s
| otherwise
- = [noLoc $ HsAppPrefix t1]
+ = [noLoc $ HsAppPrefix noExt t1]
- t2' | L _ (HsAppsTy t2s) <- t2
+ t2' | L _ (HsAppsTy _ t2s) <- t2
= t2s
| otherwise
- = [noLoc $ HsAppPrefix t2]
+ = [noLoc $ HsAppPrefix noExt t2]
cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
cvtKind = cvtTypeKind "kind"
@@ -1435,13 +1460,16 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
| null univs, null reqs = do { l <- getL
; ty' <- cvtType (ForallT exis provs ty)
; return $ L l (HsQualTy { hst_ctxt = L l []
+ , hst_xqual = noExt
, hst_body = ty' }) }
| null reqs = do { l <- getL
; univs' <- hsQTvExplicit <$> cvtTvs univs
; ty' <- cvtType (ForallT exis provs ty)
; let forTy = HsForAllTy { hst_bndrs = univs'
+ , hst_xforall = noExt
, hst_body = L l cxtTy }
cxtTy = HsQualTy { hst_ctxt = L l []
+ , hst_xqual = noExt
, hst_body = ty' }
; return $ L l forTy }
| otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty))
@@ -1491,15 +1519,16 @@ mkHsForAllTy :: [TH.TyVarBndr]
-> SrcSpan
-- ^ The location of the returned 'LHsType' if it needs an
-- explicit forall
- -> LHsQTyVars name
+ -> LHsQTyVars GhcPs
-- ^ The converted type variable binders
- -> LHsType name
+ -> LHsType GhcPs
-- ^ The converted rho type
- -> LHsType name
+ -> LHsType GhcPs
-- ^ The complete type, quantified with a forall if necessary
mkHsForAllTy tvs loc tvs' rho_ty
| null tvs = rho_ty
| otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
+ , hst_xforall = noExt
, hst_body = rho_ty }
-- | If passed an empty 'TH.Cxt', this simply returns the third argument
@@ -1514,15 +1543,16 @@ mkHsQualTy :: TH.Cxt
-> SrcSpan
-- ^ The location of the returned 'LHsType' if it needs an
-- explicit context
- -> LHsContext name
+ -> LHsContext GhcPs
-- ^ The converted context
- -> LHsType name
+ -> LHsType GhcPs
-- ^ The converted tau type
- -> LHsType name
+ -> LHsType GhcPs
-- ^ The complete type, qualified with a context if necessary
mkHsQualTy ctxt loc ctxt' ty
| null ctxt = ty
- | otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty }
+ | otherwise = L loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
+ , hst_body = ty }
--------------------------------------------------------------------
-- Turning Name back into RdrName
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 0dc5dd08ba..10e1307367 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -14,6 +14,9 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
module HsBinds where
@@ -24,6 +27,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
GRHSs, pprPatBind )
import {-# SOURCE #-} HsPat ( LPat )
+import PlaceHolder
import HsExtension
import HsTypes
import PprCore ()
@@ -88,7 +92,7 @@ data HsLocalBindsLR idL idR
type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)
-deriving instance (DataId idL, DataId idR) => Data (HsLocalBindsLR idL idR)
+deriving instance (DataIdLR idL idR) => Data (HsLocalBindsLR idL idR)
-- | Haskell Value Bindings
type HsValBinds id = HsValBindsLR id id
@@ -103,18 +107,34 @@ data HsValBindsLR idL idR
-- Before renaming RHS; idR is always RdrName
-- Not dependency analysed
-- Recursive by default
- ValBindsIn
+ ValBinds
+ (XValBinds idL idR)
(LHsBindsLR idL idR) [LSig idR]
-- | Value Bindings Out
--
-- After renaming RHS; idR can be Name or Id Dependency analysed,
-- later bindings in the list may depend on earlier ones.
- | ValBindsOut
- [(RecFlag, LHsBinds idL)]
- [LSig GhcRn] -- AZ: how to do this?
+ | XValBindsLR
+ (XXValBindsLR idL idR)
-deriving instance (DataId idL, DataId idR) => Data (HsValBindsLR idL idR)
+deriving instance (DataIdLR idL idR) => Data (HsValBindsLR idL idR)
+
+-- ---------------------------------------------------------------------
+-- Deal with ValBindsOut
+
+-- TODO: make this the only type for ValBinds
+data NHsValBindsLR idL
+ = NValBinds
+ [(RecFlag, LHsBinds idL)]
+ [LSig GhcRn]
+deriving instance (DataIdLR idL idL) => Data (NHsValBindsLR idL)
+
+type instance XValBinds (GhcPass pL) (GhcPass pR) = PlaceHolder
+type instance XXValBindsLR (GhcPass pL) (GhcPass pR)
+ = NHsValBindsLR (GhcPass pL)
+
+-- ---------------------------------------------------------------------
-- | Located Haskell Binding
type LHsBind id = LHsBindLR id id
@@ -285,7 +305,7 @@ data HsBindLR idL idR
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR)
+deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR)
-- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
--
@@ -325,7 +345,7 @@ data PatSynBind idL idR
psb_def :: LPat idR, -- ^ Right-hand side
psb_dir :: HsPatSynDir idR -- ^ Directionality
}
-deriving instance (DataId idL, DataId idR) => Data (PatSynBind idL idR)
+deriving instance (DataIdLR idL idR) => Data (PatSynBind idL idR)
{-
Note [AbsBinds]
@@ -560,20 +580,20 @@ Specifically,
it's just an error thunk
-}
-instance (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => Outputable (HsLocalBindsLR idL idR) where
+instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => Outputable (HsLocalBindsLR (GhcPass idL) (GhcPass idR)) where
ppr (HsValBinds bs) = ppr bs
ppr (HsIPBinds bs) = ppr bs
ppr EmptyLocalBinds = empty
-instance (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => Outputable (HsValBindsLR idL idR) where
- ppr (ValBindsIn binds sigs)
+instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => Outputable (HsValBindsLR (GhcPass idL) (GhcPass idR)) where
+ ppr (ValBinds _ binds sigs)
= pprDeclList (pprLHsBindsForUser binds sigs)
- ppr (ValBindsOut sccs sigs)
+ ppr (XValBindsLR (NValBinds sccs sigs))
= getPprStyle $ \ sty ->
if debugStyle sty then -- Print with sccs showing
vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
@@ -584,17 +604,19 @@ instance (SourceTextX idL, SourceTextX idR,
pp_rec Recursive = text "rec"
pp_rec NonRecursive = text "nonrec"
-pprLHsBinds :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => LHsBindsLR idL idR -> SDoc
+pprLHsBinds :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprLHsBinds binds
| isEmptyLHsBinds binds = empty
| otherwise = pprDeclList (map ppr (bagToList binds))
-pprLHsBindsForUser :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR,
- SourceTextX id2, OutputableBndrId id2)
- => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
+pprLHsBindsForUser :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL),
+ OutputableBndrId (GhcPass idR),
+ SourceTextX (GhcPass id2),
+ OutputableBndrId (GhcPass id2))
+ => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc]
-- pprLHsBindsForUser is different to pprLHsBinds because
-- a) No braces: 'let' and 'where' include a list of HsBindGroups
-- and we don't want several groups of bindings each
@@ -626,7 +648,7 @@ pprDeclList ds = pprDeeperList vcat ds
emptyLocalBinds :: HsLocalBindsLR a b
emptyLocalBinds = EmptyLocalBinds
-isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
+isEmptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool
isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
isEmptyLocalBinds EmptyLocalBinds = True
@@ -635,13 +657,13 @@ eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
eqEmptyLocalBinds EmptyLocalBinds = True
eqEmptyLocalBinds _ = False
-isEmptyValBinds :: HsValBindsLR a b -> Bool
-isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
-isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
+isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool
+isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs
+isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs
-emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
-emptyValBindsIn = ValBindsIn emptyBag []
-emptyValBindsOut = ValBindsOut [] []
+emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b)
+emptyValBindsIn = ValBinds noExt emptyBag []
+emptyValBindsOut = XValBindsLR (NValBinds [] [])
emptyLHsBinds :: LHsBindsLR idL idR
emptyLHsBinds = emptyBag
@@ -650,22 +672,24 @@ isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
isEmptyLHsBinds = isEmptyBag
------------
-plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
-plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
- = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
-plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
- = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
+plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
+ -> HsValBinds(GhcPass a)
+plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)
+ = ValBinds noExt (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
+plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))
+ (XValBindsLR (NValBinds ds2 sigs2))
+ = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2))
plusHsValBinds _ _
= panic "HsBinds.plusHsValBinds"
-instance (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => Outputable (HsBindLR idL idR) where
+instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => Outputable (HsBindLR (GhcPass idL) (GhcPass idR)) where
ppr mbind = ppr_monobind mbind
-ppr_monobind :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => HsBindLR idL idR -> SDoc
+ppr_monobind :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
= pprPatBind pat grhss
@@ -705,9 +729,9 @@ instance (OutputableBndrId p) => Outputable (ABExport p) where
, nest 2 (pprTcSpecPrags prags)
, nest 2 (text "wrap:" <+> ppr wrap)]
-instance (SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => Outputable (PatSynBind idL idR) where
+instance (SourceTextX (GhcPass idR),
+ OutputableBndrId idL, OutputableBndrId (GhcPass idR))
+ => Outputable (PatSynBind idL (GhcPass idR)) where
ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
psb_dir = dir })
= ppr_lhs <+> ppr_rhs
@@ -752,7 +776,7 @@ data HsIPBinds id
[LIPBind id]
TcEvBinds -- Only in typechecker output; binds
-- uses of the implicit parameters
-deriving instance (DataId id) => Data (HsIPBinds id)
+deriving instance (DataIdLR id id) => Data (HsIPBinds id)
isEmptyIPBinds :: HsIPBinds id -> Bool
isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
@@ -776,13 +800,15 @@ type LIPBind id = Located (IPBind id)
-- For details on above see note [Api annotations] in ApiAnnotation
data IPBind id
= IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id)
-deriving instance (DataId name) => Data (IPBind name)
+deriving instance (DataIdLR id id) => Data (IPBind id)
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsIPBinds (GhcPass p)) where
ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
$$ whenPprDebug (ppr ds)
-instance (SourceTextX p, OutputableBndrId p ) => Outputable (IPBind p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p) )
+ => Outputable (IPBind (GhcPass p)) where
ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
where name = case lr of
Left (L _ ip) -> pprBndr LetBind ip
@@ -948,7 +974,7 @@ data Sig pass
(Located [Located (IdP pass)])
(Maybe (Located (IdP pass)))
-deriving instance (DataId pass) => Data (Sig pass)
+deriving instance (DataIdLR pass pass) => Data (Sig pass)
-- | Located Fixity Signature
type LFixitySig pass = Located (FixitySig pass)
@@ -1055,11 +1081,12 @@ signatures. Since some of the signatures contain a list of names, testing for
equality is not enough -- we have to check if they overlap.
-}
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (Sig pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (Sig (GhcPass p)) where
ppr sig = ppr_sig sig
-ppr_sig :: (SourceTextX pass, OutputableBndrId pass ) => Sig pass -> SDoc
+ppr_sig :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p) )
+ => Sig (GhcPass p) -> SDoc
ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (ClassOpSig is_deflt vars ty)
| is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
@@ -1241,4 +1268,4 @@ data HsPatSynDir id
= Unidirectional
| ImplicitBidirectional
| ExplicitBidirectional (MatchGroup id (LHsExpr id))
-deriving instance (DataId id) => Data (HsPatSynDir id)
+deriving instance (DataIdLR id id) => Data (HsPatSynDir id)
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 55d43fd058..9e05a3d1c1 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -101,7 +101,7 @@ import Name
import BasicTypes
import Coercion
import ForeignCall
-import PlaceHolder ( PlaceHolder(..) )
+import PlaceHolder ( PlaceHolder, placeHolder )
import HsExtension
import NameSet
@@ -149,7 +149,7 @@ data HsDecl id
-- (Includes quasi-quotes)
| DocD (DocDecl) -- ^ Documentation comment declaration
| RoleAnnotD (RoleAnnotDecl id) -- ^ Role annotation declaration
-deriving instance (DataId id) => Data (HsDecl id)
+deriving instance (DataIdLR id id) => Data (HsDecl id)
-- NB: all top-level fixity decls are contained EITHER
@@ -195,9 +195,9 @@ data HsGroup id
hs_docs :: [LDocDecl]
}
-deriving instance (DataId id) => Data (HsGroup id)
+deriving instance (DataIdLR id id) => Data (HsGroup id)
-emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
+emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass a)
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
@@ -212,7 +212,8 @@ emptyGroup = HsGroup { hs_tyclds = [],
hs_splcds = [],
hs_docs = [] }
-appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
+appendGroups :: HsGroup (GhcPass a) -> HsGroup (GhcPass a)
+ -> HsGroup (GhcPass a)
appendGroups
HsGroup {
hs_valds = val_groups1,
@@ -255,8 +256,8 @@ appendGroups
hs_vects = vects1 ++ vects2,
hs_docs = docs1 ++ docs2 }
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsDecl (GhcPass p)) where
ppr (TyClD dcl) = ppr dcl
ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def
@@ -272,8 +273,8 @@ instance (SourceTextX pass, OutputableBndrId pass)
ppr (DocD doc) = ppr doc
ppr (RoleAnnotD ra) = ppr ra
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsGroup pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsGroup (GhcPass p)) where
ppr (HsGroup { hs_valds = val_decls,
hs_tyclds = tycl_decls,
hs_derivds = deriv_decls,
@@ -315,10 +316,10 @@ data SpliceDecl id
= SpliceDecl -- Top level splice
(Located (HsSplice id))
SpliceExplicitFlag
-deriving instance (DataId id) => Data (SpliceDecl id)
+deriving instance (DataIdLR id id) => Data (SpliceDecl id)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (SpliceDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (SpliceDecl (GhcPass p)) where
ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f
{-
@@ -538,7 +539,7 @@ data TyClDecl pass
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId id) => Data (TyClDecl id)
+deriving instance (DataIdLR id id) => Data (TyClDecl id)
-- Simple classifiers for TyClDecl
@@ -633,17 +634,17 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
= hsTvbAllKinded tyvars && rhs_annotated rhs
where
rhs_annotated (L _ ty) = case ty of
- HsParTy lty -> rhs_annotated lty
- HsKindSig {} -> True
- _ -> False
+ HsParTy _ lty -> rhs_annotated lty
+ HsKindSig {} -> True
+ _ -> False
hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk
hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
-- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (TyClDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (TyClDecl (GhcPass p)) where
ppr (FamDecl { tcdFam = decl }) = ppr decl
ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
@@ -674,8 +675,8 @@ instance (SourceTextX pass, OutputableBndrId pass)
<+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context)
<+> pprFundeps (map unLoc fds)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (TyClGroup pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (TyClGroup (GhcPass p)) where
ppr (TyClGroup { group_tyclds = tyclds
, group_roles = roles
, group_instds = instds
@@ -685,11 +686,11 @@ instance (SourceTextX pass, OutputableBndrId pass)
ppr roles $$
ppr instds
-pp_vanilla_decl_head :: (SourceTextX pass, OutputableBndrId pass)
- => Located (IdP pass)
- -> LHsQTyVars pass
+pp_vanilla_decl_head :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Located (IdP (GhcPass p))
+ -> LHsQTyVars (GhcPass p)
-> LexicalFixity
- -> HsContext pass
+ -> HsContext (GhcPass p)
-> SDoc
pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context
= hsep [pprHsContext context, pp_tyvars tyvars]
@@ -783,7 +784,7 @@ data TyClGroup pass -- See Note [TyClGroups and dependency analysis]
= TyClGroup { group_tyclds :: [LTyClDecl pass]
, group_roles :: [LRoleAnnotDecl pass]
, group_instds :: [LInstDecl pass] }
-deriving instance (DataId id) => Data (TyClGroup id)
+deriving instance (DataIdLR id id) => Data (TyClGroup id)
emptyTyClGroup :: TyClGroup pass
emptyTyClGroup = TyClGroup [] [] []
@@ -899,7 +900,7 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig]
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (FamilyResultSig pass)
+deriving instance (DataIdLR pass pass) => Data (FamilyResultSig pass)
-- | Located type Family Declaration
type LFamilyDecl pass = Located (FamilyDecl pass)
@@ -922,7 +923,7 @@ data FamilyDecl pass = FamilyDecl
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId id) => Data (FamilyDecl id)
+deriving instance (DataIdLR id id) => Data (FamilyDecl id)
-- | Located Injectivity Annotation
type LInjectivityAnn pass = Located (InjectivityAnn pass)
@@ -949,7 +950,7 @@ data FamilyInfo pass
-- | 'Nothing' if we're in an hs-boot file and the user
-- said "type family Foo x where .."
| ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
-deriving instance (DataId pass) => Data (FamilyInfo pass)
+deriving instance (DataIdLR pass pass) => Data (FamilyInfo pass)
-- | Does this family declaration have a complete, user-supplied kind signature?
famDeclHasCusk :: Maybe Bool
@@ -964,21 +965,21 @@ famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
-- | Does this family declaration have user-supplied return kind signature?
hasReturnKindSignature :: FamilyResultSig a -> Bool
-hasReturnKindSignature NoSig = False
-hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False
-hasReturnKindSignature _ = True
+hasReturnKindSignature NoSig = False
+hasReturnKindSignature (TyVarSig (L _ UserTyVar{})) = False
+hasReturnKindSignature _ = True
-- | Maybe return name of the result type variable
resultVariableName :: FamilyResultSig a -> Maybe (IdP a)
resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig
resultVariableName _ = Nothing
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (FamilyDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (FamilyDecl (GhcPass p)) where
ppr = pprFamilyDecl TopLevel
-pprFamilyDecl :: (SourceTextX pass, OutputableBndrId pass)
- => TopLevelFlag -> FamilyDecl pass -> SDoc
+pprFamilyDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc
pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
, fdTyVars = tyvars
, fdFixity = fixity
@@ -1057,7 +1058,7 @@ data HsDataDefn pass -- The payload of a data type defn
-- For details on above see note [Api annotations] in ApiAnnotation
}
-deriving instance (DataId id) => Data (HsDataDefn id)
+deriving instance (DataIdLR id id) => Data (HsDataDefn id)
-- | Haskell Deriving clause
type HsDeriving pass = Located [LHsDerivingClause pass]
@@ -1093,10 +1094,10 @@ data HsDerivingClause pass
--
-- should produce a derived instance for @C [a] (T b)@.
}
-deriving instance (DataId id) => Data (HsDerivingClause id)
+deriving instance (DataIdLR id id) => Data (HsDerivingClause id)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsDerivingClause pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsDerivingClause (GhcPass p)) where
ppr (HsDerivingClause { deriv_clause_strategy = dcs
, deriv_clause_tys = L _ dct })
= hsep [ text "deriving"
@@ -1176,7 +1177,7 @@ data ConDecl pass
, con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment.
}
-deriving instance (DataId pass) => Data (ConDecl pass)
+deriving instance (DataIdLR pass pass) => Data (ConDecl pass)
-- | Haskell data Constructor Declaration Details
type HsConDeclDetails pass
@@ -1204,7 +1205,7 @@ gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs)
(tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
(details, res_ty) -- See Note [Sorting out the result type]
= case tau of
- L _ (HsFunTy (L l (HsRecTy flds)) res_ty')
+ L _ (HsFunTy _ (L l (HsRecTy _ flds)) res_ty')
-> (RecCon (L l flds), res_ty')
_other -> (PrefixCon [], tau)
@@ -1213,9 +1214,9 @@ hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds)
-pp_data_defn :: (SourceTextX pass, OutputableBndrId pass)
- => (HsContext pass -> SDoc) -- Printing the header
- -> HsDataDefn pass
+pp_data_defn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => (HsContext (GhcPass p) -> SDoc) -- Printing the header
+ -> HsDataDefn (GhcPass p)
-> SDoc
pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
, dd_cType = mb_ct
@@ -1237,26 +1238,27 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
Just kind -> dcolon <+> ppr kind
pp_derivings (L _ ds) = vcat (map ppr ds)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsDataDefn pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsDataDefn (GhcPass p)) where
ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
instance Outputable NewOrData where
ppr NewType = text "newtype"
ppr DataType = text "data"
-pp_condecls :: (SourceTextX pass, OutputableBndrId pass)
- => [LConDecl pass] -> SDoc
+pp_condecls :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => [LConDecl (GhcPass p)] -> SDoc
pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax
= hang (text "where") 2 (vcat (map ppr cs))
pp_condecls cs -- In H98 syntax
= equals <+> sep (punctuate (text " |") (map ppr cs))
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ConDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (ConDecl (GhcPass p)) where
ppr = pprConDecl
-pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc
+pprConDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => ConDecl (GhcPass p) -> SDoc
pprConDecl (ConDeclH98 { con_name = L _ con
, con_qvars = mtvs
, con_cxt = mcxt
@@ -1381,7 +1383,7 @@ newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
-- 'ApiAnnotation.AnnInstance',
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance DataId pass => Data (TyFamInstDecl pass)
+deriving instance DataIdLR pass pass => Data (TyFamInstDecl pass)
----------------- Data family instances -------------
@@ -1399,7 +1401,7 @@ newtype DataFamInstDecl pass
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance DataId pass => Data (DataFamInstDecl pass)
+deriving instance DataIdLR pass pass => Data (DataFamInstDecl pass)
----------------- Family instances (common types) -------------
@@ -1459,7 +1461,7 @@ data ClsInstDecl pass
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId id) => Data (ClsInstDecl id)
+deriving instance (DataIdLR id id) => Data (ClsInstDecl id)
----------------- Instances of all kinds -------------
@@ -1475,14 +1477,14 @@ data InstDecl pass -- Both class and family instances
{ dfid_inst :: DataFamInstDecl pass }
| TyFamInstD -- type family instance
{ tfid_inst :: TyFamInstDecl pass }
-deriving instance (DataId id) => Data (InstDecl id)
+deriving instance (DataIdLR id id) => Data (InstDecl id)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (TyFamInstDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (TyFamInstDecl (GhcPass p)) where
ppr = pprTyFamInstDecl TopLevel
-pprTyFamInstDecl :: (SourceTextX pass, OutputableBndrId pass)
- => TopLevelFlag -> TyFamInstDecl pass -> SDoc
+pprTyFamInstDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc
pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
= text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn
@@ -1490,16 +1492,16 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc
ppr_instance_keyword TopLevel = text "instance"
ppr_instance_keyword NotTopLevel = empty
-ppr_fam_inst_eqn :: (SourceTextX pass, OutputableBndrId pass)
- => TyFamInstEqn pass -> SDoc
+ppr_fam_inst_eqn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => TyFamInstEqn (GhcPass p) -> SDoc
ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = rhs }})
= pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs
-ppr_fam_deflt_eqn :: (SourceTextX pass, OutputableBndrId pass)
- => LTyFamDefltEqn pass -> SDoc
+ppr_fam_deflt_eqn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LTyFamDefltEqn (GhcPass p) -> SDoc
ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon
, feqn_pats = tvs
, feqn_fixity = fixity
@@ -1507,12 +1509,12 @@ ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon
= text "type" <+> pp_vanilla_decl_head tycon tvs fixity []
<+> equals <+> ppr rhs
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (DataFamInstDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (DataFamInstDecl (GhcPass p)) where
ppr = pprDataFamInstDecl TopLevel
-pprDataFamInstDecl :: (SourceTextX pass, OutputableBndrId pass)
- => TopLevelFlag -> DataFamInstDecl pass -> SDoc
+pprDataFamInstDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc
pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_tycon = tycon
, feqn_pats = pats
@@ -1528,12 +1530,12 @@ pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}})
= ppr nd
-pprFamInstLHS :: (SourceTextX pass, OutputableBndrId pass)
- => Located (IdP pass)
- -> HsTyPats pass
+pprFamInstLHS :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Located (IdP (GhcPass p))
+ -> HsTyPats (GhcPass p)
-> LexicalFixity
- -> HsContext pass
- -> Maybe (LHsKind pass)
+ -> HsContext (GhcPass p)
+ -> Maybe (LHsKind (GhcPass p))
-> SDoc
pprFamInstLHS thing typats fixity context mb_kind_sig
-- explicit type patterns
@@ -1553,8 +1555,8 @@ pprFamInstLHS thing typats fixity context mb_kind_sig
| otherwise
= empty
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ClsInstDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (ClsInstDecl (GhcPass p)) where
ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
, cid_sigs = sigs, cid_tyfam_insts = ats
, cid_overlap_mode = mbOverlap
@@ -1592,8 +1594,8 @@ ppOverlapPragma mb =
maybe_stext (SourceText src) _ = text src <+> text "#-}"
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (InstDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (InstDecl (GhcPass p)) where
ppr (ClsInstD { cid_inst = decl }) = ppr decl
ppr (TyFamInstD { tfid_inst = decl }) = ppr decl
ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
@@ -1632,10 +1634,10 @@ data DerivDecl pass = DerivDecl
-- For details on above see note [Api annotations] in ApiAnnotation
}
-deriving instance (DataId pass) => Data (DerivDecl pass)
+deriving instance (DataIdLR pass pass) => Data (DerivDecl pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (DerivDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (DerivDecl (GhcPass p)) where
ppr (DerivDecl { deriv_type = ty
, deriv_strategy = ds
, deriv_overlap_mode = o })
@@ -1667,10 +1669,10 @@ data DefaultDecl pass
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (DefaultDecl pass)
+deriving instance (DataIdLR pass pass) => Data (DefaultDecl pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (DefaultDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (DefaultDecl (GhcPass p)) where
ppr (DefaultDecl tys)
= text "default" <+> parens (interpp'SP tys)
@@ -1712,7 +1714,7 @@ data ForeignDecl pass
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (ForeignDecl pass)
+deriving instance (DataIdLR pass pass) => Data (ForeignDecl pass)
{-
In both ForeignImport and ForeignExport:
sig_ty is the type given in the Haskell code
@@ -1723,10 +1725,10 @@ deriving instance (DataId pass) => Data (ForeignDecl pass)
-}
noForeignImportCoercionYet :: PlaceHolder
-noForeignImportCoercionYet = PlaceHolder
+noForeignImportCoercionYet = placeHolder
noForeignExportCoercionYet :: PlaceHolder
-noForeignExportCoercionYet = PlaceHolder
+noForeignExportCoercionYet = placeHolder
-- Specification Of an imported external entity in dependence on the calling
-- convention
@@ -1773,8 +1775,8 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling
-- pretty printing of foreign declarations
--
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ForeignDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (ForeignDecl (GhcPass p)) where
ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })
= hang (text "foreign import" <+> ppr fimport <+> ppr n)
2 (dcolon <+> ppr ty)
@@ -1829,7 +1831,7 @@ type LRuleDecls pass = Located (RuleDecls pass)
-- | Rule Declarations
data RuleDecls pass = HsRules { rds_src :: SourceText
, rds_rules :: [LRuleDecl pass] }
-deriving instance (DataId pass) => Data (RuleDecls pass)
+deriving instance (DataIdLR pass pass) => Data (RuleDecls pass)
-- | Located Rule Declaration
type LRuleDecl pass = Located (RuleDecl pass)
@@ -1855,7 +1857,7 @@ data RuleDecl pass
-- 'ApiAnnotation.AnnEqual',
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (RuleDecl pass)
+deriving instance (DataIdLR pass pass) => Data (RuleDecl pass)
flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass]
flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
@@ -1872,7 +1874,7 @@ data RuleBndr pass
-- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (RuleBndr pass)
+deriving instance (DataIdLR pass pass) => Data (RuleBndr pass)
collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
@@ -1880,14 +1882,14 @@ collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
pprFullRuleName :: Located (SourceText, RuleName) -> SDoc
pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (RuleDecls pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (RuleDecls (GhcPass p)) where
ppr (HsRules st rules)
= pprWithSourceText st (text "{-# RULES")
<+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (RuleDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (RuleDecl (GhcPass p)) where
ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
= sep [pprFullRuleName name <+> ppr act,
nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
@@ -1896,8 +1898,8 @@ instance (SourceTextX pass, OutputableBndrId pass)
pp_forall | null ns = empty
| otherwise = forAllLit <+> fsep (map ppr ns) <> dot
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (RuleBndr pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (RuleBndr (GhcPass p)) where
ppr (RuleBndr name) = ppr name
ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty)
@@ -1965,7 +1967,7 @@ data VectDecl pass
(LHsSigType pass)
| HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now
ClsInst
-deriving instance (DataId pass) => Data (VectDecl pass)
+deriving instance (DataIdLR pass pass) => Data (VectDecl pass)
lvectDeclName :: NamedThing (IdP pass) => LVectDecl pass -> Name
lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name
@@ -1984,8 +1986,8 @@ lvectInstDecl (L _ (HsVectInstIn _)) = True
lvectInstDecl (L _ (HsVectInstOut _)) = True
lvectInstDecl _ = False
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (VectDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (VectDecl (GhcPass p)) where
ppr (HsVect _ v rhs)
= sep [text "{-# VECTORISE" <+> ppr v,
nest 4 $
@@ -2104,10 +2106,10 @@ data AnnDecl pass = HsAnnotation
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (AnnDecl pass)
+deriving instance (DataIdLR pass pass) => Data (AnnDecl pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (AnnDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (AnnDecl (GhcPass p)) where
ppr (HsAnnotation _ provenance expr)
= hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index fedaa4491a..6b3440ae8b 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -11,6 +11,8 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
-- | Abstract Haskell syntax for expressions.
module HsExpr where
@@ -20,6 +22,7 @@ module HsExpr where
-- friends:
import GhcPrelude
+import PlaceHolder
import HsDecls
import HsPat
import HsLit
@@ -82,7 +85,7 @@ type PostTcExpr = HsExpr GhcTc
type PostTcTable = [(Name, PostTcExpr)]
noPostTcExpr :: PostTcExpr
-noPostTcExpr = HsLit (HsString noSourceText (fsLit "noPostTcExpr"))
+noPostTcExpr = HsLit noExt (HsString noSourceText (fsLit "noPostTcExpr"))
noPostTcTable :: PostTcTable
noPostTcTable = []
@@ -109,17 +112,17 @@ noPostTcTable = []
data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p
, syn_arg_wraps :: [HsWrapper]
, syn_res_wrap :: HsWrapper }
-deriving instance (DataId p) => Data (SyntaxExpr p)
+deriving instance (DataIdLR p p) => Data (SyntaxExpr p)
-- | This is used for rebindable-syntax pieces that are too polymorphic
-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)
-noExpr :: SourceTextX p => HsExpr p
-noExpr = HsLit (HsString (sourceText "noExpr") (fsLit "noExpr"))
+noExpr :: SourceTextX (GhcPass p) => HsExpr (GhcPass p)
+noExpr = HsLit noExt (HsString (sourceText "noExpr") (fsLit "noExpr"))
-noSyntaxExpr :: SourceTextX p => SyntaxExpr p
+noSyntaxExpr :: SourceTextX (GhcPass p) => SyntaxExpr (GhcPass p)
-- Before renaming, and sometimes after,
-- (if the syntax slot makes no sense)
-noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString noSourceText
+noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExt (HsString noSourceText
(fsLit "noSyntaxExpr"))
, syn_arg_wraps = []
, syn_res_wrap = WpHole }
@@ -127,13 +130,14 @@ noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString noSourceText
-- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the
-- renamer), missing its HsWrappers.
mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn
-mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name
+mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar noExt $ noLoc name
, syn_arg_wraps = []
, syn_res_wrap = WpHole }
-- don't care about filling in syn_arg_wraps because we're clearly
-- not past the typechecker
-instance (SourceTextX p, OutputableBndrId p) => Outputable (SyntaxExpr p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (SyntaxExpr (GhcPass p)) where
ppr (SyntaxExpr { syn_expr = expr
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap })
@@ -277,11 +281,13 @@ information to use is the GlobalRdrEnv itself.
-- | A Haskell expression.
data HsExpr p
- = HsVar (Located (IdP p)) -- ^ Variable
+ = HsVar (XVar p)
+ (Located (IdP p)) -- ^ Variable
-- See Note [Located RdrNames]
- | HsUnboundVar UnboundVar -- ^ Unbound variable; also used for "holes"
+ | HsUnboundVar (XUnboundVar p)
+ UnboundVar -- ^ Unbound variable; also used for "holes"
-- (_ or _x).
-- Turned from HsVar to HsUnboundVar by the
-- renamer, when it finds an out-of-scope
@@ -289,24 +295,31 @@ data HsExpr p
-- Turned into HsVar by type checker, to support
-- deferred type errors.
- | HsConLikeOut ConLike -- ^ After typechecker only; must be different
+ | HsConLikeOut (XConLikeOut p)
+ ConLike -- ^ After typechecker only; must be different
-- HsVar for pretty printing
- | HsRecFld (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector
+ | HsRecFld (XRecFld p)
+ (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector
-- Not in use after typechecking
- | HsOverLabel (Maybe (IdP p)) FastString
+ | HsOverLabel (XOverLabel p)
+ (Maybe (IdP p)) FastString
-- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)
-- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the
-- in-scope 'fromLabel'.
-- NB: Not in use after typechecking
- | HsIPVar HsIPName -- ^ Implicit parameter (not in use after typechecking)
- | HsOverLit (HsOverLit p) -- ^ Overloaded literals
+ | HsIPVar (XIPVar p)
+ HsIPName -- ^ Implicit parameter (not in use after typechecking)
+ | HsOverLit (XOverLitE p)
+ (HsOverLit p) -- ^ Overloaded literals
- | HsLit (HsLit p) -- ^ Simple (non-overloaded) literals
+ | HsLit (XLitE p)
+ (HsLit p) -- ^ Simple (non-overloaded) literals
- | HsLam (MatchGroup p (LHsExpr p))
+ | HsLam (XLam p)
+ (MatchGroup p (LHsExpr p))
-- ^ Lambda abstraction. Currently always a single match
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
@@ -314,7 +327,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsLamCase (MatchGroup p (LHsExpr p)) -- ^ Lambda-case
+ | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
-- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen',
@@ -322,28 +335,24 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsApp (LHsExpr p) (LHsExpr p) -- ^ Application
+ | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application
- | HsAppType (LHsExpr p) (LHsWcType p) -- ^ Visible type application
+ | HsAppType (XAppTypeE p) (LHsExpr p) -- ^ Visible type application
--
-- Explicit type argument; e.g f @Int x y
-- NB: Has wildcards, but no implicit quantification
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt',
- -- TODO:AZ: Sort out Name
- | HsAppTypeOut (LHsExpr p) (LHsWcType GhcRn) -- just for pretty-printing
-
-
-- | Operator applications:
-- NB Bracketed ops such as (+) come out as Vars.
-- NB We need an expr for the operator in an OpApp/Section since
-- the typechecker may need to apply the operator to a few types.
- | OpApp (LHsExpr p) -- left operand
+ | OpApp (XOpApp p)
+ (LHsExpr p) -- left operand
(LHsExpr p) -- operator
- (PostRn p Fixity) -- Renamer adds fixity; bottom until then
(LHsExpr p) -- right operand
-- | Negation operator. Contains the negated expression and the name
@@ -352,18 +361,22 @@ data HsExpr p
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus'
-- For details on above see note [Api annotations] in ApiAnnotation
- | NegApp (LHsExpr p)
+ | NegApp (XNegApp p)
+ (LHsExpr p)
(SyntaxExpr p)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsPar (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn]
+ | HsPar (XPar p)
+ (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn]
- | SectionL (LHsExpr p) -- operand; see Note [Sections in HsSyn]
+ | SectionL (XSectionL p)
+ (LHsExpr p) -- operand; see Note [Sections in HsSyn]
(LHsExpr p) -- operator
- | SectionR (LHsExpr p) -- operator; see Note [Sections in HsSyn]
+ | SectionR (XSectionR p)
+ (LHsExpr p) -- operator; see Note [Sections in HsSyn]
(LHsExpr p) -- operand
-- | Used for explicit tuples and sections thereof
@@ -373,6 +386,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| ExplicitTuple
+ (XExplicitTuple p)
[LHsTupArg p]
Boxity
@@ -384,17 +398,18 @@ data HsExpr p
-- There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before
-- the expression, (arity - alternative) after it
| ExplicitSum
+ (XExplicitSum p)
ConTag -- Alternative (one-based)
Arity -- Sum arity
(LHsExpr p)
- (PostTc p [Type]) -- the type arguments
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
-- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
-- 'ApiAnnotation.AnnClose' @'}'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCase (LHsExpr p)
+ | HsCase (XCase p)
+ (LHsExpr p)
(MatchGroup p (LHsExpr p))
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',
@@ -403,7 +418,8 @@ data HsExpr p
-- 'ApiAnnotation.AnnElse',
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsIf (Maybe (SyntaxExpr p)) -- cond function
+ | HsIf (XIf p)
+ (Maybe (SyntaxExpr p)) -- cond function
-- Nothing => use the built-in 'if'
-- See Note [Rebindable if]
(LHsExpr p) -- predicate
@@ -416,7 +432,7 @@ data HsExpr p
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsMultiIf (PostTc p Type) [LGRHS p (LHsExpr p)]
+ | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)]
-- | let(rec)
--
@@ -425,7 +441,8 @@ data HsExpr p
-- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsLet (LHsLocalBinds p)
+ | HsLet (XLet p)
+ (LHsLocalBinds p)
(LHsExpr p)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
@@ -434,11 +451,11 @@ data HsExpr p
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsDo (HsStmtContext Name) -- The parameterisation is unimportant
+ | HsDo (XDo p) -- Type of the whole expression
+ (HsStmtContext Name) -- The parameterisation is unimportant
-- because in this context we never use
-- the PatGuard or ParStmt variant
(Located [ExprLStmt p]) -- "do":one or more stmts
- (PostTc p Type) -- Type of the whole expression
-- | Syntactic list: [a,b,c,...]
--
@@ -447,7 +464,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| ExplicitList
- (PostTc p Type) -- Gives type of components of list
+ (XExplicitList p) -- Gives type of components of list
(Maybe (SyntaxExpr p))
-- For OverloadedLists, the fromListN witness
[LHsExpr p]
@@ -461,7 +478,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| ExplicitPArr
- (PostTc p Type) -- type of elements of the parallel array
+ (XExplicitPArr p) -- type of elements of the parallel array
[LHsExpr p]
-- | Record construction
@@ -471,11 +488,9 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| RecordCon
- { rcon_con_name :: Located (IdP p) -- The constructor name;
+ { rcon_ext :: XRecordCon p
+ , rcon_con_name :: Located (IdP p) -- The constructor name;
-- not used after type checking
- , rcon_con_like :: PostTc p ConLike
- -- The data constructor or pattern synonym
- , rcon_con_expr :: PostTcExpr -- Instantiated constructor function
, rcon_flds :: HsRecordBinds p } -- The fields
-- | Record update
@@ -485,18 +500,9 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| RecordUpd
- { rupd_expr :: LHsExpr p
+ { rupd_ext :: XRecordUpd p
+ , rupd_expr :: LHsExpr p
, rupd_flds :: [LHsRecUpdField p]
- , rupd_cons :: PostTc p [ConLike]
- -- Filled in by the type checker to the
- -- _non-empty_ list of DataCons that have
- -- all the upd'd fields
-
- , rupd_in_tys :: PostTc p [Type] -- Argument types of *input* record type
- , rupd_out_tys :: PostTc p [Type] -- and *output* record type
- -- The original type can be reconstructed
- -- with conLikeResTy
- , rupd_wrap :: PostTc p HsWrapper -- See note [Record Update HsWrapper]
}
-- For a type family, the arg types are of the *instance* tycon,
-- not the family tycon
@@ -507,14 +513,10 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| ExprWithTySig
- (LHsExpr p)
- (LHsSigWcType p)
-
- | ExprWithTySigOut -- Post typechecking
- (LHsExpr p)
- (LHsSigWcType GhcRn) -- Retain the signature,
+ (XExprWithTySig p) -- Retain the signature,
-- as HsSigType Name, for
-- round-tripping purposes
+ (LHsExpr p)
-- | Arithmetic sequence
--
@@ -524,7 +526,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| ArithSeq
- PostTcExpr
+ (XArithSeq p)
(Maybe (SyntaxExpr p))
-- For OverloadedLists, the fromList witness
(ArithSeqInfo p)
@@ -540,7 +542,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| PArrSeq
- PostTcExpr
+ (XPArrSeq p)
(ArithSeqInfo p)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@,
@@ -548,7 +550,8 @@ data HsExpr p
-- 'ApiAnnotation.AnnClose' @'\#-}'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsSCC SourceText -- Note [Pragma source text] in BasicTypes
+ | HsSCC (XSCC p)
+ SourceText -- Note [Pragma source text] in BasicTypes
StringLiteral -- "set cost centre" SCC pragma
(LHsExpr p) -- expr whose cost is to be measured
@@ -556,7 +559,8 @@ data HsExpr p
-- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCoreAnn SourceText -- Note [Pragma source text] in BasicTypes
+ | HsCoreAnn (XCoreAnn p)
+ SourceText -- Note [Pragma source text] in BasicTypes
StringLiteral -- hdaume: core annotation
(LHsExpr p)
@@ -568,15 +572,17 @@ data HsExpr p
-- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ'
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsBracket (HsBracket p)
+ | HsBracket (XBracket p) (HsBracket p)
-- See Note [Pending Splices]
| HsRnBracketOut
+ (XRnBracketOut p)
(HsBracket GhcRn) -- Output of the renamer is the *original* renamed
-- expression, plus
[PendingRnSplice] -- _renamed_ splices to be type checked
| HsTcBracketOut
+ (XTcBracketOut p)
(HsBracket GhcRn) -- Output of the type checker is the *original*
-- renamed expression, plus
[PendingTcSplice] -- _typechecked_ splices to be
@@ -586,7 +592,7 @@ data HsExpr p
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsSpliceE (HsSplice p)
+ | HsSpliceE (XSpliceE p) (HsSplice p)
-----------------------------------------------------------
-- Arrow notation extension
@@ -597,7 +603,8 @@ data HsExpr p
-- 'ApiAnnotation.AnnRarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsProc (LPat p) -- arrow abstraction, proc
+ | HsProc (XProc p)
+ (LPat p) -- arrow abstraction, proc
(LHsCmdTop p) -- body of the abstraction
-- always has an empty stack
@@ -606,7 +613,7 @@ data HsExpr p
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic',
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsStatic (PostRn p NameSet) -- Free variables of the body
+ | HsStatic (XStatic p) -- Free variables of the body
(LHsExpr p) -- Body
---------------------------------------
@@ -620,10 +627,10 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| HsArrApp -- Arrow tail, or arrow application (f -< arg)
+ (XArrApp p) -- type of the arrow expressions f,
+ -- of the form a t t', where arg :: t
(LHsExpr p) -- arrow expression, f
(LHsExpr p) -- input expression, arg
- (PostTc p Type) -- type of the arrow expressions f,
- -- of the form a t t', where arg :: t
HsArrAppType -- higher-order (-<<) or first-order (-<)
Bool -- True => right-to-left (f -< arg)
-- False => left-to-right (arg >- f)
@@ -633,6 +640,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| HsArrForm -- Command formation, (| e cmd1 .. cmdn |)
+ (XArrForm p)
(LHsExpr p) -- the operator
-- after type-checking, a type abstraction to be
-- applied to the type of the local environment tuple
@@ -644,10 +652,12 @@ data HsExpr p
-- Haskell program coverage (Hpc) Support
| HsTick
+ (XTick p)
(Tickish (IdP p))
(LHsExpr p) -- sub-expression
| HsBinTick
+ (XBinTick p)
Int -- module-local tick number for True
Int -- module-local tick number for False
(LHsExpr p) -- sub-expression
@@ -663,6 +673,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| HsTickPragma -- A pragma introduced tick
+ (XTickPragma p)
SourceText -- Note [Pragma source text] in BasicTypes
(StringLiteral,(Int,Int),(Int,Int))
-- external span for this tick
@@ -675,24 +686,26 @@ data HsExpr p
-- These constructors only appear temporarily in the parser.
-- The renamer translates them into the Right Thing.
- | EWildPat -- wildcard
+ | EWildPat (XEWildPat p) -- wildcard
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
-- For details on above see note [Api annotations] in ApiAnnotation
- | EAsPat (Located (IdP p)) -- as pattern
+ | EAsPat (XEAsPat p)
+ (Located (IdP p)) -- as pattern
(LHsExpr p)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
- | EViewPat (LHsExpr p) -- view pattern
+ | EViewPat (XEViewPat p)
+ (LHsExpr p) -- view pattern
(LHsExpr p)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
-- For details on above see note [Api annotations] in ApiAnnotation
- | ELazyPat (LHsExpr p) -- ~ pattern
+ | ELazyPat (XELazyPat p) (LHsExpr p) -- ~ pattern
---------------------------------------
@@ -701,10 +714,138 @@ data HsExpr p
-- See Note [Detecting forced eta expansion] in DsExpr. This invariant
-- is maintained by HsUtils.mkHsWrap.
- | HsWrap HsWrapper -- TRANSLATION
+ | HsWrap (XWrap p)
+ HsWrapper -- TRANSLATION
(HsExpr p)
-deriving instance (DataId p) => Data (HsExpr p)
+ | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor
+
+deriving instance (DataIdLR p p) => Data (HsExpr p)
+
+-- | Extra data fields for a 'RecordCon', added by the type checker
+data RecordConTc = RecordConTc
+ { rcon_con_like :: ConLike -- The data constructor or pattern synonym
+ , rcon_con_expr :: PostTcExpr -- Instantiated constructor function
+ } deriving Data
+
+
+-- | Extra data fields for a 'RecordUpd', added by the type checker
+data RecordUpdTc = RecordUpdTc
+ { rupd_cons :: [ConLike]
+ -- Filled in by the type checker to the
+ -- _non-empty_ list of DataCons that have
+ -- all the upd'd fields
+
+ , rupd_in_tys :: [Type] -- Argument types of *input* record type
+ , rupd_out_tys :: [Type] -- and *output* record type
+ -- The original type can be reconstructed
+ -- with conLikeResTy
+ , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper]
+ } deriving Data
+
+-- ---------------------------------------------------------------------
+
+type instance XVar (GhcPass _) = PlaceHolder
+type instance XUnboundVar (GhcPass _) = PlaceHolder
+type instance XConLikeOut (GhcPass _) = PlaceHolder
+type instance XRecFld (GhcPass _) = PlaceHolder
+type instance XOverLabel (GhcPass _) = PlaceHolder
+type instance XIPVar (GhcPass _) = PlaceHolder
+type instance XOverLitE (GhcPass _) = PlaceHolder
+type instance XLitE (GhcPass _) = PlaceHolder
+type instance XLam (GhcPass _) = PlaceHolder
+type instance XLamCase (GhcPass _) = PlaceHolder
+type instance XApp (GhcPass _) = PlaceHolder
+
+type instance XAppTypeE GhcPs = LHsWcType GhcPs
+type instance XAppTypeE GhcRn = LHsWcType GhcRn
+type instance XAppTypeE GhcTc = LHsWcType GhcRn
+
+type instance XOpApp GhcPs = PlaceHolder
+type instance XOpApp GhcRn = Fixity
+type instance XOpApp GhcTc = Fixity
+
+type instance XNegApp (GhcPass _) = PlaceHolder
+type instance XPar (GhcPass _) = PlaceHolder
+type instance XSectionL (GhcPass _) = PlaceHolder
+type instance XSectionR (GhcPass _) = PlaceHolder
+type instance XExplicitTuple (GhcPass _) = PlaceHolder
+
+type instance XExplicitSum GhcPs = PlaceHolder
+type instance XExplicitSum GhcRn = PlaceHolder
+type instance XExplicitSum GhcTc = [Type]
+
+type instance XCase (GhcPass _) = PlaceHolder
+type instance XIf (GhcPass _) = PlaceHolder
+
+type instance XMultiIf GhcPs = PlaceHolder
+type instance XMultiIf GhcRn = PlaceHolder
+type instance XMultiIf GhcTc = Type
+
+type instance XLet (GhcPass _) = PlaceHolder
+
+type instance XDo GhcPs = PlaceHolder
+type instance XDo GhcRn = PlaceHolder
+type instance XDo GhcTc = Type
+
+type instance XExplicitList GhcPs = PlaceHolder
+type instance XExplicitList GhcRn = PlaceHolder
+type instance XExplicitList GhcTc = Type
+
+type instance XExplicitPArr GhcPs = PlaceHolder
+type instance XExplicitPArr GhcRn = PlaceHolder
+type instance XExplicitPArr GhcTc = Type
+
+type instance XRecordCon GhcPs = PlaceHolder
+type instance XRecordCon GhcRn = PlaceHolder
+type instance XRecordCon GhcTc = RecordConTc
+
+type instance XRecordUpd GhcPs = PlaceHolder
+type instance XRecordUpd GhcRn = PlaceHolder
+type instance XRecordUpd GhcTc = RecordUpdTc
+
+type instance XExprWithTySig GhcPs = (LHsSigWcType GhcPs)
+type instance XExprWithTySig GhcRn = (LHsSigWcType GhcRn)
+type instance XExprWithTySig GhcTc = (LHsSigWcType GhcRn)
+
+type instance XArithSeq GhcPs = PlaceHolder
+type instance XArithSeq GhcRn = PlaceHolder
+type instance XArithSeq GhcTc = PostTcExpr
+
+type instance XPArrSeq GhcPs = PlaceHolder
+type instance XPArrSeq GhcRn = PlaceHolder
+type instance XPArrSeq GhcTc = PostTcExpr
+
+type instance XSCC (GhcPass _) = PlaceHolder
+type instance XCoreAnn (GhcPass _) = PlaceHolder
+type instance XBracket (GhcPass _) = PlaceHolder
+
+type instance XRnBracketOut (GhcPass _) = PlaceHolder
+type instance XTcBracketOut (GhcPass _) = PlaceHolder
+
+type instance XSpliceE (GhcPass _) = PlaceHolder
+type instance XProc (GhcPass _) = PlaceHolder
+
+type instance XStatic GhcPs = PlaceHolder
+type instance XStatic GhcRn = NameSet
+type instance XStatic GhcTc = NameSet
+
+type instance XArrApp GhcPs = PlaceHolder
+type instance XArrApp GhcRn = PlaceHolder
+type instance XArrApp GhcTc = Type
+
+type instance XArrForm (GhcPass _) = PlaceHolder
+type instance XTick (GhcPass _) = PlaceHolder
+type instance XBinTick (GhcPass _) = PlaceHolder
+type instance XTickPragma (GhcPass _) = PlaceHolder
+type instance XEWildPat (GhcPass _) = PlaceHolder
+type instance XEAsPat (GhcPass _) = PlaceHolder
+type instance XEViewPat (GhcPass _) = PlaceHolder
+type instance XELazyPat (GhcPass _) = PlaceHolder
+type instance XWrap (GhcPass _) = PlaceHolder
+type instance XXExpr (GhcPass _) = PlaceHolder
+
+-- ---------------------------------------------------------------------
-- | Located Haskell Tuple Argument
--
@@ -719,13 +860,23 @@ type LHsTupArg id = Located (HsTupArg id)
-- | Haskell Tuple Argument
data HsTupArg id
- = Present (LHsExpr id) -- ^ The argument
- | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type
-deriving instance (DataId id) => Data (HsTupArg id)
+ = Present (XPresent id) (LHsExpr id) -- ^ The argument
+ | Missing (XMissing id) -- ^ The argument is missing, but this is its type
+ | XTupArg (XXTupArg id) -- ^ Note [Trees that Grow] extension point
+deriving instance (DataIdLR id id) => Data (HsTupArg id)
+
+type instance XPresent (GhcPass _) = PlaceHolder
+
+type instance XMissing GhcPs = PlaceHolder
+type instance XMissing GhcRn = PlaceHolder
+type instance XMissing GhcTc = Type
+
+type instance XXTupArg (GhcPass _) = PlaceHolder
tupArgPresent :: LHsTupArg id -> Bool
tupArgPresent (L _ (Present {})) = True
tupArgPresent (L _ (Missing {})) = False
+tupArgPresent (L _ (XTupArg {})) = False
{-
Note [Parens in HsSyn]
@@ -799,16 +950,19 @@ RenamedSource that the API Annotations cannot be used directly with
RenamedSource, so this allows a simple mapping to be used based on the location.
-}
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsExpr (GhcPass p)) where
ppr expr = pprExpr expr
-----------------------
-- pprExpr, pprLExpr, pprBinds call pprDeeper;
-- the underscore versions do not
-pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsExpr (GhcPass p) -> SDoc
pprLExpr (L _ e) = pprExpr e
-pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+pprExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p) -> SDoc
pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e
| otherwise = pprDeeper (ppr_expr e)
@@ -816,56 +970,56 @@ isQuietHsExpr :: HsExpr id -> Bool
-- Parentheses do display something, but it gives little info and
-- if we go deeper when we go inside them then we get ugly things
-- like (...)
-isQuietHsExpr (HsPar _) = True
+isQuietHsExpr (HsPar {}) = True
-- applications don't display anything themselves
-isQuietHsExpr (HsApp _ _) = True
-isQuietHsExpr (HsAppType _ _) = True
-isQuietHsExpr (HsAppTypeOut _ _) = True
-isQuietHsExpr (OpApp _ _ _ _) = True
+isQuietHsExpr (HsApp {}) = True
+isQuietHsExpr (HsAppType {}) = True
+isQuietHsExpr (OpApp {}) = True
isQuietHsExpr _ = False
-pprBinds :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => HsLocalBindsLR idL idR -> SDoc
+pprBinds :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprBinds b = pprDeeper (ppr b)
-----------------------
-ppr_lexpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+ppr_lexpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsExpr (GhcPass p) -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
-ppr_expr :: forall p. (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
-ppr_expr (HsVar (L _ v)) = pprPrefixOcc v
-ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)
-ppr_expr (HsConLikeOut c) = pprPrefixOcc c
-ppr_expr (HsIPVar v) = ppr v
-ppr_expr (HsOverLabel _ l)= char '#' <> ppr l
-ppr_expr (HsLit lit) = ppr lit
-ppr_expr (HsOverLit lit) = ppr lit
-ppr_expr (HsPar e) = parens (ppr_lexpr e)
-
-ppr_expr (HsCoreAnn stc (StringLiteral sta s) e)
+ppr_expr :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p) -> SDoc
+ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v
+ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv)
+ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c
+ppr_expr (HsIPVar _ v) = ppr v
+ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l
+ppr_expr (HsLit _ lit) = ppr lit
+ppr_expr (HsOverLit _ lit) = ppr lit
+ppr_expr (HsPar _ e) = parens (ppr_lexpr e)
+
+ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e)
= vcat [pprWithSourceText stc (text "{-# CORE")
<+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"
, ppr_lexpr e]
ppr_expr e@(HsApp {}) = ppr_apps e []
ppr_expr e@(HsAppType {}) = ppr_apps e []
-ppr_expr e@(HsAppTypeOut {}) = ppr_apps e []
-ppr_expr (OpApp e1 op _ e2)
+ppr_expr (OpApp _ e1 op e2)
| Just pp_op <- should_print_infix (unLoc op)
= pp_infixly pp_op
| otherwise
= pp_prefixly
where
- should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v)
- should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c))
- should_print_infix (HsRecFld f) = Just (pprInfixOcc f)
- should_print_infix (HsUnboundVar h@TrueExprHole{})
+ should_print_infix (HsVar _ (L _ v)) = Just (pprInfixOcc v)
+ should_print_infix (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c))
+ should_print_infix (HsRecFld _ f) = Just (pprInfixOcc f)
+ should_print_infix (HsUnboundVar _ h@TrueExprHole{})
= Just (pprInfixOcc (unboundVarOcc h))
- should_print_infix EWildPat = Just (text "`_`")
- should_print_infix (HsWrap _ e) = should_print_infix e
+ should_print_infix (EWildPat _) = Just (text "`_`")
+ should_print_infix (HsWrap _ _ e) = should_print_infix e
should_print_infix _ = Nothing
pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens
@@ -877,63 +1031,67 @@ ppr_expr (OpApp e1 op _ e2)
pp_infixly pp_op
= hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])
-ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
+ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr e
-ppr_expr (SectionL expr op)
+ppr_expr (SectionL _ expr op)
= case unLoc op of
- HsVar (L _ v) -> pp_infixly v
- HsConLikeOut c -> pp_infixly (conLikeName c)
- _ -> pp_prefixly
+ HsVar _ (L _ v) -> pp_infixly v
+ HsConLikeOut _ c -> pp_infixly_n (conLikeName c)
+ _ -> pp_prefixly
where
pp_expr = pprDebugParendExpr expr
pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
4 (hsep [pp_expr, text "x_ )"])
- pp_infixly v = (sep [pp_expr, pprInfixOcc v])
+ pp_infixly_n v = (sep [pp_expr, pprInfixOcc v])
+ pp_infixly v = (sep [pp_expr, pprInfixOcc v])
-ppr_expr (SectionR op expr)
+ppr_expr (SectionR _ op expr)
= case unLoc op of
- HsVar (L _ v) -> pp_infixly v
- HsConLikeOut c -> pp_infixly (conLikeName c)
- _ -> pp_prefixly
+ HsVar _ (L _ v) -> pp_infixly v
+ HsConLikeOut _ c -> pp_infixly_n (conLikeName c)
+ _ -> pp_prefixly
where
pp_expr = pprDebugParendExpr expr
pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])
4 (pp_expr <> rparen)
- pp_infixly v = sep [pprInfixOcc v, pp_expr]
+ pp_infixly v = sep [pprInfixOcc v, pp_expr]
+ pp_infixly_n v = sep [pprInfixOcc v, pp_expr]
-ppr_expr (ExplicitTuple exprs boxity)
+ppr_expr (ExplicitTuple _ exprs boxity)
= tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))
where
ppr_tup_args [] = []
- ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
- ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
+ ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
+ ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
+ ppr_tup_args (XTupArg x : es) = (ppr x <> punc es) : ppr_tup_args es
punc (Present {} : _) = comma <> space
punc (Missing {} : _) = comma
+ punc (XTupArg {} : _) = comma <> space
punc [] = empty
-ppr_expr (ExplicitSum alt arity expr _)
+ppr_expr (ExplicitSum _ alt arity expr)
= text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"
where
ppr_bars n = hsep (replicate n (char '|'))
-ppr_expr (HsLam matches)
+ppr_expr (HsLam _ matches)
= pprMatches matches
-ppr_expr (HsLamCase matches)
+ppr_expr (HsLamCase _ matches)
= sep [ sep [text "\\case"],
nest 2 (pprMatches matches) ]
-ppr_expr (HsCase expr matches@(MG { mg_alts = L _ [_] }))
+ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] }))
= sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")],
nest 2 (pprMatches matches) <+> char '}']
-ppr_expr (HsCase expr matches)
+ppr_expr (HsCase _ expr matches)
= sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
nest 2 (pprMatches matches) ]
-ppr_expr (HsIf _ e1 e2 e3)
+ppr_expr (HsIf _ _ e1 e2 e3)
= sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")],
nest 4 (ppr e2),
text "else",
@@ -950,15 +1108,15 @@ ppr_expr (HsMultiIf _ alts)
, text "->" <+> pprDeeper (ppr expr) ]
-- special case: let ... in let ...
-ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _)))
+ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _)))
= sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),
ppr_lexpr expr]
-ppr_expr (HsLet (L _ binds) expr)
+ppr_expr (HsLet _ (L _ binds) expr)
= sep [hang (text "let") 2 (pprBinds binds),
hang (text "in") 2 (ppr expr)]
-ppr_expr (HsDo do_or_list_comp (L _ stmts) _) = pprDo do_or_list_comp stmts
+ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList _ _ exprs)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
@@ -972,49 +1130,48 @@ ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })
= hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
-ppr_expr (ExprWithTySig expr sig)
- = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
- 4 (ppr sig)
-ppr_expr (ExprWithTySigOut expr sig)
+ppr_expr (ExprWithTySig sig expr)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
4 (ppr sig)
ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
-ppr_expr (PArrSeq _ info) = paBrackets (ppr info)
+ppr_expr (PArrSeq _ info) = paBrackets (ppr info)
-ppr_expr EWildPat = char '_'
-ppr_expr (ELazyPat e) = char '~' <> ppr e
-ppr_expr (EAsPat v e) = ppr v <> char '@' <> ppr e
-ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e
+ppr_expr (EWildPat _) = char '_'
+ppr_expr (ELazyPat _ e) = char '~' <> ppr e
+ppr_expr (EAsPat _ v e) = ppr v <> char '@' <> ppr e
+ppr_expr (EViewPat _ p e) = ppr p <+> text "->" <+> ppr e
-ppr_expr (HsSCC st (StringLiteral stl lbl) expr)
+ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr)
= sep [ pprWithSourceText st (text "{-# SCC")
-- no doublequotes if stl empty, for the case where the SCC was written
-- without quotes.
<+> pprWithSourceText stl (ftext lbl) <+> text "#-}",
ppr expr ]
-ppr_expr (HsWrap co_fn e)
+ppr_expr (HsWrap _ co_fn e)
= pprHsWrapper co_fn (\parens -> if parens then pprExpr e
else pprExpr e)
-ppr_expr (HsSpliceE s) = pprSplice s
-ppr_expr (HsBracket b) = pprHsBracket b
-ppr_expr (HsRnBracketOut e []) = ppr e
-ppr_expr (HsRnBracketOut e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
-ppr_expr (HsTcBracketOut e []) = ppr e
-ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
+ppr_expr (HsSpliceE _ s) = pprSplice s
+ppr_expr (HsBracket _ b) = pprHsBracket b
+ppr_expr (HsRnBracketOut _ e []) = ppr e
+ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
+ppr_expr (HsTcBracketOut _ e []) = ppr e
+ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
-ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
+ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
= hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
+ppr_expr (HsProc _ pat (L _ (XCmdTop x)))
+ = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x]
ppr_expr (HsStatic _ e)
= hsep [text "static", ppr e]
-ppr_expr (HsTick tickish exp)
+ppr_expr (HsTick _ tickish exp)
= pprTicks (ppr exp) $
ppr tickish <+> ppr_lexpr exp
-ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
+ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)
= pprTicks (ppr exp) $
hcat [text "bintick<",
ppr tickIdTrue,
@@ -1022,7 +1179,7 @@ ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
ppr tickIdFalse,
text ">(",
ppr exp, text ")"]
-ppr_expr (HsTickPragma _ externalSrcLoc _ exp)
+ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp)
= pprTicks (ppr exp) $
hcat [text "tickpragma<",
pprExternalSrcLoc externalSrcLoc,
@@ -1030,44 +1187,49 @@ ppr_expr (HsTickPragma _ externalSrcLoc _ exp)
ppr exp,
text ")"]
-ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
+ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp True)
= hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
-ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
+ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp False)
= hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
-ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
+ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp True)
= hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
-ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
+ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp False)
= hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
-ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2])
+ppr_expr (HsArrForm _ (L _ (HsVar _ (L _ v))) (Just _) [arg1, arg2])
= sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
-ppr_expr (HsArrForm (L _ (HsConLikeOut c)) (Just _) [arg1, arg2])
+ppr_expr (HsArrForm _ (L _ (HsConLikeOut _ c)) (Just _) [arg1, arg2])
= sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]]
-ppr_expr (HsArrForm op _ args)
+ppr_expr (HsArrForm _ op _ args)
= hang (text "(|" <+> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
-ppr_expr (HsRecFld f) = ppr f
+ppr_expr (HsRecFld _ f) = ppr f
+ppr_expr (XExpr x) = ppr x
-- We must tiresomely make the "id" parameter to the LHsWcType existential
-- because it's different in the HsAppType case and the HsAppTypeOut case
-- | Located Haskell Wildcard Type Expression
-data LHsWcTypeX = forall p. (SourceTextX p, OutputableBndrId p)
- => LHsWcTypeX (LHsWcType p)
-
-ppr_apps :: (SourceTextX p, OutputableBndrId p) => HsExpr p
- -> [Either (LHsExpr p) LHsWcTypeX]
+data LHsWcTypeX = forall p. ( SourceTextX (GhcPass p)
+ , OutputableBndrId (GhcPass p))
+ => LHsWcTypeX (LHsWcType (GhcPass p))
+
+ppr_apps :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p)
+ -- -> [Either (LHsExpr (GhcPass p)) LHsWcTypeX]
+ -> [Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p))]
-> SDoc
-ppr_apps (HsApp (L _ fun) arg) args
+ppr_apps (HsApp _ (L _ fun) arg) args
= ppr_apps fun (Left arg : args)
-ppr_apps (HsAppType (L _ fun) arg) args
- = ppr_apps fun (Right (LHsWcTypeX arg) : args)
-ppr_apps (HsAppTypeOut (L _ fun) arg) args
- = ppr_apps fun (Right (LHsWcTypeX arg) : args)
+ppr_apps (HsAppType arg (L _ fun)) args
+ = ppr_apps fun (Right arg : args)
ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
where
+ -- pp :: Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p)) -> SDoc
pp (Left arg) = ppr arg
- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
- = char '@' <> pprHsType arg
+ -- pp (Right (HsWC { hswc_body = L _ arg }))
+ -- = char '@' <> pprHsType arg
+ pp (Right arg)
+ = char '@' <> ppr arg
pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
@@ -1085,16 +1247,19 @@ fixities should do the job, except in debug mode (-dppr-debug) so we
can see the structure of the parse tree.
-}
-pprDebugParendExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprDebugParendExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsExpr (GhcPass p) -> SDoc
pprDebugParendExpr expr
= getPprStyle (\sty ->
if debugStyle sty then pprParendLExpr expr
else pprLExpr expr)
-pprParendLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprParendLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsExpr (GhcPass p) -> SDoc
pprParendLExpr (L _ e) = pprParendExpr e
-pprParendExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+pprParendExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p) -> SDoc
pprParendExpr expr
| hsExprNeedsParens expr = parens (pprExpr expr)
| otherwise = pprExpr expr
@@ -1120,13 +1285,13 @@ hsExprNeedsParens (HsPar {}) = False
hsExprNeedsParens (HsBracket {}) = False
hsExprNeedsParens (HsRnBracketOut {}) = False
hsExprNeedsParens (HsTcBracketOut {}) = False
-hsExprNeedsParens (HsDo sc _ _)
+hsExprNeedsParens (HsDo _ sc _)
| isListCompExpr sc = False
hsExprNeedsParens (HsRecFld{}) = False
hsExprNeedsParens (RecordCon{}) = False
hsExprNeedsParens (HsSpliceE{}) = False
hsExprNeedsParens (RecordUpd{}) = False
-hsExprNeedsParens (HsWrap _ e) = hsExprNeedsParens e
+hsExprNeedsParens (HsWrap _ _ e) = hsExprNeedsParens e
hsExprNeedsParens _ = True
@@ -1139,8 +1304,8 @@ isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {}) = True
isAtomicHsExpr (HsOverLabel {}) = True
isAtomicHsExpr (HsUnboundVar {}) = True
-isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e
-isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e)
+isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e
+isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e)
isAtomicHsExpr (HsRecFld{}) = True
isAtomicHsExpr _ = False
@@ -1165,10 +1330,10 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
= HsCmdArrApp -- Arrow tail, or arrow application (f -< arg)
+ (XCmdArrApp id) -- type of the arrow expressions f,
+ -- of the form a t t', where arg :: t
(LHsExpr id) -- arrow expression, f
(LHsExpr id) -- input expression, arg
- (PostTc id Type) -- type of the arrow expressions f,
- -- of the form a t t', where arg :: t
HsArrAppType -- higher-order (-<<) or first-order (-<)
Bool -- True => right-to-left (f -< arg)
-- False => left-to-right (arg >- f)
@@ -1178,6 +1343,7 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
| HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |)
+ (XCmdArrForm id)
(LHsExpr id) -- The operator.
-- After type-checking, a type abstraction to be
-- applied to the type of the local environment tuple
@@ -1187,22 +1353,26 @@ data HsCmd id
-- were converted from OpApp's by the renamer
[LHsCmdTop id] -- argument commands
- | HsCmdApp (LHsCmd id)
+ | HsCmdApp (XCmdApp id)
+ (LHsCmd id)
(LHsExpr id)
- | HsCmdLam (MatchGroup id (LHsCmd id)) -- kappa
+ | HsCmdLam (XCmdLam id)
+ (MatchGroup id (LHsCmd id)) -- kappa
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
-- 'ApiAnnotation.AnnRarrow',
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCmdPar (LHsCmd id) -- parenthesised command
+ | HsCmdPar (XCmdPar id)
+ (LHsCmd id) -- parenthesised command
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCmdCase (LHsExpr id)
+ | HsCmdCase (XCmdCase id)
+ (LHsExpr id)
(MatchGroup id (LHsCmd id)) -- bodies are HsCmd's
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
-- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
@@ -1210,7 +1380,8 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCmdIf (Maybe (SyntaxExpr id)) -- cond function
+ | HsCmdIf (XCmdIf id)
+ (Maybe (SyntaxExpr id)) -- cond function
(LHsExpr id) -- predicate
(LHsCmd id) -- then part
(LHsCmd id) -- else part
@@ -1221,7 +1392,8 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCmdLet (LHsLocalBinds id) -- let(rec)
+ | HsCmdLet (XCmdLet id)
+ (LHsLocalBinds id) -- let(rec)
(LHsCmd id)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
-- 'ApiAnnotation.AnnOpen' @'{'@,
@@ -1229,8 +1401,8 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCmdDo (Located [CmdLStmt id])
- (PostTc id Type) -- Type of the whole expression
+ | HsCmdDo (XCmdDo id) -- Type of the whole expression
+ (Located [CmdLStmt id])
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
-- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',
-- 'ApiAnnotation.AnnVbar',
@@ -1238,11 +1410,32 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCmdWrap HsWrapper
+ | HsCmdWrap (XCmdWrap id)
+ HsWrapper
(HsCmd id) -- If cmd :: arg1 --> res
-- wrap :: arg1 "->" arg2
-- Then (HsCmdWrap wrap cmd) :: arg2 --> res
-deriving instance (DataId id) => Data (HsCmd id)
+ | XCmd (XXCmd id) -- Note [Trees that Grow] extension point
+deriving instance (DataIdLR id id) => Data (HsCmd id)
+
+type instance XCmdArrApp GhcPs = PlaceHolder
+type instance XCmdArrApp GhcRn = PlaceHolder
+type instance XCmdArrApp GhcTc = Type
+
+type instance XCmdArrForm (GhcPass _) = PlaceHolder
+type instance XCmdApp (GhcPass _) = PlaceHolder
+type instance XCmdLam (GhcPass _) = PlaceHolder
+type instance XCmdPar (GhcPass _) = PlaceHolder
+type instance XCmdCase (GhcPass _) = PlaceHolder
+type instance XCmdIf (GhcPass _) = PlaceHolder
+type instance XCmdLet (GhcPass _) = PlaceHolder
+
+type instance XCmdDo GhcPs = PlaceHolder
+type instance XCmdDo GhcRn = PlaceHolder
+type instance XCmdDo GhcTc = Type
+
+type instance XCmdWrap (GhcPass _) = PlaceHolder
+type instance XXCmd (GhcPass _) = PlaceHolder
-- | Haskell Array Application Type
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
@@ -1259,22 +1452,36 @@ type LHsCmdTop p = Located (HsCmdTop p)
-- | Haskell Top-level Command
data HsCmdTop p
- = HsCmdTop (LHsCmd p)
- (PostTc p Type) -- Nested tuple of inputs on the command's stack
- (PostTc p Type) -- return type of the command
- (CmdSyntaxTable p) -- See Note [CmdSyntaxTable]
-deriving instance (DataId p) => Data (HsCmdTop p)
+ = HsCmdTop (XCmdTop p)
+ (LHsCmd p)
+ | XCmdTop (XXCmdTop p) -- Note [Trees that Grow] extension point
+deriving instance (DataIdLR p p) => Data (HsCmdTop p)
+
+data CmdTopTc
+ = CmdTopTc Type -- Nested tuple of inputs on the command's stack
+ Type -- return type of the command
+ (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]
+ deriving Data
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) where
+type instance XCmdTop GhcPs = PlaceHolder
+type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]
+type instance XCmdTop GhcTc = CmdTopTc
+
+type instance XXCmdTop (GhcPass _) = PlaceHolder
+
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsCmd (GhcPass p)) where
ppr cmd = pprCmd cmd
-----------------------
-- pprCmd and pprLCmd call pprDeeper;
-- the underscore versions do not
-pprLCmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc
+pprLCmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsCmd (GhcPass p) -> SDoc
pprLCmd (L _ c) = pprCmd c
-pprCmd :: (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc
+pprCmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsCmd (GhcPass p) -> SDoc
pprCmd c | isQuietHsCmd c = ppr_cmd c
| otherwise = pprDeeper (ppr_cmd c)
@@ -1282,81 +1489,87 @@ isQuietHsCmd :: HsCmd id -> Bool
-- Parentheses do display something, but it gives little info and
-- if we go deeper when we go inside them then we get ugly things
-- like (...)
-isQuietHsCmd (HsCmdPar _) = True
+isQuietHsCmd (HsCmdPar {}) = True
-- applications don't display anything themselves
-isQuietHsCmd (HsCmdApp _ _) = True
+isQuietHsCmd (HsCmdApp {}) = True
isQuietHsCmd _ = False
-----------------------
-ppr_lcmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc
+ppr_lcmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsCmd (GhcPass p) -> SDoc
ppr_lcmd c = ppr_cmd (unLoc c)
-ppr_cmd :: forall p. (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc
-ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)
+ppr_cmd :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsCmd (GhcPass p) -> SDoc
+ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)
-ppr_cmd (HsCmdApp c e)
+ppr_cmd (HsCmdApp _ c e)
= let (fun, args) = collect_args c [e] in
hang (ppr_lcmd fun) 2 (sep (map ppr args))
where
- collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args)
+ collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
-ppr_cmd (HsCmdLam matches)
+ppr_cmd (HsCmdLam _ matches)
= pprMatches matches
-ppr_cmd (HsCmdCase expr matches)
+ppr_cmd (HsCmdCase _ expr matches)
= sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
nest 2 (pprMatches matches) ]
-ppr_cmd (HsCmdIf _ e ct ce)
+ppr_cmd (HsCmdIf _ _ e ct ce)
= sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")],
nest 4 (ppr ct),
text "else",
nest 4 (ppr ce)]
-- special case: let ... in let ...
-ppr_cmd (HsCmdLet (L _ binds) cmd@(L _ (HsCmdLet _ _)))
+ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {})))
= sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),
ppr_lcmd cmd]
-ppr_cmd (HsCmdLet (L _ binds) cmd)
+ppr_cmd (HsCmdLet _ (L _ binds) cmd)
= sep [hang (text "let") 2 (pprBinds binds),
hang (text "in") 2 (ppr cmd)]
-ppr_cmd (HsCmdDo (L _ stmts) _) = pprDo ArrowExpr stmts
+ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts
-ppr_cmd (HsCmdWrap w cmd)
+ppr_cmd (HsCmdWrap _ w cmd)
= pprHsWrapper w (\_ -> parens (ppr_cmd cmd))
-ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True)
+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)
= hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
-ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False)
+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)
= hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
-ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True)
+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)
= hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
-ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False)
+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)
= hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
-ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2])
= hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
, pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _ [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2])
= hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
, pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) _ (Just _) [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2])
= hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
, pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) Infix _ [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2])
= hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
, pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm op _ _ args)
+ppr_cmd (HsCmdArrForm _ op _ _ args)
= hang (text "(|" <> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <> text "|)")
+ppr_cmd (XCmd x) = ppr x
-pprCmdArg :: (SourceTextX p, OutputableBndrId p) => HsCmdTop p -> SDoc
-pprCmdArg (HsCmdTop cmd _ _ _)
+pprCmdArg :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsCmdTop (GhcPass p) -> SDoc
+pprCmdArg (HsCmdTop _ cmd)
= ppr_lcmd cmd
+pprCmdArg (XCmdTop x) = ppr x
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmdTop p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsCmdTop (GhcPass p)) where
ppr = pprCmdArg
{-
@@ -1392,6 +1605,7 @@ a function defined by pattern matching must have the same number of
patterns in each equation.
-}
+-- AZ:TODO complete TTG on this, once DataId etc is resolved
data MatchGroup p body
= MG { mg_alts :: Located [LMatch p body] -- The alternatives
, mg_arg_tys :: [PostTc p Type] -- Types of the arguments, t1..tn
@@ -1400,13 +1614,14 @@ data MatchGroup p body
-- The type is the type of the entire group
-- t1 -> ... -> tn -> tr
-- where there are n patterns
-deriving instance (Data body,DataId p) => Data (MatchGroup p body)
+deriving instance (Data body,DataIdLR p p) => Data (MatchGroup p body)
-- | Located Match
type LMatch id body = Located (Match id body)
-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
-- list
+-- AZ:TODO complete TTG on this, once DataId etc is resolved
-- For details on above see note [Api annotations] in ApiAnnotation
data Match p body
= Match {
@@ -1415,10 +1630,11 @@ data Match p body
m_pats :: [LPat p], -- The patterns
m_grhss :: (GRHSs p body)
}
-deriving instance (Data body,DataId p) => Data (Match p body)
+deriving instance (Data body,DataIdLR p p) => Data (Match p body)
-instance (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => Outputable (Match idR body) where
+instance (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => Outputable (Match (GhcPass idR) body) where
ppr = pprMatch
{-
@@ -1494,46 +1710,53 @@ hsLMatchPats (L _ (Match { m_pats = pats })) = pats
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
-- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi'
+-- AZ:TODO complete TTG on this, once DataId etc is resolved
-- For details on above see note [Api annotations] in ApiAnnotation
data GRHSs p body
= GRHSs {
grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs
grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause
}
-deriving instance (Data body,DataId p) => Data (GRHSs p body)
+deriving instance (Data body,DataIdLR p p) => Data (GRHSs p body)
-- | Located Guarded Right-Hand Side
type LGRHS id body = Located (GRHS id body)
+-- AZ:TODO complete TTG on this, once DataId etc is resolved
-- | Guarded Right Hand Side.
data GRHS id body = GRHS [GuardLStmt id] -- Guards
body -- Right hand side
-deriving instance (Data body,DataId id) => Data (GRHS id body)
+deriving instance (Data body,DataIdLR id id) => Data (GRHS id body)
-- We know the list must have at least one @Match@ in it.
-pprMatches :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => MatchGroup idR body -> SDoc
+pprMatches :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => MatchGroup (GhcPass idR) body -> SDoc
pprMatches MG { mg_alts = matches }
= vcat (map pprMatch (map unLoc (unLoc matches)))
-- Don't print the type; it's only a place-holder before typechecking
-- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => MatchGroup idR body -> SDoc
+pprFunBind :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => MatchGroup (GhcPass idR) body -> SDoc
pprFunBind matches = pprMatches matches
-- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr,
- OutputableBndrId bndr,
- OutputableBndrId p,
+pprPatBind :: forall bndr p body. (SourceTextX (GhcPass p),
+ SourceTextX (GhcPass bndr),
+ OutputableBndrId (GhcPass bndr),
+ OutputableBndrId (GhcPass p),
Outputable body)
- => LPat bndr -> GRHSs p body -> SDoc
+ => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
pprPatBind pat (grhss)
- = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP p)) grhss)]
+ = sep [ppr pat, nest 2
+ (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)]
-pprMatch :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => Match idR body -> SDoc
+pprMatch :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => Match (GhcPass idR) body -> SDoc
pprMatch match
= sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
, nest 2 (pprGRHSs ctxt (m_grhss match)) ]
@@ -1566,8 +1789,9 @@ pprMatch match
(pat1:pats1) = m_pats match
(pat2:pats2) = pats1
-pprGRHSs :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => HsMatchContext idL -> GRHSs idR body -> SDoc
+pprGRHSs :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc
pprGRHSs ctxt (GRHSs grhss (L _ binds))
= vcat (map (pprGRHS ctxt . unLoc) grhss)
-- Print the "where" even if the contents of the binds is empty. Only
@@ -1575,8 +1799,9 @@ pprGRHSs ctxt (GRHSs grhss (L _ binds))
$$ ppUnless (eqEmptyLocalBinds binds)
(text "where" $$ nest 4 (pprBinds binds))
-pprGRHS :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => HsMatchContext idL -> GRHS idR body -> SDoc
+pprGRHS :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc
pprGRHS ctxt (GRHS [] body)
= pp_rhs ctxt body
@@ -1670,7 +1895,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
--
| ApplicativeStmt
[ ( SyntaxExpr idR
- , ApplicativeArg idL idR) ]
+ , ApplicativeArg idL) ]
-- [(<$>, e1), (<*>, e2), ..., (<*>, en)]
(Maybe (SyntaxExpr idR)) -- 'join', if necessary
(PostTc idR Type) -- Type of the body
@@ -1759,7 +1984,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
-- With rebindable syntax the type might not
-- be quite as simple as (m (tya, tyb, tyc)).
}
-deriving instance (Data body, DataId idL, DataId idR)
+deriving instance (Data body, DataIdLR idL idR)
=> Data (StmtLR idL idR body)
data TransForm -- The 'f' below is the 'using' function, 'e' is the by function
@@ -1770,13 +1995,18 @@ data TransForm -- The 'f' below is the 'using' function, 'e' is the by functio
-- | Parenthesised Statement Block
data ParStmtBlock idL idR
= ParStmtBlock
+ (XParStmtBlock idL idR)
[ExprLStmt idL]
[IdP idR] -- The variables to be returned
(SyntaxExpr idR) -- The return operator
-deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR)
+ | XParStmtBlock (XXParStmtBlock idL idR)
+deriving instance (DataIdLR idL idR) => Data (ParStmtBlock idL idR)
+
+type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder
+type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder
-- | Applicative Argument
-data ApplicativeArg idL idR
+data ApplicativeArg idL
= ApplicativeArgOne -- A single statement (BindStmt or BodyStmt)
(LPat idL) -- WildPat if it was a BodyStmt (see below)
(LHsExpr idL)
@@ -1788,8 +2018,7 @@ data ApplicativeArg idL idR
[ExprLStmt idL] -- stmts
(HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn)
(LPat idL) -- (v1,...,vn)
-
-deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR)
+deriving instance (DataIdLR idL idL) => Data (ApplicativeArg idL)
{-
Note [The type of bind in Stmts]
@@ -1956,19 +2185,24 @@ Bool flag that is True when the original statement was a BodyStmt, so
that we can pretty-print it correctly.
-}
-instance (SourceTextX idL, OutputableBndrId idL)
- => Outputable (ParStmtBlock idL idR) where
- ppr (ParStmtBlock stmts _ _) = interpp'SP stmts
+instance (SourceTextX (GhcPass idL), OutputableBndrId (GhcPass idL),
+ Outputable (XXParStmtBlock (GhcPass idL) idR))
+ => Outputable (ParStmtBlock (GhcPass idL) idR) where
+ ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts
+ ppr (XParStmtBlock x) = ppr x
-instance (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR, Outputable body)
- => Outputable (StmtLR idL idR body) where
+instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => Outputable (StmtLR (GhcPass idL) (GhcPass idR) body) where
ppr stmt = pprStmt stmt
-pprStmt :: forall idL idR body . (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR,
+pprStmt :: forall idL idR body . (SourceTextX (GhcPass idL),
+ SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL),
+ OutputableBndrId (GhcPass idR),
Outputable body)
- => (StmtLR idL idR body) -> SDoc
+ => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc
pprStmt (LastStmt expr ret_stripped _)
= whenPprDebug (text "[last]") <+>
(if ret_stripped then text "return" else empty) <+>
@@ -2002,17 +2236,17 @@ pprStmt (ApplicativeStmt args mb_join _)
-- ppr directly rather than transforming here, because we need to
-- inject a "return" which is hard when we're polymorphic in the id
-- type.
- flattenStmt :: ExprLStmt idL -> [SDoc]
flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args
flattenStmt stmt = [ppr stmt]
+ flattenArg :: (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
flattenArg (_, ApplicativeArgOne pat expr isBody)
| isBody = -- See Note [Applicative BodyStmt]
[ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)]
+ :: ExprStmt (GhcPass idL))]
| otherwise =
[ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)]
+ :: ExprStmt (GhcPass idL))]
flattenArg (_, ApplicativeArgMany stmts _ _) =
concatMap flattenStmt stmts
@@ -2024,22 +2258,23 @@ pprStmt (ApplicativeStmt args mb_join _)
then ap_expr
else text "join" <+> parens ap_expr
+ pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
pp_arg (_, ApplicativeArgOne pat expr isBody)
| isBody = -- See Note [Applicative BodyStmt]
ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)
+ :: ExprStmt (GhcPass idL))
| otherwise =
ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)
+ :: ExprStmt (GhcPass idL))
pp_arg (_, ApplicativeArgMany stmts return pat) =
ppr pat <+>
text "<-" <+>
- ppr (HsDo DoExpr (noLoc
- (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]))
- (error "pprStmt"))
+ ppr (HsDo (panic "pprStmt") DoExpr (noLoc
+ (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])))
-pprTransformStmt :: (SourceTextX p, OutputableBndrId p)
- => [IdP p] -> LHsExpr p -> Maybe (LHsExpr p) -> SDoc
+pprTransformStmt :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
+ -> Maybe (LHsExpr (GhcPass p)) -> SDoc
pprTransformStmt bndrs using by
= sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))
, nest 2 (ppr using)
@@ -2055,8 +2290,9 @@ pprBy :: Outputable body => Maybe body -> SDoc
pprBy Nothing = empty
pprBy (Just e) = text "by" <+> ppr e
-pprDo :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => HsStmtContext any -> [LStmt p body] -> SDoc
+pprDo :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p),
+ Outputable body)
+ => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc
pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts
pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts
pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts
@@ -2066,14 +2302,16 @@ pprDo PArrComp stmts = paBrackets $ pprComp stmts
pprDo MonadComp stmts = brackets $ pprComp stmts
pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
-ppr_do_stmts :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR, Outputable body)
- => [LStmtLR idL idR body] -> SDoc
+ppr_do_stmts :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc
-- Print a bunch of do stmts
ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)
-pprComp :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => [LStmt p body] -> SDoc
+pprComp :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p),
+ Outputable body)
+ => [LStmt (GhcPass p) body] -> SDoc
pprComp quals -- Prints: body | qual1, ..., qualn
| Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals
= if null initStmts
@@ -2087,8 +2325,9 @@ pprComp quals -- Prints: body | qual1, ..., qualn
| otherwise
= pprPanic "pprComp" (pprQuals quals)
-pprQuals :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => [LStmt p body] -> SDoc
+pprQuals :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p),
+ Outputable body)
+ => [LStmt (GhcPass p) body] -> SDoc
-- Show list comprehension qualifiers separated by commas
pprQuals quals = interpp'SP quals
@@ -2103,30 +2342,44 @@ pprQuals quals = interpp'SP quals
-- | Haskell Splice
data HsSplice id
= HsTypedSplice -- $$z or $$(f 4)
+ (XTypedSplice id)
SpliceDecoration -- Whether $$( ) variant found, for pretty printing
(IdP id) -- A unique name to identify this splice point
(LHsExpr id) -- See Note [Pending Splices]
| HsUntypedSplice -- $z or $(f 4)
+ (XUntypedSplice id)
SpliceDecoration -- Whether $( ) variant found, for pretty printing
(IdP id) -- A unique name to identify this splice point
(LHsExpr id) -- See Note [Pending Splices]
| HsQuasiQuote -- See Note [Quasi-quote overview] in TcSplice
+ (XQuasiQuote id)
(IdP id) -- Splice point
(IdP id) -- Quoter
SrcSpan -- The span of the enclosed string
FastString -- The enclosed string
+ -- AZ:TODO: use XSplice instead of HsSpliced
| HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in
-- RnSplice.
-- This is the result of splicing a splice. It is produced by
-- the renamer and consumed by the typechecker. It lives only
-- between the two.
+ (XSpliced id)
ThModFinalizers -- TH finalizers produced by the splice.
(HsSplicedThing id) -- The result of splicing
+ | XSplice (XXSplice id) -- Note [Trees that Grow] extension point
deriving Typeable
-deriving instance (DataId id) => Data (HsSplice id)
+deriving instance (DataIdLR id id) => Data (HsSplice id)
+
+
+type instance XTypedSplice (GhcPass _) = PlaceHolder
+type instance XUntypedSplice (GhcPass _) = PlaceHolder
+type instance XQuasiQuote (GhcPass _) = PlaceHolder
+type instance XSpliced (GhcPass _) = PlaceHolder
+type instance XXSplice (GhcPass _) = PlaceHolder
+
-- | A splice can appear with various decorations wrapped around it. This data
-- type captures explicitly how it was originally written, for use in the pretty
@@ -2168,7 +2421,7 @@ data HsSplicedThing id
| HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern
deriving Typeable
-deriving instance (DataId id) => Data (HsSplicedThing id)
+deriving instance (DataIdLR id id) => Data (HsSplicedThing id)
-- See Note [Pending Splices]
type SplicePointName = Name
@@ -2192,7 +2445,6 @@ data PendingTcSplice
= PendingTcSplice SplicePointName (LHsExpr GhcTc)
deriving Data
-
{-
Note [Pending Splices]
~~~~~~~~~~~~~~~~~~~~~~
@@ -2257,85 +2509,103 @@ splices. In contrast, when pretty printing the output of the type checker, we
sense, although I hate to add another constructor to HsExpr.
-}
-instance (SourceTextX p, OutputableBndrId p)
- => Outputable (HsSplicedThing p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsSplicedThing (GhcPass p)) where
ppr (HsSplicedExpr e) = ppr_expr e
ppr (HsSplicedTy t) = ppr t
ppr (HsSplicedPat p) = ppr p
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsSplice p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsSplice (GhcPass p)) where
ppr s = pprSplice s
-pprPendingSplice :: (SourceTextX p, OutputableBndrId p)
- => SplicePointName -> LHsExpr p -> SDoc
+pprPendingSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => SplicePointName -> LHsExpr (GhcPass p) -> SDoc
pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e)
-pprSpliceDecl :: (SourceTextX p, OutputableBndrId p)
- => HsSplice p -> SpliceExplicitFlag -> SDoc
+pprSpliceDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e
pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")"
pprSpliceDecl e ImplicitSplice = ppr_splice_decl e
-ppr_splice_decl :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
-ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty
+ppr_splice_decl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SDoc
+ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty
ppr_splice_decl e = pprSplice e
-pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
-pprSplice (HsTypedSplice HasParens n e)
+pprSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SDoc
+pprSplice (HsTypedSplice _ HasParens n e)
= ppr_splice (text "$$(") n e (text ")")
-pprSplice (HsTypedSplice HasDollar n e)
+pprSplice (HsTypedSplice _ HasDollar n e)
= ppr_splice (text "$$") n e empty
-pprSplice (HsTypedSplice NoParens n e)
+pprSplice (HsTypedSplice _ NoParens n e)
= ppr_splice empty n e empty
-pprSplice (HsUntypedSplice HasParens n e)
+pprSplice (HsUntypedSplice _ HasParens n e)
= ppr_splice (text "$(") n e (text ")")
-pprSplice (HsUntypedSplice HasDollar n e)
+pprSplice (HsUntypedSplice _ HasDollar n e)
= ppr_splice (text "$") n e empty
-pprSplice (HsUntypedSplice NoParens n e)
+pprSplice (HsUntypedSplice _ NoParens n e)
= ppr_splice empty n e empty
-pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s
-pprSplice (HsSpliced _ thing) = ppr thing
+pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s
+pprSplice (HsSpliced _ _ thing) = ppr thing
+pprSplice (XSplice x) = ppr x
ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc
ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>
char '[' <> ppr quoter <> vbar <>
ppr quote <> text "|]"
-ppr_splice :: (SourceTextX p, OutputableBndrId p)
- => SDoc -> (IdP p) -> LHsExpr p -> SDoc -> SDoc
+ppr_splice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc
ppr_splice herald n e trail
= herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail
-- | Haskell Bracket
-data HsBracket p = ExpBr (LHsExpr p) -- [| expr |]
- | PatBr (LPat p) -- [p| pat |]
- | DecBrL [LHsDecl p] -- [d| decls |]; result of parser
- | DecBrG (HsGroup p) -- [d| decls |]; result of renamer
- | TypBr (LHsType p) -- [t| type |]
- | VarBr Bool (IdP p) -- True: 'x, False: ''T
- -- (The Bool flag is used only in pprHsBracket)
- | TExpBr (LHsExpr p) -- [|| expr ||]
-deriving instance (DataId p) => Data (HsBracket p)
+data HsBracket p
+ = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |]
+ | PatBr (XPatBr p) (LPat p) -- [p| pat |]
+ | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser
+ | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer
+ | TypBr (XTypBr p) (LHsType p) -- [t| type |]
+ | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T
+ -- (The Bool flag is used only in pprHsBracket)
+ | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||]
+ | XBracket (XXBracket p) -- Note [Trees that Grow] extension point
+deriving instance (DataIdLR p p) => Data (HsBracket p)
+
+type instance XExpBr (GhcPass _) = PlaceHolder
+type instance XPatBr (GhcPass _) = PlaceHolder
+type instance XDecBrL (GhcPass _) = PlaceHolder
+type instance XDecBrG (GhcPass _) = PlaceHolder
+type instance XTypBr (GhcPass _) = PlaceHolder
+type instance XVarBr (GhcPass _) = PlaceHolder
+type instance XTExpBr (GhcPass _) = PlaceHolder
+type instance XXBracket (GhcPass _) = PlaceHolder
isTypedBracket :: HsBracket id -> Bool
isTypedBracket (TExpBr {}) = True
isTypedBracket _ = False
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsBracket p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsBracket (GhcPass p)) where
ppr = pprHsBracket
-pprHsBracket :: (SourceTextX p, OutputableBndrId p) => HsBracket p -> SDoc
-pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
-pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
-pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
-pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
-pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
-pprHsBracket (VarBr True n)
+pprHsBracket :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsBracket (GhcPass p) -> SDoc
+pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e)
+pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p)
+pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)
+pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))
+pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t)
+pprHsBracket (VarBr _ True n)
= char '\'' <> pprPrefixOcc n
-pprHsBracket (VarBr False n)
+pprHsBracket (VarBr _ False n)
= text "''" <> pprPrefixOcc n
-pprHsBracket (TExpBr e) = thTyBrackets (ppr e)
+pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e)
+pprHsBracket (XBracket e) = ppr e
thBrackets :: SDoc -> SDoc -> SDoc
thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
@@ -2368,10 +2638,11 @@ data ArithSeqInfo id
| FromThenTo (LHsExpr id)
(LHsExpr id)
(LHsExpr id)
-deriving instance (DataId id) => Data (ArithSeqInfo id)
+deriving instance (DataIdLR id id) => Data (ArithSeqInfo id)
+-- AZ: Sould ArithSeqInfo have a TTG extension?
-instance (SourceTextX p, OutputableBndrId p)
- => Outputable (ArithSeqInfo p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (ArithSeqInfo (GhcPass p)) where
ppr (From e1) = hcat [ppr e1, pp_dotdot]
ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3]
@@ -2587,19 +2858,21 @@ matchContextErrString (StmtCtxt ListComp) = text "list comprehension"
matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension"
matchContextErrString (StmtCtxt PArrComp) = text "array comprehension"
-pprMatchInCtxt :: (SourceTextX idR, OutputableBndrId idR,
+pprMatchInCtxt :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
-- TODO:AZ these constraints do not make sense
- Outputable (NameOrRdrName (NameOrRdrName (IdP idR))),
- Outputable body)
- => Match idR body -> SDoc
+ Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))),
+ Outputable body)
+ => Match (GhcPass idR) body -> SDoc
pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
<> colon)
4 (pprMatch match)
-pprStmtInCtxt :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR,
+pprStmtInCtxt :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL),
+ OutputableBndrId (GhcPass idR),
Outputable body)
- => HsStmtContext (IdP idL) -> StmtLR idL idR body -> SDoc
+ => HsStmtContext (IdP (GhcPass idL))
+ -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
pprStmtInCtxt ctxt (LastStmt e _ _)
| isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts"
= hang (text "In the expression:") 2 (ppr e)
diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot
index bac8a5a183..500d601477 100644
--- a/compiler/hsSyn/HsExpr.hs-boot
+++ b/compiler/hsSyn/HsExpr.hs-boot
@@ -5,6 +5,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
module HsExpr where
@@ -12,7 +13,7 @@ import SrcLoc ( Located )
import Outputable ( SDoc, Outputable )
import {-# SOURCE #-} HsPat ( LPat )
import BasicTypes ( SpliceExplicitFlag(..))
-import HsExtension ( OutputableBndrId, DataId, SourceTextX )
+import HsExtension ( OutputableBndrId, DataIdLR, SourceTextX, GhcPass )
import Data.Data hiding ( Fixity )
type role HsExpr nominal
@@ -28,32 +29,39 @@ data MatchGroup (a :: *) (body :: *)
data GRHSs (a :: *) (body :: *)
data SyntaxExpr (i :: *)
-instance (DataId p) => Data (HsSplice p)
-instance (DataId p) => Data (HsExpr p)
-instance (DataId p) => Data (HsCmd p)
-instance (Data body,DataId p) => Data (MatchGroup p body)
-instance (Data body,DataId p) => Data (GRHSs p body)
-instance (DataId p) => Data (SyntaxExpr p)
+instance (DataIdLR p p) => Data (HsSplice p)
+instance (DataIdLR p p) => Data (HsExpr p)
+instance (DataIdLR p p) => Data (HsCmd p)
+instance (Data body,DataIdLR p p) => Data (MatchGroup p body)
+instance (Data body,DataIdLR p p) => Data (GRHSs p body)
+instance (DataIdLR p p) => Data (SyntaxExpr p)
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p)
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p)
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsExpr (GhcPass p))
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsCmd (GhcPass p))
type LHsExpr a = Located (HsExpr a)
-pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsExpr (GhcPass p) -> SDoc
-pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+pprExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p) -> SDoc
-pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
+pprSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SDoc
-pprSpliceDecl :: (SourceTextX p, OutputableBndrId p)
- => HsSplice p -> SpliceExplicitFlag -> SDoc
+pprSpliceDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
-pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr,
- OutputableBndrId bndr,
- OutputableBndrId p,
+pprPatBind :: forall bndr p body. (SourceTextX (GhcPass p),
+ SourceTextX (GhcPass bndr),
+ OutputableBndrId (GhcPass bndr),
+ OutputableBndrId (GhcPass p),
Outputable body)
- => LPat bndr -> GRHSs p body -> SDoc
+ => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
-pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => MatchGroup idR body -> SDoc
+pprFunBind :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => MatchGroup (GhcPass idR) body -> SDoc
diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs
index 80dfa67ea3..86a0bd9431 100644
--- a/compiler/hsSyn/HsExtension.hs
+++ b/compiler/hsSyn/HsExtension.hs
@@ -7,6 +7,9 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+ -- in module PlaceHolder
module HsExtension where
@@ -55,6 +58,10 @@ haskell-src-exts ASTs as well.
-}
+-- | Used when constructing a term with an unused extension point.
+noExt :: PlaceHolder
+noExt = PlaceHolder
+
-- | Used as a data type index for the hsSyn AST
data GhcPass (c :: Pass)
deriving instance Eq (GhcPass c)
@@ -76,6 +83,8 @@ type instance PostTc GhcPs ty = PlaceHolder
type instance PostTc GhcRn ty = PlaceHolder
type instance PostTc GhcTc ty = ty
+-- deriving instance (Data ty) => Data (PostTc (GhcPass 'Parsed) ty)
+
-- | Types that are not defined until after renaming
type family PostRn x ty -- Note [Pass sensitive types] in PlaceHolder
type instance PostRn GhcPs ty = PlaceHolder
@@ -87,88 +96,415 @@ type family IdP p
type instance IdP GhcPs = RdrName
type instance IdP GhcRn = Name
type instance IdP GhcTc = Id
+-- type instance IdP (GHC x) = IdP x
+
+type LIdP p = Located (IdP p)
+-- ---------------------------------------------------------------------
+-- type families for the Pat extension points
+type family XWildPat x
+type family XVarPat x
+type family XLazyPat x
+type family XAsPat x
+type family XParPat x
+type family XBangPat x
+type family XListPat x
+type family XTuplePat x
+type family XSumPat x
+type family XPArrPat x
+type family XConPat x
+type family XViewPat x
+type family XSplicePat x
+type family XLitPat x
+type family XNPat x
+type family XNPlusKPat x
+type family XSigPat x
+type family XCoPat x
+type family XXPat x
+
+
+type ForallXPat (c :: * -> Constraint) (x :: *) =
+ ( c (XWildPat x)
+ , c (XVarPat x)
+ , c (XLazyPat x)
+ , c (XAsPat x)
+ , c (XParPat x)
+ , c (XBangPat x)
+ , c (XListPat x)
+ , c (XTuplePat x)
+ , c (XSumPat x)
+ , c (XPArrPat x)
+ , c (XViewPat x)
+ , c (XSplicePat x)
+ , c (XLitPat x)
+ , c (XNPat x)
+ , c (XNPlusKPat x)
+ , c (XSigPat x)
+ , c (XCoPat x)
+ , c (XXPat x)
+ )
+-- ---------------------------------------------------------------------
+-- ValBindsLR type families
--- We define a type family for each extension point. This is based on prepending
--- 'X' to the constructor name, for ease of reference.
-type family XHsChar x
-type family XHsCharPrim x
-type family XHsString x
+type family XValBinds x x'
+type family XXValBindsLR x x'
+
+type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
+ ( c (XValBinds x x')
+ , c (XXValBindsLR x x')
+ )
+
+-- We define a type family for each HsLit extension point. This is based on
+-- prepending 'X' to the constructor name, for ease of reference.
+type family XHsChar x
+type family XHsCharPrim x
+type family XHsString x
type family XHsStringPrim x
-type family XHsInt x
-type family XHsIntPrim x
-type family XHsWordPrim x
-type family XHsInt64Prim x
+type family XHsInt x
+type family XHsIntPrim x
+type family XHsWordPrim x
+type family XHsInt64Prim x
type family XHsWord64Prim x
-type family XHsInteger x
-type family XHsRat x
-type family XHsFloatPrim x
+type family XHsInteger x
+type family XHsRat x
+type family XHsFloatPrim x
type family XHsDoublePrim x
+type family XXLit x
--- | Helper to apply a constraint to all extension points. It has one
+-- | Helper to apply a constraint to all HsLit extension points. It has one
-- entry per extension point type family.
-type ForallX (c :: * -> Constraint) (x :: *) =
- ( c (XHsChar x)
- , c (XHsCharPrim x)
- , c (XHsString x)
+type ForallXHsLit (c :: * -> Constraint) (x :: *) =
+ ( c (XHsChar x)
+ , c (XHsCharPrim x)
+ , c (XHsString x)
, c (XHsStringPrim x)
- , c (XHsInt x)
- , c (XHsIntPrim x)
- , c (XHsWordPrim x)
- , c (XHsInt64Prim x)
+ , c (XHsInt x)
+ , c (XHsIntPrim x)
+ , c (XHsWordPrim x)
+ , c (XHsInt64Prim x)
, c (XHsWord64Prim x)
- , c (XHsInteger x)
- , c (XHsRat x)
- , c (XHsFloatPrim x)
+ , c (XHsInteger x)
+ , c (XHsRat x)
+ , c (XHsFloatPrim x)
, c (XHsDoublePrim x)
+ , c (XXLit x)
)
--- Provide the specific extension types for the parser phase.
-type instance XHsChar GhcPs = SourceText
-type instance XHsCharPrim GhcPs = SourceText
-type instance XHsString GhcPs = SourceText
-type instance XHsStringPrim GhcPs = SourceText
-type instance XHsInt GhcPs = ()
-type instance XHsIntPrim GhcPs = SourceText
-type instance XHsWordPrim GhcPs = SourceText
-type instance XHsInt64Prim GhcPs = SourceText
-type instance XHsWord64Prim GhcPs = SourceText
-type instance XHsInteger GhcPs = SourceText
-type instance XHsRat GhcPs = ()
-type instance XHsFloatPrim GhcPs = ()
-type instance XHsDoublePrim GhcPs = ()
-
--- Provide the specific extension types for the renamer phase.
-type instance XHsChar GhcRn = SourceText
-type instance XHsCharPrim GhcRn = SourceText
-type instance XHsString GhcRn = SourceText
-type instance XHsStringPrim GhcRn = SourceText
-type instance XHsInt GhcRn = ()
-type instance XHsIntPrim GhcRn = SourceText
-type instance XHsWordPrim GhcRn = SourceText
-type instance XHsInt64Prim GhcRn = SourceText
-type instance XHsWord64Prim GhcRn = SourceText
-type instance XHsInteger GhcRn = SourceText
-type instance XHsRat GhcRn = ()
-type instance XHsFloatPrim GhcRn = ()
-type instance XHsDoublePrim GhcRn = ()
-
--- Provide the specific extension types for the typechecker phase.
-type instance XHsChar GhcTc = SourceText
-type instance XHsCharPrim GhcTc = SourceText
-type instance XHsString GhcTc = SourceText
-type instance XHsStringPrim GhcTc = SourceText
-type instance XHsInt GhcTc = ()
-type instance XHsIntPrim GhcTc = SourceText
-type instance XHsWordPrim GhcTc = SourceText
-type instance XHsInt64Prim GhcTc = SourceText
-type instance XHsWord64Prim GhcTc = SourceText
-type instance XHsInteger GhcTc = SourceText
-type instance XHsRat GhcTc = ()
-type instance XHsFloatPrim GhcTc = ()
-type instance XHsDoublePrim GhcTc = ()
+type family XOverLit x
+type family XXOverLit x
+
+type ForallXOverLit (c :: * -> Constraint) (x :: *) =
+ ( c (XOverLit x)
+ , c (XXOverLit x)
+ )
+
+-- ---------------------------------------------------------------------
+-- Type families for the Type type families
+
+type family XForAllTy x
+type family XQualTy x
+type family XTyVar x
+type family XAppsTy x
+type family XAppTy x
+type family XFunTy x
+type family XListTy x
+type family XPArrTy x
+type family XTupleTy x
+type family XSumTy x
+type family XOpTy x
+type family XParTy x
+type family XIParamTy x
+type family XEqTy x
+type family XKindSig x
+type family XSpliceTy x
+type family XDocTy x
+type family XBangTy x
+type family XRecTy x
+type family XExplicitListTy x
+type family XExplicitTupleTy x
+type family XTyLit x
+type family XWildCardTy x
+type family XXType x
+
+-- | Helper to apply a constraint to all extension points. It has one
+-- entry per extension point type family.
+type ForallXType (c :: * -> Constraint) (x :: *) =
+ ( c (XForAllTy x)
+ , c (XQualTy x)
+ , c (XTyVar x)
+ , c (XAppsTy x)
+ , c (XAppTy x)
+ , c (XFunTy x)
+ , c (XListTy x)
+ , c (XPArrTy x)
+ , c (XTupleTy x)
+ , c (XSumTy x)
+ , c (XOpTy x)
+ , c (XParTy x)
+ , c (XIParamTy x)
+ , c (XEqTy x)
+ , c (XKindSig x)
+ , c (XSpliceTy x)
+ , c (XDocTy x)
+ , c (XBangTy x)
+ , c (XRecTy x)
+ , c (XExplicitListTy x)
+ , c (XExplicitTupleTy x)
+ , c (XTyLit x)
+ , c (XWildCardTy x)
+ , c (XXType x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XUserTyVar x
+type family XKindedTyVar x
+type family XXTyVarBndr x
+
+type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) =
+ ( c (XUserTyVar x)
+ , c (XKindedTyVar x)
+ , c (XXTyVarBndr x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XAppInfix x
+type family XAppPrefix x
+type family XXAppType x
+
+type ForallXAppType (c :: * -> Constraint) (x :: *) =
+ ( c (XAppInfix x)
+ , c (XAppPrefix x)
+ , c (XXAppType x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XFieldOcc x
+type family XXFieldOcc x
+
+type ForallXFieldOcc (c :: * -> Constraint) (x :: *) =
+ ( c (XFieldOcc x)
+ , c (XXFieldOcc x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XUnambiguous x
+type family XAmbiguous x
+type family XXAmbiguousFieldOcc x
+
+type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) =
+ ( c (XUnambiguous x)
+ , c (XAmbiguous x)
+ , c (XXAmbiguousFieldOcc x)
+ )
+
+-- ---------------------------------------------------------------------
+-- Type families for the HsExpr type families
+
+type family XVar x
+type family XUnboundVar x
+type family XConLikeOut x
+type family XRecFld x
+type family XOverLabel x
+type family XIPVar x
+type family XOverLitE x
+type family XLitE x
+type family XLam x
+type family XLamCase x
+type family XApp x
+type family XAppTypeE x
+type family XOpApp x
+type family XNegApp x
+type family XPar x
+type family XSectionL x
+type family XSectionR x
+type family XExplicitTuple x
+type family XExplicitSum x
+type family XCase x
+type family XIf x
+type family XMultiIf x
+type family XLet x
+type family XDo x
+type family XExplicitList x
+type family XExplicitPArr x
+type family XRecordCon x
+type family XRecordUpd x
+type family XExprWithTySig x
+type family XArithSeq x
+type family XPArrSeq x
+type family XSCC x
+type family XCoreAnn x
+type family XBracket x
+type family XRnBracketOut x
+type family XTcBracketOut x
+type family XSpliceE x
+type family XProc x
+type family XStatic x
+type family XArrApp x
+type family XArrForm x
+type family XTick x
+type family XBinTick x
+type family XTickPragma x
+type family XEWildPat x
+type family XEAsPat x
+type family XEViewPat x
+type family XELazyPat x
+type family XWrap x
+type family XXExpr x
+
+type ForallXExpr (c :: * -> Constraint) (x :: *) =
+ ( c (XVar x)
+ , c (XUnboundVar x)
+ , c (XConLikeOut x)
+ , c (XRecFld x)
+ , c (XOverLabel x)
+ , c (XIPVar x)
+ , c (XOverLitE x)
+ , c (XLitE x)
+ , c (XLam x)
+ , c (XLamCase x)
+ , c (XApp x)
+ , c (XAppTypeE x)
+ , c (XOpApp x)
+ , c (XNegApp x)
+ , c (XPar x)
+ , c (XSectionL x)
+ , c (XSectionR x)
+ , c (XExplicitTuple x)
+ , c (XExplicitSum x)
+ , c (XCase x)
+ , c (XIf x)
+ , c (XMultiIf x)
+ , c (XLet x)
+ , c (XDo x)
+ , c (XExplicitList x)
+ , c (XExplicitPArr x)
+ , c (XRecordCon x)
+ , c (XRecordUpd x)
+ , c (XExprWithTySig x)
+ , c (XArithSeq x)
+ , c (XPArrSeq x)
+ , c (XSCC x)
+ , c (XCoreAnn x)
+ , c (XBracket x)
+ , c (XRnBracketOut x)
+ , c (XTcBracketOut x)
+ , c (XSpliceE x)
+ , c (XProc x)
+ , c (XStatic x)
+ , c (XArrApp x)
+ , c (XArrForm x)
+ , c (XTick x)
+ , c (XBinTick x)
+ , c (XTickPragma x)
+ , c (XEWildPat x)
+ , c (XEAsPat x)
+ , c (XEViewPat x)
+ , c (XELazyPat x)
+ , c (XWrap x)
+ , c (XXExpr x)
+ )
+-- ---------------------------------------------------------------------
+
+type family XPresent x
+type family XMissing x
+type family XXTupArg x
+
+type ForallXTupArg (c :: * -> Constraint) (x :: *) =
+ ( c (XPresent x)
+ , c (XMissing x)
+ , c (XXTupArg x)
+ )
+-- ---------------------------------------------------------------------
+
+type family XTypedSplice x
+type family XUntypedSplice x
+type family XQuasiQuote x
+type family XSpliced x
+type family XXSplice x
+
+type ForallXSplice (c :: * -> Constraint) (x :: *) =
+ ( c (XTypedSplice x)
+ , c (XUntypedSplice x)
+ , c (XQuasiQuote x)
+ , c (XSpliced x)
+ , c (XXSplice x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XExpBr x
+type family XPatBr x
+type family XDecBrL x
+type family XDecBrG x
+type family XTypBr x
+type family XVarBr x
+type family XTExpBr x
+type family XXBracket x
+
+type ForallXBracket (c :: * -> Constraint) (x :: *) =
+ ( c (XExpBr x)
+ , c (XPatBr x)
+ , c (XDecBrL x)
+ , c (XDecBrG x)
+ , c (XTypBr x)
+ , c (XVarBr x)
+ , c (XTExpBr x)
+ , c (XXBracket x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XCmdTop x
+type family XXCmdTop x
+
+type ForallXCmdTop (c :: * -> Constraint) (x :: *) =
+ ( c (XCmdTop x)
+ , c (XXCmdTop x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XCmdArrApp x
+type family XCmdArrForm x
+type family XCmdApp x
+type family XCmdLam x
+type family XCmdPar x
+type family XCmdCase x
+type family XCmdIf x
+type family XCmdLet x
+type family XCmdDo x
+type family XCmdWrap x
+type family XXCmd x
+
+type ForallXCmd (c :: * -> Constraint) (x :: *) =
+ ( c (XCmdArrApp x)
+ , c (XCmdArrForm x)
+ , c (XCmdApp x)
+ , c (XCmdLam x)
+ , c (XCmdPar x)
+ , c (XCmdCase x)
+ , c (XCmdIf x)
+ , c (XCmdLet x)
+ , c (XCmdDo x)
+ , c (XCmdWrap x)
+ , c (XXCmd x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XParStmtBlock x x'
+type family XXParStmtBlock x x'
+
+type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) =
+ ( c (XParStmtBlock x x')
+ , c (XXParStmtBlock x x')
+ )
-- ---------------------------------------------------------------------
@@ -212,22 +548,6 @@ instance HasSourceText SourceText where
-- ----------------------------------------------------------------------
--- | Defaults for each annotation, used to simplify creation in arbitrary
--- contexts
-class HasDefault a where
- def :: a
-
-instance HasDefault () where
- def = ()
-
-instance HasDefault SourceText where
- def = NoSourceText
-
--- | Provide a single constraint that captures the requirement for a default
--- across all the extension points.
-type HasDefaultX x = ForallX HasDefault x
-
--- ----------------------------------------------------------------------
-- | Conversion of annotations from one type index to another. This is required
-- where the AST is converted from one pass to another, and the extension values
-- need to be brought along if possible. So for example a 'SourceText' is
@@ -254,15 +574,69 @@ type ConvertIdX a b =
XHsStringPrim a ~ XHsStringPrim b,
XHsString a ~ XHsString b,
XHsCharPrim a ~ XHsCharPrim b,
- XHsChar a ~ XHsChar b)
+ XHsChar a ~ XHsChar b,
+ XXLit a ~ XXLit b)
+
+-- ----------------------------------------------------------------------
+
+-- | Provide a summary constraint that gives all am Outputable constraint to
+-- extension points needing one
+type OutputableX p =
+ ( Outputable (XXPat p)
+ , Outputable (XXPat GhcRn)
+
+ , Outputable (XSigPat p)
+ , Outputable (XSigPat GhcRn)
+
+ , Outputable (XXLit p)
+ , Outputable (XXOverLit p)
+
+ , Outputable (XXType p)
+
+ , Outputable (XExprWithTySig p)
+ , Outputable (XExprWithTySig GhcRn)
+
+ , Outputable (XAppTypeE p)
+ , Outputable (XAppTypeE GhcRn)
+
+ -- , Outputable (XXParStmtBlock (GhcPass idL) idR)
+ )
+-- TODO: Should OutputableX be included in OutputableBndrId?
-- ----------------------------------------------------------------------
--
type DataId p =
( Data p
- , ForallX Data p
+
+ , ForallXHsLit Data p
+ , ForallXPat Data p
+
+ -- Th following GhcRn constraints should go away once TTG is fully implemented
+ , ForallXPat Data GhcRn
+ , ForallXType Data GhcRn
+ , ForallXExpr Data GhcRn
+ , ForallXTupArg Data GhcRn
+ , ForallXSplice Data GhcRn
+ , ForallXBracket Data GhcRn
+ , ForallXCmdTop Data GhcRn
+ , ForallXCmd Data GhcRn
+
+ , ForallXOverLit Data p
+ , ForallXType Data p
+ , ForallXTyVarBndr Data p
+ , ForallXAppType Data p
+ , ForallXFieldOcc Data p
+ , ForallXAmbiguousFieldOcc Data p
+
+ , ForallXExpr Data p
+ , ForallXTupArg Data p
+ , ForallXSplice Data p
+ , ForallXBracket Data p
+ , ForallXCmdTop Data p
+ , ForallXCmd Data p
+
, Data (NameOrRdrName (IdP p))
, Data (IdP p)
@@ -282,10 +656,23 @@ type DataId p =
, Data (PostTc p [Type])
)
+type DataIdLR pL pR =
+ ( DataId pL
+ , DataId pR
+ , ForallXValBindsLR Data pL pR
+ , ForallXValBindsLR Data pL pL
+ , ForallXValBindsLR Data pR pR
+
+ , ForallXParStmtBlock Data pL pR
+ , ForallXParStmtBlock Data pL pL
+ , ForallXParStmtBlock Data pR pR
+ , ForallXParStmtBlock Data GhcRn GhcRn
+ )
-- |Constraint type to bundle up the requirement for 'OutputableBndr' on both
-- the @id@ and the 'NameOrRdrName' type for it
type OutputableBndrId id =
( OutputableBndr (NameOrRdrName (IdP id))
, OutputableBndr (IdP id)
+ , OutputableX id
)
diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs
index 7f0864eccc..a47b0ff4fe 100644
--- a/compiler/hsSyn/HsLit.hs
+++ b/compiler/hsSyn/HsLit.hs
@@ -28,6 +28,7 @@ import Type ( Type )
import Outputable
import FastString
import HsExtension
+import PlaceHolder
import Data.ByteString (ByteString)
import Data.Data hiding ( Fixity )
@@ -77,8 +78,25 @@ data HsLit x
| HsDoublePrim (XHsDoublePrim x) FractionalLit
-- ^ Unboxed Double
+ | XLit (XXLit x)
+
deriving instance (DataId x) => Data (HsLit x)
+type instance XHsChar (GhcPass _) = SourceText
+type instance XHsCharPrim (GhcPass _) = SourceText
+type instance XHsString (GhcPass _) = SourceText
+type instance XHsStringPrim (GhcPass _) = SourceText
+type instance XHsInt (GhcPass _) = PlaceHolder
+type instance XHsIntPrim (GhcPass _) = SourceText
+type instance XHsWordPrim (GhcPass _) = SourceText
+type instance XHsInt64Prim (GhcPass _) = SourceText
+type instance XHsWord64Prim (GhcPass _) = SourceText
+type instance XHsInteger (GhcPass _) = SourceText
+type instance XHsRat (GhcPass _) = PlaceHolder
+type instance XHsFloatPrim (GhcPass _) = PlaceHolder
+type instance XHsDoublePrim (GhcPass _) = PlaceHolder
+type instance XXLit (GhcPass _) = PlaceHolder
+
instance Eq (HsLit x) where
(HsChar _ x1) == (HsChar _ x2) = x1==x2
@@ -99,11 +117,25 @@ instance Eq (HsLit x) where
-- | Haskell Overloaded Literal
data HsOverLit p
= OverLit {
- ol_val :: OverLitVal,
- ol_rebindable :: PostRn p Bool, -- Note [ol_rebindable]
- ol_witness :: HsExpr p, -- Note [Overloaded literal witnesses]
- ol_type :: PostTc p Type }
-deriving instance (DataId p) => Data (HsOverLit p)
+ ol_ext :: (XOverLit p),
+ ol_val :: OverLitVal,
+ ol_witness :: HsExpr p} -- Note [Overloaded literal witnesses]
+
+ | XOverLit
+ (XXOverLit p)
+deriving instance (DataIdLR p p) => Data (HsOverLit p)
+
+data OverLitTc
+ = OverLitTc {
+ ol_rebindable :: Bool, -- Note [ol_rebindable]
+ ol_type :: Type }
+ deriving Data
+
+type instance XOverLit GhcPs = PlaceHolder
+type instance XOverLit GhcRn = Bool -- Note [ol_rebindable]
+type instance XOverLit GhcTc = OverLitTc
+
+type instance XXOverLit (GhcPass _) = PlaceHolder
-- Note [Literal source text] in BasicTypes for SourceText fields in
-- the following
@@ -119,8 +151,9 @@ negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)
negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)
negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"
-overLitType :: HsOverLit p -> PostTc p Type
-overLitType = ol_type
+overLitType :: HsOverLit GhcTc -> Type
+overLitType (OverLit (OverLitTc _ ty) _ _) = ty
+overLitType XOverLit{} = panic "overLitType"
-- | Convert a literal from one index type to another, updating the annotations
-- according to the relevant 'Convertable' instance
@@ -138,6 +171,7 @@ convertLit (HsInteger a x b) = (HsInteger (convert a) x b)
convertLit (HsRat a x b) = (HsRat (convert a) x b)
convertLit (HsFloatPrim a x) = (HsFloatPrim (convert a) x)
convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x)
+convertLit (XLit a) = (XLit (convert a))
{-
Note [ol_rebindable]
@@ -171,8 +205,10 @@ found to have.
-- Comparison operations are needed when grouping literals
-- for compiling pattern-matching (module MatchLit)
-instance Eq (HsOverLit p) where
- (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2
+instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where
+ (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2
+ (XOverLit val1) == (XOverLit val2) = val1 == val2
+ _ == _ = panic "Eq HsOverLit"
instance Eq OverLitVal where
(HsIntegral i1) == (HsIntegral i2) = i1 == i2
@@ -180,8 +216,10 @@ instance Eq OverLitVal where
(HsIsString _ s1) == (HsIsString _ s2) = s1 == s2
_ == _ = False
-instance Ord (HsOverLit p) where
- compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2
+instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where
+ compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2
+ compare (XOverLit val1) (XOverLit val2) = val1 `compare` val2
+ compare _ _ = panic "Ord HsOverLit"
instance Ord OverLitVal where
compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2
@@ -195,7 +233,7 @@ instance Ord OverLitVal where
compare (HsIsString _ _) (HsFractional _) = GT
-- Instance specific to GhcPs, need the SourceText
-instance (SourceTextX x) => Outputable (HsLit x) where
+instance (SourceTextX (GhcPass x)) => Outputable (HsLit (GhcPass x)) where
ppr (HsChar st c) = pprWithSourceText (getSourceText st) (pprHsChar c)
ppr (HsCharPrim st c)
= pp_st_suffix (getSourceText st) primCharSuffix (pprPrimChar c)
@@ -217,16 +255,18 @@ instance (SourceTextX x) => Outputable (HsLit x) where
= pp_st_suffix (getSourceText st) primInt64Suffix (pprPrimInt64 i)
ppr (HsWord64Prim st w)
= pp_st_suffix (getSourceText st) primWord64Suffix (pprPrimWord64 w)
+ ppr (XLit x) = ppr x
pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc
pp_st_suffix NoSourceText _ doc = doc
pp_st_suffix (SourceText st) suffix _ = text st <> suffix
-- in debug mode, print the expression that it's resolved to, too
-instance (SourceTextX p, OutputableBndrId p)
- => Outputable (HsOverLit p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsOverLit (GhcPass p)) where
ppr (OverLit {ol_val=val, ol_witness=witness})
= ppr val <+> (whenPprDebug (parens (pprExpr witness)))
+ ppr (XOverLit x) = ppr x
instance Outputable OverLitVal where
ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i))
@@ -239,7 +279,7 @@ instance Outputable OverLitVal where
-- mainly for too reasons:
-- * We do not want to expose their internal representation
-- * The warnings become too messy
-pmPprHsLit :: (SourceTextX x) => HsLit x -> SDoc
+pmPprHsLit :: (SourceTextX (GhcPass x)) => HsLit (GhcPass x) -> SDoc
pmPprHsLit (HsChar _ c) = pprHsChar c
pmPprHsLit (HsCharPrim _ c) = pprHsChar c
pmPprHsLit (HsString st s) = pprWithSourceText (getSourceText st)
@@ -254,3 +294,4 @@ pmPprHsLit (HsInteger _ i _) = integer i
pmPprHsLit (HsRat _ f _) = ppr f
pmPprHsLit (HsFloatPrim _ f) = ppr f
pmPprHsLit (HsDoublePrim _ d) = ppr d
+pmPprHsLit (XLit x) = ppr x
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index e05d8bbf68..863f00c99b 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -15,6 +15,7 @@
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
module HsPat (
Pat(..), InPat, OutPat, LPat,
@@ -49,6 +50,7 @@ import HsExtension
import HsTypes
import TcEvidence
import BasicTypes
+import PlaceHolder
-- others:
import PprCore ( {- instance OutputableBndr TyVar -} )
import TysWiredIn
@@ -78,42 +80,49 @@ type LPat p = Located (Pat p)
-- For details on above see note [Api annotations] in ApiAnnotation
data Pat p
= ------------ Simple patterns ---------------
- WildPat (PostTc p Type) -- ^ Wildcard Pattern
+ WildPat (XWildPat p) -- ^ Wildcard Pattern
-- The sole reason for a type on a WildPat is to
-- support hsPatType :: Pat Id -> Type
-- AZ:TODO above comment needs to be updated
- | VarPat (Located (IdP p)) -- ^ Variable Pattern
+ | VarPat (XVarPat p)
+ (Located (IdP p)) -- ^ Variable Pattern
-- See Note [Located RdrNames] in HsExpr
- | LazyPat (LPat p) -- ^ Lazy Pattern
+ | LazyPat (XLazyPat p)
+ (LPat p) -- ^ Lazy Pattern
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
-- For details on above see note [Api annotations] in ApiAnnotation
- | AsPat (Located (IdP p)) (LPat p) -- ^ As pattern
+ | AsPat (XAsPat p)
+ (Located (IdP p)) (LPat p) -- ^ As pattern
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
-- For details on above see note [Api annotations] in ApiAnnotation
- | ParPat (LPat p) -- ^ Parenthesised pattern
+ | ParPat (XParPat p)
+ (LPat p) -- ^ Parenthesised pattern
-- See Note [Parens in HsSyn] in HsExpr
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | BangPat (LPat p) -- ^ Bang pattern
+ | BangPat (XBangPat p)
+ (LPat p) -- ^ Bang pattern
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
-- For details on above see note [Api annotations] in ApiAnnotation
------------ Lists, tuples, arrays ---------------
- | ListPat [LPat p]
+ | ListPat (XListPat p)
+ [LPat p]
(PostTc p Type) -- The type of the elements
(Maybe (PostTc p Type, SyntaxExpr p)) -- For rebindable syntax
-- For OverloadedLists a Just (ty,fn) gives
-- overall type of the pattern, and the toList
- -- function to convert the scrutinee to a list value
+-- function to convert the scrutinee to a list value
+
-- ^ Syntactic List
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
@@ -121,12 +130,13 @@ data Pat p
-- For details on above see note [Api annotations] in ApiAnnotation
- | TuplePat [LPat p] -- Tuple sub-patterns
+ | TuplePat (XTuplePat p)
+ -- after typechecking, holds the types of the tuple components
+ [LPat p] -- Tuple sub-patterns
Boxity -- UnitPat is TuplePat []
- [PostTc p Type] -- [] before typechecker, filled in afterwards
- -- with the types of the tuple components
- -- You might think that the PostTc p Type was redundant, because we can
- -- get the pattern type by getting the types of the sub-patterns.
+ -- You might think that the post typechecking Type was redundant,
+ -- because we can get the pattern type by getting the types of the
+ -- sub-patterns.
-- But it's essential
-- data T a where
-- T1 :: Int -> T Int
@@ -146,12 +156,12 @@ data Pat p
-- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
-- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@
- | SumPat (LPat p) -- Sum sub-pattern
- ConTag -- Alternative (one-based)
- Arity -- Arity (INVARIANT: ≥ 2)
- (PostTc p [Type]) -- PlaceHolder before typechecker, filled in
+ | SumPat (XSumPat p) -- PlaceHolder before typechecker, filled in
-- afterwards with the types of the
-- alternative
+ (LPat p) -- Sum sub-pattern
+ ConTag -- Alternative (one-based)
+ Arity -- Arity (INVARIANT: ≥ 2)
-- ^ Anonymous sum pattern
--
-- - 'ApiAnnotation.AnnKeywordId' :
@@ -159,8 +169,8 @@ data Pat p
-- 'ApiAnnotation.AnnClose' @'#)'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | PArrPat [LPat p] -- Syntactic parallel array
- (PostTc p Type) -- The type of the elements
+ | PArrPat (XPArrPat p) -- After typechecking, the type of the elements
+ [LPat p] -- Syntactic parallel array
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
-- 'ApiAnnotation.AnnClose' @':]'@
@@ -195,11 +205,11 @@ data Pat p
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
- | ViewPat (LHsExpr p)
+ | ViewPat (XViewPat p) -- The overall type of the pattern
+ -- (= the argument type of the view function)
+ -- for hsPatType.
+ (LHsExpr p)
(LPat p)
- (PostTc p Type) -- The overall type of the pattern
- -- (= the argument type of the view function)
- -- for hsPatType.
-- ^ View Pattern
------------ Pattern splices ---------------
@@ -207,31 +217,34 @@ data Pat p
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | SplicePat (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes)
+ | SplicePat (XSplicePat p)
+ (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes)
------------ Literal and n+k patterns ---------------
- | LitPat (HsLit p) -- ^ Literal Pattern
+ | LitPat (XLitPat p)
+ (HsLit p) -- ^ Literal Pattern
-- Used for *non-overloaded* literal patterns:
-- Int#, Char#, Int, Char, String, etc.
| NPat -- Natural Pattern
-- Used for all overloaded literals,
-- including overloaded strings with -XOverloadedStrings
+ (XNPat p) -- Overall type of pattern. Might be
+ -- different than the literal's type
+ -- if (==) or negate changes the type
(Located (HsOverLit p)) -- ALWAYS positive
(Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for
-- negative patterns, Nothing
-- otherwise
(SyntaxExpr p) -- Equality checker, of type t->t->Bool
- (PostTc p Type) -- Overall type of pattern. Might be
- -- different than the literal's type
- -- if (==) or negate changes the type
-- ^ Natural Pattern
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | NPlusKPat (Located (IdP p)) -- n+k pattern
+ | NPlusKPat (XNPlusKPat p) -- Type of overall pattern
+ (Located (IdP p)) -- n+k pattern
(Located (HsOverLit p)) -- It'll always be an HsIntegral
(HsOverLit p) -- See Note [NPlusK patterns] in TcPat
-- NB: This could be (PostTc ...), but that induced a
@@ -239,24 +252,22 @@ data Pat p
(SyntaxExpr p) -- (>=) function, of type t1->t2->Bool
(SyntaxExpr p) -- Name of '-' (see RnEnv.lookupSyntaxName)
- (PostTc p Type) -- Type of overall pattern
-- ^ n+k pattern
------------ Pattern type signatures ---------------
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
- | SigPatIn (LPat p) -- Pattern with a type signature
- (LHsSigWcType p) -- Signature can bind both
- -- kind and type vars
- -- ^ Pattern with a type signature
-
- | SigPatOut (LPat p)
- Type
+ | SigPat (XSigPat p) -- Before typechecker
+ -- Signature can bind both
+ -- kind and type vars
+ -- After typechecker: Type
+ (LPat p) -- Pattern with a type signature
-- ^ Pattern with a type signature
------------ Pattern coercions (translation only) ---------------
- | CoPat HsWrapper -- Coercion Pattern
+ | CoPat (XCoPat p)
+ HsWrapper -- Coercion Pattern
-- If co :: t1 ~ t2, p :: t2,
-- then (CoPat co p) :: t1
(Pat p) -- Why not LPat? Ans: existing locn will do
@@ -264,7 +275,65 @@ data Pat p
-- During desugaring a (CoPat co pat) turns into a cast with 'co' on
-- the scrutinee, followed by a match on 'pat'
-- ^ Coercion Pattern
-deriving instance (DataId p) => Data (Pat p)
+
+ -- | Trees that Grow extension point for new constructors
+ | XPat
+ (XXPat p)
+deriving instance (DataIdLR p p) => Data (Pat p)
+
+-- ---------------------------------------------------------------------
+
+type instance XWildPat GhcPs = PlaceHolder
+type instance XWildPat GhcRn = PlaceHolder
+type instance XWildPat GhcTc = Type
+
+type instance XVarPat (GhcPass _) = PlaceHolder
+type instance XLazyPat (GhcPass _) = PlaceHolder
+type instance XAsPat (GhcPass _) = PlaceHolder
+type instance XParPat (GhcPass _) = PlaceHolder
+type instance XBangPat (GhcPass _) = PlaceHolder
+
+-- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap
+-- compiler, as it triggers https://ghc.haskell.org/trac/ghc/ticket/14396 for
+-- `SyntaxExpr`
+type instance XListPat (GhcPass _) = PlaceHolder
+
+type instance XTuplePat GhcPs = PlaceHolder
+type instance XTuplePat GhcRn = PlaceHolder
+type instance XTuplePat GhcTc = [Type]
+
+type instance XSumPat GhcPs = PlaceHolder
+type instance XSumPat GhcRn = PlaceHolder
+type instance XSumPat GhcTc = [Type]
+
+type instance XPArrPat GhcPs = PlaceHolder
+type instance XPArrPat GhcRn = PlaceHolder
+type instance XPArrPat GhcTc = Type
+
+type instance XViewPat GhcPs = PlaceHolder
+type instance XViewPat GhcRn = PlaceHolder
+type instance XViewPat GhcTc = Type
+
+type instance XSplicePat (GhcPass _) = PlaceHolder
+type instance XLitPat (GhcPass _) = PlaceHolder
+
+type instance XNPat GhcPs = PlaceHolder
+type instance XNPat GhcRn = PlaceHolder
+type instance XNPat GhcTc = Type
+
+type instance XNPlusKPat GhcPs = PlaceHolder
+type instance XNPlusKPat GhcRn = PlaceHolder
+type instance XNPlusKPat GhcTc = Type
+
+type instance XSigPat GhcPs = (LHsSigWcType GhcPs)
+type instance XSigPat GhcRn = (LHsSigWcType GhcRn)
+type instance XSigPat GhcTc = Type
+
+type instance XCoPat (GhcPass _) = PlaceHolder
+type instance XXPat (GhcPass _) = PlaceHolder
+
+-- ---------------------------------------------------------------------
+
-- | Haskell Constructor Pattern Details
type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))
@@ -382,24 +451,24 @@ data HsRecField' id arg = HsRecField {
--
-- See also Note [Disambiguating record fields] in TcExpr.
-hsRecFields :: HsRecFields p arg -> [PostRn p (IdP p)]
+hsRecFields :: HsRecFields p arg -> [XFieldOcc p]
hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)
-- Probably won't typecheck at once, things have changed :/
hsRecFieldsArgs :: HsRecFields p arg -> [arg]
hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds)
-hsRecFieldSel :: HsRecField pass arg -> Located (PostRn pass (IdP pass))
-hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl
+hsRecFieldSel :: HsRecField pass arg -> Located (XFieldOcc pass)
+hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl
hsRecFieldId :: HsRecField GhcTc arg -> Located Id
hsRecFieldId = hsRecFieldSel
-hsRecUpdFieldRdr :: HsRecUpdField p -> Located RdrName
+hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName
hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl
hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id
-hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc
+hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc
hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
@@ -413,8 +482,8 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
************************************************************************
-}
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (Pat pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (Pat (GhcPass p)) where
ppr = pprPat
pprPatBndr :: OutputableBndr name => name -> SDoc
@@ -426,10 +495,12 @@ pprPatBndr var -- Print with type info if -dppr-debug is on
else
pprPrefixOcc var
-pprParendLPat :: (SourceTextX pass, OutputableBndrId pass) => LPat pass -> SDoc
+pprParendLPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LPat (GhcPass p) -> SDoc
pprParendLPat (L _ p) = pprParendPat p
-pprParendPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
+pprParendPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Pat (GhcPass p) -> SDoc
pprParendPat p = sdocWithDynFlags $ \ dflags ->
if need_parens dflags p
then parens (pprPat p)
@@ -443,29 +514,31 @@ pprParendPat p = sdocWithDynFlags $ \ dflags ->
-- But otherwise the CoPat is discarded, so it
-- is the pattern inside that matters. Sigh.
-pprPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
-pprPat (VarPat (L _ var)) = pprPatBndr var
+pprPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Pat (GhcPass p) -> SDoc
+pprPat (VarPat _ (L _ var)) = pprPatBndr var
pprPat (WildPat _) = char '_'
-pprPat (LazyPat pat) = char '~' <> pprParendLPat pat
-pprPat (BangPat pat) = char '!' <> pprParendLPat pat
-pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat]
-pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
-pprPat (ParPat pat) = parens (ppr pat)
-pprPat (LitPat s) = ppr s
-pprPat (NPat l Nothing _ _) = ppr l
-pprPat (NPat l (Just _) _ _) = char '-' <> ppr l
-pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k]
-pprPat (SplicePat splice) = pprSplice splice
-pprPat (CoPat co pat _) = pprHsWrapper co (\parens -> if parens
+pprPat (LazyPat _ pat) = char '~' <> pprParendLPat pat
+pprPat (BangPat _ pat) = char '!' <> pprParendLPat pat
+pprPat (AsPat _ name pat) = hcat [ pprPrefixOcc (unLoc name), char '@'
+ , pprParendLPat pat]
+pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat]
+pprPat (ParPat _ pat) = parens (ppr pat)
+pprPat (LitPat _ s) = ppr s
+pprPat (NPat _ l Nothing _) = ppr l
+pprPat (NPat _ l (Just _) _) = char '-' <> ppr l
+pprPat (NPlusKPat _ n k _ _ _)= hcat [ppr n, char '+', ppr k]
+pprPat (SplicePat _ splice) = pprSplice splice
+pprPat (CoPat _ co pat _) = pprHsWrapper co (\parens -> if parens
then pprParendPat pat
else pprPat pat)
-pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
-pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
-pprPat (ListPat pats _ _) = brackets (interpp'SP pats)
-pprPat (PArrPat pats _) = paBrackets (interpp'SP pats)
-pprPat (TuplePat pats bx _) = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
-pprPat (SumPat pat alt arity _) = sumParens (pprAlternative ppr pat alt arity)
-pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
+pprPat (SigPat ty pat) = ppr pat <+> dcolon <+> ppr ty
+pprPat (ListPat _ pats _ _) = brackets (interpp'SP pats)
+pprPat (PArrPat _ pats) = paBrackets (interpp'SP pats)
+pprPat (TuplePat _ pats bx)
+ = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
+pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)
+pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
pat_binds = binds, pat_args = details })
= sdocWithDynFlags $ \dflags ->
@@ -478,14 +551,16 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
, ppr binds])
<+> pprConArgs details
else pprUserCon (unLoc con) details
+pprPat (XPat x) = ppr x
-
-pprUserCon :: (SourceTextX p, OutputableBndr con, OutputableBndrId p)
- => con -> HsConPatDetails p -> SDoc
+pprUserCon :: (SourceTextX (GhcPass p), OutputableBndr con,
+ OutputableBndrId (GhcPass p))
+ => con -> HsConPatDetails (GhcPass p) -> SDoc
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
-pprConArgs :: (SourceTextX p, OutputableBndrId p) => HsConPatDetails p -> SDoc
+pprConArgs :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsConPatDetails (GhcPass p) -> SDoc
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
pprConArgs (RecCon rpats) = ppr rpats
@@ -524,9 +599,12 @@ mkPrefixConPat dc pats tys
mkNilPat :: Type -> OutPat p
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
-mkCharLitPat :: (SourceTextX p) => SourceText -> Char -> OutPat p
+mkCharLitPat :: (SourceTextX (GhcPass p))
+ => SourceText -> Char -> OutPat (GhcPass p)
mkCharLitPat src c = mkPrefixConPat charDataCon
- [noLoc $ LitPat (HsCharPrim (setSourceText src) c)] []
+ [noLoc $ LitPat noExt
+ (HsCharPrim (setSourceText src) c)]
+ []
{-
************************************************************************
@@ -561,7 +639,7 @@ The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
-}
isBangedLPat :: LPat p -> Bool
-isBangedLPat (L _ (ParPat p)) = isBangedLPat p
+isBangedLPat (L _ (ParPat _ p)) = isBangedLPat p
isBangedLPat (L _ (BangPat {})) = True
isBangedLPat _ = False
@@ -579,8 +657,8 @@ looksLazyPatBind _
= False
looksLazyLPat :: LPat p -> Bool
-looksLazyLPat (L _ (ParPat p)) = looksLazyLPat p
-looksLazyLPat (L _ (AsPat _ p)) = looksLazyLPat p
+looksLazyLPat (L _ (ParPat _ p)) = looksLazyLPat p
+looksLazyLPat (L _ (AsPat _ _ p)) = looksLazyLPat p
looksLazyLPat (L _ (BangPat {})) = False
looksLazyLPat (L _ (VarPat {})) = False
looksLazyLPat (L _ (WildPat {})) = False
@@ -607,15 +685,14 @@ isIrrefutableHsPat pat
go1 (WildPat {}) = True
go1 (VarPat {}) = True
go1 (LazyPat {}) = True
- go1 (BangPat pat) = go pat
- go1 (CoPat _ pat _) = go1 pat
- go1 (ParPat pat) = go pat
- go1 (AsPat _ pat) = go pat
- go1 (ViewPat _ pat _) = go pat
- go1 (SigPatIn pat _) = go pat
- go1 (SigPatOut pat _) = go pat
- go1 (TuplePat pats _ _) = all go pats
- go1 (SumPat _ _ _ _) = False
+ go1 (BangPat _ pat) = go pat
+ go1 (CoPat _ _ pat _) = go1 pat
+ go1 (ParPat _ pat) = go pat
+ go1 (AsPat _ _ pat) = go pat
+ go1 (ViewPat _ _ pat) = go pat
+ go1 (SigPat _ pat) = go pat
+ go1 (TuplePat _ pats _) = all go pats
+ go1 (SumPat {}) = False
-- See Note [Unboxed sum patterns aren't irrefutable]
go1 (ListPat {}) = False
go1 (PArrPat {}) = False -- ?
@@ -637,6 +714,8 @@ isIrrefutableHsPat pat
-- since we cannot know until the splice is evaluated.
go1 (SplicePat {}) = False
+ go1 (XPat {}) = False
+
{- Note [Unboxed sum patterns aren't irrefutable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as
@@ -664,10 +743,9 @@ hsPatNeedsParens (NPlusKPat {}) = True
hsPatNeedsParens (SplicePat {}) = False
hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p)
-hsPatNeedsParens (SigPatIn {}) = True
-hsPatNeedsParens (SigPatOut {}) = True
+hsPatNeedsParens (SigPat {}) = True
hsPatNeedsParens (ViewPat {}) = True
-hsPatNeedsParens (CoPat _ p _) = hsPatNeedsParens p
+hsPatNeedsParens (CoPat _ _ p _) = hsPatNeedsParens p
hsPatNeedsParens (WildPat {}) = False
hsPatNeedsParens (VarPat {}) = False
hsPatNeedsParens (LazyPat {}) = False
@@ -680,6 +758,7 @@ hsPatNeedsParens (ListPat {}) = False
hsPatNeedsParens (PArrPat {}) = False
hsPatNeedsParens (LitPat {}) = False
hsPatNeedsParens (NPat {}) = False
+hsPatNeedsParens (XPat {}) = True -- conservative default
conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon {}) = False
@@ -691,30 +770,29 @@ conPatNeedsParens (RecCon {}) = False
-}
-- May need to add more cases
-collectEvVarsPats :: [Pat p] -> Bag EvVar
+collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar
collectEvVarsPats = unionManyBags . map collectEvVarsPat
-collectEvVarsLPat :: LPat p -> Bag EvVar
+collectEvVarsLPat :: LPat GhcTc -> Bag EvVar
collectEvVarsLPat (L _ pat) = collectEvVarsPat pat
-collectEvVarsPat :: Pat p -> Bag EvVar
+collectEvVarsPat :: Pat GhcTc -> Bag EvVar
collectEvVarsPat pat =
case pat of
- LazyPat p -> collectEvVarsLPat p
- AsPat _ p -> collectEvVarsLPat p
- ParPat p -> collectEvVarsLPat p
- BangPat p -> collectEvVarsLPat p
- ListPat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps
- TuplePat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps
- SumPat p _ _ _ -> collectEvVarsLPat p
- PArrPat ps _ -> unionManyBags $ map collectEvVarsLPat ps
+ LazyPat _ p -> collectEvVarsLPat p
+ AsPat _ _ p -> collectEvVarsLPat p
+ ParPat _ p -> collectEvVarsLPat p
+ BangPat _ p -> collectEvVarsLPat p
+ ListPat _ ps _ _ -> unionManyBags $ map collectEvVarsLPat ps
+ TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps
+ SumPat _ p _ _ -> collectEvVarsLPat p
+ PArrPat _ ps -> unionManyBags $ map collectEvVarsLPat ps
ConPatOut {pat_dicts = dicts, pat_args = args}
- -> unionBags (listToBag dicts)
+ -> unionBags (listToBag dicts)
$ unionManyBags
$ map collectEvVarsLPat
$ hsConPatArgs args
- SigPatOut p _ -> collectEvVarsLPat p
- CoPat _ p _ -> collectEvVarsPat p
- ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn"
- SigPatIn _ _ -> panic "foldMapPatBag: SigPatIn"
- _other_pat -> emptyBag
+ SigPat _ p -> collectEvVarsLPat p
+ CoPat _ _ p _ -> collectEvVarsPat p
+ ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn"
+ _other_pat -> emptyBag
diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot
index 8cb82ed22e..eb090bdd8f 100644
--- a/compiler/hsSyn/HsPat.hs-boot
+++ b/compiler/hsSyn/HsPat.hs-boot
@@ -4,17 +4,19 @@
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE FlexibleInstances #-}
module HsPat where
import SrcLoc( Located )
import Data.Data hiding (Fixity)
import Outputable
-import HsExtension ( SourceTextX, DataId, OutputableBndrId )
+import HsExtension ( SourceTextX, DataIdLR, OutputableBndrId, GhcPass )
type role Pat nominal
data Pat (i :: *)
type LPat i = Located (Pat i)
-instance (DataId p) => Data (Pat p)
-instance (SourceTextX pass, OutputableBndrId pass) => Outputable (Pat pass)
+instance (DataIdLR p p) => Data (Pat p)
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (Pat (GhcPass p))
diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs
index 62bfa2e5c5..4a3eca31c6 100644
--- a/compiler/hsSyn/HsSyn.hs
+++ b/compiler/hsSyn/HsSyn.hs
@@ -15,6 +15,7 @@ therefore, is almost nothing but re-exporting.
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
module HsSyn (
module HsBinds,
@@ -110,10 +111,10 @@ data HsModule name
-- hsmodImports,hsmodDecls if this style is used.
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId name) => Data (HsModule name)
+deriving instance (DataIdLR name name) => Data (HsModule name)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsModule pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsModule (GhcPass p)) where
ppr (HsModule Nothing _ imports decls _ mbDoc)
= pp_mb mbDoc $$ pp_nonnull imports
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index f5b4149f99..be70fe8ec8 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -15,9 +15,10 @@ HsTypes: Abstract syntax: user-defined types
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
module HsTypes (
- HsType(..), LHsType, HsKind, LHsKind,
+ HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,
HsTyVarBndr(..), LHsTyVarBndr,
LHsQTyVars(..),
HsImplicitBndrs(..),
@@ -44,7 +45,7 @@ module HsTypes (
rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,
unambiguousFieldOcc, ambiguousFieldOcc,
- HsWildCardInfo(..), mkAnonWildCardTy,
+ HsWildCardInfo(..), mkAnonWildCardTy, pprAnonWildCard,
wildCardName, sameWildCard,
mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
@@ -73,8 +74,9 @@ import GhcPrelude
import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
-import PlaceHolder ( PlaceHolder(..) )
+import PlaceHolder ( PlaceHolder, placeHolder )
import HsExtension
+import HsLit () -- for instances
import Id ( Id )
import Name( Name )
@@ -110,11 +112,11 @@ type LBangType pass = Located (BangType pass)
type BangType pass = HsType pass -- Bangs are in the HsType data type
getBangType :: LHsType a -> LHsType a
-getBangType (L _ (HsBangTy _ ty)) = ty
-getBangType ty = ty
+getBangType (L _ (HsBangTy _ _ ty)) = ty
+getBangType ty = ty
getBangStrictness :: LHsType a -> HsSrcBang
-getBangStrictness (L _ (HsBangTy s _)) = s
+getBangStrictness (L _ (HsBangTy _ s _)) = s
getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
{-
@@ -270,11 +272,11 @@ data LHsQTyVars pass -- See Note [HsType binders]
-- See Note [Dependent LHsQTyVars] in TcHsType
}
-deriving instance (DataId pass) => Data (LHsQTyVars pass)
+deriving instance (DataIdLR pass pass) => Data (LHsQTyVars pass)
mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
-mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs
- , hsq_dependent = PlaceHolder }
+mkHsQTvs tvs = HsQTvs { hsq_implicit = placeHolder, hsq_explicit = tvs
+ , hsq_dependent = placeHolder }
hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass]
hsQTvExplicit = hsq_explicit
@@ -364,12 +366,12 @@ the explicitly forall'd tyvar 'a' is bound by the HsForAllTy
mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs x = HsIB { hsib_body = x
- , hsib_vars = PlaceHolder
- , hsib_closed = PlaceHolder }
+ , hsib_vars = placeHolder
+ , hsib_closed = placeHolder }
mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs x = HsWC { hswc_body = x
- , hswc_wcs = PlaceHolder }
+ , hswc_wcs = placeHolder }
-- Add empty binders. This is a bit suspicious; what if
-- the wrapped thing had free type variables?
@@ -405,9 +407,11 @@ instance OutputableBndr HsIPName where
-- | Haskell Type Variable Binder
data HsTyVarBndr pass
= UserTyVar -- no explicit kinding
+ (XUserTyVar pass)
(Located (IdP pass))
-- See Note [Located RdrNames] in HsExpr
| KindedTyVar
+ (XKindedTyVar pass)
(Located (IdP pass))
(LHsKind pass) -- The user-supplied kind signature
-- ^
@@ -415,12 +419,20 @@ data HsTyVarBndr pass
-- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (HsTyVarBndr pass)
+
+ | XTyVarBndr
+ (XXTyVarBndr pass)
+deriving instance (DataIdLR pass pass) => Data (HsTyVarBndr pass)
+
+type instance XUserTyVar (GhcPass _) = PlaceHolder
+type instance XKindedTyVar (GhcPass _) = PlaceHolder
+type instance XXTyVarBndr (GhcPass _) = PlaceHolder
-- | Does this 'HsTyVarBndr' come with an explicit kind annotation?
isHsKindedTyVar :: HsTyVarBndr pass -> Bool
isHsKindedTyVar (UserTyVar {}) = False
isHsKindedTyVar (KindedTyVar {}) = True
+isHsKindedTyVar (XTyVarBndr{}) = panic "isHsKindedTyVar"
-- | Do all type variables in this 'LHsQTyVars' come with kind annotations?
hsTvbAllKinded :: LHsQTyVars pass -> Bool
@@ -429,19 +441,22 @@ hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit
-- | Haskell Type
data HsType pass
= HsForAllTy -- See Note [HsType binders]
- { hst_bndrs :: [LHsTyVarBndr pass]
+ { hst_xforall :: XForAllTy pass,
+ hst_bndrs :: [LHsTyVarBndr pass]
-- Explicit, user-supplied 'forall a b c'
- , hst_body :: LHsType pass -- body type
+ , hst_body :: LHsType pass -- body type
}
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',
-- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
| HsQualTy -- See Note [HsType binders]
- { hst_ctxt :: LHsContext pass -- Context C => blah
- , hst_body :: LHsType pass }
+ { hst_xqual :: XQualTy pass
+ , hst_ctxt :: LHsContext pass -- Context C => blah
+ , hst_body :: LHsType pass }
- | HsTyVar Promoted -- whether explicitly promoted, for the pretty
+ | HsTyVar (XTyVar pass)
+ Promoted -- whether explicitly promoted, for the pretty
-- printer
(Located (IdP pass))
-- Type variable, type constructor, or data constructor
@@ -451,53 +466,62 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsAppsTy [LHsAppType pass] -- Used only before renaming,
+ | HsAppsTy (XAppsTy pass)
+ [LHsAppType pass] -- Used only before renaming,
-- Note [HsAppsTy]
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
- | HsAppTy (LHsType pass)
+ | HsAppTy (XAppTy pass)
+ (LHsType pass)
(LHsType pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsFunTy (LHsType pass) -- function type
+ | HsFunTy (XFunTy pass)
+ (LHsType pass) -- function type
(LHsType pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow',
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsListTy (LHsType pass) -- Element type
+ | HsListTy (XListTy pass)
+ (LHsType pass) -- Element type
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
-- 'ApiAnnotation.AnnClose' @']'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsPArrTy (LHsType pass) -- Elem. type of parallel array: [:t:]
+ | HsPArrTy (XPArrTy pass)
+ (LHsType pass) -- Elem. type of parallel array: [:t:]
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
-- 'ApiAnnotation.AnnClose' @':]'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsTupleTy HsTupleSort
+ | HsTupleTy (XTupleTy pass)
+ HsTupleSort
[LHsType pass] -- Element types (length gives arity)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@,
-- 'ApiAnnotation.AnnClose' @')' or '#)'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsSumTy [LHsType pass] -- Element types (length gives arity)
+ | HsSumTy (XSumTy pass)
+ [LHsType pass] -- Element types (length gives arity)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@,
-- 'ApiAnnotation.AnnClose' '#)'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsOpTy (LHsType pass) (Located (IdP pass)) (LHsType pass)
+ | HsOpTy (XOpTy pass)
+ (LHsType pass) (Located (IdP pass)) (LHsType pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsParTy (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr
+ | HsParTy (XParTy pass)
+ (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr
-- Parenthesis preserved for the precedence re-arrangement in RnTypes
-- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
@@ -505,7 +529,8 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsIParamTy (Located HsIPName) -- (?x :: ty)
+ | HsIParamTy (XIParamTy pass)
+ (Located HsIPName) -- (?x :: ty)
(LHsType pass) -- Implicit parameters as they occur in
-- contexts
-- ^
@@ -515,7 +540,8 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsEqTy (LHsType pass) -- ty1 ~ ty2
+ | HsEqTy (XEqTy pass)
+ (LHsType pass) -- ty1 ~ ty2
(LHsType pass) -- Always allowed even without
-- TypeOperators, and has special
-- kinding rule
@@ -526,7 +552,8 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsKindSig (LHsType pass) -- (ty :: kind)
+ | HsKindSig (XKindSig pass)
+ (LHsType pass) -- (ty :: kind)
(LHsKind pass) -- A type with a kind signature
-- ^
-- > (ty :: kind)
@@ -536,19 +563,21 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsSpliceTy (HsSplice pass) -- Includes quasi-quotes
- (PostTc pass Kind)
+ | HsSpliceTy (XSpliceTy pass)
+ (HsSplice pass) -- Includes quasi-quotes
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@,
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsDocTy (LHsType pass) LHsDocString -- A documented type
+ | HsDocTy (XDocTy pass)
+ (LHsType pass) LHsDocString -- A documented type
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsBangTy HsSrcBang (LHsType pass) -- Bang-style type annotations
+ | HsBangTy (XBangTy pass)
+ HsSrcBang (LHsType pass) -- Bang-style type annotations
-- ^ - 'ApiAnnotation.AnnKeywordId' :
-- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@,
-- 'ApiAnnotation.AnnClose' @'#-}'@
@@ -556,21 +585,22 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsRecTy [LConDeclField pass] -- Only in data type declarations
+ | HsRecTy (XRecTy pass)
+ [LConDeclField pass] -- Only in data type declarations
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
-- 'ApiAnnotation.AnnClose' @'}'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCoreTy Type -- An escape hatch for tunnelling a *closed*
- -- Core Type through HsSyn.
- -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+ -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed*
+ -- -- Core Type through HsSyn.
+ -- -- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
| HsExplicitListTy -- A promoted explicit list
+ (XExplicitListTy pass)
Promoted -- whether explcitly promoted, for pretty printer
- (PostTc pass Kind) -- See Note [Promoted lists and tuples]
[LHsType pass]
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@,
-- 'ApiAnnotation.AnnClose' @']'@
@@ -578,24 +608,78 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
| HsExplicitTupleTy -- A promoted explicit tuple
- [PostTc pass Kind] -- See Note [Promoted lists and tuples]
+ (XExplicitTupleTy pass)
[LHsType pass]
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@,
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsTyLit HsTyLit -- A promoted numeric literal.
+ | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal.
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsWildCardTy (HsWildCardInfo pass) -- A type wildcard
+ | HsWildCardTy (XWildCardTy pass) -- A type wildcard
-- See Note [The wildcard story for types]
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (HsType pass)
+
+ -- For adding new constructors via Trees that Grow
+ | XHsType
+ (XXType pass)
+deriving instance (DataIdLR pass pass) => Data (HsType pass)
+
+data NewHsTypeX
+ = NHsCoreTy Type -- An escape hatch for tunnelling a *closed*
+ -- Core Type through HsSyn.
+ deriving Data
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+instance Outputable NewHsTypeX where
+ ppr (NHsCoreTy ty) = ppr ty
+
+type instance XForAllTy (GhcPass _) = PlaceHolder
+type instance XQualTy (GhcPass _) = PlaceHolder
+type instance XTyVar (GhcPass _) = PlaceHolder
+type instance XAppsTy (GhcPass _) = PlaceHolder
+type instance XAppTy (GhcPass _) = PlaceHolder
+type instance XFunTy (GhcPass _) = PlaceHolder
+type instance XListTy (GhcPass _) = PlaceHolder
+type instance XPArrTy (GhcPass _) = PlaceHolder
+type instance XTupleTy (GhcPass _) = PlaceHolder
+type instance XSumTy (GhcPass _) = PlaceHolder
+type instance XOpTy (GhcPass _) = PlaceHolder
+type instance XParTy (GhcPass _) = PlaceHolder
+type instance XIParamTy (GhcPass _) = PlaceHolder
+type instance XEqTy (GhcPass _) = PlaceHolder
+type instance XKindSig (GhcPass _) = PlaceHolder
+
+type instance XSpliceTy GhcPs = PlaceHolder
+type instance XSpliceTy GhcRn = PlaceHolder
+type instance XSpliceTy GhcTc = Kind
+
+type instance XDocTy (GhcPass _) = PlaceHolder
+type instance XBangTy (GhcPass _) = PlaceHolder
+type instance XRecTy (GhcPass _) = PlaceHolder
+
+type instance XExplicitListTy GhcPs = PlaceHolder
+type instance XExplicitListTy GhcRn = PlaceHolder
+type instance XExplicitListTy GhcTc = Kind
+
+type instance XExplicitTupleTy GhcPs = PlaceHolder
+type instance XExplicitTupleTy GhcRn = PlaceHolder
+type instance XExplicitTupleTy GhcTc = [Kind]
+
+type instance XTyLit (GhcPass _) = PlaceHolder
+
+type instance XWildCardTy GhcPs = PlaceHolder
+type instance XWildCardTy GhcRn = HsWildCardInfo GhcRn
+type instance XWildCardTy GhcTc = HsWildCardInfo GhcTc
+
+type instance XXType (GhcPass _) = NewHsTypeX
+
-- Note [Literal source text] in BasicTypes for SourceText fields in
-- the following
@@ -605,7 +689,8 @@ data HsTyLit
| HsStrTy SourceText FastString
deriving Data
-newtype HsWildCardInfo pass -- See Note [The wildcard story for types]
+-- AZ: fold this into the XWildCardTy completely, removing the type
+newtype HsWildCardInfo pass -- See Note [The wildcard story for types]
= AnonWildCard (PostRn pass (Located Name))
-- A anonymous wild card ('_'). A fresh Name is generated for
-- each individual anonymous wildcard during renaming
@@ -617,12 +702,21 @@ type LHsAppType pass = Located (HsAppType pass)
-- | Haskell Application Type
data HsAppType pass
- = HsAppInfix (Located (IdP pass)) -- either a symbol or an id in backticks
- | HsAppPrefix (LHsType pass) -- anything else, including things like (+)
-deriving instance (DataId pass) => Data (HsAppType pass)
+ = HsAppInfix (XAppInfix pass)
+ (Located (IdP pass)) -- either a symbol or an id in backticks
+ | HsAppPrefix (XAppPrefix pass)
+ (LHsType pass) -- anything else, including things like (+)
+
+ | XAppType
+ (XXAppType pass)
+deriving instance (DataIdLR pass pass) => Data (HsAppType pass)
+
+type instance XAppInfix (GhcPass _) = PlaceHolder
+type instance XAppPrefix (GhcPass _) = PlaceHolder
+type instance XXAppType (GhcPass _) = PlaceHolder
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsAppType pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsAppType (GhcPass p)) where
ppr = ppr_app_ty
{-
@@ -764,10 +858,10 @@ data ConDeclField pass -- Record fields have Haddoc docs on them
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (ConDeclField pass)
+deriving instance (DataIdLR pass pass) => Data (ConDeclField pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ConDeclField pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (ConDeclField (GhcPass p)) where
ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
-- HsConDetails is used for patterns/expressions *and* for data type
@@ -789,11 +883,11 @@ instance (Outputable arg, Outputable rec)
-- parser and rejigs them using information about fixities from the renamer.
-- See Note [Sorting out the result type] in RdrHsSyn
updateGadtResult
- :: (Monad m)
+ :: (Monad m, OutputableX GhcRn)
=> (SDoc -> m ())
-> SDoc
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
- -- ^ Original details
+ -- ^ Original details
-> LHsType GhcRn -- ^ Original result type
-> m (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
LHsType GhcRn)
@@ -874,8 +968,9 @@ I don't know if this is a good idea, but there it is.
---------------------
hsTyVarName :: HsTyVarBndr pass -> IdP pass
-hsTyVarName (UserTyVar (L _ n)) = n
-hsTyVarName (KindedTyVar (L _ n) _) = n
+hsTyVarName (UserTyVar _ (L _ n)) = n
+hsTyVarName (KindedTyVar _ (L _ n) _) = n
+hsTyVarName (XTyVarBndr{}) = panic "hsTyVarName"
hsLTyVarName :: LHsTyVarBndr pass -> IdP pass
hsLTyVarName = hsTyVarName . unLoc
@@ -896,15 +991,17 @@ hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
-- | Convert a LHsTyVarBndr to an equivalent LHsType.
-hsLTyVarBndrToType :: LHsTyVarBndr pass -> LHsType pass
+hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
hsLTyVarBndrToType = fmap cvt
- where cvt (UserTyVar n) = HsTyVar NotPromoted n
- cvt (KindedTyVar (L name_loc n) kind)
- = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc n))) kind
+ where cvt (UserTyVar _ n) = HsTyVar noExt NotPromoted n
+ cvt (KindedTyVar _ (L name_loc n) kind)
+ = HsKindSig noExt
+ (L name_loc (HsTyVar noExt NotPromoted (L name_loc n))) kind
+ cvt (XTyVarBndr{}) = panic "hsLTyVarBndrToType"
-- | Convert a LHsTyVarBndrs to a list of types.
-- Works on *type* variable only, no kind vars.
-hsLTyVarBndrsToTypes :: LHsQTyVars pass -> [LHsType pass]
+hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)]
hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs
---------------------
@@ -917,9 +1014,9 @@ sameWildCard :: Located (HsWildCardInfo pass)
sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2
ignoreParens :: LHsType pass -> LHsType pass
-ignoreParens (L _ (HsParTy ty)) = ignoreParens ty
-ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty
-ignoreParens ty = ty
+ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty
+ignoreParens (L _ (HsAppsTy _ [L _ (HsAppPrefix _ ty)])) = ignoreParens ty
+ignoreParens ty = ty
{-
************************************************************************
@@ -930,15 +1027,17 @@ ignoreParens ty = ty
-}
mkAnonWildCardTy :: HsType GhcPs
-mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder)
+mkAnonWildCardTy = HsWildCardTy noExt
-mkHsOpTy :: LHsType pass -> Located (IdP pass) -> LHsType pass -> HsType pass
-mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2
+mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p))
+ -> LHsType (GhcPass p) -> HsType (GhcPass p)
+mkHsOpTy ty1 op ty2 = HsOpTy noExt ty1 op ty2
-mkHsAppTy :: LHsType pass -> LHsType pass -> LHsType pass
-mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
+mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy noExt t1 t2)
-mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass
+mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
+ -> LHsType (GhcPass p)
mkHsAppTys = foldl mkHsAppTy
@@ -957,36 +1056,37 @@ mkHsAppTys = foldl mkHsAppTy
-- Also deals with (->) t1 t2; that is why it only works on LHsType Name
-- (see Trac #9096)
splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn)
-splitHsFunType (L _ (HsParTy ty))
+splitHsFunType (L _ (HsParTy _ ty))
= splitHsFunType ty
-splitHsFunType (L _ (HsFunTy x y))
+splitHsFunType (L _ (HsFunTy _ x y))
| (args, res) <- splitHsFunType y
= (x:args, res)
-splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
+splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2))
= go t1 [t2]
where -- Look for (->) t1 t2, possibly with parenthesisation
- go (L _ (HsTyVar _ (L _ fn))) tys | fn == funTyConName
+ go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName
, [t1,t2] <- tys
, (args, res) <- splitHsFunType t2
= (t1:args, res)
- go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys)
- go (L _ (HsParTy ty)) tys = go ty tys
- go _ _ = ([], orig_ty) -- Failure to match
+ go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys)
+ go (L _ (HsParTy _ ty)) tys = go ty tys
+ go _ _ = ([], orig_ty) -- Failure to match
splitHsFunType other = ([], other)
--------------------------------
-- | Retrieves the head of an HsAppsTy, if this can be done unambiguously,
-- without consulting fixities.
-getAppsTyHead_maybe :: [LHsAppType pass]
- -> Maybe (LHsType pass, [LHsType pass], LexicalFixity)
+getAppsTyHead_maybe :: [LHsAppType (GhcPass p)]
+ -> Maybe ( LHsType (GhcPass p)
+ , [LHsType (GhcPass p)], LexicalFixity)
getAppsTyHead_maybe tys = case splitHsAppsTy tys of
([app1:apps], []) -> -- no symbols, some normal types
Just (mkHsAppTys app1 apps, [], Prefix)
([app1l:appsl, app1r:appsr], [L loc op]) -> -- one operator
- Just ( L loc (HsTyVar NotPromoted (L loc op))
+ Just ( L loc (HsTyVar noExt NotPromoted (L loc op))
, [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr], Infix)
_ -> -- can't figure it out
Nothing
@@ -1001,35 +1101,36 @@ splitHsAppsTy :: [LHsAppType pass] -> ([[LHsType pass]], [Located (IdP pass)])
splitHsAppsTy = go [] [] []
where
go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym)
- go acc acc_non acc_sym (L _ (HsAppPrefix ty) : rest)
+ go acc acc_non acc_sym (L _ (HsAppPrefix _ ty) : rest)
= go (ty : acc) acc_non acc_sym rest
- go acc acc_non acc_sym (L _ (HsAppInfix op) : rest)
+ go acc acc_non acc_sym (L _ (HsAppInfix _ op) : rest)
= go [] (reverse acc : acc_non) (op : acc_sym) rest
+ go _ _ _ (L _ (XAppType _):_) = panic "splitHsAppsTy"
-- Retrieve the name of the "head" of a nested type application
-- somewhat like splitHsAppTys, but a little more thorough
-- used to examine the result of a GADT-like datacon, so it doesn't handle
-- *all* cases (like lists, tuples, (~), etc.)
-hsTyGetAppHead_maybe :: LHsType pass
- -> Maybe (Located (IdP pass), [LHsType pass])
+hsTyGetAppHead_maybe :: LHsType (GhcPass p)
+ -> Maybe (Located (IdP (GhcPass p)), [LHsType (GhcPass p)])
hsTyGetAppHead_maybe = go []
where
- go tys (L _ (HsTyVar _ ln)) = Just (ln, tys)
- go tys (L _ (HsAppsTy apps))
+ go tys (L _ (HsTyVar _ _ ln)) = Just (ln, tys)
+ go tys (L _ (HsAppsTy _ apps))
| Just (head, args, _) <- getAppsTyHead_maybe apps
- = go (args ++ tys) head
- go tys (L _ (HsAppTy l r)) = go (r : tys) l
- go tys (L _ (HsOpTy l (L loc n) r)) = Just (L loc n, l : r : tys)
- go tys (L _ (HsParTy t)) = go tys t
- go tys (L _ (HsKindSig t _)) = go tys t
+ = go (args ++ tys) head
+ go tys (L _ (HsAppTy _ l r)) = go (r : tys) l
+ go tys (L _ (HsOpTy _ l (L loc n) r)) = Just (L loc n, l : r : tys)
+ go tys (L _ (HsParTy _ t)) = go tys t
+ go tys (L _ (HsKindSig _ t _)) = go tys t
go _ _ = Nothing
splitHsAppTys :: LHsType GhcRn -> [LHsType GhcRn]
-> (LHsType GhcRn, [LHsType GhcRn])
-- no need to worry about HsAppsTy here
-splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
-splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as
-splitHsAppTys f as = (f,as)
+splitHsAppTys (L _ (HsAppTy _ f a)) as = splitHsAppTys f (a:as)
+splitHsAppTys (L _ (HsParTy _ f)) as = splitHsAppTys f as
+splitHsAppTys f as = (f,as)
--------------------------------
splitLHsPatSynTy :: LHsType pass
@@ -1054,12 +1155,12 @@ splitLHsSigmaTy ty
splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)
-splitLHsForAllTy (L _ (HsParTy t)) = splitLHsForAllTy t
+splitLHsForAllTy (L _ (HsParTy _ t)) = splitLHsForAllTy t
splitLHsForAllTy body = ([], body)
splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)
splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body)
-splitLHsQualTy (L _ (HsParTy t)) = splitLHsQualTy t
+splitLHsQualTy (L _ (HsParTy _ t)) = splitLHsQualTy t
splitLHsQualTy body = (noLoc [], body)
splitLHsInstDeclTy :: LHsSigType GhcRn
@@ -1077,7 +1178,8 @@ getLHsInstDeclHead inst_ty
| (_tvs, _cxt, body_ty) <- splitLHsSigmaTy (hsSigType inst_ty)
= body_ty
-getLHsInstDeclClass_maybe :: LHsSigType pass -> Maybe (Located (IdP pass))
+getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p)
+ -> Maybe (Located (IdP (GhcPass p)))
-- Works on (HsSigType RdrName)
getLHsInstDeclClass_maybe inst_ty
= do { let head_ty = getLHsInstDeclHead inst_ty
@@ -1100,19 +1202,28 @@ type LFieldOcc pass = Located (FieldOcc pass)
-- Represents an *occurrence* of an unambiguous field. We store
-- both the 'RdrName' the user originally wrote, and after the
-- renamer, the selector function.
-data FieldOcc pass = FieldOcc { rdrNameFieldOcc :: Located RdrName
+data FieldOcc pass = FieldOcc { extFieldOcc :: XFieldOcc pass
+ , rdrNameFieldOcc :: Located RdrName
-- ^ See Note [Located RdrNames] in HsExpr
- , selectorFieldOcc :: PostRn pass (IdP pass)
}
-deriving instance Eq (PostRn pass (IdP pass)) => Eq (FieldOcc pass)
-deriving instance Ord (PostRn pass (IdP pass)) => Ord (FieldOcc pass)
+
+ | XFieldOcc
+ (XXFieldOcc pass)
+deriving instance (Eq (XFieldOcc (GhcPass p))) => Eq (FieldOcc (GhcPass p))
+deriving instance (Ord (XFieldOcc (GhcPass p))) => Ord (FieldOcc (GhcPass p))
deriving instance (DataId pass) => Data (FieldOcc pass)
+type instance XFieldOcc GhcPs = PlaceHolder
+type instance XFieldOcc GhcRn = Name
+type instance XFieldOcc GhcTc = Id
+
+type instance XXFieldOcc (GhcPass _) = PlaceHolder
+
instance Outputable (FieldOcc pass) where
ppr = ppr . rdrNameFieldOcc
mkFieldOcc :: Located RdrName -> FieldOcc GhcPs
-mkFieldOcc rdr = FieldOcc rdr PlaceHolder
+mkFieldOcc rdr = FieldOcc placeHolder rdr
-- | Ambiguous Field Occurrence
@@ -1128,34 +1239,51 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder
-- Note [Disambiguating record fields] in TcExpr.
-- See Note [Located RdrNames] in HsExpr
data AmbiguousFieldOcc pass
- = Unambiguous (Located RdrName) (PostRn pass (IdP pass))
- | Ambiguous (Located RdrName) (PostTc pass (IdP pass))
+ = Unambiguous (XUnambiguous pass) (Located RdrName)
+ | Ambiguous (XAmbiguous pass) (Located RdrName)
+ | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass)
deriving instance DataId pass => Data (AmbiguousFieldOcc pass)
-instance Outputable (AmbiguousFieldOcc pass) where
+type instance XUnambiguous GhcPs = PlaceHolder
+type instance XUnambiguous GhcRn = Name
+type instance XUnambiguous GhcTc = Id
+
+type instance XAmbiguous GhcPs = PlaceHolder
+type instance XAmbiguous GhcRn = PlaceHolder
+type instance XAmbiguous GhcTc = Id
+
+type instance XXAmbiguousFieldOcc (GhcPass _) = PlaceHolder
+
+instance Outputable (AmbiguousFieldOcc (GhcPass p)) where
ppr = ppr . rdrNameAmbiguousFieldOcc
-instance OutputableBndr (AmbiguousFieldOcc pass) where
+instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where
pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc
pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc
mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs
-mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder
+mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr
-rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc pass -> RdrName
-rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr
-rdrNameAmbiguousFieldOcc (Ambiguous (L _ rdr) _) = rdr
+rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName
+rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr
+rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr
+rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _)
+ = panic "rdrNameAmbiguousFieldOcc"
selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id
-selectorAmbiguousFieldOcc (Unambiguous _ sel) = sel
-selectorAmbiguousFieldOcc (Ambiguous _ sel) = sel
+selectorAmbiguousFieldOcc (Unambiguous sel _) = sel
+selectorAmbiguousFieldOcc (Ambiguous sel _) = sel
+selectorAmbiguousFieldOcc (XAmbiguousFieldOcc _)
+ = panic "selectorAmbiguousFieldOcc"
unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc
unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel
unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel
+unambiguousFieldOcc (XAmbiguousFieldOcc _) = panic "unambiguousFieldOcc"
-ambiguousFieldOcc :: FieldOcc pass -> AmbiguousFieldOcc pass
-ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
+ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc
+ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr
+ambiguousFieldOcc (XFieldOcc _) = panic "ambiguousFieldOcc"
{-
************************************************************************
@@ -1165,21 +1293,22 @@ ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
************************************************************************
-}
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsType pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsType (GhcPass p)) where
ppr ty = pprHsType ty
instance Outputable HsTyLit where
ppr = ppr_tylit
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (LHsQTyVars pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (LHsQTyVars (GhcPass p)) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsTyVarBndr pass) where
- ppr (UserTyVar n) = ppr n
- ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsTyVarBndr (GhcPass p)) where
+ ppr (UserTyVar _ n) = ppr n
+ ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k]
+ ppr (XTyVarBndr n) = ppr n
instance (Outputable thing) => Outputable (HsImplicitBndrs pass thing) where
ppr (HsIB { hsib_body = ty }) = ppr ty
@@ -1190,8 +1319,11 @@ instance (Outputable thing) => Outputable (HsWildCardBndrs pass thing) where
instance Outputable (HsWildCardInfo pass) where
ppr (AnonWildCard _) = char '_'
-pprHsForAll :: (SourceTextX pass, OutputableBndrId pass)
- => [LHsTyVarBndr pass] -> LHsContext pass -> SDoc
+pprAnonWildCard :: SDoc
+pprAnonWildCard = char '_'
+
+pprHsForAll :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc
pprHsForAll = pprHsForAllExtra Nothing
-- | Version of 'pprHsForAll' that can also print an extra-constraints
@@ -1201,44 +1333,44 @@ pprHsForAll = pprHsForAllExtra Nothing
-- function for this is needed, as the extra-constraints wildcard is removed
-- from the actual context and type, and stored in a separate field, thus just
-- printing the type will not print the extra-constraints wildcard.
-pprHsForAllExtra :: (SourceTextX pass, OutputableBndrId pass)
- => Maybe SrcSpan -> [LHsTyVarBndr pass] -> LHsContext pass
- -> SDoc
+pprHsForAllExtra :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)]
+ -> LHsContext (GhcPass p) -> SDoc
pprHsForAllExtra extra qtvs cxt
= pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt)
where
show_extra = isJust extra
-pprHsForAllTvs :: (SourceTextX pass, OutputableBndrId pass)
- => [LHsTyVarBndr pass] -> SDoc
+pprHsForAllTvs :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => [LHsTyVarBndr (GhcPass p)] -> SDoc
pprHsForAllTvs qtvs
| null qtvs = whenPprDebug (forAllLit <+> dot)
| otherwise = forAllLit <+> interppSP qtvs <> dot
-pprHsContext :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> SDoc
+pprHsContext :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> SDoc
pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
-pprHsContextNoArrow :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> SDoc
+pprHsContextNoArrow :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> SDoc
pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
-pprHsContextMaybe :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> Maybe SDoc
+pprHsContextMaybe :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> Maybe SDoc
pprHsContextMaybe [] = Nothing
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred
pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt)
-- For use in a HsQualTy, which always gets printed if it exists.
-pprHsContextAlways :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> SDoc
+pprHsContextAlways :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> SDoc
pprHsContextAlways [] = parens empty <+> darrow
pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow
pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow
-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
-pprHsContextExtra :: (SourceTextX pass, OutputableBndrId pass)
- => Bool -> HsContext pass -> SDoc
+pprHsContextExtra :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Bool -> HsContext (GhcPass p) -> SDoc
pprHsContextExtra show_extra ctxt
| not show_extra
= pprHsContext ctxt
@@ -1249,8 +1381,8 @@ pprHsContextExtra show_extra ctxt
where
ctxt' = map ppr ctxt ++ [char '_']
-pprConDeclFields :: (SourceTextX pass, OutputableBndrId pass)
- => [LConDeclField pass] -> SDoc
+pprConDeclFields :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => [LConDeclField (GhcPass p)] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
@@ -1274,76 +1406,79 @@ seems like the Right Thing anyway.)
-- Printing works more-or-less as for Types
-pprHsType :: (SourceTextX pass, OutputableBndrId pass) => HsType pass -> SDoc
+pprHsType :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsType (GhcPass p) -> SDoc
pprHsType ty = ppr_mono_ty ty
-ppr_mono_lty :: (SourceTextX pass, OutputableBndrId pass)
- => LHsType pass -> SDoc
+ppr_mono_lty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsType (GhcPass p) -> SDoc
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
-ppr_mono_ty :: (SourceTextX pass, OutputableBndrId pass)
- => HsType pass -> SDoc
+ppr_mono_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsType (GhcPass p) -> SDoc
ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
= sep [pprHsForAllTvs tvs, ppr_mono_lty ty]
ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
= sep [pprHsContextAlways ctxt, ppr_mono_lty ty]
+ppr_mono_ty (XHsType t) = ppr t
-ppr_mono_ty (HsBangTy b ty) = ppr b <> ppr_mono_lty ty
-ppr_mono_ty (HsRecTy flds) = pprConDeclFields flds
-ppr_mono_ty (HsTyVar NotPromoted (L _ name))= pprPrefixOcc name
-ppr_mono_ty (HsTyVar Promoted (L _ name))
+ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty
+ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds
+ppr_mono_ty (HsTyVar _ NotPromoted (L _ name))= pprPrefixOcc name
+ppr_mono_ty (HsTyVar _ Promoted (L _ name))
= space <> quote (pprPrefixOcc name)
-- We need a space before the ' above, so the parser
-- does not attach it to the previous symbol
-ppr_mono_ty (HsFunTy ty1 ty2) = ppr_fun_ty ty1 ty2
-ppr_mono_ty (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys)
+ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2
+ppr_mono_ty (HsTupleTy _ con tys) = tupleParens std_con (pprWithCommas ppr tys)
where std_con = case con of
HsUnboxedTuple -> UnboxedTuple
_ -> BoxedTuple
-ppr_mono_ty (HsSumTy tys) = tupleParens UnboxedTuple (pprWithBars ppr tys)
-ppr_mono_ty (HsKindSig ty kind) = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind)
-ppr_mono_ty (HsListTy ty) = brackets (ppr_mono_lty ty)
-ppr_mono_ty (HsPArrTy ty) = paBrackets (ppr_mono_lty ty)
-ppr_mono_ty (HsIParamTy n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty)
-ppr_mono_ty (HsSpliceTy s _) = pprSplice s
-ppr_mono_ty (HsCoreTy ty) = ppr ty
-ppr_mono_ty (HsExplicitListTy Promoted _ tys)
+ppr_mono_ty (HsSumTy _ tys)
+ = tupleParens UnboxedTuple (pprWithBars ppr tys)
+ppr_mono_ty (HsKindSig _ ty kind)
+ = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind)
+ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty)
+ppr_mono_ty (HsPArrTy _ ty) = paBrackets (ppr_mono_lty ty)
+ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty)
+ppr_mono_ty (HsSpliceTy _ s) = pprSplice s
+ppr_mono_ty (HsExplicitListTy _ Promoted tys)
= quote $ brackets (interpp'SP tys)
-ppr_mono_ty (HsExplicitListTy NotPromoted _ tys)
+ppr_mono_ty (HsExplicitListTy _ NotPromoted tys)
= brackets (interpp'SP tys)
ppr_mono_ty (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
-ppr_mono_ty (HsTyLit t) = ppr_tylit t
-ppr_mono_ty (HsWildCardTy {}) = char '_'
+ppr_mono_ty (HsTyLit _ t) = ppr_tylit t
+ppr_mono_ty (HsWildCardTy {}) = char '_'
-ppr_mono_ty (HsEqTy ty1 ty2)
+ppr_mono_ty (HsEqTy _ ty1 ty2)
= ppr_mono_lty ty1 <+> char '~' <+> ppr_mono_lty ty2
-ppr_mono_ty (HsAppsTy tys)
+ppr_mono_ty (HsAppsTy _ tys)
= hsep (map (ppr_app_ty . unLoc) tys)
-ppr_mono_ty (HsAppTy fun_ty arg_ty)
+ppr_mono_ty (HsAppTy _ fun_ty arg_ty)
= hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]
-ppr_mono_ty (HsOpTy ty1 (L _ op) ty2)
+ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2)
= sep [ ppr_mono_lty ty1
, sep [pprInfixOcc op, ppr_mono_lty ty2 ] ]
-ppr_mono_ty (HsParTy ty)
+ppr_mono_ty (HsParTy _ ty)
= parens (ppr_mono_lty ty)
-- Put the parens in where the user did
-- But we still use the precedence stuff to add parens because
-- toHsType doesn't put in any HsParTys, so we may still need them
-ppr_mono_ty (HsDocTy ty doc)
+ppr_mono_ty (HsDocTy _ ty doc)
-- AZ: Should we add parens? Should we introduce "-- ^"?
= ppr_mono_lty ty <+> ppr (unLoc doc)
-- we pretty print Haddock comments on types as if they were
-- postfix operators
--------------------------
-ppr_fun_ty :: (SourceTextX pass, OutputableBndrId pass)
- => LHsType pass -> LHsType pass -> SDoc
+ppr_fun_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
ppr_fun_ty ty1 ty2
= let p1 = ppr_mono_lty ty1
p2 = ppr_mono_lty ty2
@@ -1351,16 +1486,17 @@ ppr_fun_ty ty1 ty2
sep [p1, text "->" <+> p2]
--------------------------
-ppr_app_ty :: (SourceTextX pass, OutputableBndrId pass)
- => HsAppType pass -> SDoc
-ppr_app_ty (HsAppInfix (L _ n)) = pprInfixOcc n
-ppr_app_ty (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n))))
+ppr_app_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsAppType (GhcPass p) -> SDoc
+ppr_app_ty (HsAppInfix _ (L _ n)) = pprInfixOcc n
+ppr_app_ty (HsAppPrefix _ (L _ (HsTyVar _ NotPromoted (L _ n))))
= pprPrefixOcc n
-ppr_app_ty (HsAppPrefix (L _ (HsTyVar Promoted (L _ n))))
+ppr_app_ty (HsAppPrefix _ (L _ (HsTyVar _ Promoted (L _ n))))
= space <> quote (pprPrefixOcc n) -- We need a space before the ' above, so
-- the parser does not attach it to the
-- previous symbol
-ppr_app_ty (HsAppPrefix ty) = ppr_mono_lty ty
+ppr_app_ty (HsAppPrefix _ ty) = ppr_mono_lty ty
+ppr_app_ty (XAppType ty) = ppr ty
--------------------------
ppr_tylit :: HsTyLit -> SDoc
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 8e17994993..e5f0fb6187 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -50,7 +50,7 @@ module HsUtils(
-- Patterns
mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
- nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, nlParPat,
+ nlWildPatName, nlTuplePat, mkParPat, nlParPat,
mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
-- Types
@@ -140,8 +140,8 @@ from their components, compared with the nl* functions below which
just attach noSrcSpan to everything.
-}
-mkHsPar :: LHsExpr id -> LHsExpr id
-mkHsPar e = L (getLoc e) (HsPar e)
+mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+mkHsPar e = L (getLoc e) (HsPar noExt e)
mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP id))
-> [LPat id] -> Located (body id)
@@ -174,20 +174,21 @@ mkLocatedList :: [Located a] -> Located [Located a]
mkLocatedList [] = noLoc []
mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
-mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
-mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
+mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2)
-mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name
-mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t)
+mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn
+mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType t e)
-mkHsAppTypes :: LHsExpr name -> [LHsWcType name] -> LHsExpr name
+mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
mkHsAppTypes = foldl mkHsAppType
+-- AZ:TODO this can go, in favour of mkHsAppType. ?
mkHsAppTypeOut :: LHsExpr GhcTc -> LHsWcType GhcRn -> LHsExpr GhcTc
-mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t)
+mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppType t e)
mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
-mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
+mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExt matches))
where
matches = mkMatchGroup Generated
[mkSimpleMatch LambdaExpr pats body]
@@ -202,35 +203,35 @@ mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
mkHsCaseAlt pat expr
= mkSimpleMatch CaseAlt [pat] expr
-nlHsTyApp :: IdP name -> [Type] -> LHsExpr name
-nlHsTyApp fun_id tys = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
+nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id)
+nlHsTyApp fun_id tys
+ = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExt (noLoc fun_id)))
-nlHsTyApps :: IdP name -> [Type] -> [LHsExpr name] -> LHsExpr name
+nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)]
+ -> LHsExpr (GhcPass id)
nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs
--------- Adding parens ---------
-mkLHsPar :: LHsExpr name -> LHsExpr name
+mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-- Wrap in parens if hsExprNeedsParens says it needs them
-- So 'f x' becomes '(f x)', but '3' stays as '3'
-mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le)
+mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar noExt le)
| otherwise = le
-mkParPat :: LPat name -> LPat name
-mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
+mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
+mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat noExt lp)
| otherwise = lp
-nlParPat :: LPat name -> LPat name
-nlParPat p = noLoc (ParPat p)
+nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
+nlParPat p = noLoc (ParPat noExt p)
-------------------------------
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName
-mkHsIntegral :: IntegralLit -> PostTc GhcPs Type
- -> HsOverLit GhcPs
-mkHsFractional :: FractionalLit -> PostTc GhcPs Type -> HsOverLit GhcPs
-mkHsIsString :: SourceText -> FastString -> PostTc GhcPs Type
- -> HsOverLit GhcPs
+mkHsIntegral :: IntegralLit -> HsOverLit GhcPs
+mkHsFractional :: FractionalLit -> HsOverLit GhcPs
+mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs
mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs
mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> HsExpr GhcPs
@@ -239,60 +240,72 @@ mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)
-> Pat GhcPs
mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs
-mkLastStmt :: SourceTextX idR
- => Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
+mkLastStmt :: SourceTextX (GhcPass idR)
+ => Located (bodyR (GhcPass idR))
+ -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkBodyStmt :: Located (bodyR GhcPs)
-> StmtLR idL GhcPs (Located (bodyR GhcPs))
-mkBindStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => LPat idL -> Located (bodyR idR)
- -> StmtLR idL idR (Located (bodyR idR))
+mkBindStmt :: (SourceTextX (GhcPass idR),
+ PostTc (GhcPass idR) Type ~ PlaceHolder)
+ => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR))
+ -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
-> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
-emptyRecStmt :: StmtLR idL GhcPs bodyR
+emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR
emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR
emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR
mkRecStmt :: [LStmtLR idL GhcPs bodyR] -> StmtLR idL GhcPs bodyR
-mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noExpr
-mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noExpr
-mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noExpr
+mkHsIntegral i = OverLit noExt (HsIntegral i) noExpr
+mkHsFractional f = OverLit noExt (HsFractional f) noExpr
+mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr
noRebindableInfo :: PlaceHolder
-noRebindableInfo = PlaceHolder -- Just another placeholder;
+noRebindableInfo = placeHolder -- Just another placeholder;
-mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType
+mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts)
mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
where
last_stmt = L (getLoc expr) $ mkLastStmt expr
-mkHsIf :: SourceTextX p => LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
-mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
-
-mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
-mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType
-
-mkTransformStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => [ExprLStmt idL] -> LHsExpr idR
- -> StmtLR idL idR (LHsExpr idL)
-mkTransformByStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
- -> StmtLR idL idR (LHsExpr idL)
-mkGroupUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => [ExprLStmt idL] -> LHsExpr idR
- -> StmtLR idL idR (LHsExpr idL)
-mkGroupByUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
- -> StmtLR idL idR (LHsExpr idL)
-
-emptyTransStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => StmtLR idL idR (LHsExpr idR)
+mkHsIf :: SourceTextX (GhcPass p)
+ => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
+ -> HsExpr (GhcPass p)
+mkHsIf c a b = HsIf noExt (Just noSyntaxExpr) c a b
+
+mkNPat lit neg = NPat noExt lit neg noSyntaxExpr
+mkNPlusKPat id lit
+ = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr
+
+mkTransformStmt :: (SourceTextX (GhcPass idR),
+ PostTc (GhcPass idR) Type ~ PlaceHolder)
+ => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR)
+ -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL))
+mkTransformByStmt :: (SourceTextX (GhcPass idR),
+ PostTc (GhcPass idR) Type ~ PlaceHolder)
+ => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR)
+ -> LHsExpr (GhcPass idR)
+ -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL))
+mkGroupUsingStmt :: (SourceTextX (GhcPass idR),
+ PostTc (GhcPass idR) Type ~ PlaceHolder)
+ => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR)
+ -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL))
+mkGroupByUsingStmt :: (SourceTextX (GhcPass idR),
+ PostTc (GhcPass idR) Type ~ PlaceHolder)
+ => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR)
+ -> LHsExpr (GhcPass idR)
+ -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL))
+
+emptyTransStmt :: (SourceTextX (GhcPass idR),
+ PostTc (GhcPass idR) Type ~ PlaceHolder)
+ => StmtLR idL (GhcPass idR) (LHsExpr (GhcPass idR))
emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
, trS_stmts = [], trS_bndrs = []
, trS_by = Nothing, trS_using = noLoc noExpr
, trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
- , trS_bind_arg_ty = PlaceHolder
+ , trS_bind_arg_ty = placeHolder
, trS_fmap = noExpr }
mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u }
mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
@@ -301,12 +314,12 @@ mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = s
mkLastStmt body = LastStmt body False noSyntaxExpr
mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
-mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder
+mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr placeHolder
mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy
-- don't use placeHolderTypeTc above, because that panics during zonking
-emptyRecStmt' :: forall idL idR body. SourceTextX idR =>
- PostTc idR Type -> StmtLR idL idR body
+emptyRecStmt' :: forall idL idR body. SourceTextX (GhcPass idR) =>
+ PostTc (GhcPass idR) Type -> StmtLR (GhcPass idL) (GhcPass idR) body
emptyRecStmt' tyVal =
RecStmt
{ recS_stmts = [], recS_later_ids = []
@@ -325,28 +338,29 @@ mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
-------------------------------
--- A useful function for building @OpApps@. The operator is always a
-- variable, and we don't know the fixity yet.
-mkHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> HsExpr id
-mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
- (error "mkOpApp:fixity") e2
+mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
+mkHsOpApp e1 op e2 = OpApp noExt e1 (noLoc (HsVar noExt (noLoc op))) e2
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
-mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e
+mkUntypedSplice hasParen e = HsUntypedSplice noExt hasParen unqualSplice e
mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
-mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e)
+mkHsSpliceE hasParen e = HsSpliceE noExt (mkUntypedSplice hasParen e)
mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
-mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e)
+mkHsSpliceTE hasParen e
+ = HsSpliceE noExt (HsTypedSplice noExt hasParen unqualSplice e)
mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs
-mkHsSpliceTy hasParen e
- = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind
+mkHsSpliceTy hasParen e = HsSpliceTy noExt
+ (HsUntypedSplice noExt hasParen unqualSplice e)
mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
-mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
+mkHsQuasiQuote quoter span quote
+ = HsQuasiQuote noExt unqualSplice quoter span quote
unqualQuasiQuote :: RdrName
unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
@@ -361,13 +375,15 @@ mkHsStringPrimLit fs
= HsStringPrim noSourceText (fastStringToByteString fs)
-------------
-userHsLTyVarBndrs :: SrcSpan -> [Located (IdP name)] -> [LHsTyVarBndr name]
+userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))]
+ -> [LHsTyVarBndr (GhcPass p)]
-- Caller sets location
-userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
+userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt v) | v <- bndrs ]
-userHsTyVarBndrs :: SrcSpan -> [IdP name] -> [LHsTyVarBndr name]
+userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)]
-- Caller sets location
-userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
+userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt (L loc v))
+ | v <- bndrs ]
{-
@@ -378,29 +394,30 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
************************************************************************
-}
-nlHsVar :: IdP id -> LHsExpr id
-nlHsVar n = noLoc (HsVar (noLoc n))
+nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)
+nlHsVar n = noLoc (HsVar noExt (noLoc n))
-- NB: Only for LHsExpr **Id**
nlHsDataCon :: DataCon -> LHsExpr GhcTc
-nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con))
+nlHsDataCon con = noLoc (HsConLikeOut noExt (RealDataCon con))
-nlHsLit :: HsLit p -> LHsExpr p
-nlHsLit n = noLoc (HsLit n)
+nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)
+nlHsLit n = noLoc (HsLit noExt n)
-nlHsIntLit :: HasDefaultX p => Integer -> LHsExpr p
-nlHsIntLit n = noLoc (HsLit (HsInt def (mkIntegralLit n)))
+nlHsIntLit :: Integer -> LHsExpr (GhcPass p)
+nlHsIntLit n = noLoc (HsLit noExt (HsInt noExt (mkIntegralLit n)))
-nlVarPat :: IdP id -> LPat id
-nlVarPat n = noLoc (VarPat (noLoc n))
+nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id)
+nlVarPat n = noLoc (VarPat noExt (noLoc n))
-nlLitPat :: HsLit p -> LPat p
-nlLitPat l = noLoc (LitPat l)
+nlLitPat :: HsLit GhcPs -> LPat GhcPs
+nlLitPat l = noLoc (LitPat noExt l)
-nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
-nlHsApp f x = noLoc (HsApp f (mkLHsPar x))
+nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+nlHsApp f x = noLoc (HsApp noExt f (mkLHsPar x))
-nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id
+nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)]
+ -> LHsExpr (GhcPass id)
nlHsSyntaxApps (SyntaxExpr { syn_expr = fun
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap }) args
@@ -412,13 +429,14 @@ nlHsSyntaxApps (SyntaxExpr { syn_expr = fun
= mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
mkLHsWrap arg_wraps args))
-nlHsApps :: IdP id -> [LHsExpr id] -> LHsExpr id
+nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
-nlHsVarApps :: IdP id -> [IdP id] -> LHsExpr id
-nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
+nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
+nlHsVarApps f xs = noLoc (foldl mk (HsVar noExt (noLoc f))
+ (map ((HsVar noExt) . noLoc) xs))
where
- mk f a = HsApp (noLoc f) (noLoc a)
+ mk f a = HsApp noExt (noLoc f) (noLoc a)
nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat con vars = nlConPat con (map nlVarPat vars)
@@ -444,50 +462,49 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
nlWildPat)))
nlWildPat :: LPat GhcPs
-nlWildPat = noLoc (WildPat placeHolderType ) -- Pre-typechecking
+nlWildPat = noLoc (WildPat noExt ) -- Pre-typechecking
nlWildPatName :: LPat GhcRn
-nlWildPatName = noLoc (WildPat placeHolderType ) -- Pre-typechecking
-
-nlWildPatId :: LPat GhcTc
-nlWildPatId = noLoc (WildPat placeHolderTypeTc ) -- Post-typechecking
+nlWildPatName = noLoc (WildPat noExt ) -- Pre-typechecking
nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
-nlHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> LHsExpr id
+nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
-nlHsPar :: LHsExpr id -> LHsExpr id
-nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
+nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+ -> LHsExpr (GhcPass id)
nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
-nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match]))
-nlHsPar e = noLoc (HsPar e)
+nlHsLam match = noLoc (HsLam noExt (mkMatchGroup Generated [match]))
+nlHsPar e = noLoc (HsPar noExt e)
-- Note [Rebindable nlHsIf]
-- nlHsIf should generate if-expressions which are NOT subject to
-- RebindableSyntax, so the first field of HsIf is Nothing. (#12080)
-nlHsIf cond true false = noLoc (HsIf Nothing cond true false)
+nlHsIf cond true false = noLoc (HsIf noExt Nothing cond true false)
-nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches))
-nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs)
+nlHsCase expr matches
+ = noLoc (HsCase noExt expr (mkMatchGroup Generated matches))
+nlList exprs = noLoc (ExplicitList noExt Nothing exprs)
-nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
-nlHsTyVar :: IdP name -> LHsType name
-nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
-nlHsParTy :: LHsType name -> LHsType name
+nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p)
+nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
-nlHsAppTy f t = noLoc (HsAppTy f t)
-nlHsTyVar x = noLoc (HsTyVar NotPromoted (noLoc x))
-nlHsFunTy a b = noLoc (HsFunTy a b)
-nlHsParTy t = noLoc (HsParTy t)
+nlHsAppTy f t = noLoc (HsAppTy noExt f t)
+nlHsTyVar x = noLoc (HsTyVar noExt NotPromoted (noLoc x))
+nlHsFunTy a b = noLoc (HsFunTy noExt a b)
+nlHsParTy t = noLoc (HsParTy noExt t)
-nlHsTyConApp :: IdP name -> [LHsType name] -> LHsType name
+nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
{-
@@ -495,37 +512,38 @@ Tuples. All these functions are *pre-typechecker* because they lack
types on the tuple.
-}
-mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
+mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] = e
-mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
+mkLHsTupleExpr es
+ = noLoc $ ExplicitTuple noExt (map (noLoc . (Present noExt)) es) Boxed
-mkLHsVarTuple :: [IdP a] -> LHsExpr a
+mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
-nlTuplePat :: [LPat id] -> Boxity -> LPat id
-nlTuplePat pats box = noLoc (TuplePat pats box [])
+nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs
+nlTuplePat pats box = noLoc (TuplePat noExt pats box)
missingTupArg :: HsTupArg GhcPs
-missingTupArg = Missing placeHolderType
+missingTupArg = Missing noExt
-mkLHsPatTup :: [LPat id] -> LPat id
-mkLHsPatTup [] = noLoc $ TuplePat [] Boxed []
+mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
+mkLHsPatTup [] = noLoc $ TuplePat noExt [] Boxed
mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat lpats Boxed []
+mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExt lpats Boxed
-- The Big equivalents for the source tuple expressions
-mkBigLHsVarTup :: [IdP id] -> LHsExpr id
+mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
-mkBigLHsTup :: [LHsExpr id] -> LHsExpr id
+mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
mkBigLHsTup = mkChunkified mkLHsTupleExpr
-- The Big equivalents for the source tuple patterns
-mkBigLHsVarPatTup :: [IdP id] -> LPat id
+mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
-mkBigLHsPatTup :: [LPat id] -> LPat id
+mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
mkBigLHsPatTup = mkChunkified mkLHsPatTup
-- $big_tuples
@@ -632,16 +650,18 @@ typeToLHsType ty
| isPredTy arg
, (theta, tau) <- tcSplitPhiTy ty
= noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
+ , hst_xqual = noExt
, hst_body = go tau })
go (FunTy arg res) = nlHsFunTy (go arg) (go res)
go ty@(ForAllTy {})
| (tvs, tau) <- tcSplitForAllTys ty
= noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
+ , hst_xforall = noExt
, hst_body = go tau })
go (TyVarTy tv) = nlHsTyVar (getRdrName tv)
go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2)
- go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy noSourceText n)
- go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy noSourceText s)
+ go (LitTy (NumTyLit n)) = noLoc $ HsTyLit noExt (HsNumTy noSourceText n)
+ go (LitTy (StrTyLit s)) = noLoc $ HsTyLit noExt (HsStrTy noSourceText s)
go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args')
where
args' = filterOutInvisibleTypes tc args
@@ -652,7 +672,7 @@ typeToLHsType ty
-- so we must remove them here (Trac #8563)
go_tv :: TyVar -> LHsTyVarBndr GhcPs
- go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
+ go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv))
(go (tyVarKind tv))
@@ -662,41 +682,41 @@ typeToLHsType ty
* *
********************************************************************* -}
-mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
+mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
-- Avoid (HsWrap co (HsWrap co' _)).
-- See Note [Detecting forced eta expansion] in DsExpr
-mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
+mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
-mkHsWrap co_fn (HsWrap co_fn' e) = mkHsWrap (co_fn <.> co_fn') e
-mkHsWrap co_fn e = HsWrap co_fn e
+mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e
+mkHsWrap co_fn e = HsWrap noExt co_fn e
mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b
- -> HsExpr id -> HsExpr id
+ -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b
- -> HsExpr id -> HsExpr id
+ -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
-mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
+mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
-mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id
+mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
- | otherwise = HsCmdWrap w cmd
+ | otherwise = HsCmdWrap noExt w cmd
-mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id
+mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
-mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
+mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
- | otherwise = CoPat co_fn p ty
+ | otherwise = CoPat noExt co_fn p ty
-mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
+mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
- | otherwise = CoPat (mkWpCastN co) pat ty
+ | otherwise = CoPat noExt (mkWpCastN co) pat ty
mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
@@ -769,14 +789,16 @@ mkPrefixFunRhs n = FunRhs { mc_fun = n
, mc_strictness = NoSrcStrict }
------------
-mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p
- -> Located (HsLocalBinds p) -> LMatch p (LHsExpr p)
+mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
+ -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p)
+ -> Located (HsLocalBinds (GhcPass p))
+ -> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch ctxt pats expr lbinds
= noLoc (Match { m_ctxt = ctxt
, m_pats = map paren pats
, m_grhss = GRHSs (unguardedRHS noSrcSpan expr) lbinds })
where
- paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
+ paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat noExt lp)
| otherwise = lp
{-
@@ -864,13 +886,15 @@ isBangedHsBind (PatBind {pat_lhs = pat})
isBangedHsBind _
= False
-collectLocalBinders :: HsLocalBindsLR idL idR -> [IdP idL]
+collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR)
+ -> [IdP (GhcPass idL)]
collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
-- No pattern synonyms here
collectLocalBinders (HsIPBinds _) = []
collectLocalBinders EmptyLocalBinds = []
-collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [IdP idL]
+collectHsIdBinders, collectHsValBinders
+ :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
-- Collect Id binders only, or Ids + pattern synonyms, respectively
collectHsIdBinders = collect_hs_val_binders True
collectHsValBinders = collect_hs_val_binders False
@@ -886,9 +910,11 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [IdP idL]
-- Same as collectHsBindsBinders, but works over a list of bindings
collectHsBindListBinders = foldr (collect_bind False . unLoc) []
-collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [IdP idL]
-collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds []
-collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds
+collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR)
+ -> [IdP (GhcPass idL)]
+collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []
+collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))
+ = collect_out_binds ps binds
collect_out_binds :: Bool -> [(RecFlag, LHsBinds p)] -> [IdP p]
collect_out_binds ps = foldr (collect_binds ps . snd) []
@@ -903,7 +929,7 @@ collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc
collect_bind _ (VarBind { var_id = f }) acc = f : acc
collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
-- I don't think we want the binders from the abe_binds
- -- The only time we collect binders from a typechecked
+
-- binding (hence see AbsBinds) is in zonking in TcHsSyn
collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
| omitPatSyn = acc
@@ -918,23 +944,27 @@ collectMethodBinders binds = foldrBag (get . unLoc) [] binds
-- Someone else complains about non-FunBinds
----------------- Statements --------------------------
-collectLStmtsBinders :: [LStmtLR idL idR body] -> [IdP idL]
+collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body]
+ -> [IdP (GhcPass idL)]
collectLStmtsBinders = concatMap collectLStmtBinders
-collectStmtsBinders :: [StmtLR idL idR body] -> [IdP idL]
+collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body]
+ -> [IdP (GhcPass idL)]
collectStmtsBinders = concatMap collectStmtBinders
-collectLStmtBinders :: LStmtLR idL idR body -> [IdP idL]
+collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body
+ -> [IdP (GhcPass idL)]
collectLStmtBinders = collectStmtBinders . unLoc
-collectStmtBinders :: StmtLR idL idR body -> [IdP idL]
+collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body
+ -> [IdP (GhcPass idL)]
-- Id Binders for a Stmt... [but what about pattern-sig type vars]?
collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat
collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds
collectStmtBinders (BodyStmt {}) = []
collectStmtBinders (LastStmt {}) = []
-collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
- $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
+collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
+ $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
collectStmtBinders ApplicativeStmt{} = []
@@ -952,33 +982,33 @@ collect_lpat :: LPat pass -> [IdP pass] -> [IdP pass]
collect_lpat (L _ pat) bndrs
= go pat
where
- go (VarPat (L _ var)) = var : bndrs
+ go (VarPat _ (L _ var)) = var : bndrs
go (WildPat _) = bndrs
- go (LazyPat pat) = collect_lpat pat bndrs
- go (BangPat pat) = collect_lpat pat bndrs
- go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs
- go (ViewPat _ pat _) = collect_lpat pat bndrs
- go (ParPat pat) = collect_lpat pat bndrs
+ go (LazyPat _ pat) = collect_lpat pat bndrs
+ go (BangPat _ pat) = collect_lpat pat bndrs
+ go (AsPat _ (L _ a) pat) = a : collect_lpat pat bndrs
+ go (ViewPat _ _ pat) = collect_lpat pat bndrs
+ go (ParPat _ pat) = collect_lpat pat bndrs
- go (ListPat pats _ _) = foldr collect_lpat bndrs pats
- go (PArrPat pats _) = foldr collect_lpat bndrs pats
- go (TuplePat pats _ _) = foldr collect_lpat bndrs pats
- go (SumPat pat _ _ _) = collect_lpat pat bndrs
+ go (ListPat _ pats _ _) = foldr collect_lpat bndrs pats
+ go (PArrPat _ pats) = foldr collect_lpat bndrs pats
+ go (TuplePat _ pats _) = foldr collect_lpat bndrs pats
+ go (SumPat _ pat _ _) = collect_lpat pat bndrs
go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
-- See Note [Dictionary binders in ConPatOut]
- go (LitPat _) = bndrs
- go (NPat {}) = bndrs
- go (NPlusKPat (L _ n) _ _ _ _ _)= n : bndrs
+ go (LitPat _ _) = bndrs
+ go (NPat {}) = bndrs
+ go (NPlusKPat _ (L _ n) _ _ _ _)= n : bndrs
- go (SigPatIn pat _) = collect_lpat pat bndrs
- go (SigPatOut pat _) = collect_lpat pat bndrs
+ go (SigPat _ pat) = collect_lpat pat bndrs
- go (SplicePat (HsSpliced _ (HsSplicedPat pat)))
+ go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
= go pat
- go (SplicePat _) = bndrs
- go (CoPat _ pat _) = go pat
+ go (SplicePat _ _) = bndrs
+ go (CoPat _ _ pat _) = go pat
+ go (XPat {}) = bndrs
{-
Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
@@ -1027,7 +1057,7 @@ hsTyClForeignBinders tycl_decls foreign_decls
foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
where
getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name]
- getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs
+ getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs
-------------------
hsLTyClDeclBinders :: Located (TyClDecl pass)
@@ -1062,11 +1092,11 @@ hsForeignDeclsBinders foreign_decls
-------------------
-hsPatSynSelectors :: HsValBinds p -> [IdP p]
+hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
-- Collects record pattern-synonym selectors only; the pattern synonym
-- names are collected by collectHsValBinders.
-hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors"
-hsPatSynSelectors (ValBindsOut binds _)
+hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
+hsPatSynSelectors (XValBindsLR (NValBinds binds _))
= foldrBag addPatSynSelector [] . unionManyBags $ map snd binds
addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
@@ -1123,11 +1153,11 @@ hsConDeclsBinders cons = go id cons
L loc (ConDeclGADT { con_names = names
, con_type = HsIB { hsib_body = res_ty}}) ->
case tau of
- L _ (HsFunTy
- (L _ (HsAppsTy
- [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty)
+ L _ (HsFunTy _
+ (L _ (HsAppsTy _
+ [L _ (HsAppPrefix _ (L _ (HsRecTy _ flds)))])) _)
-> record_gadt flds
- L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)
+ L _ (HsFunTy _ (L _ (HsRecTy _ flds)) _res_ty)
-> record_gadt flds
_other -> (map (L loc . unLoc) names ++ ns, fs)
@@ -1188,13 +1218,16 @@ The main purpose is to find names introduced by record wildcards so that we can
warning the user when they don't use those names (#4404)
-}
-lStmtsImplicits :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet
+lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
+ -> NameSet
lStmtsImplicits = hs_lstmts
where
- hs_lstmts :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet
+ hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
+ -> NameSet
hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
- hs_stmt :: StmtLR GhcRn idR (Located (body idR)) -> NameSet
+ hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))
+ -> NameSet
hs_stmt (BindStmt pat _ _ _ _) = lPatImplicits pat
hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args)
where do_arg (_, ApplicativeArgOne pat _ _) = lPatImplicits pat
@@ -1202,7 +1235,8 @@ lStmtsImplicits = hs_lstmts
hs_stmt (LetStmt binds) = hs_local_binds (unLoc binds)
hs_stmt (BodyStmt {}) = emptyNameSet
hs_stmt (LastStmt {}) = emptyNameSet
- hs_stmt (ParStmt xs _ _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
+ hs_stmt (ParStmt xs _ _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs
+ , s <- ss]
hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
@@ -1210,10 +1244,10 @@ lStmtsImplicits = hs_lstmts
hs_local_binds (HsIPBinds _) = emptyNameSet
hs_local_binds EmptyLocalBinds = emptyNameSet
-hsValBindsImplicits :: HsValBindsLR GhcRn idR -> NameSet
-hsValBindsImplicits (ValBindsOut binds _)
+hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> NameSet
+hsValBindsImplicits (XValBindsLR (NValBinds binds _))
= foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds
-hsValBindsImplicits (ValBindsIn binds _)
+hsValBindsImplicits (ValBinds _ binds _)
= lhsBindsImplicits binds
lhsBindsImplicits :: LHsBindsLR GhcRn idR -> NameSet
@@ -1229,18 +1263,17 @@ lPatImplicits = hs_lpat
hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet
- hs_pat (LazyPat pat) = hs_lpat pat
- hs_pat (BangPat pat) = hs_lpat pat
- hs_pat (AsPat _ pat) = hs_lpat pat
- hs_pat (ViewPat _ pat _) = hs_lpat pat
- hs_pat (ParPat pat) = hs_lpat pat
- hs_pat (ListPat pats _ _) = hs_lpats pats
- hs_pat (PArrPat pats _) = hs_lpats pats
- hs_pat (TuplePat pats _ _) = hs_lpats pats
-
- hs_pat (SigPatIn pat _) = hs_lpat pat
- hs_pat (SigPatOut pat _) = hs_lpat pat
- hs_pat (CoPat _ pat _) = hs_pat pat
+ hs_pat (LazyPat _ pat) = hs_lpat pat
+ hs_pat (BangPat _ pat) = hs_lpat pat
+ hs_pat (AsPat _ _ pat) = hs_lpat pat
+ hs_pat (ViewPat _ _ pat) = hs_lpat pat
+ hs_pat (ParPat _ pat) = hs_lpat pat
+ hs_pat (ListPat _ pats _ _) = hs_lpats pats
+ hs_pat (PArrPat _ pats) = hs_lpats pats
+ hs_pat (TuplePat _ pats _) = hs_lpats pats
+
+ hs_pat (SigPat _ pat) = hs_lpat pat
+ hs_pat (CoPat _ _ pat _) = hs_pat pat
hs_pat (ConPatIn _ ps) = details ps
hs_pat (ConPatOut {pat_args=ps}) = details ps
diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs
index 0b4711a364..9d99c9a3cb 100644
--- a/compiler/hsSyn/PlaceHolder.hs
+++ b/compiler/hsSyn/PlaceHolder.hs
@@ -6,10 +6,9 @@
module PlaceHolder where
-import GhcPrelude ()
+import GhcPrelude ( Eq(..), Ord(..) )
-import Type ( Type )
-import Outputable
+import Outputable hiding ( (<>) )
import Name
import NameSet
import RdrName
@@ -31,29 +30,23 @@ import Data.Data hiding ( Fixity )
-- | used as place holder in PostTc and PostRn values
data PlaceHolder = PlaceHolder
- deriving (Data)
+ deriving (Data,Eq,Ord)
-placeHolderKind :: PlaceHolder
-placeHolderKind = PlaceHolder
+instance Outputable PlaceHolder where
+ ppr _ = text "PlaceHolder"
-placeHolderFixity :: PlaceHolder
-placeHolderFixity = PlaceHolder
+placeHolder :: PlaceHolder
+placeHolder = PlaceHolder
placeHolderType :: PlaceHolder
placeHolderType = PlaceHolder
-placeHolderTypeTc :: Type
-placeHolderTypeTc = panic "Evaluated the place holder for a PostTcType"
-
placeHolderNames :: PlaceHolder
placeHolderNames = PlaceHolder
placeHolderNamesTc :: NameSet
placeHolderNamesTc = emptyNameSet
-placeHolderHsWrapper :: PlaceHolder
-placeHolderHsWrapper = PlaceHolder
-
{-
Note [Pass sensitive types]
diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs
index 48b8eccaca..23e5c9289a 100644
--- a/compiler/main/HscStats.hs
+++ b/compiler/main/HscStats.hs
@@ -102,7 +102,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)
= sum5 (map inst_info inst_decls)
- count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0,0)
+ count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0)
count_bind (PatBind {}) = (0,1,0)
count_bind (FunBind {}) = (0,1,0)
count_bind (PatSynBind {}) = (0,0,1)
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index e63d6e3a95..1012c25b28 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -871,7 +871,8 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
let expr_fs = fsLit "_compileParsedExpr"
expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc
let_stmt = L loc . LetStmt . L loc . HsValBinds $
- ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
+ ValBinds noExt
+ (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt
updateFixityEnv fix_env
@@ -894,7 +895,7 @@ dynCompileExpr expr = do
parsed_expr <- parseExpr expr
-- > Data.Dynamic.toDyn expr
let loc = getLoc parsed_expr
- to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ getRdrName toDynName)
+ to_dyn_expr = mkHsApp (L loc . HsVar noExt . L loc $ getRdrName toDynName)
parsed_expr
hval <- compileParsedExpr to_dyn_expr
return (unsafeCoerce# hval :: Dynamic)
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index c60f51722f..5cceaf44fe 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1739,13 +1739,15 @@ ctype :: { LHsType GhcPs }
: 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >>
ams (sLL $1 $> $
HsForAllTy { hst_bndrs = $2
+ , hst_xforall = noExt
, hst_body = $4 })
[mu AnnForall $1, mj AnnDot $3] }
| context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> return (sLL $1 $> $
HsQualTy { hst_ctxt = $1
+ , hst_xqual = noExt
, hst_body = $3 }) }
- | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy $1 $3))
+ | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExt $1 $3))
[mu AnnDcolon $2] }
| type { $1 }
@@ -1764,13 +1766,15 @@ ctypedoc :: { LHsType GhcPs }
: 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >>
ams (sLL $1 $> $
HsForAllTy { hst_bndrs = $2
+ , hst_xforall = noExt
, hst_body = $4 })
[mu AnnForall $1,mj AnnDot $3] }
| context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> return (sLL $1 $> $
HsQualTy { hst_ctxt = $1
+ , hst_xqual = noExt
, hst_body = $3 }) }
- | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy $1 $3))
+ | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExt $1 $3))
[mu AnnDcolon $2] }
| typedoc { $1 }
@@ -1822,31 +1826,32 @@ is connected to the first type too.
type :: { LHsType GhcPs }
: btype { $1 }
| btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
- >> ams (sLL $1 $> $ HsFunTy $1 $3)
+ >> ams (sLL $1 $> $ HsFunTy noExt $1 $3)
[mu AnnRarrow $2] }
typedoc :: { LHsType GhcPs }
: btype { $1 }
- | btype docprev { sLL $1 $> $ HsDocTy $1 $2 }
- | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy $1 $3)
+ | btype docprev { sLL $1 $> $ HsDocTy noExt $1 $2 }
+ | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy noExt $1 $3)
[mu AnnRarrow $2] }
| btype docprev '->' ctypedoc {% ams (sLL $1 $> $
- HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2))
+ HsFunTy noExt (L (comb2 $1 $2)
+ (HsDocTy noExt $1 $2))
$4)
[mu AnnRarrow $3] }
-- See Note [Parsing ~]
btype :: { LHsType GhcPs }
: tyapps {% splitTildeApps (reverse (unLoc $1)) >>=
- \ts -> return $ sL1 $1 $ HsAppsTy ts }
+ \ts -> return $ sL1 $1 $ HsAppsTy noExt ts }
-- Used for parsing Haskell98-style data constructors,
-- in order to forbid the blasphemous
-- > data Foo = Int :+ Char :* Bool
-- See also Note [Parsing data constructors is hard] in RdrHsSyn
btype_no_ops :: { LHsType GhcPs }
- : btype_no_ops atype { sLL $1 $> $ HsAppTy $1 $2 }
+ : btype_no_ops atype { sLL $1 $> $ HsAppTy noExt $1 $2 }
| atype { $1 }
tyapps :: { Located [LHsAppType GhcPs] } -- NB: This list is reversed
@@ -1855,58 +1860,57 @@ tyapps :: { Located [LHsAppType GhcPs] } -- NB: This list is reversed
-- See Note [HsAppsTy] in HsTypes
tyapp :: { LHsAppType GhcPs }
- : atype { sL1 $1 $ HsAppPrefix $1 }
- | qtyconop { sL1 $1 $ HsAppInfix $1 }
- | tyvarop { sL1 $1 $ HsAppInfix $1 }
- | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ HsAppInfix $2)
+ : atype { sL1 $1 $ HsAppPrefix noExt $1 }
+ | qtyconop { sL1 $1 $ HsAppInfix noExt $1 }
+ | tyvarop { sL1 $1 $ HsAppInfix noExt $1 }
+ | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ HsAppInfix noExt $2)
[mj AnnSimpleQuote $1] }
- | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix $2)
+ | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix noExt $2)
[mj AnnSimpleQuote $1] }
atype :: { LHsType GhcPs }
- : ntgtycon { sL1 $1 (HsTyVar NotPromoted $1) } -- Not including unit tuples
- | tyvar { sL1 $1 (HsTyVar NotPromoted $1) } -- (See Note [Unit tuples])
- | strict_mark atype {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2))
+ : ntgtycon { sL1 $1 (HsTyVar noExt NotPromoted $1) } -- Not including unit tuples
+ | tyvar { sL1 $1 (HsTyVar noExt NotPromoted $1) } -- (See Note [Unit tuples])
+ | strict_mark atype {% ams (sLL $1 $> (HsBangTy noExt (snd $ unLoc $1) $2))
(fst $ unLoc $1) } -- Constructor sigs only
| '{' fielddecls '}' {% amms (checkRecordSyntax
- (sLL $1 $> $ HsRecTy $2))
+ (sLL $1 $> $ HsRecTy noExt $2))
-- Constructor sigs only
[moc $1,mcc $3] }
- | '(' ')' {% ams (sLL $1 $> $ HsTupleTy
+ | '(' ')' {% ams (sLL $1 $> $ HsTupleTy noExt
HsBoxedOrConstraintTuple [])
[mop $1,mcp $2] }
| '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma
(gl $3) >>
- ams (sLL $1 $> $ HsTupleTy
+ ams (sLL $1 $> $ HsTupleTy noExt
HsBoxedOrConstraintTuple ($2 : $4))
[mop $1,mcp $5] }
- | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple [])
+ | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy noExt HsUnboxedTuple [])
[mo $1,mc $2] }
- | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2)
+ | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy noExt HsUnboxedTuple $2)
[mo $1,mc $3] }
- | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy $2)
+ | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy noExt $2)
[mo $1,mc $3] }
- | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy $2) [mos $1,mcs $3] }
- | '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy $2) [mo $1,mc $3] }
- | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy $2) [mop $1,mcp $3] }
- | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig $2 $4)
+ | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy noExt $2) [mos $1,mcs $3] }
+ | '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy noExt $2) [mo $1,mc $3] }
+ | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy noExt $2) [mop $1,mcp $3] }
+ | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig noExt $2 $4)
[mop $1,mu AnnDcolon $3,mcp $5] }
- | quasiquote { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) }
+ | quasiquote { sL1 $1 (HsSpliceTy noExt (unLoc $1)) }
| '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2)
[mj AnnOpenPE $1,mj AnnCloseP $3] }
- | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar $
+ | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar noExt $
(sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))
[mj AnnThIdSplice $1] }
-- see Note [Promotion] for the followings
- | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
+ | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
| SIMPLEQUOTE '(' ctype ',' comma_types1 ')'
{% addAnnotation (gl $3) AnnComma (gl $4) >>
- ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))
+ ams (sLL $1 $> $ HsExplicitTupleTy noExt ($3 : $5))
[mj AnnSimpleQuote $1,mop $2,mcp $6] }
- | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy Promoted
- placeHolderKind $3)
+ | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy noExt Promoted $3)
[mj AnnSimpleQuote $1,mos $2,mcs $4] }
- | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar Promoted $2)
+ | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2)
[mj AnnSimpleQuote $1,mj AnnName $2] }
-- Two or more [ty, ty, ty] must be a promoted list type, just as
@@ -1915,13 +1919,12 @@ atype :: { LHsType GhcPs }
-- so you have to quote those.)
| '[' ctype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma
(gl $3) >>
- ams (sLL $1 $> $ HsExplicitListTy NotPromoted
- placeHolderKind ($2 : $4))
+ ams (sLL $1 $> $ HsExplicitListTy noExt NotPromoted ($2 : $4))
[mos $1,mcs $5] }
- | INTEGER { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1)
- (il_value (getINTEGER $1)) }
- | STRING { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1)
- (getSTRING $1) }
+ | INTEGER { sLL $1 $> $ HsTyLit noExt $ HsNumTy (getINTEGERs $1)
+ (il_value (getINTEGER $1)) }
+ | STRING { sLL $1 $> $ HsTyLit noExt $ HsStrTy (getSTRINGs $1)
+ (getSTRING $1) }
| '_' { sL1 $1 $ mkAnonWildCardTy }
-- An inst_type is what occurs in the head of an instance decl
@@ -1956,8 +1959,8 @@ tv_bndrs :: { [LHsTyVarBndr GhcPs] }
| {- empty -} { [] }
tv_bndr :: { LHsTyVarBndr GhcPs }
- : tyvar { sL1 $1 (UserTyVar $1) }
- | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar $2 $4))
+ : tyvar { sL1 $1 (UserTyVar noExt $1) }
+ | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar noExt $2 $4))
[mop $1,mu AnnDcolon $3
,mcp $5] }
@@ -2128,7 +2131,7 @@ fielddecl :: { LConDeclField GhcPs }
-- A list because of f,g :: Int
: maybe_docnext sig_vars '::' ctype maybe_docprev
{% ams (L (comb2 $2 $4)
- (ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc ln PlaceHolder) (unLoc $2))) $4 ($1 `mplus` $5)))
+ (ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5)))
[mu AnnDcolon $3] }
-- Reversed!
@@ -2199,7 +2202,7 @@ docdecld :: { LDocDecl }
decl_no_th :: { LHsDecl GhcPs }
: sigdecl { $1 }
- | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)
+ | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)
-- Turn it all into an expression so that
-- checkPattern can check that bangs are enabled
; l = comb2 $1 $> };
@@ -2352,47 +2355,47 @@ quasiquote :: { Located (HsSplice GhcPs) }
in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
exp :: { LHsExpr GhcPs }
- : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 (mkLHsSigWcType $3))
+ : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig (mkLHsSigWcType $3) $1)
[mu AnnDcolon $2] }
- | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
+ | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3
HsFirstOrderApp True)
[mu Annlarrowtail $2] }
- | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType
+ | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1
HsFirstOrderApp False)
[mu Annrarrowtail $2] }
- | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
+ | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3
HsHigherOrderApp True)
[mu AnnLarrowtail $2] }
- | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType
+ | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1
HsHigherOrderApp False)
[mu AnnRarrowtail $2] }
| infixexp { $1 }
infixexp :: { LHsExpr GhcPs }
: exp10 { $1 }
- | infixexp qop exp10 {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3))
+ | infixexp qop exp10 {% ams (sLL $1 $> (OpApp noExt $1 $2 $3))
[mj AnnVal $2] }
-- AnnVal annotation for NPlusKPat, which discards the operator
infixexp_top :: { LHsExpr GhcPs }
: exp10_top { $1 }
| infixexp_top qop exp10_top
- {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3))
+ {% ams (sLL $1 $> (OpApp noExt $1 $2 $3))
[mj AnnVal $2] }
exp10_top :: { LHsExpr GhcPs }
: '\\' apat apats '->' exp
- {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
+ {% ams (sLL $1 $> $ HsLam noExt (mkMatchGroup FromSource
[sLL $1 $> $ Match { m_ctxt = LambdaExpr
, m_pats = $2:$3
, m_grhss = unguardedGRHSs $5 }]))
[mj AnnLam $1, mu AnnRarrow $4] }
- | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
+ | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet noExt (snd $ unLoc $2) $4)
(mj AnnLet $1:mj AnnIn $3
:(fst $ unLoc $2)) }
| '\\' 'lcase' altslist
- {% ams (sLL $1 $> $ HsLamCase
+ {% ams (sLL $1 $> $ HsLamCase noExt
(mkMatchGroup FromSource (snd $ unLoc $3)))
(mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
@@ -2403,15 +2406,14 @@ exp10_top :: { LHsExpr GhcPs }
:(map (\l -> mj AnnSemi l) (fst $3))
++(map (\l -> mj AnnSemi l) (fst $6))) }
| 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>
- ams (sLL $1 $> $ HsMultiIf
- placeHolderType
+ ams (sLL $1 $> $ HsMultiIf noExt
(reverse $ snd $ unLoc $2))
(mj AnnIf $1:(fst $ unLoc $2)) }
- | 'case' exp 'of' altslist {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup
+ | 'case' exp 'of' altslist {% ams (sLL $1 $> $ HsCase noExt $2 (mkMatchGroup
FromSource (snd $ unLoc $4)))
(mj AnnCase $1:mj AnnOf $3
:(fst $ unLoc $4)) }
- | '-' fexp {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr)
+ | '-' fexp {% ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr)
[mj AnnMinus $1] }
| 'do' stmtlist {% ams (L (comb2 $1 $2)
@@ -2421,19 +2423,18 @@ exp10_top :: { LHsExpr GhcPs }
(mkHsDo MDoExpr (snd $ unLoc $2)))
(mj AnnMdo $1:(fst $ unLoc $2)) }
- | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ fst $ unLoc $1)
- (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
+ | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1)
+ (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
(fst $ fst $ fst $ unLoc $1) }
| 'proc' aexp '->' exp
{% checkPattern empty $2 >>= \ p ->
checkCommand $4 >>= \ cmd ->
- ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType
- placeHolderType []))
+ ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd))
-- TODO: is LL right here?
[mj AnnProc $1,mu AnnRarrow $3] }
- | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4)
+ | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) $4)
[mo $1,mj AnnVal $2
,mc $3] }
-- hdaume: core annotation
@@ -2441,7 +2442,7 @@ exp10_top :: { LHsExpr GhcPs }
exp10 :: { LHsExpr GhcPs }
: exp10_top { $1 }
- | scc_annot exp {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
+ | scc_annot exp {% ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
(fst $ fst $ unLoc $1) }
optSemi :: { ([Located a],Bool) }
@@ -2484,19 +2485,19 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
}
fexp :: { LHsExpr GhcPs }
- : fexp aexp { sLL $1 $> $ HsApp $1 $2 }
- | fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3))
+ : fexp aexp { sLL $1 $> $ HsApp noExt $1 $2 }
+ | fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType (mkHsWildCardBndrs $3) $1)
[mj AnnAt $2] }
- | 'static' aexp {% ams (sLL $1 $> $ HsStatic placeHolderNames $2)
+ | 'static' aexp {% ams (sLL $1 $> $ HsStatic noExt $2)
[mj AnnStatic $1] }
| aexp { $1 }
aexp :: { LHsExpr GhcPs }
- : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] }
+ : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat noExt $1 $3) [mj AnnAt $2] }
-- If you change the parsing, make sure to understand
-- Note [Lexing type applications] in Lexer.x
- | '~' aexp {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] }
+ | '~' aexp {% ams (sLL $1 $> $ ELazyPat noExt $2) [mj AnnTilde $1] }
| aexp1 { $1 }
aexp1 :: { LHsExpr GhcPs }
@@ -2507,72 +2508,70 @@ aexp1 :: { LHsExpr GhcPs }
| aexp2 { $1 }
aexp2 :: { LHsExpr GhcPs }
- : qvar { sL1 $1 (HsVar $! $1) }
- | qcon { sL1 $1 (HsVar $! $1) }
- | ipvar { sL1 $1 (HsIPVar $! unLoc $1) }
- | overloaded_label { sL1 $1 (HsOverLabel Nothing $! unLoc $1) }
- | literal { sL1 $1 (HsLit $! unLoc $1) }
+ : qvar { sL1 $1 (HsVar noExt $! $1) }
+ | qcon { sL1 $1 (HsVar noExt $! $1) }
+ | ipvar { sL1 $1 (HsIPVar noExt $! unLoc $1) }
+ | overloaded_label { sL1 $1 (HsOverLabel noExt Nothing $! unLoc $1) }
+ | literal { sL1 $1 (HsLit noExt $! unLoc $1) }
-- This will enable overloaded strings permanently. Normally the renamer turns HsString
-- into HsOverLit when -foverloaded-strings is on.
-- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)
-- (getSTRING $1) placeHolderType) }
- | INTEGER { sL (getLoc $1) (HsOverLit $! mkHsIntegral
- (getINTEGER $1) placeHolderType) }
- | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional
- (getRATIONAL $1) placeHolderType) }
+ | INTEGER { sL (getLoc $1) (HsOverLit noExt $! mkHsIntegral (getINTEGER $1) ) }
+ | RATIONAL { sL (getLoc $1) (HsOverLit noExt $! mkHsFractional (getRATIONAL $1) ) }
-- N.B.: sections get parsed by these next two productions.
-- This allows you to write, e.g., '(+ 3, 4 -)', which isn't
-- correct Haskell (you'd have to write '((+ 3), (4 -))')
-- but the less cluttered version fell out of having texps.
- | '(' texp ')' {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] }
+ | '(' texp ')' {% ams (sLL $1 $> (HsPar noExt $2)) [mop $1,mcp $3] }
| '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2)
; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } }
- | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple [L (gl $2)
- (Present $2)] Unboxed))
+ | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [L (gl $2)
+ (Present noExt $2)] Unboxed))
[mo $1,mc $3] }
| '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2)
; ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } }
| '[' list ']' {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) }
| '[:' parr ':]' {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) }
- | '_' { sL1 $1 EWildPat }
+ | '_' { sL1 $1 $ EWildPat noExt }
-- Template Haskell Extension
| splice_exp { $1 }
- | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
- | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
- | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
- | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
- | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket (ExpBr $2))
+ | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+ | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+ | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+ | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+ | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket noExt (ExpBr noExt $2))
(if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]
else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) }
- | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket (TExpBr $2))
+ | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket noExt (TExpBr noExt $2))
(if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
- | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mu AnnCloseQ $3] }
+ | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] }
| '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p ->
- ams (sLL $1 $> $ HsBracket (PatBr p))
+ ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p))
[mo $1,mu AnnCloseQ $3] }
- | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket (DecBrL (snd $2)))
+ | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2)))
(mo $1:mu AnnCloseQ $3:fst $2) }
- | quasiquote { sL1 $1 (HsSpliceE (unLoc $1)) }
+ | quasiquote { sL1 $1 (HsSpliceE noExt (unLoc $1)) }
-- arrow notation extension
- | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm $2
+ | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm noExt $2
Nothing (reverse $3))
[mu AnnOpenB $1,mu AnnCloseB $4] }
splice_exp :: { LHsExpr GhcPs }
: TH_ID_SPLICE {% ams (sL1 $1 $ mkHsSpliceE HasDollar
- (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
+ (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName
(getTH_ID_SPLICE $1)))))
[mj AnnThIdSplice $1] }
| '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE HasParens $2)
[mj AnnOpenPE $1,mj AnnCloseP $3] }
| TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkHsSpliceTE HasDollar
- (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
+ (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName
(getTH_ID_TY_SPLICE $1)))))
[mj AnnThIdTySplice $1] }
| '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2)
@@ -2584,8 +2583,7 @@ cmdargs :: { [LHsCmdTop GhcPs] }
acmd :: { LHsCmdTop GhcPs }
: aexp2 {% checkCommand $1 >>= \ cmd ->
- return (sL1 $1 $ HsCmdTop cmd
- placeHolderType placeHolderType []) }
+ return (sL1 $1 $ HsCmdTop noExt cmd) }
cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) }
: '{' cvtopdecls0 '}' { ([mj AnnOpenC $1
@@ -2616,17 +2614,17 @@ texp :: { LHsExpr GhcPs }
-- Then when converting expr to pattern we unravel it again
-- Meanwhile, the renamer checks that real sections appear
-- inside parens.
- | infixexp qop { sLL $1 $> $ SectionL $1 $2 }
- | qopm infixexp { sLL $1 $> $ SectionR $1 $2 }
+ | infixexp qop { sLL $1 $> $ SectionL noExt $1 $2 }
+ | qopm infixexp { sLL $1 $> $ SectionR noExt $1 $2 }
-- View patterns get parenthesized above
- | exp '->' texp {% ams (sLL $1 $> $ EViewPat $1 $3) [mu AnnRarrow $2] }
+ | exp '->' texp {% ams (sLL $1 $> $ EViewPat noExt $1 $3) [mu AnnRarrow $2] }
-- Always at least one comma or bar.
tup_exprs :: { ([AddAnn],SumOrTuple) }
: texp commas_tup_tail
{% do { addAnnotation (gl $1) AnnComma (fst $2)
- ; return ([],Tuple ((sL1 $1 (Present $1)) : snd $2)) } }
+ ; return ([],Tuple ((sL1 $1 (Present noExt $1)) : snd $2)) } }
| texp bars { (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) }
@@ -2649,8 +2647,8 @@ commas_tup_tail : commas tup_tail
-- Always follows a comma
tup_tail :: { [LHsTupArg GhcPs] }
: texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >>
- return ((L (gl $1) (Present $1)) : snd $2) }
- | texp { [L (gl $1) (Present $1)] }
+ return ((L (gl $1) (Present noExt $1)) : snd $2) }
+ | texp { [L (gl $1) (Present noExt $1)] }
| {- empty -} { [noLoc missingTupArg] }
-----------------------------------------------------------------------------
@@ -2659,19 +2657,18 @@ tup_tail :: { [LHsTupArg GhcPs] }
-- The rules below are little bit contorted to keep lexps left-recursive while
-- avoiding another shift/reduce-conflict.
list :: { ([AddAnn],HsExpr GhcPs) }
- : texp { ([],ExplicitList placeHolderType Nothing [$1]) }
- | lexps { ([],ExplicitList placeHolderType Nothing
- (reverse (unLoc $1))) }
+ : texp { ([],ExplicitList noExt Nothing [$1]) }
+ | lexps { ([],ExplicitList noExt Nothing (reverse (unLoc $1))) }
| texp '..' { ([mj AnnDotdot $2],
- ArithSeq noPostTcExpr Nothing (From $1)) }
+ ArithSeq noExt Nothing (From $1)) }
| texp ',' exp '..' { ([mj AnnComma $2,mj AnnDotdot $4],
- ArithSeq noPostTcExpr Nothing
+ ArithSeq noExt Nothing
(FromThen $1 $3)) }
| texp '..' exp { ([mj AnnDotdot $2],
- ArithSeq noPostTcExpr Nothing
+ ArithSeq noExt Nothing
(FromTo $1 $3)) }
| texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4],
- ArithSeq noPostTcExpr Nothing
+ ArithSeq noExt Nothing
(FromThenTo $1 $3 $5)) }
| texp '|' flattenedpquals
{% checkMonadComp >>= \ ctxt ->
@@ -2694,7 +2691,7 @@ flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
-- We just had one thing in our "parallel" list so
-- we simply return that thing directly
- qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr |
+ qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock noExt qs [] noSyntaxExpr |
qs <- qss]
noExpr noSyntaxExpr placeHolderType]
-- We actually found some actual parallel lists so
@@ -2751,15 +2748,14 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs
-- constructor in the list case).
parr :: { ([AddAnn],HsExpr GhcPs) }
- : { ([],ExplicitPArr placeHolderType []) }
- | texp { ([],ExplicitPArr placeHolderType [$1]) }
- | lexps { ([],ExplicitPArr placeHolderType
- (reverse (unLoc $1))) }
+ : { ([],ExplicitPArr noExt []) }
+ | texp { ([],ExplicitPArr noExt [$1]) }
+ | lexps { ([],ExplicitPArr noExt (reverse (unLoc $1))) }
| texp '..' exp { ([mj AnnDotdot $2]
- ,PArrSeq noPostTcExpr (FromTo $1 $3)) }
+ ,PArrSeq noExt (FromTo $1 $3)) }
| texp ',' exp '..' exp
{ ([mj AnnComma $2,mj AnnDotdot $4]
- ,PArrSeq noPostTcExpr (FromThenTo $1 $3 $5)) }
+ ,PArrSeq noExt (FromThenTo $1 $3 $5)) }
| texp '|' flattenedpquals
{ ([mj AnnVbar $2],mkHsComp PArrComp (unLoc $3) $1) }
@@ -2845,8 +2841,8 @@ gdpat :: { LGRHS GhcPs (LHsExpr GhcPs) }
-- we parse them right when bang-patterns are off
pat :: { LPat GhcPs }
pat : exp {% checkPattern empty $1 }
- | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR
- (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+ | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR noExt
+ (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
bindpat :: { LPat GhcPs }
@@ -2854,14 +2850,14 @@ bindpat : exp {% checkPattern
(text "Possibly caused by a missing 'do'?") $1 }
| '!' aexp {% amms (checkPattern
(text "Possibly caused by a missing 'do'?")
- (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+ (sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
apat :: { LPat GhcPs }
apat : aexp {% checkPattern empty $1 }
| '!' aexp {% amms (checkPattern empty
- (sLL $1 $> (SectionR
- (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+ (sLL $1 $> (SectionR noExt
+ (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
apats :: { [LPat GhcPs] }
@@ -3139,8 +3135,8 @@ qtycon :: { Located RdrName } -- Qualified or unqualified
| tycon { $1 }
qtycondoc :: { LHsType GhcPs } -- Qualified or unqualified
- : qtycon { sL1 $1 (HsTyVar NotPromoted $1) }
- | qtycon docprev { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) }
+ : qtycon { sL1 $1 (HsTyVar noExt NotPromoted $1) }
+ | qtycon docprev { sLL $1 $> (HsDocTy noExt (sL1 $1 (HsTyVar noExt NotPromoted $1)) $2) }
tycon :: { Located RdrName } -- Unqualified
: CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) }
@@ -3173,15 +3169,15 @@ varop :: { Located RdrName }
,mj AnnBackquote $3] }
qop :: { LHsExpr GhcPs } -- used in sections
- : qvarop { sL1 $1 $ HsVar $1 }
- | qconop { sL1 $1 $ HsVar $1 }
- | '`' '_' '`' {% ams (sLL $1 $> EWildPat)
+ : qvarop { sL1 $1 $ HsVar noExt $1 }
+ | qconop { sL1 $1 $ HsVar noExt $1 }
+ | '`' '_' '`' {% ams (sLL $1 $> (EWildPat noExt))
[mj AnnBackquote $1,mj AnnVal $2
,mj AnnBackquote $3] }
qopm :: { LHsExpr GhcPs } -- used in sections
- : qvaropm { sL1 $1 $ HsVar $1 }
- | qconop { sL1 $1 $ HsVar $1 }
+ : qvaropm { sL1 $1 $ HsVar noExt $1 }
+ | qconop { sL1 $1 $ HsVar noExt $1 }
qvarop :: { Located RdrName }
: qvarsym { $1 }
@@ -3338,8 +3334,8 @@ literal :: { Located (HsLit GhcPs) }
$ getPRIMCHAR $1 }
| PRIMSTRING { sL1 $1 $ HsStringPrim (sst $ getPRIMSTRINGs $1)
$ getPRIMSTRING $1 }
- | PRIMFLOAT { sL1 $1 $ HsFloatPrim def $ getPRIMFLOAT $1 }
- | PRIMDOUBLE { sL1 $1 $ HsDoublePrim def $ getPRIMDOUBLE $1 }
+ | PRIMFLOAT { sL1 $1 $ HsFloatPrim noExt $ getPRIMFLOAT $1 }
+ | PRIMDOUBLE { sL1 $1 $ HsDoublePrim noExt $ getPRIMDOUBLE $1 }
-----------------------------------------------------------------------------
-- Layout
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 126e92e7ad..7285f5fef9 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -186,7 +186,7 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
tcdFixity = fixity,
tcdDataDefn = defn,
- tcdDataCusk = PlaceHolder,
+ tcdDataCusk = placeHolder,
tcdFVs = placeHolderNames })) }
mkDataDefn :: NewOrData
@@ -286,10 +286,10 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
-- Typed splices are not allowed at the top level, thus we do not represent them
-- as spliced declaration. See #10945
mkSpliceDecl lexpr@(L loc expr)
- | HsSpliceE splice@(HsUntypedSplice {}) <- expr
+ | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
= SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
- | HsSpliceE splice@(HsQuasiQuote {}) <- expr
+ | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
= SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
| otherwise
@@ -349,7 +349,7 @@ cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup binding
= do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
- return $ ValBindsIn mbs sigs }
+ return $ ValBinds noExt mbs sigs }
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
@@ -476,15 +476,15 @@ splitCon ty
= split ty []
where
-- This is used somewhere where HsAppsTy is not used
- split (L _ (HsAppTy t u)) ts = split t (u : ts)
- split (L l (HsTyVar _ (L _ tc))) ts = do data_con <- tyConToDataCon l tc
- return (data_con, mk_rest ts)
- split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []
+ split (L _ (HsAppTy _ t u)) ts = split t (u : ts)
+ split (L l (HsTyVar _ _ (L _ tc))) ts = do data_con <- tyConToDataCon l tc
+ return (data_con, mk_rest ts)
+ split (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) []
= return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)
split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
- mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
- mk_rest ts = PrefixCon ts
+ mk_rest [L l (HsRecTy _ flds)] = RecCon (L l flds)
+ mk_rest ts = PrefixCon ts
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
-- See Note [Parsing data constructors is hard]
@@ -695,15 +695,16 @@ checkTyVars pp_what equals_or_where tc tparms
; return (mkHsQTvs tvs) }
where
- chk (L _ (HsParTy ty)) = chk ty
- chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty
+ chk (L _ (HsParTy _ ty)) = chk ty
+ chk (L _ (HsAppsTy _ [L _ (HsAppPrefix _ ty)])) = chk ty
-- Check that the name space is correct!
- chk (L l (HsKindSig
- (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k))
- | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k))
- chk (L l (HsTyVar _ (L ltv tv)))
- | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv)))
+ chk (L l (HsKindSig _
+ (L _ (HsAppsTy _ [L _ (HsAppPrefix _ (L lv (HsTyVar _ _ (L _ tv))))]))
+ k))
+ | isRdrTyVar tv = return (L l (KindedTyVar noExt (L lv tv) k))
+ chk (L l (HsTyVar _ _ (L ltv tv)))
+ | isRdrTyVar tv = return (L l (UserTyVar noExt (L ltv tv)))
chk t@(L loc _)
= Left (loc,
vcat [ text "Unexpected type" <+> quotes (ppr t)
@@ -752,23 +753,23 @@ checkTyClHdr is_cls ty
where
goL (L l ty) acc ann fix = go l ty acc ann fix
- go l (HsTyVar _ (L _ tc)) acc ann fix
+ go l (HsTyVar _ _ (L _ tc)) acc ann fix
| isRdrTc tc = return (L l tc, acc, fix, ann)
- go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann _fix
+ go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
| isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann)
- go l (HsParTy ty) acc ann fix = goL ty acc (ann ++ mkParensApiAnn l) fix
- go _ (HsAppTy t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
- go _ (HsAppsTy ts) acc ann _fix
+ go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
+ go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
+ go _ (HsAppsTy _ ts) acc ann _fix
| Just (head, args, fixity) <- getAppsTyHead_maybe ts
= goL head (args ++ acc) ann fixity
- go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix
+ go _ (HsAppsTy _ [L _ (HsAppInfix _ (L loc star))]) [] ann fix
| isStar star
= return (L loc (nameRdrName starKindTyConName), [], fix, ann)
| isUniStar star
= return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann)
- go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix
+ go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
= return (L l (nameRdrName tup_name), ts, fix, ann)
where
arity = length ts
@@ -783,14 +784,15 @@ checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
checkContext (L l orig_t)
= check [] (L l orig_t)
where
- check anns (L lp (HsTupleTy _ ts)) -- (Eq a, Ord b) shows up as a tuple type
+ check anns (L lp (HsTupleTy _ _ ts)) -- (Eq a, Ord b) shows up as a tuple type
= return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto ()
-- don't let HsAppsTy get in the way
- check anns (L _ (HsAppsTy [L _ (HsAppPrefix ty)]))
+ check anns (L _ (HsAppsTy _ [L _ (HsAppPrefix _ ty)]))
= check anns ty
- check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way
+ check anns (L lp1 (HsParTy _ ty))
+ -- to be sure HsParTy doesn't get into the way
= check anns' ty
where anns' = if l == lp1 then anns
else (anns ++ mkParensApiAnn lp1)
@@ -815,7 +817,7 @@ checkLPat msg e@(L l _) = checkPat msg l e []
checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
-> P (LPat GhcPs)
-checkPat _ loc (L l e@(HsVar (L _ c))) args
+checkPat _ loc (L l e@(HsVar _ (L _ c))) args
| isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
| not (null args) && patIsRec c =
patFail (text "Perhaps you intended to use RecursiveDo") l e
@@ -825,7 +827,7 @@ checkPat msg loc e args -- OK to let this happen even if bang-patterns
| Just (e', args') <- splitBang e
= do { args'' <- checkPatterns msg args'
; checkPat msg loc e' (args'' ++ args) }
-checkPat msg loc (L _ (HsApp f e)) args
+checkPat msg loc (L _ (HsApp _ f e)) args
= do p <- checkLPat msg e
checkPat msg loc f (p : args)
checkPat msg loc (L _ e) []
@@ -839,76 +841,76 @@ checkAPat msg loc e0 = do
pState <- getPState
let opts = options pState
case e0 of
- EWildPat -> return (WildPat placeHolderType)
- HsVar x -> return (VarPat x)
- HsLit (HsStringPrim _ _) -- (#13260)
+ EWildPat _ -> return (WildPat noExt)
+ HsVar _ x -> return (VarPat noExt x)
+ HsLit _ (HsStringPrim _ _) -- (#13260)
-> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0)
- HsLit l -> return (LitPat l)
+ HsLit _ l -> return (LitPat noExt l)
-- Overloaded numeric patterns (e.g. f 0 x = x)
-- Negation is recorded separately, so that the literal is zero or +ve
-- NB. Negative *primitive* literals are already handled by the lexer
- HsOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
- NegApp (L l (HsOverLit pos_lit)) _
+ HsOverLit _ pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
+ NegApp _ (L l (HsOverLit _ pos_lit)) _
-> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
- SectionR (L lb (HsVar (L _ bang))) e -- (! x)
+ SectionR _ (L lb (HsVar _ (L _ bang))) e -- (! x)
| bang == bang_RDR
-> do { bang_on <- extension bangPatEnabled
; if bang_on then do { e' <- checkLPat msg e
; addAnnotation loc AnnBang lb
- ; return (BangPat e') }
+ ; return (BangPat noExt e') }
else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) }
- ELazyPat e -> checkLPat msg e >>= (return . LazyPat)
- EAsPat n e -> checkLPat msg e >>= (return . AsPat n)
+ ELazyPat _ e -> checkLPat msg e >>= (return . (LazyPat noExt))
+ EAsPat _ n e -> checkLPat msg e >>= (return . (AsPat noExt) n)
-- view pattern is well-formed if the pattern is
- EViewPat expr patE -> checkLPat msg patE >>=
- (return . (\p -> ViewPat expr p placeHolderType))
- ExprWithTySig e t -> do e <- checkLPat msg e
- return (SigPatIn e t)
+ EViewPat _ expr patE -> checkLPat msg patE >>=
+ (return . (\p -> ViewPat noExt expr p))
+ ExprWithTySig t e -> do e <- checkLPat msg e
+ return (SigPat t e)
-- n+k patterns
- OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _
- (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
+ OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus)))
+ (L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
| extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
-> return (mkNPlusKPat (L nloc n) (L lloc lit))
- OpApp l op _fix r -> do l <- checkLPat msg l
- r <- checkLPat msg r
- case op of
- L cl (HsVar (L _ c)) | isDataOcc (rdrNameOcc c)
- -> return (ConPatIn (L cl c) (InfixCon l r))
- _ -> patFail msg loc e0
+ OpApp _ l op r -> do l <- checkLPat msg l
+ r <- checkLPat msg r
+ case op of
+ L cl (HsVar _ (L _ c)) | isDataOcc (rdrNameOcc c)
+ -> return (ConPatIn (L cl c) (InfixCon l r))
+ _ -> patFail msg loc e0
- HsPar e -> checkLPat msg e >>= (return . ParPat)
+ HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt))
ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
- return (ListPat ps placeHolderType Nothing)
+ return (ListPat noExt ps placeHolderType Nothing)
ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es
- return (PArrPat ps placeHolderType)
+ return (PArrPat noExt ps)
- ExplicitTuple es b
+ ExplicitTuple _ es b
| all tupArgPresent es -> do ps <- mapM (checkLPat msg)
- [e | L _ (Present e) <- es]
- return (TuplePat ps b [])
+ [e | L _ (Present _ e) <- es]
+ return (TuplePat noExt ps b)
| otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
- ExplicitSum alt arity expr _ -> do
+ ExplicitSum _ alt arity expr -> do
p <- checkLPat msg expr
- return (SumPat p alt arity placeHolderType)
+ return (SumPat noExt p alt arity)
RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
-> do fs <- mapM (checkPatField msg) fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
- HsSpliceE s | not (isTypedSplice s)
- -> return (SplicePat s)
+ HsSpliceE _ s | not (isTypedSplice s)
+ -> return (SplicePat noExt s)
_ -> patFail msg loc e0
placeHolderPunRhs :: LHsExpr GhcPs
-- The RHS of a punned record field will be filled in by the renamer
-- It's better not to make it an error, in case we want to print it when debugging
-placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR))
+placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR))
plus_RDR, bang_RDR, pun_RDR :: RdrName
plus_RDR = mkUnqual varName (fsLit "+") -- Hack
@@ -942,7 +944,7 @@ checkValDef :: SDoc
checkValDef msg _strictness lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding
= checkPatBind msg (L (combineLocs lhs sig)
- (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss
+ (ExprWithTySig (mkLHsSigWcType sig) lhs)) grhss
checkValDef msg strictness lhs Nothing g@(L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
@@ -995,7 +997,7 @@ checkPatBind msg lhs (L _ (_,grhss))
([],[])) }
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
-checkValSigLhs (L _ (HsVar lrdr@(L _ v)))
+checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
| isUnqual v
, not (isDataOcc (rdrNameOcc v))
= return lrdr
@@ -1017,9 +1019,9 @@ checkValSigLhs lhs@(L l _)
-- A common error is to forget the ForeignFunctionInterface flag
-- so check for that, and suggest. cf Trac #3805
-- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
- looks_like s (L _ (HsVar (L _ v))) = v == s
- looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
- looks_like _ _ = False
+ looks_like s (L _ (HsVar _ (L _ v))) = v == s
+ looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs
+ looks_like _ _ = False
foreign_RDR = mkUnqual varName (fsLit "foreign")
default_RDR = mkUnqual varName (fsLit "default")
@@ -1052,13 +1054,13 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
-- not be any OpApps inside the e's
splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
-- Splits (f ! g a b) into (f, [(! g), a, b])
-splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg))
- | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns)
+splitBang (L _ (OpApp _ l_arg bang@(L _ (HsVar _ (L _ op))) r_arg))
+ | op == bang_RDR = Just (l_arg, L l' (SectionR noExt bang arg1) : argns)
where
l' = combineLocs bang arg1
(arg1,argns) = split_bang r_arg []
- split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
- split_bang e es = (e,es)
+ split_bang (L _ (HsApp _ f e)) es = split_bang f (e:es)
+ split_bang e es = (e,es)
splitBang _ = Nothing
isFunLhs :: LHsExpr GhcPs
@@ -1077,14 +1079,15 @@ isFunLhs :: LHsExpr GhcPs
isFunLhs e = go e [] []
where
- go (L loc (HsVar (L _ f))) es ann
- | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
- go (L _ (HsApp f e)) es ann = go f (e:es) ann
- go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
+ go (L loc (HsVar _ (L _ f))) es ann
+ | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
+ go (L _ (HsApp _ f e)) es ann = go f (e:es) ann
+ go (L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
-- Things of the form `!x` are also FunBinds
-- See Note [FunBind vs PatBind]
- go (L _ (SectionR (L _ (HsVar (L _ bang))) (L l (HsVar (L _ var))))) [] ann
+ go (L _ (SectionR _ (L _ (HsVar _ (L _ bang))) (L l (HsVar _ (L _ var)))))
+ [] ann
| bang == bang_RDR
, not (isRdrDataCon var) = return (Just (L l var, Prefix, [], ann))
@@ -1101,7 +1104,7 @@ isFunLhs e = go e [] []
-- ToDo: what about this?
-- x + 1 `op` y = ...
- go e@(L loc (OpApp l (L loc' (HsVar (L _ op))) fix r)) es ann
+ go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann
| Just (e',es') <- splitBang e
= do { bang_on <- extension bangPatEnabled
; if bang_on then go e' (es' ++ es) ann
@@ -1115,7 +1118,8 @@ isFunLhs e = go e [] []
Just (op', Infix, j : k : es', ann')
-> return (Just (op', Infix, j : op_app : es', ann'))
where
- op_app = L loc (OpApp k (L loc' (HsVar (L loc' op))) fix r)
+ op_app = L loc (OpApp noExt k
+ (L loc' (HsVar noExt (L loc' op))) r)
_ -> return Nothing }
go _ _ _ = return Nothing
@@ -1124,23 +1128,24 @@ isFunLhs e = go e [] []
-- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d
splitTilde :: LHsType GhcPs -> P (LHsType GhcPs)
splitTilde t = go t
- where go (L loc (HsAppTy t1 t2))
- | L lo (HsBangTy (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2')
+ where go (L loc (HsAppTy _ t1 t2))
+ | L lo (HsBangTy _ (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2')
<- t2
= do
moveAnnotations lo loc
t1' <- go t1
- return (L loc (HsEqTy t1' t2'))
+ return (L loc (HsEqTy noExt t1' t2'))
| otherwise
= do
t1' <- go t1
case t1' of
- (L lo (HsEqTy tl tr)) -> do
+ (L lo (HsEqTy _ tl tr)) -> do
let lr = combineLocs tr t2
moveAnnotations lo loc
- return (L loc (HsEqTy tl (L lr (HsAppTy tr t2))))
+ return (L loc (HsEqTy noExt tl
+ (L lr (HsAppTy noExt tr t2))))
t -> do
- return (L loc (HsAppTy t t2))
+ return (L loc (HsAppTy noExt t t2))
go t = return t
@@ -1152,14 +1157,14 @@ splitTildeApps [] = return []
splitTildeApps (t : rest) = do
rest' <- concatMapM go rest
return (t : rest')
- where go (L l (HsAppPrefix
- (L loc (HsBangTy
+ where go (L l (HsAppPrefix _
+ (L loc (HsBangTy noExt
(HsSrcBang NoSourceText NoSrcUnpack SrcLazy)
ty))))
= addAnnotation l AnnTilde tilde_loc >>
return
- [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)),
- L l (HsAppPrefix ty)]
+ [L tilde_loc (HsAppInfix noExt (L tilde_loc eqTyCon_RDR)),
+ L l (HsAppPrefix noExt ty)]
-- NOTE: no annotation is attached to an HsAppPrefix, so the
-- surrounding SrcSpan is not critical
where
@@ -1195,34 +1200,35 @@ locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
locMap f (L l a) = f l a >>= (\b -> return $ L l b)
checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
-checkCmd _ (HsArrApp e1 e2 ptt haat b) =
- return $ HsCmdArrApp e1 e2 ptt haat b
-checkCmd _ (HsArrForm e mf args) =
- return $ HsCmdArrForm e Prefix mf args
-checkCmd _ (HsApp e1 e2) =
- checkCommand e1 >>= (\c -> return $ HsCmdApp c e2)
-checkCmd _ (HsLam mg) =
- checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg')
-checkCmd _ (HsPar e) =
- checkCommand e >>= (\c -> return $ HsCmdPar c)
-checkCmd _ (HsCase e mg) =
- checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg')
-checkCmd _ (HsIf cf ep et ee) = do
+checkCmd _ (HsArrApp _ e1 e2 haat b) =
+ return $ HsCmdArrApp noExt e1 e2 haat b
+checkCmd _ (HsArrForm _ e mf args) =
+ return $ HsCmdArrForm noExt e Prefix mf args
+checkCmd _ (HsApp _ e1 e2) =
+ checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c e2)
+checkCmd _ (HsLam _ mg) =
+ checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam noExt mg')
+checkCmd _ (HsPar _ e) =
+ checkCommand e >>= (\c -> return $ HsCmdPar noExt c)
+checkCmd _ (HsCase _ e mg) =
+ checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase noExt e mg')
+checkCmd _ (HsIf _ cf ep et ee) = do
pt <- checkCommand et
pe <- checkCommand ee
- return $ HsCmdIf cf ep pt pe
-checkCmd _ (HsLet lb e) =
- checkCommand e >>= (\c -> return $ HsCmdLet lb c)
-checkCmd _ (HsDo DoExpr (L l stmts) ty) =
- mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo (L l ss) ty)
-
-checkCmd _ (OpApp eLeft op _fixity eRight) = do
+ return $ HsCmdIf noExt cf ep pt pe
+checkCmd _ (HsLet _ lb e) =
+ checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c)
+checkCmd _ (HsDo _ DoExpr (L l stmts)) =
+ mapM checkCmdLStmt stmts >>=
+ (\ss -> return $ HsCmdDo noExt (L l ss) )
+
+checkCmd _ (OpApp _ eLeft op eRight) = do
-- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
c1 <- checkCommand eLeft
c2 <- checkCommand eRight
- let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType []
- arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType []
- return $ HsCmdArrForm op Infix Nothing [arg1, arg2]
+ let arg1 = L (getLoc c1) $ HsCmdTop noExt c1
+ arg2 = L (getLoc c2) $ HsCmdTop noExt c2
+ return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2]
checkCmd l e = cmdFail l e
@@ -1286,7 +1292,7 @@ mkRecConstrOrUpdate
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)
-> P (HsExpr GhcPs)
-mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd)
+mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
| isRdrDataCon c
= return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
@@ -1295,23 +1301,23 @@ mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
mkRdrRecordUpd exp flds
- = RecordUpd { rupd_expr = exp
- , rupd_flds = flds
- , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder
- , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder }
+ = RecordUpd { rupd_ext = noExt
+ , rupd_expr = exp
+ , rupd_flds = flds }
mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
mkRdrRecordCon con flds
- = RecordCon { rcon_con_name = con, rcon_flds = flds
- , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
+ = RecordCon { rcon_ext = noExt, rcon_con_name = con, rcon_flds = flds }
mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
-mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun)
- = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun
+mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
+ = HsRecField (L loc (Unambiguous noExt rdr)) arg pun
+mk_rec_upd_field (HsRecField (L _ (XFieldOcc _)) _ _)
+ = panic "mk_rec_upd_field"
mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
-> InlinePragma
@@ -1563,11 +1569,11 @@ data SumOrTuple
mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs)
-- Tuple
-mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple es boxity)
+mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity)
-- Sum
mkSumOrTuple Unboxed _ (Sum alt arity e) =
- return (ExplicitSum alt arity e PlaceHolder)
+ return (ExplicitSum noExt alt arity e)
mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e))
where
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 02a37b20ef..d8fcf4e690 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 dbc3baf887..c51b741944 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -1557,10 +1557,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 3cb24173ec..22e474b481 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
@@ -1876,8 +1879,8 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
-- typechecker and the desugarer (I tried it that way first!).
mkApplicativeStmt
:: HsStmtContext Name
- -> [ApplicativeArg GhcRn GhcRn] -- ^ The args
- -> Bool -- ^ True <=> need a join
+ -> [ApplicativeArg GhcRn] -- ^ The args
+ -> Bool -- ^ True <=> need a join
-> [ExprLStmt GhcRn] -- ^ The body statements
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt ctxt args need_join body_stmts
@@ -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 b1dc8877b5..f4962d55ef 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -604,7 +604,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
@@ -652,11 +652,13 @@ getLocalNonValBinders fixity_env
where
(_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
cdflds = case tau of
- L _ (HsFunTy
- (L _ (HsAppsTy
- [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds
- L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds
- _ -> []
+ L _ (HsFunTy _
+ (L _ (HsAppsTy _
+ [L _ (HsAppPrefix _ (L _ (HsRecTy _ flds)))]))
+ _) -> flds
+ L _ (HsFunTy _ (L _ (HsRecTy _ flds)) _)
+ -> flds
+ _ -> []
find_con_flds _ = []
find_con_name rdr
@@ -664,10 +666,11 @@ getLocalNonValBinders fixity_env
find (\ n -> nameOccName n == rdrNameOcc rdr) names
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])])
@@ -707,7 +710,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 2846754f11..7d31a87ad3 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 b182382381..0ca811424e 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -582,7 +582,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
@@ -1039,10 +1039,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
@@ -1078,7 +1079,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
{-
@@ -1092,7 +1093,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')
@@ -2079,7 +2080,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
@@ -2092,7 +2093,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)
@@ -2251,9 +2252,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 dd66cd3aec..2e1b12d8e0 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -156,24 +156,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 wc
- ; rnAnonWildCard wc }
+ do { checkExtraConstraintWildCard env
+ ; 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
@@ -181,17 +184,16 @@ rnWcBody ctxt nwc_rdrs hs_ty
rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
-checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs
- -> RnM ()
+checkExtraConstraintWildCard :: RnTyKiEnv -> 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 wc
+checkExtraConstraintWildCard env
= checkWildCard env mb_bad
where
mb_bad | not (extraConstraintWildCardsAllowed env)
- = Just (text "Extra-constraint wildcard" <+> quotes (ppr wc)
+ = Just (text "Extra-constraint wildcard" <+> quotes (pprAnonWildCard)
<+> text "not allowed")
| otherwise
= Nothing
@@ -507,43 +509,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
@@ -552,7 +555,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
@@ -560,58 +563,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
@@ -639,7 +642,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)
@@ -660,60 +663,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
@@ -760,21 +763,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") ]
@@ -810,8 +814,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
@@ -1057,20 +1061,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
@@ -1087,44 +1094,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{}) = []
{-
*********************************************************
@@ -1159,10 +1168,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"
{-
************************************************************************
@@ -1196,15 +1206,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)
@@ -1235,38 +1245,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
@@ -1276,7 +1286,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)
----------------------------
@@ -1296,16 +1306,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
@@ -1314,14 +1324,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
@@ -1330,25 +1341,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])
--------------------------------------
@@ -1426,8 +1436,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
@@ -1713,7 +1723,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
@@ -1768,43 +1778,43 @@ extract_lkind = extract_lty KindLevel
extract_lty :: TypeOrKind -> LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
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
@@ -1812,8 +1822,9 @@ extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
extract_app :: TypeOrKind -> LHsAppType GhcPs -> FreeKiTyVars
-> RnM FreeKiTyVars
-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"
extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVars
-> FreeKiTyVars -> RnM FreeKiTyVars
@@ -1853,7 +1864,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!
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index 6d656fefc3..9675fdda22 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -97,7 +97,7 @@ newMethodFromName origin name inst_ty
; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
instCall origin [inst_ty] theta
- ; return (mkHsWrap wrap (HsVar (noLoc id))) }
+ ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) }
{-
************************************************************************
@@ -530,7 +530,7 @@ newOverloadedLit :: HsOverLit GhcRn
-> ExpRhoType
-> TcM (HsOverLit GhcTcId)
newOverloadedLit
- lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty
+ lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty
| not rebindable
-- all built-in overloaded lits are tau-types, so we can just
-- tauify the ExpType
@@ -541,8 +541,8 @@ newOverloadedLit
-- Reason: If we do, tcSimplify will call lookupInst, which
-- will call tcSyntaxName, which does unification,
-- which tcSimplify doesn't like
- Just expr -> return (lit { ol_witness = expr, ol_type = res_ty
- , ol_rebindable = False })
+ Just expr -> return (lit { ol_witness = expr
+ , ol_ext = OverLitTc False res_ty })
Nothing -> newNonTrivialOverloadedLit orig lit
(mkCheckExpType res_ty) }
@@ -550,6 +550,7 @@ newOverloadedLit
= newNonTrivialOverloadedLit orig lit res_ty
where
orig = LiteralOrigin lit
+newOverloadedLit XOverLit{} _ = panic "newOverloadedLit"
-- Does not handle things that 'shortCutLit' can handle. See also
-- newOverloadedLit in TcUnify
@@ -558,8 +559,8 @@ newNonTrivialOverloadedLit :: CtOrigin
-> ExpRhoType
-> TcM (HsOverLit GhcTcId)
newNonTrivialOverloadedLit orig
- lit@(OverLit { ol_val = val, ol_witness = HsVar (L _ meth_name)
- , ol_rebindable = rebindable }) res_ty
+ lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)
+ , ol_ext = rebindable }) res_ty
= do { hs_lit <- mkOverLit val
; let lit_ty = hsLitType hs_lit
; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
@@ -568,13 +569,12 @@ newNonTrivialOverloadedLit orig
; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
; res_ty <- readExpType res_ty
; return (lit { ol_witness = witness
- , ol_type = res_ty
- , ol_rebindable = rebindable }) }
+ , ol_ext = OverLitTc rebindable res_ty }) }
newNonTrivialOverloadedLit _ lit _
= pprPanic "newNonTrivialOverloadedLit" (ppr lit)
------------
-mkOverLit ::(HasDefaultX p, SourceTextX p) => OverLitVal -> TcM (HsLit p)
+mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
mkOverLit (HsIntegral i)
= do { integer_ty <- tcMetaTy integerTyConName
; return (HsInteger (setSourceText $ il_text i)
@@ -582,7 +582,7 @@ mkOverLit (HsIntegral i)
mkOverLit (HsFractional r)
= do { rat_ty <- tcMetaTy rationalTyConName
- ; return (HsRat def r rat_ty) }
+ ; return (HsRat noExt r rat_ty) }
mkOverLit (HsIsString src s) = return (HsString (setSourceText src) s)
@@ -626,7 +626,7 @@ tcSyntaxName :: CtOrigin
-- USED ONLY FOR CmdTop (sigh) ***
-- See Note [CmdSyntaxTable] in HsExpr
-tcSyntaxName orig ty (std_nm, HsVar (L _ user_nm))
+tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
| std_nm == user_nm
= do rhs <- newMethodFromName orig std_nm ty
return (std_nm, rhs)
diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs
index edf696e3c9..3463750d7e 100644
--- a/compiler/typecheck/TcAnnotations.hs
+++ b/compiler/typecheck/TcAnnotations.hs
@@ -72,6 +72,7 @@ annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name
annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name
annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod
-annCtxt :: (SourceTextX p, OutputableBndrId p) => AnnDecl p -> SDoc
+annCtxt :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => AnnDecl (GhcPass p) -> SDoc
annCtxt ann
= hang (text "In the annotation:") 2 (ppr ann)
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs
index 96750f7260..318e4c683b 100644
--- a/compiler/typecheck/TcArrows.hs
+++ b/compiler/typecheck/TcArrows.hs
@@ -121,11 +121,13 @@ tcCmdTop :: CmdEnv
-> CmdType
-> TcM (LHsCmdTop GhcTcId)
-tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_ty@(cmd_stk, res_ty)
+tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty)
= setSrcSpan loc $
do { cmd' <- tcCmd env cmd cmd_ty
; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
- ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
+ ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') }
+tcCmdTop _ (L _ XCmdTop{}) _ = panic "tcCmdTop"
+
----------------------------------------
tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId)
-- The main recursive function
@@ -135,35 +137,35 @@ tcCmd env (L loc cmd) res_ty
; return (L loc cmd') }
tc_cmd :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTcId)
-tc_cmd env (HsCmdPar cmd) res_ty
+tc_cmd env (HsCmdPar x cmd) res_ty
= do { cmd' <- tcCmd env cmd res_ty
- ; return (HsCmdPar cmd') }
+ ; return (HsCmdPar x cmd') }
-tc_cmd env (HsCmdLet (L l binds) (L body_loc body)) res_ty
+tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty
= do { (binds', body') <- tcLocalBinds binds $
setSrcSpan body_loc $
tc_cmd env body res_ty
- ; return (HsCmdLet (L l binds') (L body_loc body')) }
+ ; return (HsCmdLet x (L l binds') (L body_loc body')) }
-tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty)
+tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
= addErrCtxt (cmdCtxt in_cmd) $ do
(scrut', scrut_ty) <- tcInferRho scrut
matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty)
- return (HsCmdCase scrut' matches')
+ return (HsCmdCase x scrut' matches')
where
match_ctxt = MC { mc_what = CaseAlt,
mc_body = mc_body }
mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
; tcCmd env body (stk, res_ty') }
-tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty -- Ordinary 'if'
+tc_cmd env (HsCmdIf x Nothing pred b1 b2) res_ty -- Ordinary 'if'
= do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
; b1' <- tcCmd env b1 res_ty
; b2' <- tcCmd env b2 res_ty
- ; return (HsCmdIf Nothing pred' b1' b2')
+ ; return (HsCmdIf x Nothing pred' b1' b2')
}
-tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
+tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
= do { pred_ty <- newOpenFlexiTyVarTy
-- For arrows, need ifThenElse :: forall r. T -> r -> r -> r
-- because we're going to apply it to the environment, not
@@ -179,7 +181,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
; b1' <- tcCmd env b1 res_ty
; b2' <- tcCmd env b2 res_ty
- ; return (HsCmdIf (Just fun') pred' b1' b2')
+ ; return (HsCmdIf x (Just fun') pred' b1' b2')
}
-------------------------------------------
@@ -198,7 +200,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
--
-- (plus -<< requires ArrowApply)
-tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
+tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty)
= addErrCtxt (cmdCtxt cmd) $
do { arg_ty <- newOpenFlexiTyVarTy
; let fun_ty = mkCmdArrTy env arg_ty res_ty
@@ -206,7 +208,7 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty)
- ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) }
+ ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) }
where
-- Before type-checking f, use the environment of the enclosing
-- proc for the (-<) case.
@@ -225,12 +227,12 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
-- -----------------------------
-- D;G |-a cmd exp : stk --> res
-tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
do { arg_ty <- newOpenFlexiTyVarTy
; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)
; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty)
- ; return (HsCmdApp fun' arg') }
+ ; return (HsCmdApp x fun' arg') }
-------------------------------------------
-- Lambda
@@ -240,9 +242,9 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
-- D;G |-a (\x.cmd) : (t,stk) --> res
tc_cmd env
- (HsCmdLam (MG { mg_alts = L l [L mtch_loc
+ (HsCmdLam x (MG { mg_alts = L l [L mtch_loc
(match@(Match { m_pats = pats, m_grhss = grhss }))],
- mg_origin = origin }))
+ mg_origin = origin }))
(cmd_stk, res_ty)
= addErrCtxt (pprMatchInCtxt match) $
do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
@@ -255,8 +257,9 @@ tc_cmd env
; let match' = L mtch_loc (Match { m_ctxt = LambdaExpr, m_pats = pats'
, m_grhss = grhss' })
arg_tys = map hsLPatType pats'
- cmd' = HsCmdLam (MG { mg_alts = L l [match'], mg_arg_tys = arg_tys
- , mg_res_ty = res_ty, mg_origin = origin })
+ cmd' = HsCmdLam x (MG { mg_alts = L l [match']
+ , mg_arg_tys = arg_tys
+ , mg_res_ty = res_ty, mg_origin = origin })
; return (mkHsCmdWrap (mkWpCastN co) cmd') }
where
n_pats = length pats
@@ -277,10 +280,10 @@ tc_cmd env
-------------------------------------------
-- Do notation
-tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty)
+tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty)
= do { co <- unifyType Nothing unitTy cmd_stk -- Expecting empty argument stack
; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty
- ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo (L l stmts') res_ty)) }
+ ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) }
-----------------------------------------------------------------
@@ -297,7 +300,7 @@ tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty)
-- ----------------------------------------------
-- D; G |-a (| e c1 ... cn |) : stk --> t
-tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args
-- We use alphaTyVar for 'w'
@@ -305,7 +308,7 @@ tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty)
mkFunTys cmd_tys $
mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty
; expr' <- tcPolyExpr expr e_ty
- ; return (HsCmdArrForm expr' f fixity cmd_args') }
+ ; return (HsCmdArrForm x expr' f fixity cmd_args') }
where
tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType)
@@ -317,6 +320,8 @@ tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty)
; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty)
; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }
+tc_cmd _ (XCmd {}) _ = panic "tc_cmd"
+
-----------------------------------------------------------------
-- Base case for illegal commands
-- This is where expressions that aren't commands get rejected
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 6a9b22a9bb..515eb4df35 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -308,13 +308,13 @@ tcCompleteSigs sigs =
in mapMaybeM (addLocM doOne) sigs
tcRecSelBinds :: HsValBinds GhcRn -> TcM TcGblEnv
-tcRecSelBinds (ValBindsOut binds sigs)
+tcRecSelBinds (XValBindsLR (NValBinds binds sigs))
= tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
do { (rec_sel_binds, tcg_env) <- discardWarnings $
tcValBinds TopLevel binds sigs getGblEnv
; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds
; return tcg_env' }
-tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
+tcRecSelBinds (ValBinds {}) = panic "tcRecSelBinds"
tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
-- A hs-boot file has only one BindGroup, and it only has type
@@ -342,10 +342,10 @@ tcLocalBinds EmptyLocalBinds thing_inside
= do { thing <- thing_inside
; return (EmptyLocalBinds, thing) }
-tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
+tcLocalBinds (HsValBinds (XValBindsLR (NValBinds binds sigs))) thing_inside
= do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
- ; return (HsValBinds (ValBindsOut binds' sigs), thing) }
-tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
+ ; return (HsValBinds (XValBindsLR (NValBinds binds' sigs)), thing) }
+tcLocalBinds (HsValBinds (ValBinds {})) _ = panic "tcLocalBinds"
tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
= do { ipClass <- tcLookupClass ipClassName
@@ -1178,9 +1178,9 @@ tcVect :: VectDecl GhcRn -> TcM (VectDecl GhcTcId)
tcVect (HsVect s name rhs)
= addErrCtxt (vectCtxt name) $
do { var <- wrapLocM tcLookupId name
- ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs
+ ; let L rhs_loc (HsVar noExt (L lv rhs_var_name)) = rhs
; rhs_id <- tcLookupId rhs_var_name
- ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id)))
+ ; return $ HsVect s var (L rhs_loc (HsVar noExt (L lv rhs_id)))
}
tcVect (HsNoVect s name)
@@ -1742,7 +1742,8 @@ isClosedBndrGroup type_env binds
-- This one is called on LHS, when pat and grhss are both Name
-- and on RHS, when pat is TcId and grhss is still Name
-patMonoBindsCtxt :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => LPat p -> GRHSs GhcRn body -> SDoc
+patMonoBindsCtxt :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p),
+ Outputable body)
+ => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc
patMonoBindsCtxt pat grhss
= hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 33ce5810ca..3012801856 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -336,7 +336,7 @@ renameDeriv is_boot inst_infos bagBinds
-- before renaming the instances themselves
; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
- ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
+ ; let aux_val_binds = ValBinds noExt aux_binds (bagToList aux_sigs)
; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
; let bndrs = collectHsValBinders rn_aux_lhs
; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 21b895eea3..8d11fed65c 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -884,10 +884,12 @@ data InstBindings a
-- Used only to improve error messages
}
-instance (SourceTextX a, OutputableBndrId a) => Outputable (InstInfo a) where
+instance (SourceTextX (GhcPass a), OutputableBndrId (GhcPass a))
+ => Outputable (InstInfo (GhcPass a)) where
ppr = pprInstInfoDetails
-pprInstInfoDetails :: (SourceTextX a, OutputableBndrId a) => InstInfo a -> SDoc
+pprInstInfoDetails :: (SourceTextX (GhcPass a), OutputableBndrId (GhcPass a))
+ => InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails info
= hang (pprInstanceHdr (iSpec info) <+> text "where")
2 (details (iBinds info))
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 4eb5dd1562..a9d8b64515 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -167,43 +167,43 @@ NB: The res_ty is always deeply skolemised.
-}
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
-tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
-tcExpr e@(HsUnboundVar uv) res_ty = tcUnboundId e uv res_ty
+tcExpr (HsVar _ (L _ name)) res_ty = tcCheckId name res_ty
+tcExpr e@(HsUnboundVar _ uv) res_ty = tcUnboundId e uv res_ty
tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty
tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty
-tcExpr e@(HsLit lit) res_ty
+tcExpr e@(HsLit x lit) res_ty
= do { let lit_ty = hsLitType lit
- ; tcWrapResult e (HsLit (convertLit lit)) lit_ty res_ty }
+ ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty }
-tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
- ; return (HsPar expr') }
+tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
+ ; return (HsPar x expr') }
-tcExpr (HsSCC src lbl expr) res_ty
+tcExpr (HsSCC x src lbl expr) res_ty
= do { expr' <- tcMonoExpr expr res_ty
- ; return (HsSCC src lbl expr') }
+ ; return (HsSCC x src lbl expr') }
-tcExpr (HsTickPragma src info srcInfo expr) res_ty
+tcExpr (HsTickPragma x src info srcInfo expr) res_ty
= do { expr' <- tcMonoExpr expr res_ty
- ; return (HsTickPragma src info srcInfo expr') }
+ ; return (HsTickPragma x src info srcInfo expr') }
-tcExpr (HsCoreAnn src lbl expr) res_ty
+tcExpr (HsCoreAnn x src lbl expr) res_ty
= do { expr' <- tcMonoExpr expr res_ty
- ; return (HsCoreAnn src lbl expr') }
+ ; return (HsCoreAnn x src lbl expr') }
-tcExpr (HsOverLit lit) res_ty
+tcExpr (HsOverLit x lit) res_ty
= do { lit' <- newOverloadedLit lit res_ty
- ; return (HsOverLit lit') }
+ ; return (HsOverLit x lit') }
-tcExpr (NegApp expr neg_expr) res_ty
+tcExpr (NegApp x expr neg_expr) res_ty
= do { (expr', neg_expr')
<- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
\[arg_ty] ->
tcMonoExpr expr (mkCheckExpType arg_ty)
- ; return (NegApp expr' neg_expr') }
+ ; return (NegApp x expr' neg_expr') }
-tcExpr e@(HsIPVar x) res_ty
+tcExpr e@(HsIPVar _ x) res_ty
= do { {- Implicit parameters must have a *tau-type* not a
type scheme. We enforce this by creating a fresh
type variable as its type. (Because res_ty may not
@@ -212,15 +212,16 @@ tcExpr e@(HsIPVar x) res_ty
; let ip_name = mkStrLitTy (hsIPNameFS x)
; ipClass <- tcLookupClass ipClassName
; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
- ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var)))
- ip_ty res_ty }
+ ; tcWrapResult e
+ (fromDict ipClass ip_name ip_ty (HsVar noExt (noLoc ip_var)))
+ ip_ty res_ty }
where
-- Coerces a dictionary for `IP "x" t` into `t`.
fromDict ipClass x ty = mkHsWrap $ mkWpCastR $
unwrapIP $ mkClassPred ipClass [x,ty]
origin = IPOccOrigin x
-tcExpr e@(HsOverLabel mb_fromLabel l) res_ty
+tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty
= do { -- See Note [Type-checking overloaded labels]
loc <- getSrcSpanM
; case mb_fromLabel of
@@ -230,7 +231,8 @@ tcExpr e@(HsOverLabel mb_fromLabel l) res_ty
; let pred = mkClassPred isLabelClass [lbl, alpha]
; loc <- getSrcSpanM
; var <- emitWantedEvVar origin pred
- ; tcWrapResult e (fromDict pred (HsVar (L loc var)))
+ ; tcWrapResult e
+ (fromDict pred (HsVar noExt (L loc var)))
alpha res_ty } }
where
-- Coerces a dictionary for `IsLabel "x" t` into `t`,
@@ -240,12 +242,13 @@ tcExpr e@(HsOverLabel mb_fromLabel l) res_ty
lbl = mkStrLitTy l
applyFromLabel loc fromLabel =
- L loc (HsVar (L loc fromLabel)) `HsAppType`
- mkEmptyWildCardBndrs (L loc (HsTyLit (HsStrTy NoSourceText l)))
+ HsAppType
+ (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l))))
+ (L loc (HsVar noExt (L loc fromLabel)))
-tcExpr (HsLam match) res_ty
+tcExpr (HsLam x match) res_ty
= do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
- ; return (mkHsWrap wrap (HsLam match')) }
+ ; return (mkHsWrap wrap (HsLam x match')) }
where
match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
herald = sep [ text "The lambda expression" <+>
@@ -254,23 +257,23 @@ tcExpr (HsLam match) res_ty
-- The pprSetDepth makes the abstraction print briefly
text "has"]
-tcExpr e@(HsLamCase matches) res_ty
+tcExpr e@(HsLamCase x matches) res_ty
= do { (matches', wrap)
<- tcMatchLambda msg match_ctxt matches res_ty
-- The laziness annotation is because we don't want to fail here
-- if there are multiple arguments
- ; return (mkHsWrap wrap $ HsLamCase matches') }
+ ; return (mkHsWrap wrap $ HsLamCase x matches') }
where
msg = sep [ text "The function" <+> quotes (ppr e)
, text "requires"]
match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
-tcExpr e@(ExprWithTySig expr sig_ty) res_ty
+tcExpr e@(ExprWithTySig sig_ty expr) res_ty
= do { let loc = getLoc (hsSigWcType sig_ty)
; sig_info <- checkNoErrs $ -- Avoid error cascade
tcUserTypeSig loc sig_ty Nothing
; (expr', poly_ty) <- tcExprSig expr sig_info
- ; let expr'' = ExprWithTySigOut expr' sig_ty
+ ; let expr'' = ExprWithTySig sig_ty expr'
; tcWrapResult e expr'' poly_ty res_ty }
{-
@@ -349,8 +352,8 @@ construct.
See also Note [seqId magic] in MkId
-}
-tcExpr expr@(OpApp arg1 op fix arg2) res_ty
- | (L loc (HsVar (L lv op_name))) <- op
+tcExpr expr@(OpApp fix arg1 op arg2) res_ty
+ | (L loc (HsVar _ (L lv op_name))) <- op
, op_name `hasKey` seqIdKey -- Note [Typing rule for seq]
= do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
; let arg2_exp_ty = res_ty
@@ -360,10 +363,10 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
; arg2_ty <- readExpType arg2_exp_ty
; op_id <- tcLookupId op_name
; let op' = L loc (mkHsWrap (mkWpTyApps [arg1_ty, arg2_ty])
- (HsVar (L lv op_id)))
- ; return $ OpApp arg1' op' fix arg2' }
+ (HsVar noExt (L lv op_id)))
+ ; return $ OpApp fix arg1' op' arg2' }
- | (L loc (HsVar (L lv op_name))) <- op
+ | (L loc (HsVar _ (L lv op_name))) <- op
, op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)]
= do { traceTc "Application rule" (ppr op)
; (arg1', arg1_ty) <- tcInferSigma arg1
@@ -386,7 +389,8 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
--
-- The *result* type can have any kind (Trac #8739),
-- so we don't need to check anything for that
- ; _ <- unifyKind (Just (HsCoreTy arg2_sigma)) (typeKind arg2_sigma) liftedTypeKind
+ ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma))
+ (typeKind arg2_sigma) liftedTypeKind
-- ignore the evidence. arg2_sigma must have type * or #,
-- because we know arg2_sigma -> or_res_ty is well-kinded
-- (because otherwise matchActualFunTys would fail)
@@ -400,7 +404,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep res_ty
, arg2_sigma
, res_ty])
- (HsVar (L lv op_id)))
+ (HsVar noExt (L lv op_id)))
-- arg1' :: arg1_ty
-- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)
-- wrap_res :: op_res_ty "->" res_ty
@@ -411,15 +415,15 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
<.> wrap_arg1
doc = text "When looking at the argument to ($)"
- ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') }
+ ; return (OpApp fix (mkLHsWrap wrap1 arg1') op' arg2') }
- | (L loc (HsRecFld (Ambiguous lbl _))) <- op
+ | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op
, Just sig_ty <- obviousSig (unLoc arg1)
-- See Note [Disambiguating record fields]
= do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
; sel_name <- disambiguateSelector lbl sig_tc_ty
- ; let op' = L loc (HsRecFld (Unambiguous lbl sel_name))
- ; tcExpr (OpApp arg1 op' fix arg2) res_ty
+ ; let op' = L loc (HsRecFld noExt (Unambiguous sel_name lbl))
+ ; tcExpr (OpApp fix arg1 op' arg2) res_ty
}
| otherwise
@@ -427,12 +431,12 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
; (wrap, op', [HsValArg arg1', HsValArg arg2'])
<- tcApp (Just $ mk_op_msg op)
op [HsValArg arg1, HsValArg arg2] res_ty
- ; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') }
+ ; return (mkHsWrap wrap $ OpApp fix arg1' op' arg2') }
-- Right sections, equivalent to \ x -> x `op` expr, or
-- \ x -> op x expr
-tcExpr expr@(SectionR op arg2) res_ty
+tcExpr expr@(SectionR x op arg2) res_ty
= do { (op', op_ty) <- tcInferFun op
; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)
<- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty
@@ -440,14 +444,14 @@ tcExpr expr@(SectionR op arg2) res_ty
(mkFunTy arg1_ty op_res_ty) res_ty
; arg2' <- tcArg op arg2 arg2_ty 2
; return ( mkHsWrap wrap_res $
- SectionR (mkLHsWrap wrap_fun op') arg2' ) }
+ SectionR x (mkLHsWrap wrap_fun op') arg2' ) }
where
fn_orig = lexprCtOrigin op
-- It's important to use the origin of 'op', so that call-stacks
-- come out right; they are driven by the OccurrenceOf CtOrigin
-- See Trac #13285
-tcExpr expr@(SectionL arg1 op) res_ty
+tcExpr expr@(SectionL x arg1 op) res_ty
= do { (op', op_ty) <- tcInferFun op
; dflags <- getDynFlags -- Note [Left sections]
; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1
@@ -460,14 +464,14 @@ tcExpr expr@(SectionL arg1 op) res_ty
(mkFunTys arg_tys op_res_ty) res_ty
; arg1' <- tcArg op arg1 arg1_ty 1
; return ( mkHsWrap wrap_res $
- SectionL arg1' (mkLHsWrap wrap_fn op') ) }
+ SectionL x arg1' (mkLHsWrap wrap_fn op') ) }
where
fn_orig = lexprCtOrigin op
-- It's important to use the origin of 'op', so that call-stacks
-- come out right; they are driven by the OccurrenceOf CtOrigin
-- See Trac #13285
-tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
+tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty
| all tupArgPresent tup_args
= do { let arity = length tup_args
tup_tc = tupleTyCon boxity arity
@@ -479,7 +483,7 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys
Boxed -> arg_tys
; tup_args1 <- tcTupArgs tup_args arg_tys'
- ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
+ ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) }
| otherwise
= -- The tup_args are a mixture of Present and Missing (for tuple sections)
@@ -499,16 +503,16 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
-- Handle tuple sections where
; tup_args1 <- tcTupArgs tup_args arg_tys
- ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) }
+ ; return $ mkHsWrap wrap (ExplicitTuple x tup_args1 boxity) }
-tcExpr (ExplicitSum alt arity expr _) res_ty
+tcExpr (ExplicitSum _ alt arity expr) res_ty
= do { let sum_tc = sumTyCon arity
; res_ty <- expTypeToType res_ty
; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty
; -- Drop levity vars, we don't care about them here
let arg_tys' = drop arity arg_tys
; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1))
- ; return $ mkHsWrapCo coi (ExplicitSum alt arity expr' arg_tys') }
+ ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }
tcExpr (ExplicitList _ witness exprs) res_ty
= case witness of
@@ -546,12 +550,12 @@ tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty
************************************************************************
-}
-tcExpr (HsLet (L l binds) expr) res_ty
+tcExpr (HsLet x (L l binds) expr) res_ty
= do { (binds', expr') <- tcLocalBinds binds $
tcMonoExpr expr res_ty
- ; return (HsLet (L l binds') expr') }
+ ; return (HsLet x (L l binds') expr') }
-tcExpr (HsCase scrut matches) res_ty
+tcExpr (HsCase x scrut matches) res_ty
= do { -- We used to typecheck the case alternatives first.
-- The case patterns tend to give good type info to use
-- when typechecking the scrutinee. For example
@@ -565,12 +569,12 @@ tcExpr (HsCase scrut matches) res_ty
; traceTc "HsCase" (ppr scrut_ty)
; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
- ; return (HsCase scrut' matches') }
+ ; return (HsCase x scrut' matches') }
where
match_ctxt = MC { mc_what = CaseAlt,
mc_body = tcBody }
-tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if'
+tcExpr (HsIf x Nothing pred b1 b2) res_ty -- Ordinary 'if'
= do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
; res_ty <- tauifyExpType res_ty
-- Just like Note [Case branches must never infer a non-tau type]
@@ -578,9 +582,9 @@ tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if'
; b1' <- tcMonoExpr b1 res_ty
; b2' <- tcMonoExpr b2 res_ty
- ; return (HsIf Nothing pred' b1' b2') }
+ ; return (HsIf x Nothing pred' b1' b2') }
-tcExpr (HsIf (Just fun) pred b1 b2) res_ty
+tcExpr (HsIf x (Just fun) pred b1 b2) res_ty
= do { ((pred', b1', b2'), fun')
<- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $
\ [pred_ty, b1_ty, b2_ty] ->
@@ -588,7 +592,7 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty
; b1' <- tcPolyExpr b1 b1_ty
; b2' <- tcPolyExpr b2 b2_ty
; return (pred', b1', b2') }
- ; return (HsIf (Just fun') pred' b1' b2') }
+ ; return (HsIf x (Just fun') pred' b1' b2') }
tcExpr (HsMultiIf _ alts) res_ty
= do { res_ty <- if isSingleton alts
@@ -602,13 +606,13 @@ tcExpr (HsMultiIf _ alts) res_ty
; return (HsMultiIf res_ty alts') }
where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
-tcExpr (HsDo do_or_lc stmts _) res_ty
+tcExpr (HsDo _ do_or_lc stmts) res_ty
= do { expr' <- tcDoStmts do_or_lc stmts res_ty
; return expr' }
-tcExpr (HsProc pat cmd) res_ty
+tcExpr (HsProc x pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty
- ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
+ ; return $ mkHsWrapCo coi (HsProc x pat' cmd') }
-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
-- See Note [Grand plan for static forms] in StaticPtrTable for an overview.
@@ -649,7 +653,8 @@ tcExpr (HsStatic fvs expr) res_ty
; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty
; let wrap = mkWpTyApps [expr_ty]
; loc <- getSrcSpanM
- ; return $ mkHsWrapCo co $ HsApp (L loc $ mkHsWrap wrap fromStaticPtr)
+ ; return $ mkHsWrapCo co $ HsApp noExt
+ (L loc $ mkHsWrap wrap fromStaticPtr)
(L loc (HsStatic fvs expr'))
}
@@ -683,9 +688,10 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name
; rbinds' <- tcRecordBinds con_like arg_tys rbinds
; return $
mkHsWrap res_wrap $
- RecordCon { rcon_con_name = L loc con_id
- , rcon_con_expr = mkHsWrap con_wrap con_expr
- , rcon_con_like = con_like
+ RecordCon { rcon_ext = RecordConTc
+ { rcon_con_like = con_like
+ , rcon_con_expr = mkHsWrap con_wrap con_expr }
+ , rcon_con_name = L loc con_id
, rcon_flds = rbinds' } } }
{-
@@ -970,12 +976,16 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
-- Phew!
; return $
mkHsWrap wrap_res $
- RecordUpd { rupd_expr = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr')
+ RecordUpd { rupd_expr
+ = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr')
, rupd_flds = rbinds'
- , rupd_cons = relevant_cons, rupd_in_tys = scrut_inst_tys
- , rupd_out_tys = result_inst_tys, rupd_wrap = req_wrap } }
+ , rupd_ext = RecordUpdTc
+ { rupd_cons = relevant_cons
+ , rupd_in_tys = scrut_inst_tys
+ , rupd_out_tys = result_inst_tys
+ , rupd_wrap = req_wrap }} }
-tcExpr e@(HsRecFld f) res_ty
+tcExpr e@(HsRecFld _ f) res_ty
= tcCheckRecSelId e f res_ty
{-
@@ -1012,10 +1022,9 @@ tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
; eft <- newMethodFromName (PArrSeqOrigin seq)
(idName enumFromThenToP) elt_ty -- !!!FIXME: chak
; return $
- mkHsWrapCo coi $
- PArrSeq eft (FromThenTo expr1' expr2' expr3') }
+ mkHsWrapCo coi $ PArrSeq eft (FromThenTo expr1' expr2' expr3') }
-tcExpr (PArrSeq _ _) _
+tcExpr (PArrSeq {}) _
= panic "TcExpr.tcExpr: Infinite parallel array!"
-- the parser shouldn't have generated it and the renamer shouldn't have
-- let it through
@@ -1032,15 +1041,15 @@ tcExpr (PArrSeq _ _) _
-- Here we get rid of it and add the finalizers to the global environment.
--
-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
-tcExpr (HsSpliceE (HsSpliced mod_finalizers (HsSplicedExpr expr)))
+tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))
res_ty
= do addModFinalizersWithLclEnv mod_finalizers
tcExpr expr res_ty
-tcExpr (HsSpliceE splice) res_ty
+tcExpr (HsSpliceE _ splice) res_ty
= tcSpliceExpr splice res_ty
-tcExpr e@(HsBracket brack) res_ty
+tcExpr e@(HsBracket _ brack) res_ty
= tcTypedBracket e brack res_ty
-tcExpr e@(HsRnBracketOut brack ps) res_ty
+tcExpr e@(HsRnBracketOut _ brack ps) res_ty
= tcUntypedBracket e brack ps res_ty
{-
@@ -1157,11 +1166,11 @@ tcApp m_herald orig_fun orig_args res_ty
where
go :: LHsExpr GhcRn -> [LHsExprArgIn]
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
- go (L _ (HsPar e)) args = go e args
- go (L _ (HsApp e1 e2)) args = go e1 (HsValArg e2:args)
- go (L _ (HsAppType e t)) args = go e (HsTypeArg t:args)
+ go (L _ (HsPar _ e)) args = go e args
+ go (L _ (HsApp _ e1 e2)) args = go e1 (HsValArg e2:args)
+ go (L _ (HsAppType t e)) args = go e (HsTypeArg t:args)
- go (L loc (HsVar (L _ fun))) args
+ go (L loc (HsVar _ (L _ fun))) args
| fun `hasKey` tagToEnumKey
, count isHsValArg args == 1
= do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty
@@ -1172,11 +1181,11 @@ tcApp m_herald orig_fun orig_args res_ty
= do { (wrap, expr, args) <- tcSeq loc fun args res_ty
; return (wrap, expr, args) }
- go (L loc (HsRecFld (Ambiguous lbl _))) args@(HsValArg (L _ arg) : _)
+ go (L loc (HsRecFld _ (Ambiguous _ lbl))) args@(HsValArg (L _ arg) : _)
| Just sig_ty <- obviousSig arg
= do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
; sel_name <- disambiguateSelector lbl sig_tc_ty
- ; go (L loc (HsRecFld (Unambiguous lbl sel_name))) args }
+ ; go (L loc (HsRecFld noExt (Unambiguous sel_name lbl))) args }
-- See Note [Visible type application for the empty list constructor]
go (L loc (ExplicitList _ Nothing [])) [HsTypeArg ty_arg]
@@ -1246,12 +1255,12 @@ which is better than before.
----------------
tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
-- Infer type of a function
-tcInferFun (L loc (HsVar (L _ name)))
+tcInferFun (L loc (HsVar _ (L _ name)))
= do { (fun, ty) <- setSrcSpan loc (tcInferId name)
-- Don't wrap a context around a plain Id
; return (L loc fun, ty) }
-tcInferFun (L loc (HsRecFld f))
+tcInferFun (L loc (HsRecFld _ f))
= do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)
-- Don't wrap a context around a plain Id
; return (L loc fun, ty) }
@@ -1383,8 +1392,9 @@ tcTupArgs args tys
= ASSERT( equalLength args tys ) mapM go (args `zip` tys)
where
go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty))
- go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
- ; return (L l (Present expr')) }
+ go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+ ; return (L l (Present x expr')) }
+ go (L _ (XTupArg{}), _) = panic "tcTupArgs"
---------------------------
-- See TcType.SyntaxOpType also for commentary
@@ -1407,7 +1417,7 @@ tcSyntaxOpGen :: CtOrigin
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
-tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) })
+tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar _ (L _ op) })
arg_tys res_ty thing_inside
= do { (expr, sigma) <- tcInferId op
; (result, expr_wrap, arg_wraps, res_wrap)
@@ -1680,27 +1690,31 @@ tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcCheckId name res_ty
= do { (expr, actual_res_ty) <- tcInferId name
; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
- ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $
- tcWrapResultO (OccurrenceOf name) (HsVar (noLoc name)) expr actual_res_ty res_ty }
+ ; addFunResCtxt False (HsVar noExt (noLoc name)) actual_res_ty res_ty $
+ tcWrapResultO (OccurrenceOf name) (HsVar noExt (noLoc name)) expr
+ actual_res_ty res_ty }
tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
-tcCheckRecSelId rn_expr f@(Unambiguous (L _ lbl) _) res_ty
+tcCheckRecSelId rn_expr f@(Unambiguous _ (L _ lbl)) res_ty
= do { (expr, actual_res_ty) <- tcInferRecSelId f
- ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $
+ ; addFunResCtxt False (HsRecFld noExt f) actual_res_ty res_ty $
tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty }
-tcCheckRecSelId rn_expr (Ambiguous lbl _) res_ty
+tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty
= case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of
Nothing -> ambiguousSelector lbl
Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
- ; tcCheckRecSelId rn_expr (Unambiguous lbl sel_name) res_ty }
+ ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl)
+ res_ty }
+tcCheckRecSelId _ (XAmbiguousFieldOcc _) _ = panic "tcCheckRecSelId"
------------------------
tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType)
-tcInferRecSelId (Unambiguous (L _ lbl) sel)
+tcInferRecSelId (Unambiguous sel (L _ lbl))
= do { (expr', ty) <- tc_infer_id lbl sel
; return (expr', ty) }
-tcInferRecSelId (Ambiguous lbl _)
+tcInferRecSelId (Ambiguous _ lbl)
= ambiguousSelector lbl
+tcInferRecSelId (XAmbiguousFieldOcc _) = panic "tcInferRecSelId"
------------------------
tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
@@ -1729,7 +1743,7 @@ tc_infer_assert assert_name
= do { assert_error_id <- tcLookupId assertErrorName
; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
(idType assert_error_id)
- ; return (mkHsWrap wrap (HsVar (noLoc assert_error_id)), id_rho)
+ ; return (mkHsWrap wrap (HsVar noExt (noLoc assert_error_id)), id_rho)
}
tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)
@@ -1755,12 +1769,12 @@ tc_infer_id lbl id_name
_ -> failWithTc $
ppr thing <+> text "used where a value identifier was expected" }
where
- return_id id = return (HsVar (noLoc id), idType id)
+ return_id id = return (HsVar noExt (noLoc id), idType id)
return_data_con con
-- For data constructors, must perform the stupid-theta check
| null stupid_theta
- = return (HsConLikeOut (RealDataCon con), con_ty)
+ = return (HsConLikeOut noExt (RealDataCon con), con_ty)
| otherwise
-- See Note [Instantiating stupid theta]
@@ -1771,7 +1785,8 @@ tc_infer_id lbl id_name
rho' = substTy subst rho
; wrap <- instCall (OccurrenceOf id_name) tys' theta'
; addDataConStupidTheta con tys'
- ; return (mkHsWrap wrap (HsConLikeOut (RealDataCon con)), rho') }
+ ; return ( mkHsWrap wrap (HsConLikeOut noExt (RealDataCon con))
+ , rho') }
where
con_ty = dataConUserType con
@@ -1803,7 +1818,8 @@ tcUnboundId rn_expr unbound res_ty
, ctev_loc = loc}
, cc_hole = ExprHole unbound }
; emitInsoluble can
- ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar (noLoc ev)) ty res_ty }
+ ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExt (noLoc ev))
+ ty res_ty }
{-
@@ -1885,7 +1901,7 @@ tcSeq loc fun_name args res_ty
; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty)
; arg2' <- tcMonoExpr arg2 arg2_exp_ty
; res_ty <- readExpType res_ty -- by now, it's surely filled in
- ; let fun' = L loc (mkHsWrap ty_args (HsVar (L loc fun)))
+ ; let fun' = L loc (mkHsWrap ty_args (HsVar noExt (L loc fun)))
ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
; return (idHsWrapper, fun', [HsValArg arg1', HsValArg arg2']) }
@@ -1927,7 +1943,7 @@ tcTagToEnum loc fun_name args res_ty
(mk_error ty' doc2)
; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)
- ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar (L loc fun)))
+ ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExt (L loc fun)))
rep_ty = mkTyConApp rep_tc rep_args
; return (mkWpCastR (mkTcSymCo coi), fun', [HsValArg arg']) }
@@ -2005,7 +2021,7 @@ checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))
; lift <- if isStringTy id_ty then
do { sid <- tcLookupId THNames.liftStringName
-- See Note [Lifting strings]
- ; return (HsVar (noLoc sid)) }
+ ; return (HsVar noExt (noLoc sid)) }
else
setConstraintVar lie_var $
-- Put the 'lift' constraint into the right LIE
@@ -2215,8 +2231,9 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
-- Extract the selector name of a field update if it is unambiguous
isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)
isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of
- Unambiguous _ sel_name -> Just (x, sel_name)
+ Unambiguous sel_name _ -> Just (x, sel_name)
Ambiguous{} -> Nothing
+ XAmbiguousFieldOcc{} -> Nothing
-- Look up the possible parents and selector GREs for each field
getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
@@ -2284,7 +2301,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
; let L loc af = hsRecFieldLbl upd
lbl = rdrNameAmbiguousFieldOcc af
; return $ L l upd { hsRecFieldLbl
- = L loc (Unambiguous (L loc lbl) i) } }
+ = L loc (Unambiguous i (L loc lbl)) } }
-- Extract the outermost TyCon of a type, if there is one; for
@@ -2320,8 +2337,8 @@ lookupParents rdr
-- the record expression in an update must be "obvious", i.e. the
-- outermost constructor ignoring parentheses.
obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
-obviousSig (ExprWithTySig _ ty) = Just ty
-obviousSig (HsPar p) = obviousSig (unLoc p)
+obviousSig (ExprWithTySig ty _) = Just ty
+obviousSig (HsPar _ p) = obviousSig (unLoc p)
obviousSig _ = Nothing
@@ -2384,21 +2401,22 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
, hsRecFieldArg = rhs }))
= do { let lbl = rdrNameAmbiguousFieldOcc af
sel_id = selectorAmbiguousFieldOcc af
- f = L loc (FieldOcc (L loc lbl) (idName sel_id))
+ f = L loc (FieldOcc (idName sel_id) (L loc lbl))
; mb <- tcRecordField con_like flds_w_tys f rhs
; case mb of
Nothing -> return Nothing
Just (f', rhs') ->
return (Just
(L l (fld { hsRecFieldLbl
- = L loc (Unambiguous (L loc lbl)
- (selectorFieldOcc (unLoc f')))
+ = L loc (Unambiguous
+ (extFieldOcc (unLoc f'))
+ (L loc lbl))
, hsRecFieldArg = rhs' }))) }
tcRecordField :: ConLike -> Assoc Name Type
-> LFieldOcc GhcRn -> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs
+tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
| Just field_ty <- assocMaybe flds_w_tys sel_name
= addErrCtxt (fieldCtxt field_lbl) $
do { rhs' <- tcPolyExprNC rhs field_ty
@@ -2409,12 +2427,13 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs
-- (so we can find it easily)
-- but is a LocalId with the appropriate type of the RHS
-- (so the desugarer knows the type of local binder to make)
- ; return (Just (L loc (FieldOcc lbl field_id), rhs')) }
+ ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }
| otherwise
= do { addErrTc (badFieldCon con_like field_lbl)
; return Nothing }
where
field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
+tcRecordField _ _ (L _ (XFieldOcc _)) _ = panic "tcRecordField"
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM ()
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index d9166e5e00..9140de69f7 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -447,7 +447,7 @@ gen_Ord_binds loc tycon = do
, mkHsCaseAlt nlWildPat (gtResult op) ]
where
tag = get_tag data_con
- tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag)))
+ tag_lit = noLoc (HsLit noExt (HsIntPrim NoSourceText (toInteger tag)))
mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
-- First argument 'a' known to be built with K
@@ -614,7 +614,8 @@ gen_Enum_binds loc tycon = do
(nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
(nlHsApps plus_RDR
[ nlHsVarApps intDataCon_RDR [ah_RDR]
- , nlHsLit (HsInt def (mkIntegralLit (-1 :: Int)))]))
+ , nlHsLit (HsInt noExt
+ (mkIntegralLit (-1 :: Int)))]))
to_enum dflags
= mk_easy_FunBind loc toEnum_RDR [a_Pat] $
@@ -774,7 +775,7 @@ gen_Ix_binds loc tycon = do
enum_index dflags
= mk_easy_FunBind loc unsafeIndex_RDR
- [noLoc (AsPat (noLoc c_RDR)
+ [noLoc (AsPat noExt (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
d_Pat] (
untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
@@ -1142,7 +1143,7 @@ gen_Show_binds get_fixity loc tycon
| otherwise =
([a_Pat, con_pat],
showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit
- (HsInt def (mkIntegralLit con_prec_plus_one))))
+ (HsInt noExt (mkIntegralLit con_prec_plus_one))))
(nlHsPar (nested_compose_Expr show_thingies)))
where
data_con_RDR = getRdrName data_con
@@ -1226,7 +1227,7 @@ mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString st
-- | showsPrec :: Show a => Int -> a -> ShowS
mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
mk_showsPrec_app p x
- = nlHsApps showsPrec_RDR [nlHsLit (HsInt def (mkIntegralLit p)), x]
+ = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExt (mkIntegralLit p)), x]
-- | shows :: Show a => a -> ShowS
mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
@@ -1699,12 +1700,12 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
pp_lhs = ppr (mkTyConApp fam_tc rep_lhs_tys)
nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
-nlHsAppType e s = noLoc (e `HsAppType` hs_ty)
+nlHsAppType e s = noLoc (HsAppType hs_ty e)
where
hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s)
nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
-nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty)
+nlExprWithTySig e s = noLoc (ExprWithTySig hs_ty e)
where
hs_ty = mkLHsSigWcType (typeToLHsType s)
@@ -1758,7 +1759,7 @@ genAuxBindSpec dflags loc (DerivCon2Tag tycon)
where
rdr_name = con2tag_RDR dflags tycon
- sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
+ sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $
mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
mkParentType tycon `mkFunTy` intPrimTy
@@ -1783,7 +1784,7 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon)
L loc (TypeSig [L loc rdr_name] sig_ty))
where
sig_ty = mkLHsSigWcType $ L loc $
- HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
+ XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
intTy `mkFunTy` mkParentType tycon
rdr_name = tag2con_RDR dflags tycon
@@ -1793,7 +1794,7 @@ genAuxBindSpec dflags loc (DerivMaxTag tycon)
L loc (TypeSig [L loc rdr_name] sig_ty))
where
rdr_name = maxtag_RDR dflags tycon
- sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
+ sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))
rhs = nlHsApp (nlHsVar intDataCon_RDR)
(nlHsLit (HsIntPrim NoSourceText max_tag))
max_tag = case (tyConDataCons tycon) of
@@ -2092,8 +2093,8 @@ illegal_toEnum_tag tp maxtag =
(nlHsLit (mkHsString ")"))))))
parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
-parenify e@(L _ (HsVar _)) = e
-parenify e = mkHsPar e
+parenify e@(L _ (HsVar _ _)) = e
+parenify e = mkHsPar e
-- genOpApp wraps brackets round the operator application, so that the
-- renamer won't subsequently try to re-associate it.
diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs
index 61e2864c13..ab6220e9b5 100644
--- a/compiler/typecheck/TcGenFunctor.hs
+++ b/compiler/typecheck/TcGenFunctor.hs
@@ -8,6 +8,7 @@ The deriving code for the Functor, Foldable, and Traversable classes
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
module TcGenFunctor (
FFoldType(..), functorLikeTraverse,
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 01b7176a6e..29dfefbab2 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -10,7 +10,8 @@ checker.
-}
{-# LANGUAGE CPP, TupleSections #-}
-{-# LANGUAGE CPP, TypeFamilies #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
module TcHsSyn (
-- * Extracting types from HsSyn
@@ -88,28 +89,28 @@ hsLPatType :: OutPat GhcTc -> Type
hsLPatType (L _ pat) = hsPatType pat
hsPatType :: Pat GhcTc -> Type
-hsPatType (ParPat pat) = hsLPatType pat
-hsPatType (WildPat ty) = ty
-hsPatType (VarPat (L _ var)) = idType var
-hsPatType (BangPat pat) = hsLPatType pat
-hsPatType (LazyPat pat) = hsLPatType pat
-hsPatType (LitPat lit) = hsLitType lit
-hsPatType (AsPat var _) = idType (unLoc var)
-hsPatType (ViewPat _ _ ty) = ty
-hsPatType (ListPat _ ty Nothing) = mkListTy ty
-hsPatType (ListPat _ _ (Just (ty,_))) = ty
-hsPatType (PArrPat _ ty) = mkPArrTy ty
-hsPatType (TuplePat _ bx tys) = mkTupleTy bx tys
-hsPatType (SumPat _ _ _ tys) = mkSumTy tys
+hsPatType (ParPat _ pat) = hsLPatType pat
+hsPatType (WildPat ty) = ty
+hsPatType (VarPat _ (L _ var)) = idType var
+hsPatType (BangPat _ pat) = hsLPatType pat
+hsPatType (LazyPat _ pat) = hsLPatType pat
+hsPatType (LitPat _ lit) = hsLitType lit
+hsPatType (AsPat _ var _) = idType (unLoc var)
+hsPatType (ViewPat ty _ _) = ty
+hsPatType (ListPat _ _ ty Nothing) = mkListTy ty
+hsPatType (ListPat _ _ _ (Just (ty,_))) = ty
+hsPatType (PArrPat ty _) = mkPArrTy ty
+hsPatType (TuplePat tys _ bx) = mkTupleTy bx tys
+hsPatType (SumPat tys _ _ _ ) = mkSumTy tys
hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
- = conLikeResTy con tys
-hsPatType (SigPatOut _ ty) = ty
-hsPatType (NPat _ _ _ ty) = ty
-hsPatType (NPlusKPat _ _ _ _ _ ty) = ty
-hsPatType (CoPat _ _ ty) = ty
-hsPatType p = pprPanic "hsPatType" (ppr p)
-
-hsLitType :: HsLit p -> TcType
+ = conLikeResTy con tys
+hsPatType (SigPat ty _) = ty
+hsPatType (NPat ty _ _ _) = ty
+hsPatType (NPlusKPat ty _ _ _ _ _) = ty
+hsPatType (CoPat _ _ _ ty) = ty
+hsPatType p = pprPanic "hsPatType" (ppr p)
+
+hsLitType :: HsLit (GhcPass p) -> TcType
hsLitType (HsChar _ _) = charTy
hsLitType (HsCharPrim _ _) = charPrimTy
hsLitType (HsString _ _) = stringTy
@@ -123,14 +124,15 @@ hsLitType (HsInteger _ _ ty) = ty
hsLitType (HsRat _ _ ty) = ty
hsLitType (HsFloatPrim _ _) = floatPrimTy
hsLitType (HsDoublePrim _ _) = doublePrimTy
+hsLitType (XLit p) = pprPanic "hsLitType" (ppr p)
-- Overloaded literals. Here mainly because it uses isIntTy etc
shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId)
shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
- | isIntTy ty && inIntRange dflags i = Just (HsLit (HsInt def int))
+ | isIntTy ty && inIntRange dflags i = Just (HsLit noExt (HsInt noExt int))
| isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))
- | isIntegerTy ty = Just (HsLit (HsInteger src i ty))
+ | isIntegerTy ty = Just (HsLit noExt (HsInteger src i ty))
| otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty
-- The 'otherwise' case is important
-- Consider (3 :: Float). Syntactically it looks like an IntLit,
@@ -139,16 +141,16 @@ shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
-- literals, compiled without -O
shortCutLit _ (HsFractional f) ty
- | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim def f))
- | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim def f))
+ | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExt f))
+ | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExt f))
| otherwise = Nothing
shortCutLit _ (HsIsString src s) ty
- | isStringTy ty = Just (HsLit (HsString src s))
+ | isStringTy ty = Just (HsLit noExt (HsString src s))
| otherwise = Nothing
mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
-mkLit con lit = HsApp (nlHsDataCon con) (nlHsLit lit)
+mkLit con lit = HsApp noExt (nlHsDataCon con) (nlHsLit lit)
------------------------------
hsOverLitName :: OverLitVal -> Name
@@ -308,7 +310,9 @@ zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)
-zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel
+zonkFieldOcc env (FieldOcc sel lbl)
+ = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
+zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc"
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
zonkEvBndrsX = mapAccumLM zonkEvBndrX
@@ -393,12 +397,12 @@ zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
zonkLocalBinds env EmptyLocalBinds
= return (env, EmptyLocalBinds)
-zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
+zonkLocalBinds _ (HsValBinds (ValBinds {}))
= panic "zonkLocalBinds" -- Not in typechecker output
-zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))
+zonkLocalBinds env (HsValBinds (XValBindsLR (NValBinds binds sigs)))
= do { (env1, new_binds) <- go env binds
- ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
+ ; return (env1, HsValBinds (XValBindsLR (NValBinds new_binds sigs))) }
where
go env []
= return (env, [])
@@ -603,115 +607,116 @@ zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc)
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
zonkLExpr env expr = wrapLocM (zonkExpr env) expr
-zonkExpr env (HsVar (L l id))
+zonkExpr env (HsVar x (L l id))
= ASSERT2( isNothing (isDataConId_maybe id), ppr id )
- return (HsVar (L l (zonkIdOcc env id)))
+ return (HsVar x (L l (zonkIdOcc env id)))
zonkExpr _ e@(HsConLikeOut {}) = return e
-zonkExpr _ (HsIPVar id)
- = return (HsIPVar id)
+zonkExpr _ (HsIPVar x id)
+ = return (HsIPVar x id)
zonkExpr _ e@HsOverLabel{} = return e
-zonkExpr env (HsLit (HsRat e f ty))
+zonkExpr env (HsLit x (HsRat e f ty))
= do new_ty <- zonkTcTypeToType env ty
- return (HsLit (HsRat e f new_ty))
+ return (HsLit x (HsRat e f new_ty))
-zonkExpr _ (HsLit lit)
- = return (HsLit lit)
+zonkExpr _ (HsLit x lit)
+ = return (HsLit x lit)
-zonkExpr env (HsOverLit lit)
+zonkExpr env (HsOverLit x lit)
= do { lit' <- zonkOverLit env lit
- ; return (HsOverLit lit') }
+ ; return (HsOverLit x lit') }
-zonkExpr env (HsLam matches)
+zonkExpr env (HsLam x matches)
= do new_matches <- zonkMatchGroup env zonkLExpr matches
- return (HsLam new_matches)
+ return (HsLam x new_matches)
-zonkExpr env (HsLamCase matches)
+zonkExpr env (HsLamCase x matches)
= do new_matches <- zonkMatchGroup env zonkLExpr matches
- return (HsLamCase new_matches)
+ return (HsLamCase x new_matches)
-zonkExpr env (HsApp e1 e2)
+zonkExpr env (HsApp x e1 e2)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
- return (HsApp new_e1 new_e2)
+ return (HsApp x new_e1 new_e2)
-zonkExpr env (HsAppTypeOut e t)
+zonkExpr env (HsAppType t e)
= do new_e <- zonkLExpr env e
- return (HsAppTypeOut new_e t)
+ return (HsAppType t new_e)
-- NB: the type is an HsType; can't zonk that!
-zonkExpr _ e@(HsRnBracketOut _ _)
+zonkExpr _ e@(HsRnBracketOut _ _ _)
= pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
-zonkExpr env (HsTcBracketOut body bs)
+zonkExpr env (HsTcBracketOut x body bs)
= do bs' <- mapM zonk_b bs
- return (HsTcBracketOut body bs')
+ return (HsTcBracketOut x body bs')
where
zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
return (PendingTcSplice n e')
-zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
- return (HsSpliceE s)
+zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
+ return (HsSpliceE x s)
-zonkExpr env (OpApp e1 op fixity e2)
+zonkExpr env (OpApp fixity e1 op e2)
= do new_e1 <- zonkLExpr env e1
new_op <- zonkLExpr env op
new_e2 <- zonkLExpr env e2
- return (OpApp new_e1 new_op fixity new_e2)
+ return (OpApp fixity new_e1 new_op new_e2)
-zonkExpr env (NegApp expr op)
+zonkExpr env (NegApp x expr op)
= do (env', new_op) <- zonkSyntaxExpr env op
new_expr <- zonkLExpr env' expr
- return (NegApp new_expr new_op)
+ return (NegApp x new_expr new_op)
-zonkExpr env (HsPar e)
+zonkExpr env (HsPar x e)
= do new_e <- zonkLExpr env e
- return (HsPar new_e)
+ return (HsPar x new_e)
-zonkExpr env (SectionL expr op)
+zonkExpr env (SectionL x expr op)
= do new_expr <- zonkLExpr env expr
new_op <- zonkLExpr env op
- return (SectionL new_expr new_op)
+ return (SectionL x new_expr new_op)
-zonkExpr env (SectionR op expr)
+zonkExpr env (SectionR x op expr)
= do new_op <- zonkLExpr env op
new_expr <- zonkLExpr env expr
- return (SectionR new_op new_expr)
+ return (SectionR x new_op new_expr)
-zonkExpr env (ExplicitTuple tup_args boxed)
+zonkExpr env (ExplicitTuple x tup_args boxed)
= do { new_tup_args <- mapM zonk_tup_arg tup_args
- ; return (ExplicitTuple new_tup_args boxed) }
+ ; return (ExplicitTuple x new_tup_args boxed) }
where
- zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e
- ; return (L l (Present e')) }
+ zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e
+ ; return (L l (Present x e')) }
zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t
; return (L l (Missing t')) }
+ zonk_tup_arg (L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
-zonkExpr env (ExplicitSum alt arity expr args)
+zonkExpr env (ExplicitSum args alt arity expr)
= do new_args <- mapM (zonkTcTypeToType env) args
new_expr <- zonkLExpr env expr
- return (ExplicitSum alt arity new_expr new_args)
+ return (ExplicitSum new_args alt arity new_expr)
-zonkExpr env (HsCase expr ms)
+zonkExpr env (HsCase x expr ms)
= do new_expr <- zonkLExpr env expr
new_ms <- zonkMatchGroup env zonkLExpr ms
- return (HsCase new_expr new_ms)
+ return (HsCase x new_expr new_ms)
-zonkExpr env (HsIf Nothing e1 e2 e3)
+zonkExpr env (HsIf x Nothing e1 e2 e3)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
new_e3 <- zonkLExpr env e3
- return (HsIf Nothing new_e1 new_e2 new_e3)
+ return (HsIf x Nothing new_e1 new_e2 new_e3)
-zonkExpr env (HsIf (Just fun) e1 e2 e3)
+zonkExpr env (HsIf x (Just fun) e1 e2 e3)
= do (env1, new_fun) <- zonkSyntaxExpr env fun
new_e1 <- zonkLExpr env1 e1
new_e2 <- zonkLExpr env1 e2
new_e3 <- zonkLExpr env1 e3
- return (HsIf (Just new_fun) new_e1 new_e2 new_e3)
+ return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)
zonkExpr env (HsMultiIf ty alts)
= do { alts' <- mapM (wrapLocM zonk_alt) alts
@@ -722,15 +727,15 @@ zonkExpr env (HsMultiIf ty alts)
; expr' <- zonkLExpr env' expr
; return $ GRHS guard' expr' }
-zonkExpr env (HsLet (L l binds) expr)
+zonkExpr env (HsLet x (L l binds) expr)
= do (new_env, new_binds) <- zonkLocalBinds env binds
new_expr <- zonkLExpr new_env expr
- return (HsLet (L l new_binds) new_expr)
+ return (HsLet x (L l new_binds) new_expr)
-zonkExpr env (HsDo do_or_lc (L l stmts) ty)
+zonkExpr env (HsDo ty do_or_lc (L l stmts))
= do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
new_ty <- zonkTcTypeToType env ty
- return (HsDo do_or_lc (L l new_stmts) new_ty)
+ return (HsDo new_ty do_or_lc (L l new_stmts))
zonkExpr env (ExplicitList ty wit exprs)
= do (env1, new_wit) <- zonkWit env wit
@@ -745,27 +750,31 @@ zonkExpr env (ExplicitPArr ty exprs)
new_exprs <- zonkLExprs env exprs
return (ExplicitPArr new_ty new_exprs)
-zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
- = do { new_con_expr <- zonkExpr env con_expr
+zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })
+ = do { new_con_expr <- zonkExpr env (rcon_con_expr ext)
; new_rbinds <- zonkRecFields env rbinds
- ; return (expr { rcon_con_expr = new_con_expr
+ ; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr }
, rcon_flds = new_rbinds }) }
-zonkExpr env (RecordUpd { rupd_expr = expr, rupd_flds = rbinds
- , rupd_cons = cons, rupd_in_tys = in_tys
- , rupd_out_tys = out_tys, rupd_wrap = req_wrap })
+zonkExpr env (RecordUpd { rupd_flds = rbinds
+ , rupd_expr = expr
+ , rupd_ext = RecordUpdTc
+ { rupd_cons = cons, rupd_in_tys = in_tys
+ , rupd_out_tys = out_tys, rupd_wrap = req_wrap }})
= do { new_expr <- zonkLExpr env expr
; new_in_tys <- mapM (zonkTcTypeToType env) in_tys
; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
; new_rbinds <- zonkRecUpdFields env rbinds
; (_, new_recwrap) <- zonkCoFn env req_wrap
; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds
- , rupd_cons = cons, rupd_in_tys = new_in_tys
- , rupd_out_tys = new_out_tys, rupd_wrap = new_recwrap }) }
+ , rupd_ext = RecordUpdTc
+ { rupd_cons = cons, rupd_in_tys = new_in_tys
+ , rupd_out_tys = new_out_tys
+ , rupd_wrap = new_recwrap }}) }
-zonkExpr env (ExprWithTySigOut e ty)
+zonkExpr env (ExprWithTySig ty e)
= do { e' <- zonkLExpr env e
- ; return (ExprWithTySigOut e' ty) }
+ ; return (ExprWithTySig ty e') }
zonkExpr env (ArithSeq expr wit info)
= do (env1, new_wit) <- zonkWit env wit
@@ -780,33 +789,33 @@ zonkExpr env (PArrSeq expr info)
new_info <- zonkArithSeq env info
return (PArrSeq new_expr new_info)
-zonkExpr env (HsSCC src lbl expr)
+zonkExpr env (HsSCC x src lbl expr)
= do new_expr <- zonkLExpr env expr
- return (HsSCC src lbl new_expr)
+ return (HsSCC x src lbl new_expr)
-zonkExpr env (HsTickPragma src info srcInfo expr)
+zonkExpr env (HsTickPragma x src info srcInfo expr)
= do new_expr <- zonkLExpr env expr
- return (HsTickPragma src info srcInfo new_expr)
+ return (HsTickPragma x src info srcInfo new_expr)
-- hdaume: core annotations
-zonkExpr env (HsCoreAnn src lbl expr)
+zonkExpr env (HsCoreAnn x src lbl expr)
= do new_expr <- zonkLExpr env expr
- return (HsCoreAnn src lbl new_expr)
+ return (HsCoreAnn x src lbl new_expr)
-- arrow notation extensions
-zonkExpr env (HsProc pat body)
+zonkExpr env (HsProc x pat body)
= do { (env1, new_pat) <- zonkPat env pat
; new_body <- zonkCmdTop env1 body
- ; return (HsProc new_pat new_body) }
+ ; return (HsProc x new_pat new_body) }
-- StaticPointers extension
zonkExpr env (HsStatic fvs expr)
= HsStatic fvs <$> zonkLExpr env expr
-zonkExpr env (HsWrap co_fn expr)
+zonkExpr env (HsWrap x co_fn expr)
= do (env1, new_co_fn) <- zonkCoFn env co_fn
new_expr <- zonkExpr env1 expr
- return (HsWrap new_co_fn new_expr)
+ return (HsWrap x new_co_fn new_expr)
zonkExpr _ e@(HsUnboundVar {}) = return e
@@ -853,60 +862,60 @@ zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc)
zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd
-zonkCmd env (HsCmdWrap w cmd)
+zonkCmd env (HsCmdWrap x w cmd)
= do { (env1, w') <- zonkCoFn env w
; cmd' <- zonkCmd env1 cmd
- ; return (HsCmdWrap w' cmd') }
-zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
+ ; return (HsCmdWrap x w' cmd') }
+zonkCmd env (HsCmdArrApp ty e1 e2 ho rl)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
new_ty <- zonkTcTypeToType env ty
- return (HsCmdArrApp new_e1 new_e2 new_ty ho rl)
+ return (HsCmdArrApp new_ty new_e1 new_e2 ho rl)
-zonkCmd env (HsCmdArrForm op f fixity args)
+zonkCmd env (HsCmdArrForm x op f fixity args)
= do new_op <- zonkLExpr env op
new_args <- mapM (zonkCmdTop env) args
- return (HsCmdArrForm new_op f fixity new_args)
+ return (HsCmdArrForm x new_op f fixity new_args)
-zonkCmd env (HsCmdApp c e)
+zonkCmd env (HsCmdApp x c e)
= do new_c <- zonkLCmd env c
new_e <- zonkLExpr env e
- return (HsCmdApp new_c new_e)
+ return (HsCmdApp x new_c new_e)
-zonkCmd env (HsCmdLam matches)
+zonkCmd env (HsCmdLam x matches)
= do new_matches <- zonkMatchGroup env zonkLCmd matches
- return (HsCmdLam new_matches)
+ return (HsCmdLam x new_matches)
-zonkCmd env (HsCmdPar c)
+zonkCmd env (HsCmdPar x c)
= do new_c <- zonkLCmd env c
- return (HsCmdPar new_c)
+ return (HsCmdPar x new_c)
-zonkCmd env (HsCmdCase expr ms)
+zonkCmd env (HsCmdCase x expr ms)
= do new_expr <- zonkLExpr env expr
new_ms <- zonkMatchGroup env zonkLCmd ms
- return (HsCmdCase new_expr new_ms)
+ return (HsCmdCase x new_expr new_ms)
-zonkCmd env (HsCmdIf eCond ePred cThen cElse)
+zonkCmd env (HsCmdIf x eCond ePred cThen cElse)
= do { (env1, new_eCond) <- zonkWit env eCond
; new_ePred <- zonkLExpr env1 ePred
; new_cThen <- zonkLCmd env1 cThen
; new_cElse <- zonkLCmd env1 cElse
- ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
+ ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) }
where
zonkWit env Nothing = return (env, Nothing)
zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w
-zonkCmd env (HsCmdLet (L l binds) cmd)
+zonkCmd env (HsCmdLet x (L l binds) cmd)
= do (new_env, new_binds) <- zonkLocalBinds env binds
new_cmd <- zonkLCmd new_env cmd
- return (HsCmdLet (L l new_binds) new_cmd)
+ return (HsCmdLet x (L l new_binds) new_cmd)
-zonkCmd env (HsCmdDo (L l stmts) ty)
+zonkCmd env (HsCmdDo ty (L l stmts))
= do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
new_ty <- zonkTcTypeToType env ty
- return (HsCmdDo (L l new_stmts) new_ty)
-
+ return (HsCmdDo new_ty (L l new_stmts))
+zonkCmd _ (XCmd{}) = panic "zonkCmd"
@@ -914,7 +923,7 @@ zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc)
-zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
+zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
= do new_cmd <- zonkLCmd env cmd
new_stack_tys <- zonkTcTypeToType env stack_tys
new_ty <- zonkTcTypeToType env ty
@@ -925,7 +934,8 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
-- but indeed it should always be lifted due to the typing
-- rules for arrows
- return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
+ return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)
+zonk_cmd_top _ (XCmdTop {}) = panic "zonk_cmd_top"
-------------------------------------------------------------------------
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
@@ -953,10 +963,12 @@ zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc)
-zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
+zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e })
= do { ty' <- zonkTcTypeToType env ty
; e' <- zonkExpr env e
- ; return (lit { ol_witness = e', ol_type = ty' }) }
+ ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) }
+
+zonkOverLit _ XOverLit{} = panic "zonkOverLit"
-------------------------------------------------------------------------
zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc)
@@ -1000,15 +1012,18 @@ zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty)
= do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op
; new_bind_ty <- zonkTcTypeToType env1 bind_ty
; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs
- ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs]
+ ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs
+ , b <- bs]
env2 = extendIdZonkEnvRec env1 new_binders
; new_mzip <- zonkExpr env2 mzip_op
; return (env2, ParStmt new_stmts_w_bndrs new_mzip new_bind_op new_bind_ty) }
where
- zonk_branch env1 (ParStmtBlock stmts bndrs return_op)
+ zonk_branch env1 (ParStmtBlock x stmts bndrs return_op)
= do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts
; (env3, new_return) <- zonkSyntaxExpr env2 return_op
- ; return (ParStmtBlock new_stmts (zonkIdOccs env3 bndrs) new_return) }
+ ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs)
+ new_return) }
+ zonk_branch _ (XParStmtBlock{}) = panic "zonkStmt"
zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
, recS_ret_fn = ret_id, recS_mfix_fn = mfix_id
@@ -1173,9 +1188,9 @@ zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc)
zonkPat env pat = wrapLocSndM (zonk_pat env) pat
zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc)
-zonk_pat env (ParPat p)
+zonk_pat env (ParPat x p)
= do { (env', p') <- zonkPat env p
- ; return (env', ParPat p') }
+ ; return (env', ParPat x p') }
zonk_pat env (WildPat ty)
= do { ty' <- zonkTcTypeToType env ty
@@ -1183,55 +1198,55 @@ zonk_pat env (WildPat ty)
(text "In a wildcard pattern")
; return (env, WildPat ty') }
-zonk_pat env (VarPat (L l v))
+zonk_pat env (VarPat x (L l v))
= do { v' <- zonkIdBndr env v
- ; return (extendIdZonkEnv1 env v', VarPat (L l v')) }
+ ; return (extendIdZonkEnv1 env v', VarPat x (L l v')) }
-zonk_pat env (LazyPat pat)
+zonk_pat env (LazyPat x pat)
= do { (env', pat') <- zonkPat env pat
- ; return (env', LazyPat pat') }
+ ; return (env', LazyPat x pat') }
-zonk_pat env (BangPat pat)
+zonk_pat env (BangPat x pat)
= do { (env', pat') <- zonkPat env pat
- ; return (env', BangPat pat') }
+ ; return (env', BangPat x pat') }
-zonk_pat env (AsPat (L loc v) pat)
+zonk_pat env (AsPat x (L loc v) pat)
= do { v' <- zonkIdBndr env v
; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
- ; return (env', AsPat (L loc v') pat') }
+ ; return (env', AsPat x (L loc v') pat') }
-zonk_pat env (ViewPat expr pat ty)
+zonk_pat env (ViewPat ty expr pat)
= do { expr' <- zonkLExpr env expr
; (env', pat') <- zonkPat env pat
; ty' <- zonkTcTypeToType env ty
- ; return (env', ViewPat expr' pat' ty') }
+ ; return (env', ViewPat ty' expr' pat') }
-zonk_pat env (ListPat pats ty Nothing)
+zonk_pat env (ListPat x pats ty Nothing)
= do { ty' <- zonkTcTypeToType env ty
; (env', pats') <- zonkPats env pats
- ; return (env', ListPat pats' ty' Nothing) }
+ ; return (env', ListPat x pats' ty' Nothing) }
-zonk_pat env (ListPat pats ty (Just (ty2,wit)))
+zonk_pat env (ListPat x pats ty (Just (ty2,wit)))
= do { (env', wit') <- zonkSyntaxExpr env wit
; ty2' <- zonkTcTypeToType env' ty2
; ty' <- zonkTcTypeToType env' ty
; (env'', pats') <- zonkPats env' pats
- ; return (env'', ListPat pats' ty' (Just (ty2',wit'))) }
+ ; return (env'', ListPat x pats' ty' (Just (ty2',wit'))) }
-zonk_pat env (PArrPat pats ty)
+zonk_pat env (PArrPat ty pats)
= do { ty' <- zonkTcTypeToType env ty
; (env', pats') <- zonkPats env pats
- ; return (env', PArrPat pats' ty') }
+ ; return (env', PArrPat ty' pats') }
-zonk_pat env (TuplePat pats boxed tys)
+zonk_pat env (TuplePat tys pats boxed)
= do { tys' <- mapM (zonkTcTypeToType env) tys
; (env', pats') <- zonkPats env pats
- ; return (env', TuplePat pats' boxed tys') }
+ ; return (env', TuplePat tys' pats' boxed) }
-zonk_pat env (SumPat pat alt arity tys)
+zonk_pat env (SumPat tys pat alt arity )
= do { tys' <- mapM (zonkTcTypeToType env) tys
; (env', pat') <- zonkPat env pat
- ; return (env', SumPat pat' alt arity tys') }
+ ; return (env', SumPat tys' pat' alt arity) }
zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
, pat_dicts = evs, pat_binds = binds
@@ -1265,14 +1280,14 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
where
doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p
-zonk_pat env (LitPat lit) = return (env, LitPat lit)
+zonk_pat env (LitPat x lit) = return (env, LitPat x lit)
-zonk_pat env (SigPatOut pat ty)
+zonk_pat env (SigPat ty pat)
= do { ty' <- zonkTcTypeToType env ty
; (env', pat') <- zonkPat env pat
- ; return (env', SigPatOut pat' ty') }
+ ; return (env', SigPat ty' pat') }
-zonk_pat env (NPat (L l lit) mb_neg eq_expr ty)
+zonk_pat env (NPat ty (L l lit) mb_neg eq_expr)
= do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
; (env2, mb_neg') <- case mb_neg of
Nothing -> return (env1, Nothing)
@@ -1280,9 +1295,9 @@ zonk_pat env (NPat (L l lit) mb_neg eq_expr ty)
; lit' <- zonkOverLit env2 lit
; ty' <- zonkTcTypeToType env2 ty
- ; return (env2, NPat (L l lit') mb_neg' eq_expr' ty') }
+ ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') }
-zonk_pat env (NPlusKPat (L loc n) (L l lit1) lit2 e1 e2 ty)
+zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
= do { (env1, e1') <- zonkSyntaxExpr env e1
; (env2, e2') <- zonkSyntaxExpr env1 e2
; n' <- zonkIdBndr env2 n
@@ -1290,13 +1305,13 @@ zonk_pat env (NPlusKPat (L loc n) (L l lit1) lit2 e1 e2 ty)
; lit2' <- zonkOverLit env2 lit2
; ty' <- zonkTcTypeToType env2 ty
; return (extendIdZonkEnv1 env2 n',
- NPlusKPat (L loc n') (L l lit1') lit2' e1' e2' ty') }
+ NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }
-zonk_pat env (CoPat co_fn pat ty)
+zonk_pat env (CoPat x co_fn pat ty)
= do { (env', co_fn') <- zonkCoFn env co_fn
; (env'', pat') <- zonkPat env' (noLoc pat)
; ty' <- zonkTcTypeToType env'' ty
- ; return (env'', CoPat co_fn' (unLoc pat') ty') }
+ ; return (env'', CoPat x co_fn' (unLoc pat') ty') }
zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 6908d16dfc..762efbf5c8 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -484,19 +484,20 @@ tc_infer_lhs_type mode (L span ty)
-- | Infer the kind of a type and desugar. This is the "up" type-checker,
-- as described in Note [Bidirectional type checking]
tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)
-tc_infer_hs_type mode (HsTyVar _ (L _ tv)) = tcTyVar mode tv
-tc_infer_hs_type mode (HsAppTy ty1 ty2)
+tc_infer_hs_type mode (HsTyVar _ _ (L _ tv)) = tcTyVar mode tv
+tc_infer_hs_type mode (HsAppTy _ ty1 ty2)
= do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
; (fun_ty', fun_kind) <- tc_infer_lhs_type mode fun_ty
; fun_kind' <- zonkTcType fun_kind
; tcTyApps mode fun_ty fun_ty' fun_kind' arg_tys }
-tc_infer_hs_type mode (HsParTy t) = tc_infer_lhs_type mode t
-tc_infer_hs_type mode (HsOpTy lhs (L loc_op op) rhs)
+tc_infer_hs_type mode (HsParTy _ t) = tc_infer_lhs_type mode t
+tc_infer_hs_type mode (HsOpTy _ lhs (L loc_op op) rhs)
| not (op `hasKey` funTyConKey)
= do { (op', op_kind) <- tcTyVar mode op
; op_kind' <- zonkTcType op_kind
- ; tcTyApps mode (noLoc $ HsTyVar NotPromoted (L loc_op op)) op' op_kind' [lhs, rhs] }
-tc_infer_hs_type mode (HsKindSig ty sig)
+ ; tcTyApps mode (noLoc $ HsTyVar noExt NotPromoted (L loc_op op))
+ op' op_kind' [lhs, rhs] }
+tc_infer_hs_type mode (HsKindSig _ ty sig)
= do { sig' <- tc_lhs_kind (kindLevel mode) sig
; ty' <- tc_lhs_type mode ty sig'
; return (ty', sig') }
@@ -506,10 +507,10 @@ tc_infer_hs_type mode (HsKindSig ty sig)
-- splices or not.
--
-- See Note [Delaying modFinalizers in untyped splices].
-tc_infer_hs_type mode (HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _)
+tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))
= tc_infer_hs_type mode ty
-tc_infer_hs_type mode (HsDocTy ty _) = tc_infer_lhs_type mode ty
-tc_infer_hs_type _ (HsCoreTy ty) = return (ty, typeKind ty)
+tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty
+tc_infer_hs_type _ (XHsType (NHsCoreTy ty)) = return (ty, typeKind ty)
tc_infer_hs_type mode other_ty
= do { kv <- newMetaKindVar
; ty' <- tc_hs_type mode other_ty kv
@@ -531,23 +532,25 @@ tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of
; res_k <- newOpenTypeKind
; ty1' <- tc_lhs_type mode ty1 arg_k
; ty2' <- tc_lhs_type mode ty2 res_k
- ; checkExpectedKind (HsFunTy ty1 ty2) (mkFunTy ty1' ty2') liftedTypeKind exp_kind }
+ ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2')
+ liftedTypeKind exp_kind }
KindLevel -> -- no representation polymorphism in kinds. yet.
do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind
; ty2' <- tc_lhs_type mode ty2 liftedTypeKind
- ; checkExpectedKind (HsFunTy ty1 ty2) (mkFunTy ty1' ty2') liftedTypeKind exp_kind }
+ ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2')
+ liftedTypeKind exp_kind }
------------------------------------------
-- See also Note [Bidirectional type checking]
tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
-tc_hs_type mode (HsParTy ty) exp_kind = tc_lhs_type mode ty exp_kind
-tc_hs_type mode (HsDocTy ty _) exp_kind = tc_lhs_type mode ty exp_kind
+tc_hs_type mode (HsParTy _ ty) exp_kind = tc_lhs_type mode ty exp_kind
+tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind
tc_hs_type _ ty@(HsBangTy {}) _
-- While top-level bangs at this point are eliminated (eg !(Maybe Int)),
-- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
-- bangs are invalid, so fail. (#7210)
= failWithTc (text "Unexpected strictness annotation:" <+> ppr ty)
-tc_hs_type _ ty@(HsRecTy _) _
+tc_hs_type _ ty@(HsRecTy _ _) _
-- Record types (which only show up temporarily in constructor
-- signatures) should have been removed by now
= failWithTc (text "Record syntax is illegal here:" <+> ppr ty)
@@ -557,9 +560,7 @@ tc_hs_type _ ty@(HsRecTy _) _
-- while capturing the local environment.
--
-- See Note [Delaying modFinalizers in untyped splices].
-tc_hs_type mode (HsSpliceTy (HsSpliced mod_finalizers (HsSplicedTy ty))
- _
- )
+tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))
exp_kind
= do addModFinalizersWithLclEnv mod_finalizers
tc_hs_type mode ty exp_kind
@@ -569,10 +570,10 @@ tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind
= failWithTc (text "Unexpected type splice:" <+> ppr ty)
---------- Functions and applications
-tc_hs_type mode (HsFunTy ty1 ty2) exp_kind
+tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind
= tc_fun_type mode ty1 ty2 exp_kind
-tc_hs_type mode (HsOpTy ty1 (L _ op) ty2) exp_kind
+tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind
| op `hasKey` funTyConKey
= tc_fun_type mode ty1 ty2 exp_kind
@@ -606,12 +607,12 @@ tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind
; return (mkPhiTy ctxt' ty') }
--------- Lists, arrays, and tuples
-tc_hs_type mode rn_ty@(HsListTy elt_ty) exp_kind
+tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind
= do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind
; checkWiredInTyCon listTyCon
; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }
-tc_hs_type mode rn_ty@(HsPArrTy elt_ty) exp_kind
+tc_hs_type mode rn_ty@(HsPArrTy _ elt_ty) exp_kind
= do { MASSERT( isTypeLevel (mode_level mode) )
; tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind
; checkWiredInTyCon parrTyCon
@@ -619,7 +620,7 @@ tc_hs_type mode rn_ty@(HsPArrTy elt_ty) exp_kind
-- See Note [Distinguishing tuple kinds] in HsTypes
-- See Note [Inferring tuple kinds]
-tc_hs_type mode rn_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind
+tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind
-- (NB: not zonking before looking at exp_k, to avoid left-right bias)
| Just tup_sort <- tupKindSort_maybe exp_kind
= traceTc "tc_hs_type tuple" (ppr hs_tys) >>
@@ -647,7 +648,7 @@ tc_hs_type mode rn_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind
; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }
-tc_hs_type mode rn_ty@(HsTupleTy hs_tup_sort tys) exp_kind
+tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind
= tc_tuple rn_ty mode tup_sort tys exp_kind
where
tup_sort = case hs_tup_sort of -- Fourth case dealt with above
@@ -656,7 +657,7 @@ tc_hs_type mode rn_ty@(HsTupleTy hs_tup_sort tys) exp_kind
HsConstraintTuple -> ConstraintTuple
_ -> panic "tc_hs_type HsTupleTy"
-tc_hs_type mode rn_ty@(HsSumTy hs_tys) exp_kind
+tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind
= do { let arity = length hs_tys
; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys
; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds
@@ -669,7 +670,7 @@ tc_hs_type mode rn_ty@(HsSumTy hs_tys) exp_kind
}
--------- Promoted lists and tuples
-tc_hs_type mode rn_ty@(HsExplicitListTy _ _k tys) exp_kind
+tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind
= do { tks <- mapM (tc_infer_lhs_type mode) tys
; (taus', kind) <- unifyKinds tys tks
; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')
@@ -691,7 +692,7 @@ tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind
arity = length tys
--------- Constraint types
-tc_hs_type mode rn_ty@(HsIParamTy (L _ n) ty) exp_kind
+tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind
= do { MASSERT( isTypeLevel (mode_level mode) )
; ty' <- tc_lhs_type mode ty liftedTypeKind
; let n' = mkStrLitTy $ hsIPNameFS n
@@ -699,7 +700,7 @@ tc_hs_type mode rn_ty@(HsIParamTy (L _ n) ty) exp_kind
; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])
constraintKind exp_kind }
-tc_hs_type mode rn_ty@(HsEqTy ty1 ty2) exp_kind
+tc_hs_type mode rn_ty@(HsEqTy _ ty1 ty2) exp_kind
= do { (ty1', kind1) <- tc_infer_lhs_type mode ty1
; (ty2', kind2) <- tc_infer_lhs_type mode ty2
; ty2'' <- checkExpectedKind (unLoc ty2) ty2' kind2 kind1
@@ -708,11 +709,11 @@ tc_hs_type mode rn_ty@(HsEqTy ty1 ty2) exp_kind
; checkExpectedKind rn_ty ty' constraintKind exp_kind }
--------- Literals
-tc_hs_type _ rn_ty@(HsTyLit (HsNumTy _ n)) exp_kind
+tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind
= do { checkWiredInTyCon typeNatKindCon
; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind }
-tc_hs_type _ rn_ty@(HsTyLit (HsStrTy _ s)) exp_kind
+tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind
= do { checkWiredInTyCon typeSymbolKindCon
; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }
@@ -722,7 +723,7 @@ tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek
tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek
tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek
tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek
-tc_hs_type mode ty@(HsCoreTy {}) ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek
tc_hs_type _ (HsWildCardTy wc) exp_kind
= do { wc_tv <- tcWildCardOcc wc exp_kind
@@ -1496,19 +1497,20 @@ kcHsTyVarBndrs name flav cusk all_kind_vars
= tcExtendTyVarEnv [tv] thing_inside
kc_hs_tv :: HsTyVarBndr GhcRn -> TcM (TcTyVar, Bool)
- kc_hs_tv (UserTyVar lname@(L _ name))
+ kc_hs_tv (UserTyVar _ lname@(L _ name))
= do { tv_pair@(tv, scoped) <- tcHsTyVarName Nothing name
-- Open type/data families default their variables to kind *.
; when (open_fam && not scoped) $ -- (don't default class tyvars)
- discardResult $ unifyKind (Just (HsTyVar NotPromoted lname)) liftedTypeKind
- (tyVarKind tv)
+ discardResult $ unifyKind (Just (HsTyVar noExt NotPromoted lname))
+ liftedTypeKind (tyVarKind tv)
; return tv_pair }
- kc_hs_tv (KindedTyVar (L _ name) lhs_kind)
+ kc_hs_tv (KindedTyVar _ (L _ name) lhs_kind)
= do { kind <- tcLHsKindSig lhs_kind
; tcHsTyVarName (Just kind) name }
+ kc_hs_tv (XTyVarBndr{}) = panic "kc_hs_tv"
report_non_cusk_tvs all_tvs
= do { all_tvs <- mapM zonkTyCoVarKind all_tvs
@@ -1626,14 +1628,16 @@ tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar)
--
-- See also Note [Associated type tyvar names] in Class
--
-tcHsTyVarBndr new_tv (UserTyVar (L _ name))
+tcHsTyVarBndr new_tv (UserTyVar _(L _ name))
= do { kind <- newMetaKindVar
; new_tv name kind }
-tcHsTyVarBndr new_tv (KindedTyVar (L _ name) kind)
+tcHsTyVarBndr new_tv (KindedTyVar _ (L _ name) kind)
= do { kind <- tcLHsKindSig kind
; new_tv name kind }
+tcHsTyVarBndr _ (XTyVarBndr{}) = panic "tcHsTyVarBndr"
+
newWildTyVar :: Name -> TcM TcTyVar
-- ^ New unification variable for a wildcard
newWildTyVar _name
@@ -1656,7 +1660,8 @@ tcHsTyVarName m_kind name
Just (ATyVar _ tv)
-> do { whenIsJust m_kind $ \ kind ->
discardResult $
- unifyKind (Just (HsTyVar NotPromoted (noLoc name))) kind (tyVarKind tv)
+ unifyKind (Just (HsTyVar noExt NotPromoted (noLoc name)))
+ kind (tyVarKind tv)
; return (tv, True) }
_ -> do { kind <- case m_kind of
Just kind -> return kind
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 89a0ec6272..f88a11619a 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -870,14 +870,15 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
-- con_app_scs = MkD ty1 ty2 sc1 sc2
-- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
con_app_tys = mkHsWrap (mkWpTyApps inst_tys)
- (HsConLikeOut (RealDataCon dict_constr))
+ (HsConLikeOut noExt (RealDataCon dict_constr))
-- NB: We *can* have covars in inst_tys, in the case of
-- promoted GADT constructors.
con_app_args = foldl app_to_meth con_app_tys sc_meth_ids
app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc
- app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id)
+ app_to_meth fun meth_id = HsApp noExt (L loc fun)
+ (L loc (wrapId arg_wrapper meth_id))
inst_tv_tys = mkTyVarTys inst_tyvars
arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
@@ -940,8 +941,8 @@ addDFunPrags dfun_id sc_meth_ids
[dict_con] = tyConDataCons clas_tc
is_newtype = isNewTyCon clas_tc
-wrapId :: HsWrapper -> IdP id -> HsExpr id
-wrapId wrapper id = mkHsWrap wrapper (HsVar (noLoc id))
+wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id)
+wrapId wrapper id = mkHsWrap wrapper (HsVar noExt (noLoc id))
{- Note [Typechecking plan for instance declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1334,12 +1335,12 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
mkLHsWrap lam_wrapper (error_rhs dflags)
; return (meth_id, meth_bind, Nothing) }
where
- error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags)
+ error_rhs dflags = L inst_loc $ HsApp noExt error_fun (error_msg dflags)
error_fun = L inst_loc $
wrapId (mkWpTyApps
[ getRuntimeRep meth_tau, meth_tau])
nO_METHOD_BINDING_ERROR_ID
- error_msg dflags = L inst_loc (HsLit (HsStringPrim noSourceText
+ error_msg dflags = L inst_loc (HsLit noExt (HsStringPrim noSourceText
(unsafeMkByteString (error_string dflags))))
meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys)
error_string dflags = showSDoc dflags
@@ -1605,8 +1606,8 @@ mkDefMethBind clas inst_tys sel_id dm_name
; return (bind, inline_prags) }
where
mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
- mk_vta fun ty = noLoc (HsAppType fun (mkEmptyWildCardBndrs
- $ nlHsParTy $ noLoc $ HsCoreTy ty))
+ mk_vta fun ty = noLoc (HsAppType (mkEmptyWildCardBndrs $ nlHsParTy
+ $ noLoc $ XHsType $ NHsCoreTy ty) fun)
-- NB: use visible type application
-- See Note [Default methods in instances]
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index d938de0e22..1863a2fdda 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -296,7 +296,7 @@ tcDoStmts ListComp (L l stmts) res_ty
; let list_ty = mkListTy elt_ty
; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts
(mkCheckExpType elt_ty)
- ; return $ mkHsWrapCo co (HsDo ListComp (L l stmts') list_ty) }
+ ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
tcDoStmts PArrComp (L l stmts) res_ty
= do { res_ty <- expTypeToType res_ty
@@ -304,22 +304,22 @@ tcDoStmts PArrComp (L l stmts) res_ty
; let parr_ty = mkPArrTy elt_ty
; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
(mkCheckExpType elt_ty)
- ; return $ mkHsWrapCo co (HsDo PArrComp (L l stmts') parr_ty) }
+ ; return $ mkHsWrapCo co (HsDo parr_ty PArrComp (L l stmts')) }
tcDoStmts DoExpr (L l stmts) res_ty
= do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
; res_ty <- readExpType res_ty
- ; return (HsDo DoExpr (L l stmts') res_ty) }
+ ; return (HsDo res_ty DoExpr (L l stmts')) }
tcDoStmts MDoExpr (L l stmts) res_ty
= do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
; res_ty <- readExpType res_ty
- ; return (HsDo MDoExpr (L l stmts') res_ty) }
+ ; return (HsDo res_ty MDoExpr (L l stmts')) }
tcDoStmts MonadComp (L l stmts) res_ty
= do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
; res_ty <- readExpType res_ty
- ; return (HsDo MonadComp (L l stmts') res_ty) }
+ ; return (HsDo res_ty MonadComp (L l stmts')) }
tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
@@ -468,13 +468,14 @@ tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
loop [] = do { thing <- thing_inside elt_ty
; return ([], thing) } -- matching in the branches
- loop (ParStmtBlock stmts names _ : pairs)
+ loop (ParStmtBlock x stmts names _ : pairs)
= do { (stmts', (ids, pairs', thing))
<- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
do { ids <- tcLookupLocalIds names
; (pairs', thing) <- loop pairs
; return (ids, pairs', thing) }
- ; return ( ParStmtBlock stmts' ids noSyntaxExpr : pairs', thing ) }
+ ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
+ loop (XParStmtBlock{}:_) = panic "tcLcStmt"
tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
, trS_bndrs = bindersMap
@@ -761,7 +762,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
-- type dummies since we don't know all binder types yet
; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
- [ names | ParStmtBlock _ names _ <- bndr_stmts_s ]
+ [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]
-- Typecheck bind:
; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
@@ -791,7 +792,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
-- matching in the branches
loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
- (ParStmtBlock stmts names return_op : pairs)
+ (ParStmtBlock x stmts names return_op : pairs)
= do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
; (stmts', (ids, return_op', pairs', thing))
<- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
@@ -804,7 +805,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
\ _ -> return ()
; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
; return (ids, return_op', pairs', thing) }
- ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) }
+ ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }
loop _ _ _ _ = panic "tcMcStmt.loop"
tcMcStmt _ stmt _ _
@@ -1011,10 +1012,10 @@ join :: tn -> res_ty
tcApplicativeStmts
:: HsStmtContext Name
- -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn GhcRn)]
+ -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType -- rhs_ty
-> (TcRhoType -> TcM t) -- thing_inside
- -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId GhcTcId)], Type, t)
+ -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t)
tcApplicativeStmts ctxt pairs rhs_ty thing_inside
= do { body_ty <- newFlexiTyVarTy liftedTypeKind
@@ -1052,8 +1053,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
; ops' <- goOps t_i ops
; return (op' : ops') }
- goArg :: (ApplicativeArg GhcRn GhcRn, Type, Type)
- -> TcM (ApplicativeArg GhcTcId GhcTcId)
+ goArg :: (ApplicativeArg GhcRn, Type, Type) -> TcM (ApplicativeArg GhcTcId)
goArg (ApplicativeArgOne pat rhs isBody, pat_ty, exp_ty)
= setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
@@ -1074,7 +1074,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
}
; return (ApplicativeArgMany stmts' ret' pat') }
- get_arg_bndrs :: ApplicativeArg GhcTcId GhcTcId -> [Id]
+ get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
get_arg_bndrs (ApplicativeArgOne pat _ _) = collectPatBinders pat
get_arg_bndrs (ApplicativeArgMany _ _ pat) = collectPatBinders pat
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index c5e367e3be..05aa489b55 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -324,21 +324,21 @@ tc_pat :: PatEnv
-> TcM (Pat GhcTcId, -- Translated pattern
a) -- Result of thing inside
-tc_pat penv (VarPat (L l name)) pat_ty thing_inside
+tc_pat penv (VarPat x (L l name)) pat_ty thing_inside
= do { (wrap, id) <- tcPatBndr penv name pat_ty
; res <- tcExtendIdEnv1 name id thing_inside
; pat_ty <- readExpType pat_ty
- ; return (mkHsWrapPat wrap (VarPat (L l id)) pat_ty, res) }
+ ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
-tc_pat penv (ParPat pat) pat_ty thing_inside
+tc_pat penv (ParPat x pat) pat_ty thing_inside
= do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
- ; return (ParPat pat', res) }
+ ; return (ParPat x pat', res) }
-tc_pat penv (BangPat pat) pat_ty thing_inside
+tc_pat penv (BangPat x pat) pat_ty thing_inside
= do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
- ; return (BangPat pat', res) }
+ ; return (BangPat x pat', res) }
-tc_pat penv (LazyPat pat) pat_ty thing_inside
+tc_pat penv (LazyPat x pat) pat_ty thing_inside
= do { (pat', (res, pat_ct))
<- tc_lpat pat pat_ty (makeLazy penv) $
captureConstraints thing_inside
@@ -352,14 +352,14 @@ tc_pat penv (LazyPat pat) pat_ty thing_inside
; pat_ty <- readExpType pat_ty
; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
- ; return (LazyPat pat', res) }
+ ; return (LazyPat x pat', res) }
tc_pat _ (WildPat _) pat_ty thing_inside
= do { res <- thing_inside
; pat_ty <- expTypeToType pat_ty
; return (WildPat pat_ty, res) }
-tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside
+tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside
= do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
; (pat', res) <- tcExtendIdEnv1 name bndr_id $
tc_lpat pat (mkCheckExpType $ idType bndr_id)
@@ -372,9 +372,10 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside
--
-- If you fix it, don't forget the bindInstsOfPatIds!
; pat_ty <- readExpType pat_ty
- ; return (mkHsWrapPat wrap (AsPat (L nm_loc bndr_id) pat') pat_ty, res) }
+ ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty,
+ res) }
-tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
+tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside
= do {
-- Expr must have type `forall a1...aN. OPT' -> B`
-- where overall_pat_ty is an instance of OPT'.
@@ -401,30 +402,30 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
-- (overall_pat_ty -> inf_res_ty)
expr_wrap = expr_wrap2' <.> expr_wrap1
doc = text "When checking the view pattern function:" <+> (ppr expr)
- ; return (ViewPat (mkLHsWrap expr_wrap expr') pat' overall_pat_ty, res) }
+ ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)}
-- Type signatures in patterns
-- See Note [Pattern coercions] below
-tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside
+tc_pat penv (SigPat sig_ty pat ) pat_ty thing_inside
= do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
sig_ty pat_ty
; (pat', res) <- tcExtendTyVarEnv2 wcs $
tcExtendTyVarEnv2 tv_binds $
tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside
; pat_ty <- readExpType pat_ty
- ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) }
+ ; return (mkHsWrapPat wrap (SigPat inner_ty pat') pat_ty, res) }
------------------------
-- Lists, tuples, arrays
-tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside
+tc_pat penv (ListPat x pats _ Nothing) pat_ty thing_inside
= do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty
; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
pats penv thing_inside
; pat_ty <- readExpType pat_ty
- ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res)
- }
+ ; return (mkHsWrapPat coi (ListPat x pats' elt_ty Nothing) pat_ty, res)
+}
-tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside
+tc_pat penv (ListPat x pats _ (Just (_,e))) pat_ty thing_inside
= do { tau_pat_ty <- expTypeToType pat_ty
; ((pats', res, elt_ty), e')
<- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]
@@ -433,18 +434,18 @@ tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside
do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
pats penv thing_inside
; return (pats', res, elt_ty) }
- ; return (ListPat pats' elt_ty (Just (tau_pat_ty,e')), res)
- }
+ ; return (ListPat x pats' elt_ty (Just (tau_pat_ty,e')), res)
+}
-tc_pat penv (PArrPat pats _) pat_ty thing_inside
+tc_pat penv (PArrPat _ pats ) pat_ty thing_inside
= do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedPArrTy penv pat_ty
; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
pats penv thing_inside
; pat_ty <- readExpType pat_ty
- ; return (mkHsWrapPat coi (PArrPat pats' elt_ty) pat_ty, res)
+ ; return (mkHsWrapPat coi (PArrPat elt_ty pats') pat_ty, res)
}
-tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside
+tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside
= do { let arity = length pats
tc = tupleTyCon boxity arity
; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
@@ -463,19 +464,19 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside
-- This is a pretty odd place to make the switch, but
-- it was easy to do.
; let
- unmangled_result = TuplePat pats' boxity con_arg_tys
+ unmangled_result = TuplePat con_arg_tys pats' boxity
-- pat_ty /= pat_ty iff coi /= IdCo
possibly_mangled_result
| gopt Opt_IrrefutableTuples dflags &&
- isBoxed boxity = LazyPat (noLoc unmangled_result)
- | otherwise = unmangled_result
+ isBoxed boxity = LazyPat noExt (noLoc unmangled_result)
+ | otherwise = unmangled_result
; pat_ty <- readExpType pat_ty
; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced
return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
}
-tc_pat penv (SumPat pat alt arity _) pat_ty thing_inside
+tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside
= do { let tc = sumTyCon arity
; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
penv pat_ty
@@ -484,7 +485,8 @@ tc_pat penv (SumPat pat alt arity _) pat_ty thing_inside
; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
penv thing_inside
; pat_ty <- readExpType pat_ty
- ; return (mkHsWrapPat coi (SumPat pat' alt arity con_arg_tys) pat_ty, res)
+ ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
+ , res)
}
------------------------
@@ -494,12 +496,12 @@ tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside
------------------------
-- Literal patterns
-tc_pat penv (LitPat simple_lit) pat_ty thing_inside
+tc_pat penv (LitPat x simple_lit) pat_ty thing_inside
= do { let lit_ty = hsLitType simple_lit
; wrap <- tcSubTypePat penv pat_ty lit_ty
; res <- thing_inside
; pat_ty <- readExpType pat_ty
- ; return ( mkHsWrapPat wrap (LitPat (convertLit simple_lit)) pat_ty
+ ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
, res) }
------------------------
@@ -520,7 +522,7 @@ tc_pat penv (LitPat simple_lit) pat_ty thing_inside
-- where lit_ty is the type of the overloaded literal 5.
--
-- When there is no negation, neg_lit_ty and lit_ty are the same
-tc_pat _ (NPat (L l over_lit) mb_neg eq _) pat_ty thing_inside
+tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside
= do { let orig = LiteralOrigin over_lit
; ((lit', mb_neg'), eq')
<- tcSyntaxOp orig eq [SynType pat_ty, SynAny]
@@ -538,7 +540,7 @@ tc_pat _ (NPat (L l over_lit) mb_neg eq _) pat_ty thing_inside
; res <- thing_inside
; pat_ty <- readExpType pat_ty
- ; return (NPat (L l lit') mb_neg' eq' pat_ty, res) }
+ ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
{-
Note [NPlusK patterns]
@@ -569,7 +571,8 @@ AST is used for the subtraction operation.
-}
-- See Note [NPlusK patterns]
-tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_inside
+tc_pat penv (NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus) pat_ty
+ thing_inside
= do { pat_ty <- expTypeToType pat_ty
; let orig = LiteralOrigin lit
; (lit1', ge')
@@ -598,15 +601,15 @@ tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_in
; let minus'' = minus' { syn_res_wrap =
minus_wrap <.> syn_res_wrap minus' }
- pat' = NPlusKPat (L nm_loc bndr_id) (L loc lit1') lit2'
- ge' minus'' pat_ty
+ pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
+ ge' minus''
; return (pat', res) }
-- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'.
-- Here we get rid of it and add the finalizers to the global environment.
--
-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
-tc_pat penv (SplicePat (HsSpliced mod_finalizers (HsSplicedPat pat)))
+tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat)))
pat_ty thing_inside
= do addModFinalizersWithLclEnv mod_finalizers
tc_pat penv pat pat_ty thing_inside
@@ -982,14 +985,16 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
where
tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))
(LHsRecField GhcTcId (LPat GhcTcId))
- tc_field (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel)) pat pun)) penv
+ tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) penv
thing_inside
= do { sel' <- tcLookupId sel
; pat_ty <- setSrcSpan loc $ find_field_ty sel
(occNameFS $ rdrNameOcc rdr)
; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
- ; return (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel')) pat'
+ ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat'
pun), res) }
+ tc_field (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) _ _
+ = panic "tcConArgs"
find_field_ty :: Name -> FieldLabelString -> TcM TcType
find_field_ty sel lbl
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 283127215c..2035abc1ba 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -474,14 +474,14 @@ tcPatSynMatcher (L loc name) lpat
mkHsCaseAlt lwpat fail']
body = mkLHsWrap (mkWpLet req_ev_binds) $
L (getLoc lpat) $
- HsCase (nlHsVar scrutinee) $
+ HsCase noExt (nlHsVar scrutinee) $
MG{ mg_alts = L (getLoc lpat) cases
, mg_arg_tys = [pat_ty]
, mg_res_ty = res_ty
, mg_origin = Generated
}
body' = noLoc $
- HsLam $
+ HsLam noExt $
MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr
args body]
, mg_arg_tys = [pat_ty, cont_ty, fail_ty]
@@ -515,7 +515,7 @@ mkPatSynRecSelBinds :: PatSyn
-> [FieldLabel] -- ^ Visible field labels
-> HsValBinds GhcRn
mkPatSynRecSelBinds ps fields
- = ValBindsOut selector_binds sigs
+ = XValBindsLR (NValBinds selector_binds sigs)
where
(sigs, selector_binds) = unzip (map mkRecSel fields)
mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
@@ -608,11 +608,11 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
mk_mg body = mkMatchGroup Generated [builder_match]
- where
- builder_args = [L loc (VarPat (L loc n)) | L loc n <- args]
- builder_match = mkMatch (mkPrefixFunRhs (L loc name))
- builder_args body
- (noLoc EmptyLocalBinds)
+ where
+ builder_args = [L loc (VarPat noExt (L loc n)) | L loc n <- args]
+ builder_match = mkMatch (mkPrefixFunRhs (L loc name))
+ builder_args body
+ (noLoc EmptyLocalBinds)
args = case details of
PrefixPatSyn args -> args
@@ -630,7 +630,7 @@ tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
-- monadic only for failure
tcPatSynBuilderOcc ps
| Just (builder_id, add_void_arg) <- builder
- , let builder_expr = HsConLikeOut (PatSynCon ps)
+ , let builder_expr = HsConLikeOut noExt (PatSynCon ps)
builder_ty = idType builder_id
= return $
if add_void_arg
@@ -669,14 +669,14 @@ tcPatToExpr name args pat = go pat
-> Either MsgDoc (HsExpr GhcRn)
mkPrefixConExpr lcon@(L loc _) pats
= do { exprs <- mapM go pats
- ; return (foldl (\x y -> HsApp (L loc x) y)
- (HsVar lcon) exprs) }
+ ; return (foldl (\x y -> HsApp noExt (L loc x) y)
+ (HsVar noExt lcon) exprs) }
mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)
-> Either MsgDoc (HsExpr GhcRn)
mkRecordConExpr con fields
= do { exprFields <- mapM go fields
- ; return (RecordCon con PlaceHolder noPostTcExpr exprFields) }
+ ; return (RecordCon noExt con exprFields) }
go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
go (L loc p) = L loc <$> go1 p
@@ -688,48 +688,52 @@ tcPatToExpr name args pat = go pat
InfixCon l r -> mkPrefixConExpr con [l,r]
RecCon fields -> mkRecordConExpr con fields
- go1 (SigPatIn pat _) = go1 (unLoc pat)
+ go1 (SigPat _ pat) = go1 (unLoc pat)
-- See Note [Type signatures and the builder expression]
- go1 (VarPat (L l var))
+ go1 (VarPat _ (L l var))
| var `elemNameSet` lhsVars
- = return $ HsVar (L l var)
+ = return $ HsVar noExt (L l var)
| otherwise
= Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
- go1 (ParPat pat) = fmap HsPar $ go pat
- go1 (PArrPat pats ptt) = do { exprs <- mapM go pats
- ; return $ ExplicitPArr ptt exprs }
- go1 p@(ListPat pats ptt reb)
- | Nothing <- reb = do { exprs <- mapM go pats
- ; return $ ExplicitList ptt Nothing exprs }
+ go1 (ParPat _ pat) = fmap (HsPar noExt) $ go pat
+ go1 (PArrPat _ pats) = do { exprs <- mapM go pats
+ ; return $ ExplicitPArr noExt exprs }
+ go1 p@(ListPat _ pats _ty reb)
+ | Nothing <- reb = do { exprs <- mapM go pats
+ ; return $ ExplicitList noExt Nothing exprs }
| otherwise = notInvertibleListPat p
- go1 (TuplePat pats box _) = do { exprs <- mapM go pats
- ; return $ ExplicitTuple
- (map (noLoc . Present) exprs) box }
- go1 (SumPat pat alt arity _) = do { expr <- go1 (unLoc pat)
- ; return $ ExplicitSum alt arity (noLoc expr) PlaceHolder
+ go1 (TuplePat _ pats box) = do { exprs <- mapM go pats
+ ; return $ ExplicitTuple noExt
+ (map (noLoc . (Present noExt)) exprs)
+ box }
+ go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat)
+ ; return $ ExplicitSum noExt alt arity
+ (noLoc expr)
}
- go1 (LitPat lit) = return $ HsLit lit
- go1 (NPat (L _ n) mb_neg _ _)
- | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)]
- | otherwise = return $ HsOverLit n
+ go1 (LitPat _ lit) = return $ HsLit noExt lit
+ go1 (NPat _ (L _ n) mb_neg _)
+ | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg
+ [noLoc (HsOverLit noExt n)]
+ | otherwise = return $ HsOverLit noExt n
go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
- go1 (SigPatOut{}) = panic "SigPatOut in output of renamer"
go1 (CoPat{}) = panic "CoPat in output of renamer"
- go1 (SplicePat (HsSpliced _ (HsSplicedPat pat)))
+ go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
= go1 pat
- go1 (SplicePat (HsSpliced{})) = panic "Invalid splice variety"
+ go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
-- The following patterns are not invertible.
- go1 p@(BangPat {}) = notInvertible p -- #14112
- go1 p@(LazyPat {}) = notInvertible p
- go1 p@(WildPat {}) = notInvertible p
- go1 p@(AsPat {}) = notInvertible p
- go1 p@(ViewPat {}) = notInvertible p
- go1 p@(NPlusKPat {}) = notInvertible p
- go1 p@(SplicePat (HsTypedSplice {})) = notInvertible p
- go1 p@(SplicePat (HsUntypedSplice {})) = notInvertible p
- go1 p@(SplicePat (HsQuasiQuote {})) = notInvertible p
+ go1 p@(BangPat {}) = notInvertible p -- #14112
+ go1 p@(LazyPat {}) = notInvertible p
+ go1 p@(WildPat {}) = notInvertible p
+ go1 p@(AsPat {}) = notInvertible p
+ go1 p@(ViewPat {}) = notInvertible p
+ go1 p@(NPlusKPat {}) = notInvertible p
+ go1 p@(XPat {}) = notInvertible p
+ go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p
+ go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
+ go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p
+ go1 p@(SplicePat _ (XSplice {})) = notInvertible p
notInvertible p = Left (not_invertible_msg p)
@@ -841,39 +845,41 @@ tcCheckPatSynPat = go
go1 :: Pat GhcRn -> TcM ()
-- See Note [Bad patterns]
- go1 p@(AsPat _ _) = asPatInPatSynErr p
- go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p
-
- go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info)
- go1 VarPat{} = return ()
- go1 WildPat{} = return ()
- go1 (LazyPat pat) = go pat
- go1 (ParPat pat) = go pat
- go1 (BangPat pat) = go pat
- go1 (PArrPat pats _) = mapM_ go pats
- go1 (ListPat pats _ _) = mapM_ go pats
- go1 (TuplePat pats _ _) = mapM_ go pats
- go1 (SumPat pat _ _ _) = go pat
- go1 LitPat{} = return ()
- go1 NPat{} = return ()
- go1 (SigPatIn pat _) = go pat
- go1 (ViewPat _ pat _) = go pat
- go1 (SplicePat splice)
- | HsSpliced mod_finalizers (HsSplicedPat pat) <- splice
+ go1 p@(AsPat _ _ _) = asPatInPatSynErr p
+ go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p
+
+ go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info)
+ go1 VarPat{} = return ()
+ go1 WildPat{} = return ()
+ go1 (LazyPat _ pat) = go pat
+ go1 (ParPat _ pat) = go pat
+ go1 (BangPat _ pat) = go pat
+ go1 (PArrPat _ pats) = mapM_ go pats
+ go1 (ListPat _ pats _ _) = mapM_ go pats
+ go1 (TuplePat _ pats _) = mapM_ go pats
+ go1 (SumPat _ pat _ _) = go pat
+ go1 LitPat{} = return ()
+ go1 NPat{} = return ()
+ go1 (SigPat _ pat) = go pat
+ go1 (ViewPat _ _ pat) = go pat
+ go1 (SplicePat _ splice)
+ | HsSpliced _ mod_finalizers (HsSplicedPat pat) <- splice
= do addModFinalizersWithLclEnv mod_finalizers
go1 pat
| otherwise = panic "non-pattern from spliced thing"
go1 ConPatOut{} = panic "ConPatOut in output of renamer"
- go1 SigPatOut{} = panic "SigPatOut in output of renamer"
go1 CoPat{} = panic "CoPat in output of renamer"
+ go1 XPat{} = panic "XPat in output of renamer"
-asPatInPatSynErr :: (SourceTextX p, OutputableBndrId p) => Pat p -> TcM a
+asPatInPatSynErr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Pat (GhcPass p) -> TcM a
asPatInPatSynErr pat
= failWithTc $
hang (text "Pattern synonym definition cannot contain as-patterns (@):")
2 (ppr pat)
-nPlusKPatInPatSynErr :: (SourceTextX p, OutputableBndrId p) => Pat p -> TcM a
+nPlusKPatInPatSynErr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Pat (GhcPass p) -> TcM a
nPlusKPatInPatSynErr pat
= failWithTc $
hang (text "Pattern synonym definition cannot contain n+k-pattern:")
@@ -919,20 +925,20 @@ tcCollectEx pat = go pat
go = go1 . unLoc
go1 :: Pat GhcTc -> ([TyVar], [EvVar])
- go1 (LazyPat p) = go p
- go1 (AsPat _ p) = go p
- go1 (ParPat p) = go p
- go1 (BangPat p) = go p
- go1 (ListPat ps _ _) = mergeMany . map go $ ps
- go1 (TuplePat ps _ _) = mergeMany . map go $ ps
- go1 (SumPat p _ _ _) = go p
- go1 (PArrPat ps _) = mergeMany . map go $ ps
- go1 (ViewPat _ p _) = go p
- go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $
+ go1 (LazyPat _ p) = go p
+ go1 (AsPat _ _ p) = go p
+ go1 (ParPat _ p) = go p
+ go1 (BangPat _ p) = go p
+ go1 (ListPat _ ps _ _) = mergeMany . map go $ ps
+ go1 (TuplePat _ ps _) = mergeMany . map go $ ps
+ go1 (SumPat _ p _ _) = go p
+ go1 (PArrPat _ ps) = mergeMany . map go $ ps
+ go1 (ViewPat _ _ p) = go p
+ go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $
goConDetails $ pat_args con
- go1 (SigPatOut p _) = go p
- go1 (CoPat _ p _) = go1 p
- go1 (NPlusKPat n k _ geq subtract _)
+ go1 (SigPat _ p) = go p
+ go1 (CoPat _ _ p _) = go1 p
+ go1 (NPlusKPat _ n k _ geq subtract)
= pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
go1 _ = empty
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index fd63effbe6..58fb78be14 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -13,6 +13,7 @@ https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
module TcRnDriver (
tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,
@@ -576,7 +577,8 @@ tcRnHsBootDecls hsc_src decls
, hs_ruleds = rule_decls
, hs_vects = vect_decls
, hs_annds = _
- , hs_valds = ValBindsOut val_binds val_sigs })
+ , hs_valds
+ = XValBindsLR (NValBinds val_binds val_sigs) })
<- rnTopSrcDecls first_group
-- The empty list is for extra dependencies coming from .hs-boot files
-- See Note [Extra dependencies from .hs-boot files] in RnSource
@@ -1322,7 +1324,8 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
hs_annds = annotation_decls,
hs_ruleds = rule_decls,
hs_vects = vect_decls,
- hs_valds = hs_val_binds@(ValBindsOut val_binds val_sigs) })
+ hs_valds = hs_val_binds@(XValBindsLR
+ (NValBinds val_binds val_sigs)) })
= do { -- Type-check the type and class decls, and all imported decls
-- The latter come in via tycl_decls
traceTc "Tc2 (src)" empty ;
@@ -1330,7 +1333,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc "Tc3" empty ;
- (tcg_env, inst_infos, ValBindsOut deriv_binds deriv_sigs)
+ (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))
<- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
setGblEnv tcg_env $ do {
@@ -1675,7 +1678,7 @@ check_main dflags tcg_env explicit_mod_hdr
; (ev_binds, main_expr)
<- checkConstraints skol_info [] [] $
addErrCtxt mainCtxt $
- tcMonoExpr (L loc (HsVar (L loc main_name)))
+ tcMonoExpr (L loc (HsVar noExt (L loc main_name)))
(mkCheckExpType io_ty)
-- See Note [Root-main Id]
@@ -1995,15 +1998,16 @@ tcUserStmt (L loc (BodyStmt expr _ _ _))
-- (if we are at a breakpoint, say). We must put those free vars
-- [let it = expr]
- let_stmt = L loc $ LetStmt $ noLoc $ HsValBinds $
- ValBindsOut [(NonRecursive,unitBag the_bind)] []
+ let_stmt = L loc $ LetStmt $ noLoc $ HsValBinds $ XValBindsLR
+ (NValBinds [(NonRecursive,unitBag the_bind)] [])
-- [it <- e]
- bind_stmt = L loc $ BindStmt (L loc (VarPat (L loc fresh_it)))
- (nlHsApp ghciStep rn_expr)
- (mkRnSyntaxExpr bindIOName)
- noSyntaxExpr
- PlaceHolder
+ bind_stmt = L loc $ BindStmt
+ (L loc (VarPat noExt (L loc fresh_it)))
+ (nlHsApp ghciStep rn_expr)
+ (mkRnSyntaxExpr bindIOName)
+ noSyntaxExpr
+ placeHolder
-- [; print it]
print_it = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it))
@@ -2120,7 +2124,8 @@ tcGhciStmts stmts
-- get their *polymorphic* values. (And we'd get ambiguity errs
-- if they were overloaded, since they aren't applied to anything.)
ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
- (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ;
+ (noLoc $ ExplicitList unitTy Nothing
+ (map mk_item ids)) ;
mk_item id = let ty_args = [idType id, unitTy] in
nlHsApp (nlHsTyApp unsafeCoerceId
(map getRuntimeRep ty_args ++ ty_args))
@@ -2128,7 +2133,7 @@ tcGhciStmts stmts
stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
} ;
return (ids, mkHsDictLet (EvBinds const_binds) $
- noLoc (HsDo GhciStmtCtxt (noLoc stmts) io_ret_ty))
+ noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts)))
}
-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
@@ -2139,13 +2144,15 @@ getGhciStepIO = do
let ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
- step_ty = noLoc $ HsForAllTy { hst_bndrs = [noLoc $ UserTyVar (noLoc a_tv)]
- , hst_body = nlHsFunTy ghciM ioM }
+ step_ty = noLoc $ HsForAllTy
+ { hst_bndrs = [noLoc $ UserTyVar noExt (noLoc a_tv)]
+ , hst_xforall = noExt
+ , hst_body = nlHsFunTy ghciM ioM }
stepTy :: LHsSigWcType GhcRn
stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)
- return (noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy)
+ return (noLoc $ ExprWithTySig stepTy (nlHsVar ghciStepIoMName))
isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)
isGHCiMonad hsc_env ty
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 5f7498fa16..7e347ffe2c 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -3380,58 +3380,57 @@ lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin
lexprCtOrigin (L _ e) = exprCtOrigin e
exprCtOrigin :: HsExpr GhcRn -> CtOrigin
-exprCtOrigin (HsVar (L _ name)) = OccurrenceOf name
-exprCtOrigin (HsUnboundVar uv) = UnboundOccurrenceOf (unboundVarOcc uv)
-exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut"
-exprCtOrigin (HsRecFld f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)
-exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l
-exprCtOrigin (HsIPVar ip) = IPOccOrigin ip
-exprCtOrigin (HsOverLit lit) = LiteralOrigin lit
-exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal"
-exprCtOrigin (HsLam matches) = matchesCtOrigin matches
-exprCtOrigin (HsLamCase ms) = matchesCtOrigin ms
-exprCtOrigin (HsApp e1 _) = lexprCtOrigin e1
-exprCtOrigin (HsAppType e1 _) = lexprCtOrigin e1
-exprCtOrigin (HsAppTypeOut {}) = panic "exprCtOrigin HsAppTypeOut"
-exprCtOrigin (OpApp _ op _ _) = lexprCtOrigin op
-exprCtOrigin (NegApp e _) = lexprCtOrigin e
-exprCtOrigin (HsPar e) = lexprCtOrigin e
-exprCtOrigin (SectionL _ _) = SectionOrigin
-exprCtOrigin (SectionR _ _) = SectionOrigin
-exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"
-exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum"
-exprCtOrigin (HsCase _ matches) = matchesCtOrigin matches
-exprCtOrigin (HsIf (Just syn) _ _ _) = exprCtOrigin (syn_expr syn)
-exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression"
-exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs
-exprCtOrigin (HsLet _ e) = lexprCtOrigin e
-exprCtOrigin (HsDo _ _ _) = DoOrigin
-exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list"
-exprCtOrigin (ExplicitPArr {}) = Shouldn'tHappenOrigin "parallel array"
-exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction"
-exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update"
-exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin
-exprCtOrigin (ExprWithTySigOut {}) = panic "exprCtOrigin ExprWithTySigOut"
-exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence"
-exprCtOrigin (PArrSeq {}) = Shouldn'tHappenOrigin "parallel array sequence"
-exprCtOrigin (HsSCC _ _ e) = lexprCtOrigin e
-exprCtOrigin (HsCoreAnn _ _ e) = lexprCtOrigin e
-exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket"
+exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name
+exprCtOrigin (HsUnboundVar _ uv) = UnboundOccurrenceOf (unboundVarOcc uv)
+exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut"
+exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)
+exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l
+exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip
+exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit
+exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal"
+exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches
+exprCtOrigin (HsLamCase _ ms) = matchesCtOrigin ms
+exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1
+exprCtOrigin (HsAppType _ e1) = lexprCtOrigin e1
+exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op
+exprCtOrigin (NegApp _ e _) = lexprCtOrigin e
+exprCtOrigin (HsPar _ e) = lexprCtOrigin e
+exprCtOrigin (SectionL _ _ _) = SectionOrigin
+exprCtOrigin (SectionR _ _ _) = SectionOrigin
+exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"
+exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum"
+exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches
+exprCtOrigin (HsIf _ (Just syn) _ _ _) = exprCtOrigin (syn_expr syn)
+exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression"
+exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs
+exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e
+exprCtOrigin (HsDo {}) = DoOrigin
+exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list"
+exprCtOrigin (ExplicitPArr {}) = Shouldn'tHappenOrigin "parallel array"
+exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction"
+exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update"
+exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin
+exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence"
+exprCtOrigin (PArrSeq {}) = Shouldn'tHappenOrigin "parallel array sequence"
+exprCtOrigin (HsSCC _ _ _ e) = lexprCtOrigin e
+exprCtOrigin (HsCoreAnn _ _ _ e) = lexprCtOrigin e
+exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket"
exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut"
exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut"
-exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice"
-exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
-exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
-exprCtOrigin (HsArrApp {}) = panic "exprCtOrigin HsArrApp"
-exprCtOrigin (HsArrForm {}) = panic "exprCtOrigin HsArrForm"
-exprCtOrigin (HsTick _ e) = lexprCtOrigin e
-exprCtOrigin (HsBinTick _ _ e) = lexprCtOrigin e
-exprCtOrigin (HsTickPragma _ _ _ e) = lexprCtOrigin e
-exprCtOrigin EWildPat = panic "exprCtOrigin EWildPat"
+exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice"
+exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
+exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
+exprCtOrigin (HsArrApp {}) = panic "exprCtOrigin HsArrApp"
+exprCtOrigin (HsArrForm {}) = panic "exprCtOrigin HsArrForm"
+exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e
+exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e
+exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e
+exprCtOrigin (EWildPat {}) = panic "exprCtOrigin EWildPat"
exprCtOrigin (EAsPat {}) = panic "exprCtOrigin EAsPat"
exprCtOrigin (EViewPat {}) = panic "exprCtOrigin EViewPat"
exprCtOrigin (ELazyPat {}) = panic "exprCtOrigin ELazyPat"
exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap"
+exprCtOrigin (XExpr {}) = panic "exprCtOrigin XExpr"
-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 45e18e69fe..1543b7f085 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -161,7 +161,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
-- See Note [How brackets and nested splices are handled]
-- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
-tcTypedBracket rn_expr brack@(TExpBr expr) res_ty
+tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
= addErrCtxt (quotationCtxtDoc brack) $
do { cur_stage <- getStage
; ps_ref <- newMutVar []
@@ -182,7 +182,7 @@ tcTypedBracket rn_expr brack@(TExpBr expr) res_ty
; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
rn_expr
(unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
- (noLoc (HsTcBracketOut brack ps'))))
+ (noLoc (HsTcBracketOut noExt brack ps'))))
meta_ty res_ty }
tcTypedBracket _ other_brack _
= pprPanic "tcTypedBracket" (ppr other_brack)
@@ -194,17 +194,19 @@ tcUntypedBracket rn_expr brack ps res_ty
; meta_ty <- tcBrackTy brack
; traceTc "tc_bracket done untyped" (ppr meta_ty)
; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket")
- rn_expr (HsTcBracketOut brack ps') meta_ty res_ty }
+ rn_expr (HsTcBracketOut noExt brack ps') meta_ty res_ty }
---------------
tcBrackTy :: HsBracket GhcRn -> TcM TcType
-tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
-tcBrackTy (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp)
-tcBrackTy (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
-tcBrackTy (DecBrG _) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
-tcBrackTy (PatBr _) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat)
-tcBrackTy (DecBrL _) = panic "tcBrackTy: Unexpected DecBrL"
-tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr"
+tcBrackTy (VarBr {}) = tcMetaTy nameTyConName
+ -- Result type is Var (not Q-monadic)
+tcBrackTy (ExpBr {}) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp)
+tcBrackTy (TypBr {}) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
+tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
+tcBrackTy (PatBr {}) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat)
+tcBrackTy (DecBrL {}) = panic "tcBrackTy: Unexpected DecBrL"
+tcBrackTy (TExpBr {}) = panic "tcUntypedBracket: Unexpected TExpBr"
+tcBrackTy (XBracket {}) = panic "tcUntypedBracket: Unexpected XBracket"
---------------
tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
@@ -432,7 +434,7 @@ When a variable is used, we compare
************************************************************************
-}
-tcSpliceExpr splice@(HsTypedSplice _ name expr) res_ty
+tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty
= addErrCtxt (spliceCtxtDoc splice) $
setSrcSpan (getLoc expr) $ do
{ stage <- getStage
@@ -582,8 +584,9 @@ runAnnotation target expr = do
; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
; let specialised_to_annotation_wrapper_expr
= L loc (mkHsWrap wrapper
- (HsVar (L loc to_annotation_wrapper_id)))
- ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
+ (HsVar noExt (L loc to_annotation_wrapper_id)))
+ ; return (L loc (HsApp noExt
+ specialised_to_annotation_wrapper_expr expr')) }
-- Run the appropriately wrapped expression to get the value of
-- the annotation and its dictionaries. The return value is of
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 97981836ae..b0b90d910f 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -526,9 +526,9 @@ getInitialKind decl@(SynDecl { tcdLName = L _ name
where
-- Keep this synchronized with 'hsDeclHasCusk'.
kind_annotation (L _ ty) = case ty of
- HsParTy lty -> kind_annotation lty
- HsKindSig _ k -> Just k
- _ -> Nothing
+ HsParTy _ lty -> kind_annotation lty
+ HsKindSig _ _ k -> Just k
+ _ -> Nothing
---------------------------------
getFamDeclInitialKinds :: Maybe Bool -- if assoc., CUSKness of assoc. class
@@ -548,8 +548,8 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name
= do { (tycon, _) <-
kcHsTyVarBndrs name flav cusk True ktvs $
do { res_k <- case resultSig of
- KindSig ki -> tcLHsKindSig ki
- TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKindSig ki
+ KindSig ki -> tcLHsKindSig ki
+ TyVarSig (L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ki
_ -- open type families have * return kind by default
| tcFlavourIsOpen flav -> return liftedTypeKind
-- closed type families have their return kind inferred
@@ -1403,7 +1403,7 @@ tc_fam_ty_pats tc_fam_tc mb_clsinfo tv_names arg_pats
-- See Note [Quantifying over family patterns]
; (arg_tvs, (args, stuff)) <- tcImplicitTKBndrs tv_names $
do { let loc = nameSrcSpan name
- lhs_fun = L loc (HsTyVar NotPromoted (L loc name))
+ lhs_fun = L loc (HsTyVar noExt NotPromoted (L loc name))
fun_ty = mkTyConApp tc_fam_tc []
fun_kind = tyConKind tc_fam_tc
mb_kind_env = thdOf3 <$> mb_clsinfo
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 6b77cc7b7b..7d8a004041 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -827,7 +827,7 @@ mkRecSelBinds :: [TyCon] -> HsValBinds GhcRn
-- This makes life easier, because the later type checking will add
-- all necessary type abstractions and applications
mkRecSelBinds tycons
- = ValBindsOut binds sigs
+ = XValBindsLR (NValBinds binds sigs)
where
(sigs, binds) = unzip rec_sels
rec_sels = map mkRecSelBind [ (tc,fld)
@@ -882,13 +882,14 @@ mkOneRecordSelector all_cons idDetails fl
| otherwise = map mk_match cons_w_field ++ deflt
mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
[L loc (mk_sel_pat con)]
- (L loc (HsVar (L loc field_var)))
+ (L loc (HsVar noExt (L loc field_var)))
mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
rec_field = noLoc (HsRecField
{ hsRecFieldLbl
- = L loc (FieldOcc (L loc $ mkVarUnqual lbl) sel_name)
- , hsRecFieldArg = L loc (VarPat (L loc field_var))
+ = L loc (FieldOcc sel_name (L loc $ mkVarUnqual lbl))
+ , hsRecFieldArg
+ = L loc (VarPat noExt (L loc field_var))
, hsRecPun = False })
sel_lname = L loc sel_name
field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
@@ -898,10 +899,10 @@ mkOneRecordSelector all_cons idDetails fl
-- mentions this particular record selector
deflt | all dealt_with all_cons = []
| otherwise = [mkSimpleMatch CaseAlt
- [L loc (WildPat placeHolderType)]
- (mkHsApp (L loc (HsVar
+ [L loc (WildPat noExt)]
+ (mkHsApp (L loc (HsVar noExt
(L loc (getName rEC_SEL_ERROR_ID))))
- (L loc (HsLit msg_lit)))]
+ (L loc (HsLit noExt msg_lit)))]
-- Do not add a default case unless there are unmatched
-- constructors. We must take account of GADTs, else we
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 01c8505562..0fccffa229 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -1514,7 +1514,7 @@ defineMacro overwrite s = do
body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
`mkHsApp` (nlHsPar expr)
tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)
- new_expr = L (getLoc expr) $ ExprWithTySig body tySig
+ new_expr = L (getLoc expr) $ ExprWithTySig tySig body
hv <- GHC.compileParsedExprRemote new_expr
let newCmd = Command { cmdName = macro_name
@@ -1578,7 +1578,7 @@ getGhciStepIO = do
ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
body = nlHsVar (getRdrName ghciStepIoMName)
tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)
- return $ noLoc $ ExprWithTySig body tySig
+ return $ noLoc $ ExprWithTySig tySig body
-----------------------------------------------------------------------------
-- :check
diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs
index fd8749a3e1..bd555916a2 100644
--- a/ghc/GHCi/UI/Info.hs
+++ b/ghc/GHCi/UI/Info.hs
@@ -321,19 +321,19 @@ processAllTypeCheckedModule tcm = do
return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe
where
mid :: Maybe Id
- mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just i
- | otherwise = Nothing
+ mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i
+ | otherwise = Nothing
- unwrapVar (HsWrap _ var) = var
- unwrapVar e' = e'
+ unwrapVar (HsWrap _ _ var) = var
+ unwrapVar e' = e'
-- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's
getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
getTypeLPat (L spn pat) =
pure (Just (getMaybeId pat,spn,hsPatType pat))
where
- getMaybeId (VarPat (L _ vid)) = Just vid
- getMaybeId _ = Nothing
+ getMaybeId (VarPat _ (L _ vid)) = Just vid
+ getMaybeId _ = Nothing
-- | Get ALL source spans in the source.
listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]
diff --git a/testsuite/tests/ghc-api/annotations/parseTree.hs b/testsuite/tests/ghc-api/annotations/parseTree.hs
index 3a8a29abd4..b04be775c3 100644
--- a/testsuite/tests/ghc-api/annotations/parseTree.hs
+++ b/testsuite/tests/ghc-api/annotations/parseTree.hs
@@ -51,8 +51,10 @@ testOneFile libdir fileName = do
gq ast = everything (++) ([] `mkQ` doLHsTupArg) ast
doLHsTupArg :: LHsTupArg GhcPs -> [(SrcSpan,String,HsExpr GhcPs)]
- doLHsTupArg (L l arg@(Present _)) = [(l,"p",ExplicitTuple [L l arg] Boxed)]
- doLHsTupArg (L l arg@(Missing _)) = [(l,"m",ExplicitTuple [L l arg] Boxed)]
+ doLHsTupArg (L l arg@(Present {}))
+ = [(l,"p",ExplicitTuple noExt [L l arg] Boxed)]
+ doLHsTupArg (L l arg@(Missing {}))
+ = [(l,"m",ExplicitTuple noExt [L l arg] Boxed)]
showAnns anns = "[\n" ++ (intercalate "\n"
diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs
index b89911d6c7..4089d4a88a 100644
--- a/testsuite/tests/ghc-api/annotations/stringSource.hs
+++ b/testsuite/tests/ghc-api/annotations/stringSource.hs
@@ -80,9 +80,9 @@ testOneFile libdir fileName = do
doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])]
doHsExpr :: HsExpr GhcPs -> [(String,[Located (SourceText,FastString)])]
- doHsExpr (HsCoreAnn src ss _) = [("co",[conv (noLoc ss)])]
- doHsExpr (HsSCC src ss _) = [("sc",[conv (noLoc ss)])]
- doHsExpr (HsTickPragma src (ss,_,_) _ss2 _) = [("tp",[conv (noLoc ss)])]
+ doHsExpr (HsCoreAnn _ src ss _) = [("co",[conv (noLoc ss)])]
+ doHsExpr (HsSCC _ src ss _) = [("sc",[conv (noLoc ss)])]
+ doHsExpr (HsTickPragma _ src (ss,_,_) _ss2 _) = [("tp",[conv (noLoc ss)])]
doHsExpr _ = []
conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs)
diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs
index 4b8119459b..40d23b5712 100644
--- a/testsuite/tests/ghc-api/annotations/t11430.hs
+++ b/testsuite/tests/ghc-api/annotations/t11430.hs
@@ -67,7 +67,7 @@ testOneFile libdir fileName = do
doRuleDecl (HsRule _ _ _ _ _ _ _) = []
doHsExpr :: HsExpr GhcPs -> [(String,[String])]
- doHsExpr (HsTickPragma src (_,_,_) ss _) = [("tp",[show ss])]
+ doHsExpr (HsTickPragma _ src (_,_,_) ss _) = [("tp",[show ss])]
doHsExpr _ = []
doInline (InlinePragma _ _ _ (ActiveBefore (SourceText ss) _) _)
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
index 46ab21412e..b80ab62507 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -49,6 +49,7 @@
(PrefixCon
[({ DumpParsedAst.hs:5:26-30 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpParsedAst.hs:5:26-30 }
(Unqual
@@ -73,25 +74,32 @@
{OccName: Length}))
[({ DumpParsedAst.hs:8:10-17 }
(HsParTy
+ (PlaceHolder)
({ DumpParsedAst.hs:8:11-16 }
(HsAppsTy
+ (PlaceHolder)
[({ DumpParsedAst.hs:8:11 }
(HsAppPrefix
+ (PlaceHolder)
({ DumpParsedAst.hs:8:11 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpParsedAst.hs:8:11 }
(Unqual
{OccName: a}))))))
,({ DumpParsedAst.hs:8:13 }
(HsAppInfix
+ (PlaceHolder)
({ DumpParsedAst.hs:8:13 }
(Exact
{Name: :}))))
,({ DumpParsedAst.hs:8:15-16 }
(HsAppPrefix
+ (PlaceHolder)
({ DumpParsedAst.hs:8:15-16 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpParsedAst.hs:8:15-16 }
(Unqual
@@ -99,32 +107,42 @@
(Prefix)
({ DumpParsedAst.hs:8:21-36 }
(HsAppsTy
+ (PlaceHolder)
[({ DumpParsedAst.hs:8:21-24 }
(HsAppPrefix
+ (PlaceHolder)
({ DumpParsedAst.hs:8:21-24 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpParsedAst.hs:8:21-24 }
(Unqual
{OccName: Succ}))))))
,({ DumpParsedAst.hs:8:26-36 }
(HsAppPrefix
+ (PlaceHolder)
({ DumpParsedAst.hs:8:26-36 }
(HsParTy
+ (PlaceHolder)
({ DumpParsedAst.hs:8:27-35 }
(HsAppsTy
+ (PlaceHolder)
[({ DumpParsedAst.hs:8:27-32 }
(HsAppPrefix
+ (PlaceHolder)
({ DumpParsedAst.hs:8:27-32 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpParsedAst.hs:8:27-32 }
(Unqual
{OccName: Length}))))))
,({ DumpParsedAst.hs:8:34-35 }
(HsAppPrefix
+ (PlaceHolder)
({ DumpParsedAst.hs:8:34-35 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpParsedAst.hs:8:34-35 }
(Unqual
@@ -139,16 +157,19 @@
{OccName: Length}))
[({ DumpParsedAst.hs:9:10-12 }
(HsExplicitListTy
- (Promoted)
(PlaceHolder)
+ (Promoted)
[]))]
(Prefix)
({ DumpParsedAst.hs:9:21-24 }
(HsAppsTy
+ (PlaceHolder)
[({ DumpParsedAst.hs:9:21-24 }
(HsAppPrefix
+ (PlaceHolder)
({ DumpParsedAst.hs:9:21-24 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpParsedAst.hs:9:21-24 }
(Unqual
@@ -161,21 +182,28 @@
(PlaceHolder)
[({ DumpParsedAst.hs:7:20-30 }
(KindedTyVar
+ (PlaceHolder)
({ DumpParsedAst.hs:7:21-22 }
(Unqual
{OccName: as}))
({ DumpParsedAst.hs:7:27-29 }
(HsAppsTy
+ (PlaceHolder)
[({ DumpParsedAst.hs:7:27-29 }
(HsAppPrefix
+ (PlaceHolder)
({ DumpParsedAst.hs:7:27-29 }
(HsListTy
+ (PlaceHolder)
({ DumpParsedAst.hs:7:28 }
(HsAppsTy
+ (PlaceHolder)
[({ DumpParsedAst.hs:7:28 }
(HsAppPrefix
+ (PlaceHolder)
({ DumpParsedAst.hs:7:28 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpParsedAst.hs:7:28 }
(Unqual
@@ -186,10 +214,13 @@
(KindSig
({ DumpParsedAst.hs:7:35-39 }
(HsAppsTy
+ (PlaceHolder)
[({ DumpParsedAst.hs:7:35-39 }
(HsAppPrefix
+ (PlaceHolder)
({ DumpParsedAst.hs:7:35-39 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpParsedAst.hs:7:35-39 }
(Unqual
@@ -218,13 +249,16 @@
[]
({ DumpParsedAst.hs:11:8-23 }
(HsApp
+ (PlaceHolder)
({ DumpParsedAst.hs:11:8-15 }
(HsVar
+ (PlaceHolder)
({ DumpParsedAst.hs:11:8-15 }
(Unqual
{OccName: putStrLn}))))
({ DumpParsedAst.hs:11:17-23 }
(HsLit
+ (PlaceHolder)
(HsString
(SourceText
"\"hello\"")
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index c7daf90ff0..fbc30626fa 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -4,50 +4,54 @@
(Just
((,,,)
(HsGroup
- (ValBindsOut
- [((,)
- (NonRecursive)
- {Bag(Located (HsBind Name)):
- [({ DumpRenamedAst.hs:18:1-23 }
- (FunBind
- ({ DumpRenamedAst.hs:18:1-4 }
- {Name: DumpRenamedAst.main})
- (MG
- ({ DumpRenamedAst.hs:18:1-23 }
- [({ DumpRenamedAst.hs:18:1-23 }
- (Match
- (FunRhs
- ({ DumpRenamedAst.hs:18:1-4 }
- {Name: DumpRenamedAst.main})
- (Prefix)
- (NoSrcStrict))
- []
- (GRHSs
- [({ DumpRenamedAst.hs:18:6-23 }
- (GRHS
- []
- ({ DumpRenamedAst.hs:18:8-23 }
- (HsApp
- ({ DumpRenamedAst.hs:18:8-15 }
- (HsVar
- ({ DumpRenamedAst.hs:18:8-15 }
- {Name: System.IO.putStrLn})))
- ({ DumpRenamedAst.hs:18:17-23 }
- (HsLit
- (HsString
- (SourceText
- "\"hello\"")
- {FastString: "hello"})))))))]
- ({ <no location info> }
- (EmptyLocalBinds)))))])
- []
- (PlaceHolder)
- (FromSource))
- (WpHole)
- {NameSet:
- []}
- []))]})]
- [])
+ (XValBindsLR
+ (NValBinds
+ [((,)
+ (NonRecursive)
+ {Bag(Located (HsBind Name)):
+ [({ DumpRenamedAst.hs:18:1-23 }
+ (FunBind
+ ({ DumpRenamedAst.hs:18:1-4 }
+ {Name: DumpRenamedAst.main})
+ (MG
+ ({ DumpRenamedAst.hs:18:1-23 }
+ [({ DumpRenamedAst.hs:18:1-23 }
+ (Match
+ (FunRhs
+ ({ DumpRenamedAst.hs:18:1-4 }
+ {Name: DumpRenamedAst.main})
+ (Prefix)
+ (NoSrcStrict))
+ []
+ (GRHSs
+ [({ DumpRenamedAst.hs:18:6-23 }
+ (GRHS
+ []
+ ({ DumpRenamedAst.hs:18:8-23 }
+ (HsApp
+ (PlaceHolder)
+ ({ DumpRenamedAst.hs:18:8-15 }
+ (HsVar
+ (PlaceHolder)
+ ({ DumpRenamedAst.hs:18:8-15 }
+ {Name: System.IO.putStrLn})))
+ ({ DumpRenamedAst.hs:18:17-23 }
+ (HsLit
+ (PlaceHolder)
+ (HsString
+ (SourceText
+ "\"hello\"")
+ {FastString: "hello"})))))))]
+ ({ <no location info> }
+ (EmptyLocalBinds)))))])
+ []
+ (PlaceHolder)
+ (FromSource))
+ (WpHole)
+ {NameSet:
+ []}
+ []))]})]
+ []))
[]
[(TyClGroup
[({ DumpRenamedAst.hs:6:1-30 }
@@ -88,6 +92,7 @@
(PrefixCon
[({ DumpRenamedAst.hs:6:26-30 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:6:26-30 }
{Name: DumpRenamedAst.Peano})))])
@@ -114,10 +119,13 @@
{Name: DumpRenamedAst.Length})
[({ DumpRenamedAst.hs:9:10-17 }
(HsParTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:9:11-16 }
(HsOpTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:9:11 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:9:11 }
{Name: a})))
@@ -125,28 +133,35 @@
{Name: :})
({ DumpRenamedAst.hs:9:15-16 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:9:15-16 }
{Name: as})))))))]
(Prefix)
({ DumpRenamedAst.hs:9:21-36 }
(HsAppTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:9:21-24 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:9:21-24 }
{Name: DumpRenamedAst.Succ})))
({ DumpRenamedAst.hs:9:26-36 }
(HsParTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:9:27-35 }
(HsAppTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:9:27-32 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:9:27-32 }
{Name: DumpRenamedAst.Length})))
({ DumpRenamedAst.hs:9:34-35 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:9:34-35 }
{Name: as}))))))))))
@@ -159,12 +174,13 @@
{Name: DumpRenamedAst.Length})
[({ DumpRenamedAst.hs:10:10-12 }
(HsExplicitListTy
- (Promoted)
(PlaceHolder)
+ (Promoted)
[]))]
(Prefix)
({ DumpRenamedAst.hs:10:21-24 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:10:21-24 }
{Name: DumpRenamedAst.Zero}))))
@@ -175,12 +191,15 @@
[{Name: k}]
[({ DumpRenamedAst.hs:8:20-30 }
(KindedTyVar
+ (PlaceHolder)
({ DumpRenamedAst.hs:8:21-22 }
{Name: as})
({ DumpRenamedAst.hs:8:27-29 }
(HsListTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:8:28 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:8:28 }
{Name: k})))))))]
@@ -191,6 +210,7 @@
(KindSig
({ DumpRenamedAst.hs:8:35-39 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:8:35-39 }
{Name: DumpRenamedAst.Peano})))))
@@ -214,20 +234,25 @@
(KindSig
({ DumpRenamedAst.hs:12:20-30 }
(HsFunTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:12:20 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:12:20 }
{Name: k})))
({ DumpRenamedAst.hs:12:25-30 }
(HsFunTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:12:25 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:12:25 }
{Name: k})))
({ DumpRenamedAst.hs:12:30 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:12:30 }
{Name: GHC.Types.*})))))))))
@@ -244,20 +269,25 @@
{Name: DumpRenamedAst.Nat})
[({ DumpRenamedAst.hs:15:22-34 }
(HsKindSig
+ (PlaceHolder)
({ DumpRenamedAst.hs:15:23 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:15:23 }
{Name: a})))
({ DumpRenamedAst.hs:15:28-33 }
(HsFunTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:15:28 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:15:28 }
{Name: k})))
({ DumpRenamedAst.hs:15:33 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:15:33 }
{Name: GHC.Types.*})))))))]
@@ -270,22 +300,28 @@
(Just
({ DumpRenamedAst.hs:15:39-51 }
(HsFunTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:15:39-46 }
(HsParTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:15:40-45 }
(HsFunTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:15:40 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:15:40 }
{Name: k})))
({ DumpRenamedAst.hs:15:45 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:15:45 }
{Name: GHC.Types.*})))))))
({ DumpRenamedAst.hs:15:51 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:15:51 }
{Name: GHC.Types.*}))))))
@@ -298,56 +334,72 @@
,{Name: g}]
({ DumpRenamedAst.hs:16:10-45 }
(HsFunTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:16:10-34 }
(HsParTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:16:11-33 }
(HsForAllTy
+ (PlaceHolder)
[({ DumpRenamedAst.hs:16:18-19 }
(UserTyVar
+ (PlaceHolder)
({ DumpRenamedAst.hs:16:18-19 }
{Name: xx})))]
({ DumpRenamedAst.hs:16:22-33 }
(HsFunTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:16:22-25 }
(HsAppTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:16:22 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:16:22 }
{Name: f})))
({ DumpRenamedAst.hs:16:24-25 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:16:24-25 }
{Name: xx})))))
({ DumpRenamedAst.hs:16:30-33 }
(HsAppTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:16:30 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:16:30 }
{Name: g})))
({ DumpRenamedAst.hs:16:32-33 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:16:32-33 }
{Name: xx})))))))))))
({ DumpRenamedAst.hs:16:39-45 }
(HsAppTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:16:39-43 }
(HsAppTy
+ (PlaceHolder)
({ DumpRenamedAst.hs:16:39-41 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:16:39-41 }
{Name: DumpRenamedAst.Nat})))
({ DumpRenamedAst.hs:16:43 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:16:43 }
{Name: f})))))
({ DumpRenamedAst.hs:16:45 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ DumpRenamedAst.hs:16:45 }
{Name: g})))))))
diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
index e0d810d4b4..b888067af1 100644
--- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
@@ -7,47 +7,63 @@
{Var: DumpTypecheckedAst.$tcPeano}
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsConLikeOut
+ (PlaceHolder)
({abstract:ConLike})))
({ <no location info> }
(HsLit
+ (PlaceHolder)
{HsWord{64}Prim (14073232900889011755) (NoSourceText)}))))
({ <no location info> }
(HsLit
+ (PlaceHolder)
{HsWord{64}Prim (2739668351064589274) (NoSourceText)}))))
({ <no location info> }
(HsVar
+ (PlaceHolder)
({ <no location info> }
{Var: DumpTypecheckedAst.$trModule})))))
({ <no location info> }
(HsPar
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsConLikeOut
+ (PlaceHolder)
({abstract:ConLike})))
({ <no location info> }
(HsLit
+ (PlaceHolder)
(HsStringPrim
(NoSourceText)
"Peano")))))))))
({ <no location info> }
(HsLit
+ (PlaceHolder)
{HsInt{64}Prim (0) (SourceText
"0")}))))
({ <no location info> }
(HsVar
+ (PlaceHolder)
({ <no location info> }
{Var: GHC.Types.krep$*})))))
(False)))
@@ -56,47 +72,63 @@
{Var: DumpTypecheckedAst.$tc'Zero}
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsConLikeOut
+ (PlaceHolder)
({abstract:ConLike})))
({ <no location info> }
(HsLit
+ (PlaceHolder)
{HsWord{64}Prim (13760111476013868540) (NoSourceText)}))))
({ <no location info> }
(HsLit
+ (PlaceHolder)
{HsWord{64}Prim (12314848029315386153) (NoSourceText)}))))
({ <no location info> }
(HsVar
+ (PlaceHolder)
({ <no location info> }
{Var: DumpTypecheckedAst.$trModule})))))
({ <no location info> }
(HsPar
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsConLikeOut
+ (PlaceHolder)
({abstract:ConLike})))
({ <no location info> }
(HsLit
+ (PlaceHolder)
(HsStringPrim
(NoSourceText)
"'Zero")))))))))
({ <no location info> }
(HsLit
+ (PlaceHolder)
{HsInt{64}Prim (0) (SourceText
"0")}))))
({ <no location info> }
(HsVar
+ (PlaceHolder)
({ <no location info> }
{Var: $krep})))))
(False)))
@@ -105,47 +137,63 @@
{Var: DumpTypecheckedAst.$tc'Succ}
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsConLikeOut
+ (PlaceHolder)
({abstract:ConLike})))
({ <no location info> }
(HsLit
+ (PlaceHolder)
{HsWord{64}Prim (1143980031331647856) (NoSourceText)}))))
({ <no location info> }
(HsLit
+ (PlaceHolder)
{HsWord{64}Prim (14802086722010293686) (NoSourceText)}))))
({ <no location info> }
(HsVar
+ (PlaceHolder)
({ <no location info> }
{Var: DumpTypecheckedAst.$trModule})))))
({ <no location info> }
(HsPar
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsConLikeOut
+ (PlaceHolder)
({abstract:ConLike})))
({ <no location info> }
(HsLit
+ (PlaceHolder)
(HsStringPrim
(NoSourceText)
"'Succ")))))))))
({ <no location info> }
(HsLit
+ (PlaceHolder)
{HsInt{64}Prim (0) (SourceText
"0")}))))
({ <no location info> }
(HsVar
+ (PlaceHolder)
({ <no location info> }
{Var: $krep})))))
(False)))
@@ -154,17 +202,22 @@
{Var: $krep}
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsConLikeOut
+ (PlaceHolder)
({abstract:ConLike})))
({ <no location info> }
(HsVar
+ (PlaceHolder)
({ <no location info> }
{Var: $krep})))))
({ <no location info> }
(HsVar
+ (PlaceHolder)
({ <no location info> }
{Var: $krep})))))
(False)))
@@ -173,22 +226,28 @@
{Var: $krep}
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsConLikeOut
+ (PlaceHolder)
({abstract:ConLike})))
({ <no location info> }
(HsVar
+ (PlaceHolder)
({ <no location info> }
{Var: DumpTypecheckedAst.$tcPeano})))))
({ <no location info> }
(HsWrap
+ (PlaceHolder)
(WpTyApp
(TyConApp
({abstract:TyCon})
[]))
(HsConLikeOut
+ (PlaceHolder)
({abstract:ConLike}))))))
(False)))
,({ <no location info> }
@@ -196,32 +255,43 @@
{Var: DumpTypecheckedAst.$trModule}
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsConLikeOut
+ (PlaceHolder)
({abstract:ConLike})))
({ <no location info> }
(HsPar
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsConLikeOut
+ (PlaceHolder)
({abstract:ConLike})))
({ <no location info> }
(HsLit
+ (PlaceHolder)
(HsStringPrim
(NoSourceText)
"main")))))))))
({ <no location info> }
(HsPar
+ (PlaceHolder)
({ <no location info> }
(HsApp
+ (PlaceHolder)
({ <no location info> }
(HsConLikeOut
+ (PlaceHolder)
({abstract:ConLike})))
({ <no location info> }
(HsLit
+ (PlaceHolder)
(HsStringPrim
(NoSourceText)
"DumpTypecheckedAst")))))))))
@@ -258,12 +328,15 @@
[]
({ DumpTypecheckedAst.hs:11:8-23 }
(HsApp
+ (PlaceHolder)
({ DumpTypecheckedAst.hs:11:8-15 }
(HsVar
+ (PlaceHolder)
({ <no location info> }
{Var: putStrLn})))
({ DumpTypecheckedAst.hs:11:17-23 }
(HsLit
+ (PlaceHolder)
(HsString
(SourceText
"\"hello\"")
diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr
index 53e4a6f941..4965410e65 100644
--- a/testsuite/tests/parser/should_compile/T14189.stderr
+++ b/testsuite/tests/parser/should_compile/T14189.stderr
@@ -4,9 +4,10 @@
(Just
((,,,)
(HsGroup
- (ValBindsOut
- []
- [])
+ (XValBindsLR
+ (NValBinds
+ []
+ []))
[]
[(TyClGroup
[({ T14189.hs:6:1-42 }
@@ -36,6 +37,7 @@
(PrefixCon
[({ T14189.hs:6:18-20 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ T14189.hs:6:18-20 }
{Name: GHC.Types.Int})))])
@@ -65,12 +67,13 @@
(ConDeclField
[({ T14189.hs:6:33 }
(FieldOcc
+ {Name: T14189.f}
({ T14189.hs:6:33 }
(Unqual
- {OccName: f}))
- {Name: T14189.f}))]
+ {OccName: f}))))]
({ T14189.hs:6:38-40 }
(HsTyVar
+ (PlaceHolder)
(NotPromoted)
({ T14189.hs:6:38-40 }
{Name: GHC.Types.Int})))
diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T
index b7e6b215ca..4d7c171393 100644
--- a/testsuite/tests/perf/haddock/all.T
+++ b/testsuite/tests/perf/haddock/all.T
@@ -144,7 +144,7 @@ test('haddock.compiler',
[extra_files(['../../../../compiler/stage2/haddock.t']),
unless(in_tree_compiler(), skip), req_haddock
,stats_num_field('bytes allocated',
- [(wordsize(64), 51592019560, 10)
+ [(wordsize(64), 102142130576, 10)
# 2012-08-14: 26070600504 (amd64/Linux)
# 2012-08-29: 26353100288 (amd64/Linux, new CG)
# 2012-09-18: 26882813032 (amd64/Linux)
@@ -166,6 +166,9 @@ test('haddock.compiler',
# 2017-06-05: 65378619232 (amd64/Linux) Desugar modules compiled with -fno-code
# 2017-06-06: 55990521024 (amd64/Linux) Don't pass on -dcore-lint in Haddock.mk
# 2017-07-12: 51592019560 (amd64/Linux) Use getNameToInstancesIndex
+ # 2017-11-07: 65807004616 (amd64/Linux) Trees that grow
+ # 2017-11-11: 89414230688 (amd64/Linux) Trees that grow HsExpr
+ # 2017-11-12: 102142130576 (amd64/Linux) Trees that grow HsExpr #2
,(platform('i386-unknown-mingw32'), 367546388, 10)
# 2012-10-30: 13773051312 (x86/Windows)
diff --git a/testsuite/tests/quasiquotation/T7918.hs b/testsuite/tests/quasiquotation/T7918.hs
index 42bb1b05c8..9cf060937e 100644
--- a/testsuite/tests/quasiquotation/T7918.hs
+++ b/testsuite/tests/quasiquotation/T7918.hs
@@ -29,19 +29,19 @@ traverse a =
gmapM traverse a
where
showVar :: Maybe (HsExpr GhcTc) -> Traverse ()
- showVar (Just (HsVar (L _ v))) =
+ showVar (Just (HsVar _ (L _ v))) =
modify $ \(loc, ids) -> (loc, (varName v, loc) : ids)
showVar _ =
return ()
showTyVar :: Maybe (HsType GhcRn) -> Traverse ()
- showTyVar (Just (HsTyVar _ (L _ v))) =
+ showTyVar (Just (HsTyVar _ _ (L _ v))) =
modify $ \(loc, ids) -> (loc, (v, loc) : ids)
showTyVar _ =
return ()
showPatVar :: Maybe (Pat GhcTc) -> Traverse ()
- showPatVar (Just (VarPat (L _ v))) =
+ showPatVar (Just (VarPat _ (L _ v))) =
modify $ \(loc, ids) -> (loc, (varName v, loc) : ids)
showPatVar _
= return ()
diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs
index f74c7514db..059692622e 100644
--- a/utils/ghctags/Main.hs
+++ b/utils/ghctags/Main.hs
@@ -254,7 +254,7 @@ boundValues :: ModuleName -> HsGroup GhcRn -> [FoundThing]
-- ^Finds all the top-level definitions in a module
boundValues mod group =
let vals = case hs_valds group of
- ValBindsOut nest _sigs ->
+ XValBindsLR (NValBinds nest _sigs) ->
[ x | (_rec, binds) <- nest
, bind <- bagToList binds
, x <- boundThings mod bind ]
@@ -291,21 +291,20 @@ boundThings modname lbinding =
lid id = FoundThing modname (getOccString id) loc
in case unLoc lpat of
WildPat _ -> tl
- VarPat (L _ name) -> lid name : tl
- LazyPat p -> patThings p tl
- AsPat id p -> patThings p (thing id : tl)
- ParPat p -> patThings p tl
- BangPat p -> patThings p tl
- ListPat ps _ _ -> foldr patThings tl ps
- TuplePat ps _ _ -> foldr patThings tl ps
- PArrPat ps _ -> foldr patThings tl ps
+ VarPat _ (L _ name) -> lid name : tl
+ LazyPat _ p -> patThings p tl
+ AsPat _ id p -> patThings p (thing id : tl)
+ ParPat _ p -> patThings p tl
+ BangPat _ p -> patThings p tl
+ ListPat _ ps _ _ -> foldr patThings tl ps
+ TuplePat _ ps _ -> foldr patThings tl ps
+ PArrPat _ ps -> foldr patThings tl ps
ConPatIn _ conargs -> conArgs conargs tl
ConPatOut{ pat_args = conargs } -> conArgs conargs tl
- LitPat _ -> tl
+ LitPat _ _ -> tl
NPat {} -> tl -- form of literal pattern?
- NPlusKPat id _ _ _ _ _ -> thing id : tl
- SigPatIn p _ -> patThings p tl
- SigPatOut p _ -> patThings p tl
+ NPlusKPat _ id _ _ _ _ -> thing id : tl
+ SigPat _ p -> patThings p tl
_ -> error "boundThings"
conArgs (PrefixCon ps) tl = foldr patThings tl ps
conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
diff --git a/utils/haddock b/utils/haddock
-Subproject ae0d140334fff57f2737dbd7c5804b4868d9c3a
+Subproject 04fd3e021cfe04eaaa470be4ae8408a41782186