summaryrefslogtreecommitdiff
path: root/compiler/hsSyn
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/hsSyn')
-rw-r--r--compiler/hsSyn/Convert.hs257
-rw-r--r--compiler/hsSyn/HsBinds.hs71
-rw-r--r--compiler/hsSyn/HsDecls.hs65
-rw-r--r--compiler/hsSyn/HsExpr.hs724
-rw-r--r--compiler/hsSyn/HsExpr.hs-boot14
-rw-r--r--compiler/hsSyn/HsExtension.hs499
-rw-r--r--compiler/hsSyn/HsLit.hs64
-rw-r--r--compiler/hsSyn/HsPat.hs283
-rw-r--r--compiler/hsSyn/HsPat.hs-boot4
-rw-r--r--compiler/hsSyn/HsSyn.hs2
-rw-r--r--compiler/hsSyn/HsTypes.hs414
-rw-r--r--compiler/hsSyn/HsUtils.hs372
-rw-r--r--compiler/hsSyn/PlaceHolder.hs21
13 files changed, 1871 insertions, 919 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 3bb61e04f0..f766074ef3 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)
@@ -539,7 +540,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' rec_ty }
cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
@@ -558,7 +560,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)
@@ -566,7 +568,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}) }
@@ -751,7 +753,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))
@@ -770,11 +772,11 @@ 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 = go cvtOverLit HsOverLit isCompoundHsOverLit
- | otherwise = go cvtLit HsLit isCompoundHsLit
+ | overloadedLit l = go cvtOverLit (HsOverLit noExt) isCompoundHsOverLit
+ | otherwise = go cvtLit (HsLit noExt) isCompoundHsLit
where
go :: (Lit -> CvtM (l GhcPs))
-> (l GhcPs -> HsExpr GhcPs)
@@ -783,55 +785,63 @@ cvtl e = wrapL (cvt e)
go cvt_lit mk_expr is_compound_lit = do
l' <- cvt_lit l
let e' = mk_expr l'
- return $ if is_compound_lit l' then HsPar (noLoc e') else e'
+ return $ if is_compound_lit l' then HsPar noExt (noLoc e') else e'
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
; let pats = map parenthesizeCompoundPat ps'
- ; return $ HsLam (mkMatchGroup FromSource
+ ; return $ HsLam noExt (mkMatchGroup FromSource
[mkSimpleMatch LambdaExpr
pats 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' }
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'
@@ -839,19 +849,23 @@ cvtl e = wrapL (cvt e)
-- 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]
@@ -861,9 +875,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) }
@@ -872,9 +886,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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -965,7 +979,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
@@ -982,7 +996,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
@@ -997,8 +1011,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))
@@ -1024,13 +1039,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
@@ -1061,9 +1076,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 }
@@ -1092,40 +1107,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)
@@ -1136,9 +1157,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@.
@@ -1164,11 +1185,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
@@ -1205,17 +1226,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
@@ -1224,29 +1246,33 @@ 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
x'' <- case x' of
- L _ HsFunTy{} -> returnL (HsParTy x')
- L _ HsForAllTy{} -> returnL (HsParTy x') -- #14646
+ L _ HsFunTy{} -> returnL (HsParTy noExt x')
+ L _ HsForAllTy{} -> returnL (HsParTy noExt x')
+ -- #14646
_ -> return x'
- returnL (HsFunTy 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'
@@ -1262,11 +1288,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'
@@ -1275,7 +1301,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
@@ -1287,49 +1313,49 @@ 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')
| otherwise
- -> mk_apps (HsTyVar NotPromoted
+ -> mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName (tupleDataCon Boxed n)))) 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))
@@ -1341,15 +1367,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
-- ---------------------------------------------------------------------
@@ -1380,7 +1406,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 []
@@ -1398,17 +1424,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"
@@ -1448,13 +1474,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))
@@ -1504,15 +1533,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
@@ -1527,15 +1557,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 0724420e83..5fa0a62687 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -25,6 +25,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
GRHSs, pprPatBind )
import {-# SOURCE #-} HsPat ( LPat )
+import PlaceHolder
import HsExtension
import HsTypes
import PprCore ()
@@ -89,7 +90,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
@@ -104,18 +105,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
@@ -286,7 +303,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]
--
@@ -326,7 +343,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]
@@ -571,10 +588,10 @@ instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsValBindsLR idL idR) where
- ppr (ValBindsIn binds sigs)
+ 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)
@@ -626,7 +643,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 +652,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,11 +667,13 @@ 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"
@@ -749,7 +768,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
@@ -773,7 +792,7 @@ 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 (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsIPBinds p) where
@@ -946,7 +965,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)
@@ -1196,4 +1215,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 f29e7e2b0a..54314a9048 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -99,7 +99,7 @@ import Name
import BasicTypes
import Coercion
import ForeignCall
-import PlaceHolder ( PlaceHolder(..) )
+import PlaceHolder ( PlaceHolder, placeHolder )
import HsExtension
import NameSet
@@ -147,7 +147,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
@@ -193,9 +193,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 }
@@ -210,7 +210,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,
@@ -311,7 +312,7 @@ 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 (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (SpliceDecl p) where
@@ -534,7 +535,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
@@ -629,9 +630,9 @@ 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
@@ -778,7 +779,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 [] [] []
@@ -894,7 +895,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)
@@ -917,7 +918,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)
@@ -944,7 +945,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
@@ -960,7 +961,7 @@ 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 (TyVarSig (L _ (UserTyVar{}))) = False
hasReturnKindSignature _ = True
-- | Maybe return name of the result type variable
@@ -1052,7 +1053,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]
@@ -1088,7 +1089,7 @@ 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 (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsDerivingClause p) where
@@ -1182,7 +1183,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)
{- Note [GADT abstract syntax]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1415,7 +1416,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 -------------
@@ -1433,7 +1434,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) -------------
@@ -1493,7 +1494,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 -------------
@@ -1509,7 +1510,7 @@ 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 (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (TyFamInstDecl p) where
@@ -1679,7 +1680,7 @@ 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 (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (DerivDecl p) where
@@ -1714,7 +1715,7 @@ 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 (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (DefaultDecl p) where
@@ -1758,7 +1759,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
@@ -1769,10 +1770,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
@@ -1875,7 +1876,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)
@@ -1901,7 +1902,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
@@ -1918,7 +1919,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]
@@ -2009,7 +2010,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
@@ -2147,7 +2148,7 @@ 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 (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where
ppr (HsAnnotation _ provenance expr)
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 51d47b9fc8..92797faf40 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -21,6 +21,7 @@ module HsExpr where
-- friends:
import GhcPrelude
+import PlaceHolder
import HsDecls
import HsPat
import HsLit
@@ -83,7 +84,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 = []
@@ -110,17 +111,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 :: HsExpr (GhcPass p)
-noExpr = HsLit (HsString (SourceText "noExpr") (fsLit "noExpr"))
+noExpr = HsLit noExt (HsString (SourceText "noExpr") (fsLit "noExpr"))
noSyntaxExpr :: 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 }
@@ -128,7 +129,7 @@ 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
@@ -279,11 +280,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
@@ -291,24 +294,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',
@@ -316,7 +326,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',
@@ -324,28 +334,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
@@ -354,18 +360,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
@@ -375,6 +385,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| ExplicitTuple
+ (XExplicitTuple p)
[LHsTupArg p]
Boxity
@@ -386,17 +397,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',
@@ -405,7 +417,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
@@ -418,7 +431,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)
--
@@ -427,7 +440,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',
@@ -436,11 +450,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,...]
--
@@ -449,7 +463,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]
@@ -463,7 +477,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
@@ -473,11 +487,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
@@ -487,18 +499,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
@@ -509,14 +512,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
--
@@ -526,7 +525,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)
@@ -542,7 +541,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'@,
@@ -550,7 +549,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
@@ -558,7 +558,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)
@@ -570,15 +571,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
@@ -588,7 +591,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
@@ -599,7 +602,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
@@ -608,7 +612,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
---------------------------------------
@@ -622,10 +626,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)
@@ -635,6 +639,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
@@ -646,10 +651,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
@@ -665,6 +672,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
@@ -677,24 +685,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
---------------------------------------
@@ -703,10 +713,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
--
@@ -721,13 +859,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]
@@ -818,12 +966,11 @@ 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 :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
@@ -836,38 +983,37 @@ ppr_lexpr e = ppr_expr (unLoc e)
ppr_expr :: forall 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)
+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
@@ -879,15 +1025,15 @@ 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)
- HsUnboundVar h@TrueExprHole{}
- -> pp_infixly (unboundVarOcc h)
- _ -> pp_prefixly
+ HsVar _ (L _ v) -> pp_infixly v
+ HsConLikeOut _ c -> pp_infixly (conLikeName c)
+ HsUnboundVar _ h@TrueExprHole{}
+ -> pp_infixly (unboundVarOcc h)
+ _ -> pp_prefixly
where
pp_expr = pprDebugParendExpr expr
@@ -897,13 +1043,13 @@ ppr_expr (SectionL expr op)
pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
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)
- HsUnboundVar h@TrueExprHole{}
- -> pp_infixly (unboundVarOcc h)
- _ -> pp_prefixly
+ HsVar _ (L _ v) -> pp_infixly v
+ HsConLikeOut _ c -> pp_infixly (conLikeName c)
+ HsUnboundVar _ h@TrueExprHole{}
+ -> pp_infixly (unboundVarOcc h)
+ _ -> pp_prefixly
where
pp_expr = pprDebugParendExpr expr
@@ -913,37 +1059,39 @@ ppr_expr (SectionR op expr)
pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
pp_infixly 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",
@@ -960,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)))
@@ -982,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,
@@ -1032,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,
@@ -1040,45 +1187,40 @@ 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
-
--- 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. (OutputableBndrId (GhcPass p))
- => LHsWcTypeX (LHsWcType (GhcPass p))
+ppr_expr (HsRecFld _ f) = ppr f
+ppr_expr (XExpr x) = ppr x
ppr_apps :: (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 (Left arg) = ppr arg
- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
- = char '@' <> pprHsType arg
+ -- pp (Right (LHsWcTypeX (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))
@@ -1132,13 +1274,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
@@ -1151,8 +1293,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
@@ -1177,10 +1319,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)
@@ -1190,6 +1332,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
@@ -1199,22 +1342,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' @'{'@,
@@ -1222,7 +1369,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
@@ -1233,7 +1381,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' @'{'@,
@@ -1241,8 +1390,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',
@@ -1250,11 +1399,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
@@ -1271,11 +1441,22 @@ 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
+
+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 (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where
ppr cmd = pprCmd cmd
@@ -1294,9 +1475,9 @@ 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
-----------------------
@@ -1304,69 +1485,71 @@ ppr_lcmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc
ppr_lcmd c = ppr_cmd (unLoc c)
ppr_cmd :: forall p. (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc
-ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)
+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 :: (OutputableBndrId (GhcPass p)) => HsCmdTop (GhcPass p) -> SDoc
-pprCmdArg (HsCmdTop cmd _ _ _)
+pprCmdArg (HsCmdTop _ cmd)
= ppr_lcmd cmd
+pprCmdArg (XCmdTop x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmdTop p) where
ppr = pprCmdArg
@@ -1404,6 +1587,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
@@ -1412,13 +1596,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 {
@@ -1427,7 +1612,7 @@ 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 (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body)
=> Outputable (Match idR body) where
@@ -1506,21 +1691,23 @@ 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.
@@ -1773,7 +1960,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
@@ -1784,10 +1971,15 @@ 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
@@ -1803,7 +1995,8 @@ data ApplicativeArg idL
(HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn)
(LPat idL) -- (v1,...,vn)
-deriving instance (DataId idL) => Data (ApplicativeArg idL)
+-- AZ: May need to bring back idR?
+deriving instance (DataIdLR idL idL) => Data (ApplicativeArg idL)
{-
Note [The type of bind in Stmts]
@@ -1970,9 +2163,11 @@ Bool flag that is True when the original statement was a BodyStmt, so
that we can pretty-print it correctly.
-}
-instance (Outputable (StmtLR idL idL (LHsExpr idL)))
+instance (Outputable (StmtLR idL idL (LHsExpr idL)),
+ Outputable (XXParStmtBlock idL idR))
=> Outputable (ParStmtBlock idL idR) where
- ppr (ParStmtBlock stmts _ _) = interpp'SP stmts
+ ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts
+ ppr (XParStmtBlock x) = ppr x
instance (idL ~ GhcPass pl,idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR,
@@ -2041,6 +2236,7 @@ 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")
@@ -2051,9 +2247,8 @@ pprStmt (ApplicativeStmt args mb_join _)
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 :: (OutputableBndrId (GhcPass p))
=> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
@@ -2121,29 +2316,41 @@ 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
-deriving instance (DataId id) => Data (HsSplice id)
+ | XSplice (XXSplice id) -- Note [Trees that Grow] extension point
+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
@@ -2184,7 +2391,7 @@ data HsSplicedThing id
| HsSplicedTy (HsType id) -- ^ Haskell Spliced Type
| HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern
-deriving instance (DataId id) => Data (HsSplicedThing id)
+deriving instance (DataIdLR id id) => Data (HsSplicedThing id)
-- See Note [Pending Splices]
type SplicePointName = Name
@@ -2208,7 +2415,6 @@ data PendingTcSplice
= PendingTcSplice SplicePointName (LHsExpr GhcTc)
deriving Data
-
{-
Note [Pending Splices]
~~~~~~~~~~~~~~~~~~~~~~
@@ -2294,24 +2500,25 @@ pprSpliceDecl e ImplicitSplice = ppr_splice_decl e
ppr_splice_decl :: (OutputableBndrId (GhcPass p))
=> HsSplice (GhcPass p) -> SDoc
-ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty
+ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty
ppr_splice_decl e = pprSplice e
pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc
-pprSplice (HsTypedSplice HasParens n e)
+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)) <>
@@ -2324,15 +2531,26 @@ 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
@@ -2344,16 +2562,17 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
pprHsBracket :: (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)
+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 <+>
@@ -2386,7 +2605,8 @@ 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 (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (ArithSeqInfo p) where
diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot
index 0229039935..e8fa7a4e23 100644
--- a/compiler/hsSyn/HsExpr.hs-boot
+++ b/compiler/hsSyn/HsExpr.hs-boot
@@ -13,7 +13,7 @@ import SrcLoc ( Located )
import Outputable ( SDoc, Outputable )
import {-# SOURCE #-} HsPat ( LPat )
import BasicTypes ( SpliceExplicitFlag(..))
-import HsExtension ( OutputableBndrId, DataId, GhcPass )
+import HsExtension ( OutputableBndrId, DataIdLR, GhcPass )
import Data.Data hiding ( Fixity )
type role HsExpr nominal
@@ -29,12 +29,12 @@ 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 id id) => Data (HsSplice id)
+instance (DataIdLR p p) => Data (HsExpr p)
+instance (DataIdLR id id) => Data (HsCmd id)
+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 (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p)
diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs
index 8efd005c8f..779ecc53e4 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
@@ -88,6 +97,61 @@ type instance IdP GhcPs = RdrName
type instance IdP GhcRn = Name
type instance IdP GhcTc = Id
+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
+
+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 extension point. This is based on prepending
-- 'X' to the constructor name, for ease of reference.
@@ -104,57 +168,341 @@ 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
-- 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 (XHsDoublePrim x)
+ , c (XHsFloatPrim x)
+ , c (XHsInt x)
+ , c (XHsInt64Prim x)
+ , c (XHsIntPrim x)
+ , c (XHsInteger x)
+ , c (XHsRat x)
+ , c (XHsString x)
, c (XHsStringPrim 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 (XHsDoublePrim x)
+ , c (XHsWordPrim x)
+ , c (XXLit x)
)
+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
-type instance XHsChar (GhcPass _) = SourceText
-type instance XHsCharPrim (GhcPass _) = SourceText
-type instance XHsString (GhcPass _) = SourceText
-type instance XHsStringPrim (GhcPass _) = SourceText
-type instance XHsInt (GhcPass _) = ()
-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 _) = ()
-type instance XHsFloatPrim (GhcPass _) = ()
-type instance XHsDoublePrim (GhcPass _) = ()
-
-
+-- | 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 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 XUnambiguous x
+type family XAmbiguous x
+type family XXAmbiguousFieldOcc x
+
+type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) =
+ ( c (XUnambiguous x)
+ , c (XAmbiguous x)
+ , c (XXAmbiguousFieldOcc x)
+ )
-- ----------------------------------------------------------------------
--- | 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
+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')
+ )
-- ----------------------------------------------------------------------
-- | Conversion of annotations from one type index to another. This is required
@@ -183,15 +531,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)
@@ -211,10 +613,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 271a415914..182d00a929 100644
--- a/compiler/hsSyn/HsLit.hs
+++ b/compiler/hsSyn/HsLit.hs
@@ -27,6 +27,7 @@ import Type ( Type )
import Outputable
import FastString
import HsExtension
+import PlaceHolder
import Data.ByteString (ByteString)
import Data.Data hiding ( Fixity )
@@ -76,8 +77,24 @@ 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
@@ -98,11 +115,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
@@ -118,8 +149,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
@@ -137,6 +169,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]
@@ -170,8 +203,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
@@ -179,8 +214,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
@@ -209,6 +246,7 @@ instance p ~ GhcPass pass => Outputable (HsLit p) where
ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w)
ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i)
ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w)
+ ppr (XLit x) = ppr x
pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc
pp_st_suffix NoSourceText _ doc = doc
@@ -219,6 +257,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsOverLit 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))
@@ -245,6 +284,7 @@ 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
-- | Returns 'True' for compound literals that will need parentheses.
isCompoundHsLit :: HsLit x -> Bool
@@ -261,6 +301,7 @@ isCompoundHsLit (HsInteger _ x _) = x < 0
isCompoundHsLit (HsRat _ x _) = fl_neg x
isCompoundHsLit (HsFloatPrim _ x) = fl_neg x
isCompoundHsLit (HsDoublePrim _ x) = fl_neg x
+isCompoundHsLit (XLit _) = False
-- | Returns 'True' for compound overloaded literals that will need
-- parentheses when used in an argument position.
@@ -271,3 +312,4 @@ isCompoundHsOverLit (OverLit { ol_val = olv }) = compound_ol_val olv
compound_ol_val (HsIntegral x) = il_neg x
compound_ol_val (HsFractional x) = fl_neg x
compound_ol_val (HsIsString {}) = False
+isCompoundHsOverLit (XOverLit { }) = False
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index cfd923c0aa..8ffde32b5a 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -50,6 +50,7 @@ import HsExtension
import HsTypes
import TcEvidence
import BasicTypes
+import PlaceHolder
-- others:
import PprCore ( {- instance OutputableBndr TyVar -} )
import TysWiredIn
@@ -79,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' @'['@,
@@ -122,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
@@ -147,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' :
@@ -160,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' @':]'@
@@ -196,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 ---------------
@@ -208,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
@@ -240,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
@@ -265,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))
@@ -383,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
@@ -444,28 +512,30 @@ pprParendPat p = sdocWithDynFlags $ \ dflags ->
-- is the pattern inside that matters. Sigh.
pprPat :: (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
- 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 (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
+ then pprParendPat pat
+ else pprPat pat)
+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,6 +548,7 @@ 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 :: (OutputableBndr con, OutputableBndrId (GhcPass p))
@@ -527,7 +598,7 @@ mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
mkCharLitPat src c = mkPrefixConPat charDataCon
- [noLoc $ LitPat (HsCharPrim src c)] []
+ [noLoc $ LitPat PlaceHolder (HsCharPrim src c)] []
{-
************************************************************************
@@ -562,7 +633,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
@@ -580,8 +651,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
@@ -608,15 +679,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 -- ?
@@ -638,6 +708,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
@@ -667,10 +739,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
@@ -683,6 +754,7 @@ hsPatNeedsParens (ListPat {}) = False
hsPatNeedsParens (PArrPat {}) = False
hsPatNeedsParens (LitPat {}) = False
hsPatNeedsParens (NPat {}) = False
+hsPatNeedsParens (XPat {}) = True -- conservative default
-- | Returns 'True' if a constructor pattern must be parenthesized in order
-- to parse.
@@ -704,10 +776,9 @@ isCompoundPat (NPlusKPat {}) = True
isCompoundPat (SplicePat {}) = False
isCompoundPat (ConPatIn _ ds) = isCompoundConPat ds
isCompoundPat p@(ConPatOut {}) = isCompoundConPat (pat_args p)
-isCompoundPat (SigPatIn {}) = True
-isCompoundPat (SigPatOut {}) = True
+isCompoundPat (SigPat {}) = True
isCompoundPat (ViewPat {}) = True
-isCompoundPat (CoPat _ p _) = isCompoundPat p
+isCompoundPat (CoPat _ _ p _) = isCompoundPat p
isCompoundPat (WildPat {}) = False
isCompoundPat (VarPat {}) = False
isCompoundPat (LazyPat {}) = False
@@ -718,8 +789,9 @@ isCompoundPat (TuplePat {}) = False
isCompoundPat (SumPat {}) = False
isCompoundPat (ListPat {}) = False
isCompoundPat (PArrPat {}) = False
-isCompoundPat (LitPat p) = isCompoundHsLit p
-isCompoundPat (NPat (L _ p) _ _ _) = isCompoundHsOverLit p
+isCompoundPat (LitPat _ p) = isCompoundHsLit p
+isCompoundPat (NPat _ (L _ p) _ _) = isCompoundHsOverLit p
+isCompoundPat (XPat {}) = False -- Assumption
-- | Returns 'True' for compound constructor patterns that need parentheses
-- when used in an argument position.
@@ -736,9 +808,9 @@ isCompoundConPat (RecCon {}) = False
-- | @'parenthesizeCompoundPat' p@ checks if @'isCompoundPat' p@ is true, and
-- if so, surrounds @p@ with a 'ParPat'. Otherwise, it simply returns @p@.
-parenthesizeCompoundPat :: LPat p -> LPat p
+parenthesizeCompoundPat :: LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizeCompoundPat lp@(L loc p)
- | isCompoundPat p = L loc (ParPat lp)
+ | isCompoundPat p = L loc (ParPat PlaceHolder lp)
| otherwise = lp
{-
@@ -746,30 +818,29 @@ parenthesizeCompoundPat lp@(L loc p)
-}
-- 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 55c63fe7a4..d9a4d79412 100644
--- a/compiler/hsSyn/HsPat.hs-boot
+++ b/compiler/hsSyn/HsPat.hs-boot
@@ -11,11 +11,11 @@ import SrcLoc( Located )
import Data.Data hiding (Fixity)
import Outputable
-import HsExtension ( DataId, OutputableBndrId, GhcPass )
+import HsExtension ( DataIdLR, OutputableBndrId, GhcPass )
type role Pat nominal
data Pat (i :: *)
type LPat i = Located (Pat i)
-instance (DataId p) => Data (Pat p)
+instance (DataIdLR p p) => Data (Pat p)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p)
diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs
index 7631c95a7d..1534491a47 100644
--- a/compiler/hsSyn/HsSyn.hs
+++ b/compiler/hsSyn/HsSyn.hs
@@ -111,7 +111,7 @@ 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 (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index a2c863e0d5..5be6ddb26e 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -17,7 +17,7 @@ HsTypes: Abstract syntax: user-defined types
{-# LANGUAGE TypeFamilies #-}
module HsTypes (
- HsType(..), LHsType, HsKind, LHsKind,
+ HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,
HsTyVarBndr(..), LHsTyVarBndr,
LHsQTyVars(..),
HsImplicitBndrs(..),
@@ -44,7 +44,7 @@ module HsTypes (
rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,
unambiguousFieldOcc, ambiguousFieldOcc,
- HsWildCardInfo(..), mkAnonWildCardTy,
+ HsWildCardInfo(..), mkAnonWildCardTy, pprAnonWildCard,
wildCardName, sameWildCard,
mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
@@ -73,8 +73,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 )
@@ -109,11 +110,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)
{-
@@ -269,11 +270,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
@@ -363,12 +364,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?
@@ -404,9 +405,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
-- ^
@@ -414,12 +417,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
@@ -428,19 +439,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
@@ -450,53 +464,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' @'('@,
@@ -504,7 +527,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
-- ^
@@ -514,7 +538,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
@@ -525,7 +550,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)
@@ -535,19 +561,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' @'#-}'@
@@ -555,21 +583,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' @']'@
@@ -577,24 +606,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
@@ -604,7 +687,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
@@ -616,9 +700,17 @@ 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 (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsAppType p) where
@@ -763,7 +855,7 @@ 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 (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (ConDeclField p) where
@@ -849,8 +941,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
@@ -871,15 +964,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
---------------------
@@ -892,8 +987,8 @@ 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 ty = ty
+ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty
+ignoreParens ty = ty
isLHsForAllTy :: LHsType p -> Bool
isLHsForAllTy (L _ (HsForAllTy {})) = True
@@ -908,22 +1003,25 @@ isLHsForAllTy _ = False
-}
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 (parenthesizeCompoundHsType t2))
+mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+mkHsAppTy t1 t2
+ = addCLoc t1 t2 (HsAppTy noExt t1 (parenthesizeCompoundHsType t2))
-mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass
+mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
+ -> LHsType (GhcPass p)
mkHsAppTys = foldl mkHsAppTy
mkHsAppsTy :: [LHsAppType GhcPs] -> HsType GhcPs
-- In the common case of a singleton non-operator,
-- avoid the clutter of wrapping in a HsAppsTy
-mkHsAppsTy [L _ (HsAppPrefix (L _ ty))] = ty
-mkHsAppsTy app_tys = HsAppsTy app_tys
+mkHsAppsTy [L _ (HsAppPrefix _ (L _ ty))] = ty
+mkHsAppsTy app_tys = HsAppsTy PlaceHolder app_tys
{-
************************************************************************
@@ -940,36 +1038,37 @@ mkHsAppsTy app_tys = HsAppsTy app_tys
-- 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
@@ -984,35 +1083,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
@@ -1036,12 +1136,12 @@ splitLHsSigmaTy ty
= (tvs, ctxt, ty2)
splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
-splitLHsForAllTy (L _ (HsParTy ty)) = splitLHsForAllTy ty
+splitLHsForAllTy (L _ (HsParTy _ ty)) = splitLHsForAllTy ty
splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)
splitLHsForAllTy body = ([], body)
splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)
-splitLHsQualTy (L _ (HsParTy ty)) = splitLHsQualTy ty
+splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty
splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body)
splitLHsQualTy body = (noLoc [], body)
@@ -1060,7 +1160,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
@@ -1083,19 +1184,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 (p ~ GhcPass pass, Eq (XFieldOcc p)) => Eq (FieldOcc p)
+deriving instance (p ~ GhcPass pass, Ord (XFieldOcc p)) => Ord (FieldOcc 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
@@ -1111,34 +1221,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 p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where
ppr = ppr . rdrNameAmbiguousFieldOcc
-instance OutputableBndr (AmbiguousFieldOcc pass) where
+instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc 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"
{-
************************************************************************
@@ -1160,8 +1287,9 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsTyVarBndr p) where
- ppr (UserTyVar n) = ppr n
- ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
+ 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
@@ -1172,6 +1300,9 @@ instance (Outputable thing) => Outputable (HsWildCardBndrs pass thing) where
instance Outputable (HsWildCardInfo pass) where
ppr (AnonWildCard _) = char '_'
+pprAnonWildCard :: SDoc
+pprAnonWildCard = char '_'
+
pprHsForAll :: (OutputableBndrId (GhcPass p))
=> [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc
pprHsForAll = pprHsForAllExtra Nothing
@@ -1268,58 +1399,61 @@ ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
= sep [pprHsContextAlways ctxt, ppr_mono_lty ty]
-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 (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_mono_ty (XHsType t) = ppr t
+
--------------------------
ppr_fun_ty :: (OutputableBndrId (GhcPass p))
=> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
@@ -1331,14 +1465,16 @@ ppr_fun_ty ty1 ty2
--------------------------
ppr_app_ty :: (OutputableBndrId (GhcPass p)) => HsAppType (GhcPass p) -> SDoc
-ppr_app_ty (HsAppInfix (L _ n)) = pprInfixOcc n
-ppr_app_ty (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n))))
+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
@@ -1359,7 +1495,7 @@ isCompoundHsType _ = False
-- | @'parenthesizeCompoundHsType' ty@ checks if @'isCompoundHsType' ty@ is
-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply
-- returns @ty@.
-parenthesizeCompoundHsType :: LHsType pass -> LHsType pass
+parenthesizeCompoundHsType :: LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeCompoundHsType ty@(L loc _)
- | isCompoundHsType ty = L loc (HsParTy ty)
+ | isCompoundHsType ty = L loc (HsParTy PlaceHolder ty)
| otherwise = ty
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 6a6b3bbd70..aa40ad65fa 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]
@@ -203,35 +204,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
@@ -256,24 +257,25 @@ 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 :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
-> HsExpr (GhcPass p)
-mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
+mkHsIf c a b = HsIf noExt (Just noSyntaxExpr) c a b
-mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
-mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType
+mkNPat lit neg = NPat noExt lit neg noSyntaxExpr
+mkNPlusKPat id lit
+ = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr
mkTransformStmt :: (PostTc (GhcPass idR) Type ~ PlaceHolder)
=> [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR)
@@ -296,7 +298,7 @@ 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 }
@@ -305,7 +307,7 @@ 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
@@ -329,28 +331,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"))
@@ -365,13 +368,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 ]
{-
@@ -382,29 +387,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
@@ -416,13 +422,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)
@@ -450,50 +457,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 (parenthesizeCompoundHsType 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 (parenthesizeCompoundHsType 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
{-
@@ -501,37 +507,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
@@ -638,21 +645,25 @@ 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 PlaceHolder (HsNumTy NoSourceText n)
+ go (LitTy (StrTyLit s))
+ = noLoc $ HsTyLit PlaceHolder (HsStrTy NoSourceText s)
go ty@(TyConApp tc args)
| any isInvisibleTyConBinder (tyConBinders tc)
-- We must produce an explicit kind signature here to make certain
-- programs kind-check. See Note [Kind signatures in typeToLHsType].
- = noLoc $ HsKindSig lhs_ty (go (typeKind ty))
+ = noLoc $ HsKindSig PlaceHolder lhs_ty (go (typeKind ty))
| otherwise = lhs_ty
where
lhs_ty = nlHsTyConApp (getRdrName tc) (map go args')
@@ -664,7 +675,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))
{-
@@ -723,41 +734,41 @@ to make those work.
* *
********************************************************************* -}
-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
@@ -830,14 +841,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
{-
@@ -925,13 +938,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
@@ -947,9 +962,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) []
@@ -964,7 +981,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
@@ -979,23 +996,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{} = []
@@ -1013,33 +1034,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
@@ -1088,7 +1109,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)
@@ -1123,11 +1144,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]
@@ -1242,13 +1263,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
@@ -1256,7 +1280,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
@@ -1264,10 +1289,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
@@ -1283,18 +1308,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]
View Lorry Controller Status