summaryrefslogtreecommitdiff
path: root/compiler/hsSyn
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2017-11-05 21:49:11 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2017-11-08 17:49:54 +0200
commit438dd1cbba13d35f3452b4dcef3f94ce9a216905 (patch)
tree0678edb3697fb53b5f38a6e80473e658961f4b53 /compiler/hsSyn
parentfe6848f544c2a14086bcef388c46f4070c22d287 (diff)
downloadhaskell-438dd1cbba13d35f3452b4dcef3f94ce9a216905.tar.gz
WIP on Doing a combined Step 1 and 3 for Trees That Grow
See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow Trees that grow extension points are added for - ValBinds - HsPat - HsLit - HsOverLit - HsType - HsTyVarBndr - HsAppType - FieldOcc - AmbiguousFieldOcc Updates haddock submodule Test Plan: ./validate Reviewers: shayan-najd, simonpj, austin, goldfire, bgamari Subscribers: goldfire, rwbarton, thomie, mpickering Differential Revision: https://phabricator.haskell.org/D4147
Diffstat (limited to 'compiler/hsSyn')
-rw-r--r--compiler/hsSyn/Convert.hs163
-rw-r--r--compiler/hsSyn/HsBinds.hs167
-rw-r--r--compiler/hsSyn/HsDecls.hs200
-rw-r--r--compiler/hsSyn/HsExpr.hs248
-rw-r--r--compiler/hsSyn/HsExpr.hs-boot48
-rw-r--r--compiler/hsSyn/HsExtension.hs330
-rw-r--r--compiler/hsSyn/HsLit.hs71
-rw-r--r--compiler/hsSyn/HsPat.hs300
-rw-r--r--compiler/hsSyn/HsPat.hs-boot8
-rw-r--r--compiler/hsSyn/HsSyn.hs7
-rw-r--r--compiler/hsSyn/HsTypes.hs478
-rw-r--r--compiler/hsSyn/HsUtils.hs227
-rw-r--r--compiler/hsSyn/PlaceHolder.hs9
13 files changed, 1414 insertions, 842 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 4336243e91..119f31afa0 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,
@@ -541,7 +542,8 @@ cvtConstr (RecGadtC c varstrtys ty)
= do { c' <- mapM cNameL c
; ty' <- cvtType ty
; rec_flds <- mapM cvt_id_arg varstrtys
- ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
+ ; let rec_ty = noLoc (HsFunTy noExt
+ (noLoc $ HsRecTy noExt rec_flds) ty')
; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
@@ -560,7 +562,7 @@ cvt_arg (Bang su ss, ty)
; ty' <- wrap_apps ty''
; let su' = cvtSrcUnpackedness su
; let ss' = cvtSrcStrictness ss
- ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' }
+ ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }
cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
cvt_id_arg (i, str, ty)
@@ -568,7 +570,7 @@ cvt_id_arg (i, str, ty)
; ty' <- cvt_arg (str,ty)
; return $ noLoc (ConDeclField
{ cd_fld_names
- = [L li $ FieldOcc (L li i') PlaceHolder]
+ = [L li $ FieldOcc noExt (L li i')]
, cd_fld_type = ty'
, cd_fld_doc = Nothing}) }
@@ -753,7 +755,7 @@ cvtLocalDecs doc ds
; let (binds, prob_sigs) = partitionWith is_bind ds'
; let (sigs, bads) = partitionWith is_sig prob_sigs
; unless (null bads) (failWith (mkBadDecMsg doc bads))
- ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
+ ; return (HsValBinds (ValBinds noExt (listToBag binds) sigs)) }
cvtClause :: HsMatchContext RdrName
-> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
@@ -1015,13 +1017,13 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
cvtOverLit (IntegerL i)
- = do { force i; return $ mkHsIntegral (mkIntegralLit i) placeHolderType}
+ = do { force i; return $ mkHsIntegral (mkIntegralLit i) }
cvtOverLit (RationalL r)
- = do { force r; return $ mkHsFractional (mkFractionalLit r) placeHolderType}
+ = do { force r; return $ mkHsFractional (mkFractionalLit r) }
cvtOverLit (StringL s)
= do { let { s' = mkFastString s }
; force s'
- ; return $ mkHsIsString (quotedSourceText s) s' placeHolderType
+ ; return $ mkHsIsString (quotedSourceText s) s'
}
cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
-- An Integer is like an (overloaded) '3' in a Haskell source program
@@ -1052,9 +1054,9 @@ cvtLit :: Lit -> CvtM (HsLit GhcPs)
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i }
cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w }
cvtLit (FloatPrimL f)
- = do { force f; return $ HsFloatPrim def (mkFractionalLit f) }
+ = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) }
cvtLit (DoublePrimL f)
- = do { force f; return $ HsDoublePrim def (mkFractionalLit f) }
+ = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) }
cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c }
cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c }
cvtLit (StringL s) = do { let { s' = mkFastString s }
@@ -1083,40 +1085,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' }
+ _ -> 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 placeHolderType
cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
; return $ ConPatIn c'
$ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps) = do { ps' <- cvtPats ps
- ; return $ ListPat ps' placeHolderType Nothing }
+ ; return
+ $ ListPat noExt ps' placeHolderType Nothing }
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
- ; return $ SigPatIn p' (mkLHsSigWcType t') }
+ ; return $ SigPat (mkLHsSigWcType t') p' }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
- ; return $ ViewPat e' p' placeHolderType }
+ ; return $ ViewPat noExt e' p'}
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (s,p)
@@ -1127,9 +1135,9 @@ cvtPatFld (s,p)
, hsRecPun = False}) }
wrap_conpat :: Hs.LPat GhcPs -> CvtM (Hs.LPat GhcPs)
-wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat p
+wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat noExt p
wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p
-wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat p
+wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat noExt p
wrap_conpat p = return p
{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
@@ -1155,11 +1163,11 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
cvt_tv (TH.PlainTV nm)
= do { nm' <- tNameL nm
- ; returnL $ UserTyVar nm' }
+ ; returnL $ UserTyVar noExt nm' }
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tNameL nm
; ki' <- cvtKind ki
- ; returnL $ KindedTyVar nm' ki' }
+ ; returnL $ KindedTyVar noExt nm' ki' }
cvtRole :: TH.Role -> Maybe Coercion.Role
cvtRole TH.NominalR = Just Coercion.Nominal
@@ -1196,17 +1204,18 @@ cvtTypeKind ty_str ty
| tys' `lengthIs` n -- Saturated
-> if n==1 then return (head tys') -- Singleton tuples treated
-- like nothing (ie just parens)
- else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')
+ else returnL (HsTupleTy noExt
+ HsBoxedOrConstraintTuple tys')
| n == 1
-> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
| otherwise
- -> mk_apps (HsTyVar NotPromoted
+ -> mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
UnboxedTupleT n
| tys' `lengthIs` n -- Saturated
- -> returnL (HsTupleTy HsUnboxedTuple tys')
+ -> returnL (HsTupleTy noExt HsUnboxedTuple tys')
| otherwise
- -> mk_apps (HsTyVar NotPromoted
+ -> mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName (tupleTyCon Unboxed n)))) tys'
UnboxedSumT n
| n < 2
@@ -1215,28 +1224,31 @@ cvtTypeKind ty_str ty
, nest 2 $
text "Sums must have an arity of at least 2" ]
| tys' `lengthIs` n -- Saturated
- -> returnL (HsSumTy tys')
+ -> returnL (HsSumTy noExt tys')
| otherwise
- -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n))))
+ -> mk_apps (HsTyVar noExt NotPromoted
+ (noLoc (getRdrName (sumTyCon n))))
tys'
ArrowT
| [x',y'] <- tys' -> do
case x' of
- (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy x')
- ; returnL (HsFunTy x'' y') }
- _ -> returnL (HsFunTy x' y')
+ (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy noExt x')
+ ; returnL (HsFunTy noExt x'' y') }
+ _ -> returnL (HsFunTy noExt x' y')
| otherwise ->
- mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon)))
+ mk_apps (HsTyVar noExt NotPromoted
+ (noLoc (getRdrName funTyCon)))
tys'
ListT
- | [x'] <- tys' -> returnL (HsListTy x')
+ | [x'] <- tys' -> returnL (HsListTy noExt x')
| otherwise ->
- mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon)))
+ mk_apps (HsTyVar noExt NotPromoted
+ (noLoc (getRdrName listTyCon)))
tys'
VarT nm -> do { nm' <- tNameL nm
- ; mk_apps (HsTyVar NotPromoted nm') tys' }
+ ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }
ConT nm -> do { nm' <- tconName nm
- ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
+ ; mk_apps (HsTyVar noExt NotPromoted (noLoc nm')) tys'}
ForallT tvs cxt ty
| null tys'
@@ -1252,11 +1264,11 @@ cvtTypeKind ty_str ty
SigT ty ki
-> do { ty' <- cvtType ty
; ki' <- cvtKind ki
- ; mk_apps (HsKindSig ty' ki') tys'
+ ; mk_apps (HsKindSig noExt ty' ki') tys'
}
LitT lit
- -> returnL (HsTyLit (cvtTyLit lit))
+ -> returnL (HsTyLit noExt (cvtTyLit lit))
WildCardT
-> mk_apps mkAnonWildCardTy tys'
@@ -1265,7 +1277,7 @@ cvtTypeKind ty_str ty
-> do { s' <- tconName s
; t1' <- cvtType t1
; t2' <- cvtType t2
- ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2']
+ ; mk_apps (HsTyVar noExt NotPromoted (noLoc s')) [t1', t2']
}
UInfixT t1 s t2
@@ -1277,46 +1289,46 @@ cvtTypeKind ty_str ty
ParensT t
-> do { t' <- cvtType t
- ; returnL $ HsParTy t'
+ ; returnL $ HsParTy noExt t'
}
PromotedT nm -> do { nm' <- cName nm
- ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
+ ; mk_apps (HsTyVar noExt NotPromoted
+ (noLoc nm')) tys' }
-- Promoted data constructor; hence cName
PromotedTupleT n
| n == 1
-> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
| m == n -- Saturated
- -> do { let kis = replicate m placeHolderKind
- ; returnL (HsExplicitTupleTy kis tys')
- }
+ -> returnL (HsExplicitTupleTy noExt tys')
where
m = length tys'
PromotedNilT
- -> returnL (HsExplicitListTy Promoted placeHolderKind [])
+ -> returnL (HsExplicitListTy noExt Promoted [])
PromotedConsT -- See Note [Representing concrete syntax in types]
-- in Language.Haskell.TH.Syntax
- | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys'
- -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2))
+ | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys'
+ -> returnL (HsExplicitListTy noExt ip (ty1:tys2))
| otherwise
- -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon)))
+ -> mk_apps (HsTyVar noExt NotPromoted
+ (noLoc (getRdrName consDataCon)))
tys'
StarT
- -> returnL (HsTyVar NotPromoted (noLoc
+ -> returnL (HsTyVar noExt NotPromoted (noLoc
(getRdrName liftedTypeKindTyCon)))
ConstraintT
- -> returnL (HsTyVar NotPromoted
+ -> returnL (HsTyVar noExt NotPromoted
(noLoc (getRdrName constraintKindTyCon)))
EqualityT
- | [x',y'] <- tys' -> returnL (HsEqTy x' y')
+ | [x',y'] <- tys' -> returnL (HsEqTy noExt x' y')
| otherwise ->
- mk_apps (HsTyVar NotPromoted
+ mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName eqPrimTyCon))) tys'
_ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
@@ -1328,15 +1340,15 @@ mk_apps head_ty [] = returnL head_ty
mk_apps head_ty (ty:tys) =
do { head_ty' <- returnL head_ty
; p_ty <- add_parens ty
- ; mk_apps (HsAppTy head_ty' p_ty) tys }
+ ; mk_apps (HsAppTy noExt head_ty' p_ty) tys }
where
-- See Note [Adding parens for splices]
add_parens t
- | isCompoundHsType t = returnL (HsParTy t)
+ | isCompoundHsType t = returnL (HsParTy noExt t)
| otherwise = return t
wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs)
-wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t)
+wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t)
wrap_apps t = return t
-- ---------------------------------------------------------------------
@@ -1367,7 +1379,7 @@ mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)
go arg ret_ty = do { ret_ty_l <- returnL ret_ty
- ; return (HsFunTy arg ret_ty_l) }
+ ; return (HsFunTy noExt arg ret_ty_l) }
split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType GhcPs])
split_ty_app ty = go ty []
@@ -1385,17 +1397,17 @@ cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
cvtOpAppT :: LHsType GhcPs -> RdrName -> LHsType GhcPs -> LHsType GhcPs
cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)
= L (combineSrcSpans loc1 loc2) $
- HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2')
+ HsAppsTy noExt (t1' ++ [noLoc $ HsAppInfix noExt (noLoc op)] ++ t2')
where
- t1' | L _ (HsAppsTy t1s) <- t1
+ t1' | L _ (HsAppsTy _ t1s) <- t1
= t1s
| otherwise
- = [noLoc $ HsAppPrefix t1]
+ = [noLoc $ HsAppPrefix noExt t1]
- t2' | L _ (HsAppsTy t2s) <- t2
+ t2' | L _ (HsAppsTy _ t2s) <- t2
= t2s
| otherwise
- = [noLoc $ HsAppPrefix t2]
+ = [noLoc $ HsAppPrefix noExt t2]
cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
cvtKind = cvtTypeKind "kind"
@@ -1435,13 +1447,16 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
| null univs, null reqs = do { l <- getL
; ty' <- cvtType (ForallT exis provs ty)
; return $ L l (HsQualTy { hst_ctxt = L l []
+ , hst_xqual = noExt
, hst_body = ty' }) }
| null reqs = do { l <- getL
; univs' <- hsQTvExplicit <$> cvtTvs univs
; ty' <- cvtType (ForallT exis provs ty)
; let forTy = HsForAllTy { hst_bndrs = univs'
+ , hst_xforall = noExt
, hst_body = L l cxtTy }
cxtTy = HsQualTy { hst_ctxt = L l []
+ , hst_xqual = noExt
, hst_body = ty' }
; return $ L l forTy }
| otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty))
@@ -1491,15 +1506,16 @@ mkHsForAllTy :: [TH.TyVarBndr]
-> SrcSpan
-- ^ The location of the returned 'LHsType' if it needs an
-- explicit forall
- -> LHsQTyVars name
+ -> LHsQTyVars GhcPs
-- ^ The converted type variable binders
- -> LHsType name
+ -> LHsType GhcPs
-- ^ The converted rho type
- -> LHsType name
+ -> LHsType GhcPs
-- ^ The complete type, quantified with a forall if necessary
mkHsForAllTy tvs loc tvs' rho_ty
| null tvs = rho_ty
| otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
+ , hst_xforall = noExt
, hst_body = rho_ty }
-- | If passed an empty 'TH.Cxt', this simply returns the third argument
@@ -1514,15 +1530,16 @@ mkHsQualTy :: TH.Cxt
-> SrcSpan
-- ^ The location of the returned 'LHsType' if it needs an
-- explicit context
- -> LHsContext name
+ -> LHsContext GhcPs
-- ^ The converted context
- -> LHsType name
+ -> LHsType GhcPs
-- ^ The converted tau type
- -> LHsType name
+ -> LHsType GhcPs
-- ^ The complete type, qualified with a context if necessary
mkHsQualTy ctxt loc ctxt' ty
| null ctxt = ty
- | otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty }
+ | otherwise = L loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
+ , hst_body = ty }
--------------------------------------------------------------------
-- Turning Name back into RdrName
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 0dc5dd08ba..9a106e3759 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -14,6 +14,9 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
module HsBinds where
@@ -24,6 +27,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
GRHSs, pprPatBind )
import {-# SOURCE #-} HsPat ( LPat )
+import PlaceHolder
import HsExtension
import HsTypes
import PprCore ()
@@ -88,7 +92,7 @@ data HsLocalBindsLR idL idR
type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)
-deriving instance (DataId idL, DataId idR) => Data (HsLocalBindsLR idL idR)
+deriving instance (DataIdLR idL idR) => Data (HsLocalBindsLR idL idR)
-- | Haskell Value Bindings
type HsValBinds id = HsValBindsLR id id
@@ -103,18 +107,68 @@ 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
+
+data NHsValBindsLR idL
+ = NValBinds
+ [(RecFlag, LHsBinds idL)]
+ [LSig GhcRn]
+deriving instance (DataIdLR idL idL) => Data (NHsValBindsLR idL)
+
+{-
+-- The ValBindsIn pattern exists so we can use the COMPLETE pragma for these
+-- patterns
+pattern
+ ValBindsIn ::
+ (XValBinds idL idR) ->
+ (LHsBindsLR idL idR) ->
+ [LSig idR] ->
+ HsValBindsLR idL idR
+pattern
+ ValBindsOut ::
+ [(RecFlag, LHsBinds idL)] ->
+ [LSig GhcRn] ->
+ HsValBindsLR idL idR
+
+pattern
+ ValBindsIn x b s
+ = ValBinds x b s
+pattern
+ ValBindsOut a b
+ = XValBindsLR (NValBindsOut a b)
+
+{-#
+ COMPLETE
+ ValBindsIn,
+ ValBindsOut
+ #-}
+-}
+
+-- This is not extensible using the parameterised GhcPass namespace
+-- type instance
+-- XValBinds (GhcPass pass) (GhcPass pass') = NoFieldExt
+-- type instance
+-- XNewValBindsLR (GhcPass pass) (GhcPass pass')
+-- = NewHsValBindsLR (GhcPass pass) (GhcPass pass')
+type instance XValBinds (GhcPass pL) (GhcPass pR) = PlaceHolder
+type instance XXValBindsLR (GhcPass pL) (GhcPass pR)
+ = NHsValBindsLR (GhcPass pL)
+
+-- ---------------------------------------------------------------------
-- | Located Haskell Binding
type LHsBind id = LHsBindLR id id
@@ -285,7 +339,7 @@ data HsBindLR idL idR
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR)
+deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR)
-- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
--
@@ -325,7 +379,7 @@ data PatSynBind idL idR
psb_def :: LPat idR, -- ^ Right-hand side
psb_dir :: HsPatSynDir idR -- ^ Directionality
}
-deriving instance (DataId idL, DataId idR) => Data (PatSynBind idL idR)
+deriving instance (DataIdLR idL idR) => Data (PatSynBind idL idR)
{-
Note [AbsBinds]
@@ -560,20 +614,20 @@ Specifically,
it's just an error thunk
-}
-instance (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => Outputable (HsLocalBindsLR idL idR) where
+instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => Outputable (HsLocalBindsLR (GhcPass idL) (GhcPass idR)) where
ppr (HsValBinds bs) = ppr bs
ppr (HsIPBinds bs) = ppr bs
ppr EmptyLocalBinds = empty
-instance (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => Outputable (HsValBindsLR idL idR) where
- ppr (ValBindsIn binds sigs)
+instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => Outputable (HsValBindsLR (GhcPass idL) (GhcPass idR)) where
+ ppr (ValBinds _ binds sigs)
= pprDeclList (pprLHsBindsForUser binds sigs)
- ppr (ValBindsOut sccs sigs)
+ ppr (XValBindsLR (NValBinds sccs sigs))
= getPprStyle $ \ sty ->
if debugStyle sty then -- Print with sccs showing
vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
@@ -584,17 +638,19 @@ instance (SourceTextX idL, SourceTextX idR,
pp_rec Recursive = text "rec"
pp_rec NonRecursive = text "nonrec"
-pprLHsBinds :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => LHsBindsLR idL idR -> SDoc
+pprLHsBinds :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprLHsBinds binds
| isEmptyLHsBinds binds = empty
| otherwise = pprDeclList (map ppr (bagToList binds))
-pprLHsBindsForUser :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR,
- SourceTextX id2, OutputableBndrId id2)
- => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
+pprLHsBindsForUser :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL),
+ OutputableBndrId (GhcPass idR),
+ SourceTextX (GhcPass id2),
+ OutputableBndrId (GhcPass id2))
+ => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc]
-- pprLHsBindsForUser is different to pprLHsBinds because
-- a) No braces: 'let' and 'where' include a list of HsBindGroups
-- and we don't want several groups of bindings each
@@ -626,7 +682,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 +691,13 @@ eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
eqEmptyLocalBinds EmptyLocalBinds = True
eqEmptyLocalBinds _ = False
-isEmptyValBinds :: HsValBindsLR a b -> Bool
-isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
-isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
+isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool
+isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs
+isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs
-emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
-emptyValBindsIn = ValBindsIn emptyBag []
-emptyValBindsOut = ValBindsOut [] []
+emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b)
+emptyValBindsIn = ValBinds noExt emptyBag []
+emptyValBindsOut = XValBindsLR (NValBinds [] [])
emptyLHsBinds :: LHsBindsLR idL idR
emptyLHsBinds = emptyBag
@@ -650,22 +706,24 @@ isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
isEmptyLHsBinds = isEmptyBag
------------
-plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
-plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
- = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
-plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
- = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
+plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
+ -> HsValBinds(GhcPass a)
+plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)
+ = ValBinds noExt (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
+plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))
+ (XValBindsLR (NValBinds ds2 sigs2))
+ = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2))
plusHsValBinds _ _
= panic "HsBinds.plusHsValBinds"
-instance (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => Outputable (HsBindLR idL idR) where
+instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => Outputable (HsBindLR (GhcPass idL) (GhcPass idR)) where
ppr mbind = ppr_monobind mbind
-ppr_monobind :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => HsBindLR idL idR -> SDoc
+ppr_monobind :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
= pprPatBind pat grhss
@@ -705,9 +763,9 @@ instance (OutputableBndrId p) => Outputable (ABExport p) where
, nest 2 (pprTcSpecPrags prags)
, nest 2 (text "wrap:" <+> ppr wrap)]
-instance (SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => Outputable (PatSynBind idL idR) where
+instance (SourceTextX (GhcPass idR),
+ OutputableBndrId idL, OutputableBndrId (GhcPass idR))
+ => Outputable (PatSynBind idL (GhcPass idR)) where
ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
psb_dir = dir })
= ppr_lhs <+> ppr_rhs
@@ -752,7 +810,7 @@ data HsIPBinds id
[LIPBind id]
TcEvBinds -- Only in typechecker output; binds
-- uses of the implicit parameters
-deriving instance (DataId id) => Data (HsIPBinds id)
+deriving instance (DataIdLR id id) => Data (HsIPBinds id)
isEmptyIPBinds :: HsIPBinds id -> Bool
isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
@@ -776,13 +834,15 @@ type LIPBind id = Located (IPBind id)
-- For details on above see note [Api annotations] in ApiAnnotation
data IPBind id
= IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id)
-deriving instance (DataId name) => Data (IPBind name)
+deriving instance (DataIdLR id id) => Data (IPBind id)
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsIPBinds (GhcPass p)) where
ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
$$ whenPprDebug (ppr ds)
-instance (SourceTextX p, OutputableBndrId p ) => Outputable (IPBind p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p) )
+ => Outputable (IPBind (GhcPass p)) where
ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
where name = case lr of
Left (L _ ip) -> pprBndr LetBind ip
@@ -948,7 +1008,7 @@ data Sig pass
(Located [Located (IdP pass)])
(Maybe (Located (IdP pass)))
-deriving instance (DataId pass) => Data (Sig pass)
+deriving instance (DataIdLR pass pass) => Data (Sig pass)
-- | Located Fixity Signature
type LFixitySig pass = Located (FixitySig pass)
@@ -1055,11 +1115,12 @@ signatures. Since some of the signatures contain a list of names, testing for
equality is not enough -- we have to check if they overlap.
-}
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (Sig pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (Sig (GhcPass p)) where
ppr sig = ppr_sig sig
-ppr_sig :: (SourceTextX pass, OutputableBndrId pass ) => Sig pass -> SDoc
+ppr_sig :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p) )
+ => Sig (GhcPass p) -> SDoc
ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (ClassOpSig is_deflt vars ty)
| is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
@@ -1241,4 +1302,4 @@ data HsPatSynDir id
= Unidirectional
| ImplicitBidirectional
| ExplicitBidirectional (MatchGroup id (LHsExpr id))
-deriving instance (DataId id) => Data (HsPatSynDir id)
+deriving instance (DataIdLR id id) => Data (HsPatSynDir id)
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 55d43fd058..3641e27f98 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -149,7 +149,7 @@ data HsDecl id
-- (Includes quasi-quotes)
| DocD (DocDecl) -- ^ Documentation comment declaration
| RoleAnnotD (RoleAnnotDecl id) -- ^ Role annotation declaration
-deriving instance (DataId id) => Data (HsDecl id)
+deriving instance (DataIdLR id id) => Data (HsDecl id)
-- NB: all top-level fixity decls are contained EITHER
@@ -195,9 +195,9 @@ data HsGroup id
hs_docs :: [LDocDecl]
}
-deriving instance (DataId id) => Data (HsGroup id)
+deriving instance (DataIdLR id id) => Data (HsGroup id)
-emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
+emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass a)
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
@@ -212,7 +212,8 @@ emptyGroup = HsGroup { hs_tyclds = [],
hs_splcds = [],
hs_docs = [] }
-appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
+appendGroups :: HsGroup (GhcPass a) -> HsGroup (GhcPass a)
+ -> HsGroup (GhcPass a)
appendGroups
HsGroup {
hs_valds = val_groups1,
@@ -255,8 +256,8 @@ appendGroups
hs_vects = vects1 ++ vects2,
hs_docs = docs1 ++ docs2 }
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsDecl (GhcPass p)) where
ppr (TyClD dcl) = ppr dcl
ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def
@@ -272,8 +273,8 @@ instance (SourceTextX pass, OutputableBndrId pass)
ppr (DocD doc) = ppr doc
ppr (RoleAnnotD ra) = ppr ra
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsGroup pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsGroup (GhcPass p)) where
ppr (HsGroup { hs_valds = val_decls,
hs_tyclds = tycl_decls,
hs_derivds = deriv_decls,
@@ -315,10 +316,10 @@ data SpliceDecl id
= SpliceDecl -- Top level splice
(Located (HsSplice id))
SpliceExplicitFlag
-deriving instance (DataId id) => Data (SpliceDecl id)
+deriving instance (DataIdLR id id) => Data (SpliceDecl id)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (SpliceDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (SpliceDecl (GhcPass p)) where
ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f
{-
@@ -538,7 +539,7 @@ data TyClDecl pass
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId id) => Data (TyClDecl id)
+deriving instance (DataIdLR id id) => Data (TyClDecl id)
-- Simple classifiers for TyClDecl
@@ -633,17 +634,17 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
= hsTvbAllKinded tyvars && rhs_annotated rhs
where
rhs_annotated (L _ ty) = case ty of
- HsParTy lty -> rhs_annotated lty
- HsKindSig {} -> True
- _ -> False
+ HsParTy _ lty -> rhs_annotated lty
+ HsKindSig {} -> True
+ _ -> False
hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk
hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
-- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (TyClDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (TyClDecl (GhcPass p)) where
ppr (FamDecl { tcdFam = decl }) = ppr decl
ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
@@ -674,8 +675,8 @@ instance (SourceTextX pass, OutputableBndrId pass)
<+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context)
<+> pprFundeps (map unLoc fds)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (TyClGroup pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (TyClGroup (GhcPass p)) where
ppr (TyClGroup { group_tyclds = tyclds
, group_roles = roles
, group_instds = instds
@@ -685,11 +686,11 @@ instance (SourceTextX pass, OutputableBndrId pass)
ppr roles $$
ppr instds
-pp_vanilla_decl_head :: (SourceTextX pass, OutputableBndrId pass)
- => Located (IdP pass)
- -> LHsQTyVars pass
+pp_vanilla_decl_head :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Located (IdP (GhcPass p))
+ -> LHsQTyVars (GhcPass p)
-> LexicalFixity
- -> HsContext pass
+ -> HsContext (GhcPass p)
-> SDoc
pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context
= hsep [pprHsContext context, pp_tyvars tyvars]
@@ -783,7 +784,7 @@ data TyClGroup pass -- See Note [TyClGroups and dependency analysis]
= TyClGroup { group_tyclds :: [LTyClDecl pass]
, group_roles :: [LRoleAnnotDecl pass]
, group_instds :: [LInstDecl pass] }
-deriving instance (DataId id) => Data (TyClGroup id)
+deriving instance (DataIdLR id id) => Data (TyClGroup id)
emptyTyClGroup :: TyClGroup pass
emptyTyClGroup = TyClGroup [] [] []
@@ -899,7 +900,7 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig]
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (FamilyResultSig pass)
+deriving instance (DataIdLR pass pass) => Data (FamilyResultSig pass)
-- | Located type Family Declaration
type LFamilyDecl pass = Located (FamilyDecl pass)
@@ -922,7 +923,7 @@ data FamilyDecl pass = FamilyDecl
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId id) => Data (FamilyDecl id)
+deriving instance (DataIdLR id id) => Data (FamilyDecl id)
-- | Located Injectivity Annotation
type LInjectivityAnn pass = Located (InjectivityAnn pass)
@@ -949,7 +950,7 @@ data FamilyInfo pass
-- | 'Nothing' if we're in an hs-boot file and the user
-- said "type family Foo x where .."
| ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
-deriving instance (DataId pass) => Data (FamilyInfo pass)
+deriving instance (DataIdLR pass pass) => Data (FamilyInfo pass)
-- | Does this family declaration have a complete, user-supplied kind signature?
famDeclHasCusk :: Maybe Bool
@@ -964,21 +965,21 @@ famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
-- | Does this family declaration have user-supplied return kind signature?
hasReturnKindSignature :: FamilyResultSig a -> Bool
-hasReturnKindSignature NoSig = False
-hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False
-hasReturnKindSignature _ = True
+hasReturnKindSignature NoSig = False
+hasReturnKindSignature (TyVarSig (L _ UserTyVar{})) = False
+hasReturnKindSignature _ = True
-- | Maybe return name of the result type variable
resultVariableName :: FamilyResultSig a -> Maybe (IdP a)
resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig
resultVariableName _ = Nothing
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (FamilyDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (FamilyDecl (GhcPass p)) where
ppr = pprFamilyDecl TopLevel
-pprFamilyDecl :: (SourceTextX pass, OutputableBndrId pass)
- => TopLevelFlag -> FamilyDecl pass -> SDoc
+pprFamilyDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc
pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
, fdTyVars = tyvars
, fdFixity = fixity
@@ -1057,7 +1058,7 @@ data HsDataDefn pass -- The payload of a data type defn
-- For details on above see note [Api annotations] in ApiAnnotation
}
-deriving instance (DataId id) => Data (HsDataDefn id)
+deriving instance (DataIdLR id id) => Data (HsDataDefn id)
-- | Haskell Deriving clause
type HsDeriving pass = Located [LHsDerivingClause pass]
@@ -1093,10 +1094,10 @@ data HsDerivingClause pass
--
-- should produce a derived instance for @C [a] (T b)@.
}
-deriving instance (DataId id) => Data (HsDerivingClause id)
+deriving instance (DataIdLR id id) => Data (HsDerivingClause id)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsDerivingClause pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsDerivingClause (GhcPass p)) where
ppr (HsDerivingClause { deriv_clause_strategy = dcs
, deriv_clause_tys = L _ dct })
= hsep [ text "deriving"
@@ -1176,7 +1177,7 @@ data ConDecl pass
, con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment.
}
-deriving instance (DataId pass) => Data (ConDecl pass)
+deriving instance (DataIdLR pass pass) => Data (ConDecl pass)
-- | Haskell data Constructor Declaration Details
type HsConDeclDetails pass
@@ -1204,7 +1205,7 @@ gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs)
(tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
(details, res_ty) -- See Note [Sorting out the result type]
= case tau of
- L _ (HsFunTy (L l (HsRecTy flds)) res_ty')
+ L _ (HsFunTy _ (L l (HsRecTy _ flds)) res_ty')
-> (RecCon (L l flds), res_ty')
_other -> (PrefixCon [], tau)
@@ -1213,9 +1214,9 @@ hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds)
-pp_data_defn :: (SourceTextX pass, OutputableBndrId pass)
- => (HsContext pass -> SDoc) -- Printing the header
- -> HsDataDefn pass
+pp_data_defn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => (HsContext (GhcPass p) -> SDoc) -- Printing the header
+ -> HsDataDefn (GhcPass p)
-> SDoc
pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
, dd_cType = mb_ct
@@ -1237,26 +1238,27 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
Just kind -> dcolon <+> ppr kind
pp_derivings (L _ ds) = vcat (map ppr ds)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsDataDefn pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsDataDefn (GhcPass p)) where
ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
instance Outputable NewOrData where
ppr NewType = text "newtype"
ppr DataType = text "data"
-pp_condecls :: (SourceTextX pass, OutputableBndrId pass)
- => [LConDecl pass] -> SDoc
+pp_condecls :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => [LConDecl (GhcPass p)] -> SDoc
pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax
= hang (text "where") 2 (vcat (map ppr cs))
pp_condecls cs -- In H98 syntax
= equals <+> sep (punctuate (text " |") (map ppr cs))
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ConDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (ConDecl (GhcPass p)) where
ppr = pprConDecl
-pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc
+pprConDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => ConDecl (GhcPass p) -> SDoc
pprConDecl (ConDeclH98 { con_name = L _ con
, con_qvars = mtvs
, con_cxt = mcxt
@@ -1381,7 +1383,7 @@ newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
-- 'ApiAnnotation.AnnInstance',
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance DataId pass => Data (TyFamInstDecl pass)
+deriving instance DataIdLR pass pass => Data (TyFamInstDecl pass)
----------------- Data family instances -------------
@@ -1399,7 +1401,7 @@ newtype DataFamInstDecl pass
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance DataId pass => Data (DataFamInstDecl pass)
+deriving instance DataIdLR pass pass => Data (DataFamInstDecl pass)
----------------- Family instances (common types) -------------
@@ -1459,7 +1461,7 @@ data ClsInstDecl pass
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId id) => Data (ClsInstDecl id)
+deriving instance (DataIdLR id id) => Data (ClsInstDecl id)
----------------- Instances of all kinds -------------
@@ -1475,14 +1477,14 @@ data InstDecl pass -- Both class and family instances
{ dfid_inst :: DataFamInstDecl pass }
| TyFamInstD -- type family instance
{ tfid_inst :: TyFamInstDecl pass }
-deriving instance (DataId id) => Data (InstDecl id)
+deriving instance (DataIdLR id id) => Data (InstDecl id)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (TyFamInstDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (TyFamInstDecl (GhcPass p)) where
ppr = pprTyFamInstDecl TopLevel
-pprTyFamInstDecl :: (SourceTextX pass, OutputableBndrId pass)
- => TopLevelFlag -> TyFamInstDecl pass -> SDoc
+pprTyFamInstDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc
pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
= text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn
@@ -1490,16 +1492,16 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc
ppr_instance_keyword TopLevel = text "instance"
ppr_instance_keyword NotTopLevel = empty
-ppr_fam_inst_eqn :: (SourceTextX pass, OutputableBndrId pass)
- => TyFamInstEqn pass -> SDoc
+ppr_fam_inst_eqn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => TyFamInstEqn (GhcPass p) -> SDoc
ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = rhs }})
= pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs
-ppr_fam_deflt_eqn :: (SourceTextX pass, OutputableBndrId pass)
- => LTyFamDefltEqn pass -> SDoc
+ppr_fam_deflt_eqn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LTyFamDefltEqn (GhcPass p) -> SDoc
ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon
, feqn_pats = tvs
, feqn_fixity = fixity
@@ -1507,12 +1509,12 @@ ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon
= text "type" <+> pp_vanilla_decl_head tycon tvs fixity []
<+> equals <+> ppr rhs
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (DataFamInstDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (DataFamInstDecl (GhcPass p)) where
ppr = pprDataFamInstDecl TopLevel
-pprDataFamInstDecl :: (SourceTextX pass, OutputableBndrId pass)
- => TopLevelFlag -> DataFamInstDecl pass -> SDoc
+pprDataFamInstDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc
pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_tycon = tycon
, feqn_pats = pats
@@ -1528,12 +1530,12 @@ pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}})
= ppr nd
-pprFamInstLHS :: (SourceTextX pass, OutputableBndrId pass)
- => Located (IdP pass)
- -> HsTyPats pass
+pprFamInstLHS :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Located (IdP (GhcPass p))
+ -> HsTyPats (GhcPass p)
-> LexicalFixity
- -> HsContext pass
- -> Maybe (LHsKind pass)
+ -> HsContext (GhcPass p)
+ -> Maybe (LHsKind (GhcPass p))
-> SDoc
pprFamInstLHS thing typats fixity context mb_kind_sig
-- explicit type patterns
@@ -1553,8 +1555,8 @@ pprFamInstLHS thing typats fixity context mb_kind_sig
| otherwise
= empty
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ClsInstDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (ClsInstDecl (GhcPass p)) where
ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
, cid_sigs = sigs, cid_tyfam_insts = ats
, cid_overlap_mode = mbOverlap
@@ -1592,8 +1594,8 @@ ppOverlapPragma mb =
maybe_stext (SourceText src) _ = text src <+> text "#-}"
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (InstDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (InstDecl (GhcPass p)) where
ppr (ClsInstD { cid_inst = decl }) = ppr decl
ppr (TyFamInstD { tfid_inst = decl }) = ppr decl
ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
@@ -1632,10 +1634,10 @@ data DerivDecl pass = DerivDecl
-- For details on above see note [Api annotations] in ApiAnnotation
}
-deriving instance (DataId pass) => Data (DerivDecl pass)
+deriving instance (DataIdLR pass pass) => Data (DerivDecl pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (DerivDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (DerivDecl (GhcPass p)) where
ppr (DerivDecl { deriv_type = ty
, deriv_strategy = ds
, deriv_overlap_mode = o })
@@ -1667,10 +1669,10 @@ data DefaultDecl pass
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (DefaultDecl pass)
+deriving instance (DataIdLR pass pass) => Data (DefaultDecl pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (DefaultDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (DefaultDecl (GhcPass p)) where
ppr (DefaultDecl tys)
= text "default" <+> parens (interpp'SP tys)
@@ -1712,7 +1714,7 @@ data ForeignDecl pass
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (ForeignDecl pass)
+deriving instance (DataIdLR pass pass) => Data (ForeignDecl pass)
{-
In both ForeignImport and ForeignExport:
sig_ty is the type given in the Haskell code
@@ -1773,8 +1775,8 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling
-- pretty printing of foreign declarations
--
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ForeignDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (ForeignDecl (GhcPass p)) where
ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })
= hang (text "foreign import" <+> ppr fimport <+> ppr n)
2 (dcolon <+> ppr ty)
@@ -1829,7 +1831,7 @@ type LRuleDecls pass = Located (RuleDecls pass)
-- | Rule Declarations
data RuleDecls pass = HsRules { rds_src :: SourceText
, rds_rules :: [LRuleDecl pass] }
-deriving instance (DataId pass) => Data (RuleDecls pass)
+deriving instance (DataIdLR pass pass) => Data (RuleDecls pass)
-- | Located Rule Declaration
type LRuleDecl pass = Located (RuleDecl pass)
@@ -1855,7 +1857,7 @@ data RuleDecl pass
-- 'ApiAnnotation.AnnEqual',
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (RuleDecl pass)
+deriving instance (DataIdLR pass pass) => Data (RuleDecl pass)
flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass]
flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
@@ -1872,7 +1874,7 @@ data RuleBndr pass
-- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (RuleBndr pass)
+deriving instance (DataIdLR pass pass) => Data (RuleBndr pass)
collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
@@ -1880,14 +1882,14 @@ collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
pprFullRuleName :: Located (SourceText, RuleName) -> SDoc
pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (RuleDecls pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (RuleDecls (GhcPass p)) where
ppr (HsRules st rules)
= pprWithSourceText st (text "{-# RULES")
<+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (RuleDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (RuleDecl (GhcPass p)) where
ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
= sep [pprFullRuleName name <+> ppr act,
nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
@@ -1896,8 +1898,8 @@ instance (SourceTextX pass, OutputableBndrId pass)
pp_forall | null ns = empty
| otherwise = forAllLit <+> fsep (map ppr ns) <> dot
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (RuleBndr pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (RuleBndr (GhcPass p)) where
ppr (RuleBndr name) = ppr name
ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty)
@@ -1965,7 +1967,7 @@ data VectDecl pass
(LHsSigType pass)
| HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now
ClsInst
-deriving instance (DataId pass) => Data (VectDecl pass)
+deriving instance (DataIdLR pass pass) => Data (VectDecl pass)
lvectDeclName :: NamedThing (IdP pass) => LVectDecl pass -> Name
lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name
@@ -1984,8 +1986,8 @@ lvectInstDecl (L _ (HsVectInstIn _)) = True
lvectInstDecl (L _ (HsVectInstOut _)) = True
lvectInstDecl _ = False
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (VectDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (VectDecl (GhcPass p)) where
ppr (HsVect _ v rhs)
= sep [text "{-# VECTORISE" <+> ppr v,
nest 4 $
@@ -2104,10 +2106,10 @@ data AnnDecl pass = HsAnnotation
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (AnnDecl pass)
+deriving instance (DataIdLR pass pass) => Data (AnnDecl pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (AnnDecl pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (AnnDecl (GhcPass p)) where
ppr (HsAnnotation _ provenance expr)
= hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index fedaa4491a..82e7f27b46 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -11,6 +11,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
-- | Abstract Haskell syntax for expressions.
module HsExpr where
@@ -109,7 +110,7 @@ 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)
@@ -133,7 +134,8 @@ mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name
-- don't care about filling in syn_arg_wraps because we're clearly
-- not past the typechecker
-instance (SourceTextX p, OutputableBndrId p) => Outputable (SyntaxExpr p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (SyntaxExpr (GhcPass p)) where
ppr (SyntaxExpr { syn_expr = expr
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap })
@@ -704,7 +706,7 @@ data HsExpr p
| HsWrap HsWrapper -- TRANSLATION
(HsExpr p)
-deriving instance (DataId p) => Data (HsExpr p)
+deriving instance (DataIdLR p p) => Data (HsExpr p)
-- | Located Haskell Tuple Argument
--
@@ -721,7 +723,7 @@ type LHsTupArg id = Located (HsTupArg id)
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)
+deriving instance (DataIdLR id id) => Data (HsTupArg id)
tupArgPresent :: LHsTupArg id -> Bool
tupArgPresent (L _ (Present {})) = True
@@ -799,16 +801,19 @@ RenamedSource that the API Annotations cannot be used directly with
RenamedSource, so this allows a simple mapping to be used based on the location.
-}
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsExpr (GhcPass p)) where
ppr expr = pprExpr expr
-----------------------
-- pprExpr, pprLExpr, pprBinds call pprDeeper;
-- the underscore versions do not
-pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsExpr (GhcPass p) -> SDoc
pprLExpr (L _ e) = pprExpr e
-pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+pprExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p) -> SDoc
pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e
| otherwise = pprDeeper (ppr_expr e)
@@ -824,16 +829,18 @@ isQuietHsExpr (HsAppTypeOut _ _) = True
isQuietHsExpr (OpApp _ _ _ _) = True
isQuietHsExpr _ = False
-pprBinds :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => HsLocalBindsLR idL idR -> SDoc
+pprBinds :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprBinds b = pprDeeper (ppr b)
-----------------------
-ppr_lexpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+ppr_lexpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsExpr (GhcPass p) -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
-ppr_expr :: forall p. (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+ppr_expr :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p) -> SDoc
ppr_expr (HsVar (L _ v)) = pprPrefixOcc v
ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)
ppr_expr (HsConLikeOut c) = pprPrefixOcc c
@@ -1051,11 +1058,13 @@ 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. (SourceTextX p, OutputableBndrId p)
- => LHsWcTypeX (LHsWcType p)
+data LHsWcTypeX = forall p. ( SourceTextX (GhcPass p)
+ , OutputableBndrId (GhcPass p))
+ => LHsWcTypeX (LHsWcType (GhcPass p))
-ppr_apps :: (SourceTextX p, OutputableBndrId p) => HsExpr p
- -> [Either (LHsExpr p) LHsWcTypeX]
+ppr_apps :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p)
+ -> [Either (LHsExpr (GhcPass p)) LHsWcTypeX]
-> SDoc
ppr_apps (HsApp (L _ fun) arg) args
= ppr_apps fun (Left arg : args)
@@ -1085,16 +1094,19 @@ fixities should do the job, except in debug mode (-dppr-debug) so we
can see the structure of the parse tree.
-}
-pprDebugParendExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprDebugParendExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsExpr (GhcPass p) -> SDoc
pprDebugParendExpr expr
= getPprStyle (\sty ->
if debugStyle sty then pprParendLExpr expr
else pprLExpr expr)
-pprParendLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprParendLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsExpr (GhcPass p) -> SDoc
pprParendLExpr (L _ e) = pprParendExpr e
-pprParendExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+pprParendExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p) -> SDoc
pprParendExpr expr
| hsExprNeedsParens expr = parens (pprExpr expr)
| otherwise = pprExpr expr
@@ -1242,7 +1254,7 @@ data HsCmd id
(HsCmd id) -- If cmd :: arg1 --> res
-- wrap :: arg1 "->" arg2
-- Then (HsCmdWrap wrap cmd) :: arg2 --> res
-deriving instance (DataId id) => Data (HsCmd id)
+deriving instance (DataIdLR id id) => Data (HsCmd id)
-- | Haskell Array Application Type
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
@@ -1263,18 +1275,21 @@ data HsCmdTop 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)
+deriving instance (DataIdLR p p) => Data (HsCmdTop p)
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsCmd (GhcPass p)) where
ppr cmd = pprCmd cmd
-----------------------
-- pprCmd and pprLCmd call pprDeeper;
-- the underscore versions do not
-pprLCmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc
+pprLCmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsCmd (GhcPass p) -> SDoc
pprLCmd (L _ c) = pprCmd c
-pprCmd :: (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc
+pprCmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsCmd (GhcPass p) -> SDoc
pprCmd c | isQuietHsCmd c = ppr_cmd c
| otherwise = pprDeeper (ppr_cmd c)
@@ -1288,10 +1303,12 @@ isQuietHsCmd (HsCmdApp _ _) = True
isQuietHsCmd _ = False
-----------------------
-ppr_lcmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc
+ppr_lcmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsCmd (GhcPass p) -> SDoc
ppr_lcmd c = ppr_cmd (unLoc c)
-ppr_cmd :: forall p. (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc
+ppr_cmd :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsCmd (GhcPass p) -> SDoc
ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)
ppr_cmd (HsCmdApp c e)
@@ -1352,11 +1369,13 @@ ppr_cmd (HsCmdArrForm op _ _ args)
= hang (text "(|" <> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <> text "|)")
-pprCmdArg :: (SourceTextX p, OutputableBndrId p) => HsCmdTop p -> SDoc
+pprCmdArg :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsCmdTop (GhcPass p) -> SDoc
pprCmdArg (HsCmdTop cmd _ _ _)
= ppr_lcmd cmd
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmdTop p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsCmdTop (GhcPass p)) where
ppr = pprCmdArg
{-
@@ -1400,7 +1419,7 @@ 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)
@@ -1415,10 +1434,11 @@ data Match p body
m_pats :: [LPat p], -- The patterns
m_grhss :: (GRHSs p body)
}
-deriving instance (Data body,DataId p) => Data (Match p body)
+deriving instance (Data body,DataIdLR p p) => Data (Match p body)
-instance (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => Outputable (Match idR body) where
+instance (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => Outputable (Match (GhcPass idR) body) where
ppr = pprMatch
{-
@@ -1500,7 +1520,7 @@ data GRHSs p body
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)
@@ -1508,32 +1528,37 @@ type LGRHS id body = Located (GRHS id body)
-- | Guarded Right Hand Side.
data GRHS id body = GRHS [GuardLStmt id] -- Guards
body -- Right hand side
-deriving instance (Data body,DataId id) => Data (GRHS id body)
+deriving instance (Data body,DataIdLR id id) => Data (GRHS id body)
-- We know the list must have at least one @Match@ in it.
-pprMatches :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => MatchGroup idR body -> SDoc
+pprMatches :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => MatchGroup (GhcPass idR) body -> SDoc
pprMatches MG { mg_alts = matches }
= vcat (map pprMatch (map unLoc (unLoc matches)))
-- Don't print the type; it's only a place-holder before typechecking
-- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => MatchGroup idR body -> SDoc
+pprFunBind :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => MatchGroup (GhcPass idR) body -> SDoc
pprFunBind matches = pprMatches matches
-- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr,
- OutputableBndrId bndr,
- OutputableBndrId p,
+pprPatBind :: forall bndr p body. (SourceTextX (GhcPass p),
+ SourceTextX (GhcPass bndr),
+ OutputableBndrId (GhcPass bndr),
+ OutputableBndrId (GhcPass p),
Outputable body)
- => LPat bndr -> GRHSs p body -> SDoc
+ => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
pprPatBind pat (grhss)
- = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP p)) grhss)]
+ = sep [ppr pat, nest 2
+ (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)]
-pprMatch :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => Match idR body -> SDoc
+pprMatch :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => Match (GhcPass idR) body -> SDoc
pprMatch match
= sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
, nest 2 (pprGRHSs ctxt (m_grhss match)) ]
@@ -1566,8 +1591,9 @@ pprMatch match
(pat1:pats1) = m_pats match
(pat2:pats2) = pats1
-pprGRHSs :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => HsMatchContext idL -> GRHSs idR body -> SDoc
+pprGRHSs :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc
pprGRHSs ctxt (GRHSs grhss (L _ binds))
= vcat (map (pprGRHS ctxt . unLoc) grhss)
-- Print the "where" even if the contents of the binds is empty. Only
@@ -1575,8 +1601,9 @@ pprGRHSs ctxt (GRHSs grhss (L _ binds))
$$ ppUnless (eqEmptyLocalBinds binds)
(text "where" $$ nest 4 (pprBinds binds))
-pprGRHS :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => HsMatchContext idL -> GRHS idR body -> SDoc
+pprGRHS :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc
pprGRHS ctxt (GRHS [] body)
= pp_rhs ctxt body
@@ -1759,7 +1786,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
@@ -1773,7 +1800,7 @@ data ParStmtBlock 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)
+deriving instance (DataIdLR idL idR) => Data (ParStmtBlock idL idR)
-- | Applicative Argument
data ApplicativeArg idL idR
@@ -1788,8 +1815,7 @@ data ApplicativeArg idL idR
[ExprLStmt idL] -- stmts
(HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn)
(LPat idL) -- (v1,...,vn)
-
-deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR)
+deriving instance (DataIdLR idL idR) => Data (ApplicativeArg idL idR)
{-
Note [The type of bind in Stmts]
@@ -1956,19 +1982,22 @@ Bool flag that is True when the original statement was a BodyStmt, so
that we can pretty-print it correctly.
-}
-instance (SourceTextX idL, OutputableBndrId idL)
- => Outputable (ParStmtBlock idL idR) where
+instance (SourceTextX (GhcPass idL), OutputableBndrId (GhcPass idL))
+ => Outputable (ParStmtBlock (GhcPass idL) idR) where
ppr (ParStmtBlock stmts _ _) = interpp'SP stmts
-instance (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR, Outputable body)
- => Outputable (StmtLR idL idR body) where
+instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => Outputable (StmtLR (GhcPass idL) (GhcPass idR) body) where
ppr stmt = pprStmt stmt
-pprStmt :: forall idL idR body . (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR,
+pprStmt :: forall idL idR body . (SourceTextX (GhcPass idL),
+ SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL),
+ OutputableBndrId (GhcPass idR),
Outputable body)
- => (StmtLR idL idR body) -> SDoc
+ => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc
pprStmt (LastStmt expr ret_stripped _)
= whenPprDebug (text "[last]") <+>
(if ret_stripped then text "return" else empty) <+>
@@ -2002,17 +2031,17 @@ pprStmt (ApplicativeStmt args mb_join _)
-- ppr directly rather than transforming here, because we need to
-- inject a "return" which is hard when we're polymorphic in the id
-- type.
- flattenStmt :: ExprLStmt idL -> [SDoc]
+ flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]
flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args
flattenStmt stmt = [ppr stmt]
flattenArg (_, ApplicativeArgOne pat expr isBody)
| isBody = -- See Note [Applicative BodyStmt]
[ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)]
+ :: ExprStmt (GhcPass idL))]
| otherwise =
[ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)]
+ :: ExprStmt (GhcPass idL))]
flattenArg (_, ApplicativeArgMany stmts _ _) =
concatMap flattenStmt stmts
@@ -2027,10 +2056,10 @@ pprStmt (ApplicativeStmt args mb_join _)
pp_arg (_, ApplicativeArgOne pat expr isBody)
| isBody = -- See Note [Applicative BodyStmt]
ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)
+ :: ExprStmt (GhcPass idL))
| otherwise =
ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)
+ :: ExprStmt (GhcPass idL))
pp_arg (_, ApplicativeArgMany stmts return pat) =
ppr pat <+>
text "<-" <+>
@@ -2038,8 +2067,9 @@ pprStmt (ApplicativeStmt args mb_join _)
(stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]))
(error "pprStmt"))
-pprTransformStmt :: (SourceTextX p, OutputableBndrId p)
- => [IdP p] -> LHsExpr p -> Maybe (LHsExpr p) -> SDoc
+pprTransformStmt :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
+ -> Maybe (LHsExpr (GhcPass p)) -> SDoc
pprTransformStmt bndrs using by
= sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))
, nest 2 (ppr using)
@@ -2055,8 +2085,9 @@ pprBy :: Outputable body => Maybe body -> SDoc
pprBy Nothing = empty
pprBy (Just e) = text "by" <+> ppr e
-pprDo :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => HsStmtContext any -> [LStmt p body] -> SDoc
+pprDo :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p),
+ Outputable body)
+ => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc
pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts
pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts
pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts
@@ -2066,14 +2097,16 @@ pprDo PArrComp stmts = paBrackets $ pprComp stmts
pprDo MonadComp stmts = brackets $ pprComp stmts
pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
-ppr_do_stmts :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR, Outputable body)
- => [LStmtLR idL idR body] -> SDoc
+ppr_do_stmts :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc
-- Print a bunch of do stmts
ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)
-pprComp :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => [LStmt p body] -> SDoc
+pprComp :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p),
+ Outputable body)
+ => [LStmt (GhcPass p) body] -> SDoc
pprComp quals -- Prints: body | qual1, ..., qualn
| Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals
= if null initStmts
@@ -2087,8 +2120,9 @@ pprComp quals -- Prints: body | qual1, ..., qualn
| otherwise
= pprPanic "pprComp" (pprQuals quals)
-pprQuals :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => [LStmt p body] -> SDoc
+pprQuals :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p),
+ Outputable body)
+ => [LStmt (GhcPass p) body] -> SDoc
-- Show list comprehension qualifiers separated by commas
pprQuals quals = interpp'SP quals
@@ -2126,7 +2160,7 @@ data HsSplice id
ThModFinalizers -- TH finalizers produced by the splice.
(HsSplicedThing id) -- The result of splicing
deriving Typeable
-deriving instance (DataId id) => Data (HsSplice id)
+deriving instance (DataIdLR id id) => Data (HsSplice id)
-- | A splice can appear with various decorations wrapped around it. This data
-- type captures explicitly how it was originally written, for use in the pretty
@@ -2168,7 +2202,7 @@ data HsSplicedThing id
| HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern
deriving Typeable
-deriving instance (DataId id) => Data (HsSplicedThing id)
+deriving instance (DataIdLR id id) => Data (HsSplicedThing id)
-- See Note [Pending Splices]
type SplicePointName = Name
@@ -2192,7 +2226,6 @@ data PendingTcSplice
= PendingTcSplice SplicePointName (LHsExpr GhcTc)
deriving Data
-
{-
Note [Pending Splices]
~~~~~~~~~~~~~~~~~~~~~~
@@ -2257,30 +2290,33 @@ splices. In contrast, when pretty printing the output of the type checker, we
sense, although I hate to add another constructor to HsExpr.
-}
-instance (SourceTextX p, OutputableBndrId p)
- => Outputable (HsSplicedThing p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsSplicedThing (GhcPass p)) where
ppr (HsSplicedExpr e) = ppr_expr e
ppr (HsSplicedTy t) = ppr t
ppr (HsSplicedPat p) = ppr p
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsSplice p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsSplice (GhcPass p)) where
ppr s = pprSplice s
-pprPendingSplice :: (SourceTextX p, OutputableBndrId p)
- => SplicePointName -> LHsExpr p -> SDoc
+pprPendingSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => SplicePointName -> LHsExpr (GhcPass p) -> SDoc
pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e)
-pprSpliceDecl :: (SourceTextX p, OutputableBndrId p)
- => HsSplice p -> SpliceExplicitFlag -> SDoc
+pprSpliceDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e
pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")"
pprSpliceDecl e ImplicitSplice = ppr_splice_decl e
-ppr_splice_decl :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
+ppr_splice_decl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SDoc
ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty
ppr_splice_decl e = pprSplice e
-pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
+pprSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SDoc
pprSplice (HsTypedSplice HasParens n e)
= ppr_splice (text "$$(") n e (text ")")
pprSplice (HsTypedSplice HasDollar n e)
@@ -2301,8 +2337,8 @@ ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>
char '[' <> ppr quoter <> vbar <>
ppr quote <> text "|]"
-ppr_splice :: (SourceTextX p, OutputableBndrId p)
- => SDoc -> (IdP p) -> LHsExpr p -> SDoc -> SDoc
+ppr_splice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc
ppr_splice herald n e trail
= herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail
@@ -2315,17 +2351,19 @@ data HsBracket p = ExpBr (LHsExpr p) -- [| expr |]
| 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)
+deriving instance (DataIdLR p p) => Data (HsBracket p)
isTypedBracket :: HsBracket id -> Bool
isTypedBracket (TExpBr {}) = True
isTypedBracket _ = False
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsBracket p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsBracket (GhcPass p)) where
ppr = pprHsBracket
-pprHsBracket :: (SourceTextX p, OutputableBndrId p) => HsBracket p -> SDoc
+pprHsBracket :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsBracket (GhcPass p) -> SDoc
pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
@@ -2368,10 +2406,10 @@ 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)
-instance (SourceTextX p, OutputableBndrId p)
- => Outputable (ArithSeqInfo p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (ArithSeqInfo (GhcPass p)) where
ppr (From e1) = hcat [ppr e1, pp_dotdot]
ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3]
@@ -2587,19 +2625,21 @@ matchContextErrString (StmtCtxt ListComp) = text "list comprehension"
matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension"
matchContextErrString (StmtCtxt PArrComp) = text "array comprehension"
-pprMatchInCtxt :: (SourceTextX idR, OutputableBndrId idR,
+pprMatchInCtxt :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
-- TODO:AZ these constraints do not make sense
- Outputable (NameOrRdrName (NameOrRdrName (IdP idR))),
- Outputable body)
- => Match idR body -> SDoc
+ Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))),
+ Outputable body)
+ => Match (GhcPass idR) body -> SDoc
pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
<> colon)
4 (pprMatch match)
-pprStmtInCtxt :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR,
+pprStmtInCtxt :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
+ OutputableBndrId (GhcPass idL),
+ OutputableBndrId (GhcPass idR),
Outputable body)
- => HsStmtContext (IdP idL) -> StmtLR idL idR body -> SDoc
+ => HsStmtContext (IdP (GhcPass idL))
+ -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
pprStmtInCtxt ctxt (LastStmt e _ _)
| isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts"
= hang (text "In the expression:") 2 (ppr e)
diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot
index bac8a5a183..500d601477 100644
--- a/compiler/hsSyn/HsExpr.hs-boot
+++ b/compiler/hsSyn/HsExpr.hs-boot
@@ -5,6 +5,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
module HsExpr where
@@ -12,7 +13,7 @@ import SrcLoc ( Located )
import Outputable ( SDoc, Outputable )
import {-# SOURCE #-} HsPat ( LPat )
import BasicTypes ( SpliceExplicitFlag(..))
-import HsExtension ( OutputableBndrId, DataId, SourceTextX )
+import HsExtension ( OutputableBndrId, DataIdLR, SourceTextX, GhcPass )
import Data.Data hiding ( Fixity )
type role HsExpr nominal
@@ -28,32 +29,39 @@ data MatchGroup (a :: *) (body :: *)
data GRHSs (a :: *) (body :: *)
data SyntaxExpr (i :: *)
-instance (DataId p) => Data (HsSplice p)
-instance (DataId p) => Data (HsExpr p)
-instance (DataId p) => Data (HsCmd p)
-instance (Data body,DataId p) => Data (MatchGroup p body)
-instance (Data body,DataId p) => Data (GRHSs p body)
-instance (DataId p) => Data (SyntaxExpr p)
+instance (DataIdLR p p) => Data (HsSplice p)
+instance (DataIdLR p p) => Data (HsExpr p)
+instance (DataIdLR p p) => Data (HsCmd p)
+instance (Data body,DataIdLR p p) => Data (MatchGroup p body)
+instance (Data body,DataIdLR p p) => Data (GRHSs p body)
+instance (DataIdLR p p) => Data (SyntaxExpr p)
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p)
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p)
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsExpr (GhcPass p))
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsCmd (GhcPass p))
type LHsExpr a = Located (HsExpr a)
-pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsExpr (GhcPass p) -> SDoc
-pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+pprExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p) -> SDoc
-pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
+pprSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SDoc
-pprSpliceDecl :: (SourceTextX p, OutputableBndrId p)
- => HsSplice p -> SpliceExplicitFlag -> SDoc
+pprSpliceDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
-pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr,
- OutputableBndrId bndr,
- OutputableBndrId p,
+pprPatBind :: forall bndr p body. (SourceTextX (GhcPass p),
+ SourceTextX (GhcPass bndr),
+ OutputableBndrId (GhcPass bndr),
+ OutputableBndrId (GhcPass p),
Outputable body)
- => LPat bndr -> GRHSs p body -> SDoc
+ => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
-pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => MatchGroup idR body -> SDoc
+pprFunBind :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => MatchGroup (GhcPass idR) body -> SDoc
diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs
index 80dfa67ea3..b641670108 100644
--- a/compiler/hsSyn/HsExtension.hs
+++ b/compiler/hsSyn/HsExtension.hs
@@ -7,6 +7,9 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+ -- in module PlaceHolder
module HsExtension where
@@ -55,6 +58,10 @@ haskell-src-exts ASTs as well.
-}
+-- | Used when constructing a term with an unused extension point.
+noExt :: PlaceHolder
+noExt = PlaceHolder
+
-- | Used as a data type index for the hsSyn AST
data GhcPass (c :: Pass)
deriving instance Eq (GhcPass c)
@@ -76,6 +83,8 @@ type instance PostTc GhcPs ty = PlaceHolder
type instance PostTc GhcRn ty = PlaceHolder
type instance PostTc GhcTc ty = ty
+-- deriving instance (Data ty) => Data (PostTc (GhcPass 'Parsed) ty)
+
-- | Types that are not defined until after renaming
type family PostRn x ty -- Note [Pass sensitive types] in PlaceHolder
type instance PostRn GhcPs ty = PlaceHolder
@@ -87,88 +96,214 @@ type family IdP p
type instance IdP GhcPs = RdrName
type instance IdP GhcRn = Name
type instance IdP GhcTc = Id
+-- type instance IdP (GHC x) = IdP x
+
+type LIdP p = Located (IdP p)
+
+-- ---------------------------------------------------------------------
+-- type families for the Pat extension points
+type family XWildPat x
+type family XVarPat x
+type family XLazyPat x
+type family XAsPat x
+type family XParPat x
+type family XBangPat x
+type family XListPat x
+type family XTuplePat x
+type family XSumPat x
+type family XPArrPat x
+type family XConPat x
+type family XViewPat x
+type family XSplicePat x
+type family XLitPat x
+type family XNPat x
+type family XNPlusKPat x
+type family XSigPat x
+type family XCoPat x
+type family XXPat x
+
+
+type ForallXPat (c :: * -> Constraint) (x :: *) =
+ ( c (XWildPat x)
+ , c (XVarPat x)
+ , c (XLazyPat x)
+ , c (XAsPat x)
+ , c (XParPat x)
+ , c (XBangPat x)
+ , c (XListPat x)
+ , c (XTuplePat x)
+ , c (XSumPat x)
+ , c (XPArrPat x)
+ , c (XViewPat x)
+ , c (XSplicePat x)
+ , c (XLitPat x)
+ , c (XNPat x)
+ , c (XNPlusKPat x)
+ , c (XSigPat x)
+ , c (XCoPat x)
+ , c (XXPat x)
+ )
+-- ---------------------------------------------------------------------
+-- ValBindsLR type families
+type family XValBinds x x'
+type family 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.
-type family XHsChar x
-type family XHsCharPrim x
-type family XHsString x
+type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *)=
+ ( c (XValBinds x x')
+ , c (XXValBindsLR x x')
+ )
+
+
+
+
+-- We define a type family for each HsLit extension point. This is based on
+-- prepending 'X' to the constructor name, for ease of reference.
+type family XHsChar x
+type family XHsCharPrim x
+type family XHsString x
type family XHsStringPrim x
-type family XHsInt x
-type family XHsIntPrim x
-type family XHsWordPrim x
-type family XHsInt64Prim x
+type family XHsInt x
+type family XHsIntPrim x
+type family XHsWordPrim x
+type family XHsInt64Prim x
type family XHsWord64Prim x
-type family XHsInteger x
-type family XHsRat x
-type family XHsFloatPrim x
+type family XHsInteger x
+type family XHsRat x
+type family XHsFloatPrim x
type family XHsDoublePrim x
+type family XXLit x
--- | Helper to apply a constraint to all extension points. It has one
+-- | Helper to apply a constraint to all HsLit extension points. It has one
-- entry per extension point type family.
-type ForallX (c :: * -> Constraint) (x :: *) =
- ( c (XHsChar x)
- , c (XHsCharPrim x)
- , c (XHsString x)
+type ForallXHsLit (c :: * -> Constraint) (x :: *) =
+ ( c (XHsChar x)
+ , c (XHsCharPrim x)
+ , c (XHsString x)
, c (XHsStringPrim x)
- , c (XHsInt x)
- , c (XHsIntPrim x)
- , c (XHsWordPrim x)
- , c (XHsInt64Prim x)
+ , c (XHsInt x)
+ , c (XHsIntPrim x)
+ , c (XHsWordPrim x)
+ , c (XHsInt64Prim x)
, c (XHsWord64Prim x)
- , c (XHsInteger x)
- , c (XHsRat x)
- , c (XHsFloatPrim x)
+ , c (XHsInteger x)
+ , c (XHsRat x)
+ , c (XHsFloatPrim x)
, c (XHsDoublePrim x)
+ , c (XXLit x)
)
--- Provide the specific extension types for the parser phase.
-type instance XHsChar GhcPs = SourceText
-type instance XHsCharPrim GhcPs = SourceText
-type instance XHsString GhcPs = SourceText
-type instance XHsStringPrim GhcPs = SourceText
-type instance XHsInt GhcPs = ()
-type instance XHsIntPrim GhcPs = SourceText
-type instance XHsWordPrim GhcPs = SourceText
-type instance XHsInt64Prim GhcPs = SourceText
-type instance XHsWord64Prim GhcPs = SourceText
-type instance XHsInteger GhcPs = SourceText
-type instance XHsRat GhcPs = ()
-type instance XHsFloatPrim GhcPs = ()
-type instance XHsDoublePrim GhcPs = ()
-
--- Provide the specific extension types for the renamer phase.
-type instance XHsChar GhcRn = SourceText
-type instance XHsCharPrim GhcRn = SourceText
-type instance XHsString GhcRn = SourceText
-type instance XHsStringPrim GhcRn = SourceText
-type instance XHsInt GhcRn = ()
-type instance XHsIntPrim GhcRn = SourceText
-type instance XHsWordPrim GhcRn = SourceText
-type instance XHsInt64Prim GhcRn = SourceText
-type instance XHsWord64Prim GhcRn = SourceText
-type instance XHsInteger GhcRn = SourceText
-type instance XHsRat GhcRn = ()
-type instance XHsFloatPrim GhcRn = ()
-type instance XHsDoublePrim GhcRn = ()
-
--- Provide the specific extension types for the typechecker phase.
-type instance XHsChar GhcTc = SourceText
-type instance XHsCharPrim GhcTc = SourceText
-type instance XHsString GhcTc = SourceText
-type instance XHsStringPrim GhcTc = SourceText
-type instance XHsInt GhcTc = ()
-type instance XHsIntPrim GhcTc = SourceText
-type instance XHsWordPrim GhcTc = SourceText
-type instance XHsInt64Prim GhcTc = SourceText
-type instance XHsWord64Prim GhcTc = SourceText
-type instance XHsInteger GhcTc = SourceText
-type instance XHsRat GhcTc = ()
-type instance XHsFloatPrim GhcTc = ()
-type instance XHsDoublePrim GhcTc = ()
+type family XOverLit x
+type family XXOverLit x
+type ForallXOverLit (c :: * -> Constraint) (x :: *) =
+ ( c (XOverLit x)
+ , c (XXOverLit x)
+ )
+
+-- ---------------------------------------------------------------------
+-- Type families for the Type type families
+
+type family XForAllTy x
+type family XQualTy x
+type family XTyVar x
+type family XAppsTy x
+type family XAppTy x
+type family XFunTy x
+type family XListTy x
+type family XPArrTy x
+type family XTupleTy x
+type family XSumTy x
+type family XOpTy x
+type family XParTy x
+type family XIParamTy x
+type family XEqTy x
+type family XKindSig x
+type family XSpliceTy x
+type family XDocTy x
+type family XBangTy x
+type family XRecTy x
+type family XExplicitListTy x
+type family XExplicitTupleTy x
+type family XTyLit x
+type family XWildCardTy x
+type family XXType x
+
+-- | Helper to apply a constraint to all extension points. It has one
+-- entry per extension point type family.
+type ForallXType (c :: * -> Constraint) (x :: *) =
+ ( c (XForAllTy x)
+ , c (XQualTy x)
+ , c (XTyVar x)
+ , c (XAppsTy x)
+ , c (XAppTy x)
+ , c (XFunTy x)
+ , c (XListTy x)
+ , c (XPArrTy x)
+ , c (XTupleTy x)
+ , c (XSumTy x)
+ , c (XOpTy x)
+ , c (XParTy x)
+ , c (XIParamTy x)
+ , c (XEqTy x)
+ , c (XKindSig x)
+ , c (XSpliceTy x)
+ , c (XDocTy x)
+ , c (XBangTy x)
+ , c (XRecTy x)
+ , c (XExplicitListTy x)
+ , c (XExplicitTupleTy x)
+ , c (XTyLit x)
+ , c (XWildCardTy x)
+ , c (XXType x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XUserTyVar x
+type family XKindedTyVar x
+type family XXTyVarBndr x
+
+type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) =
+ ( c (XUserTyVar x)
+ , c (XKindedTyVar x)
+ , c (XXTyVarBndr x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XAppInfix x
+type family XAppPrefix x
+type family XXAppType x
+
+type ForallXAppType (c :: * -> Constraint) (x :: *) =
+ ( c (XAppInfix x)
+ , c (XAppPrefix x)
+ , c (XXAppType x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XFieldOcc x
+type family XXFieldOcc x
+
+type ForallXFieldOcc (c :: * -> Constraint) (x :: *) =
+ ( c (XFieldOcc x)
+ , c (XXFieldOcc x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XUnambiguous x
+type family XAmbiguous x
+type family XXAmbiguousFieldOcc x
+
+type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) =
+ ( c (XUnambiguous x)
+ , c (XAmbiguous x)
+ , c (XXAmbiguousFieldOcc x)
+ )
-- ---------------------------------------------------------------------
@@ -212,22 +347,6 @@ instance HasSourceText SourceText where
-- ----------------------------------------------------------------------
--- | Defaults for each annotation, used to simplify creation in arbitrary
--- contexts
-class HasDefault a where
- def :: a
-
-instance HasDefault () where
- def = ()
-
-instance HasDefault SourceText where
- def = NoSourceText
-
--- | Provide a single constraint that captures the requirement for a default
--- across all the extension points.
-type HasDefaultX x = ForallX HasDefault x
-
--- ----------------------------------------------------------------------
-- | Conversion of annotations from one type index to another. This is required
-- where the AST is converted from one pass to another, and the extension values
-- need to be brought along if possible. So for example a 'SourceText' is
@@ -254,15 +373,46 @@ 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)
+ )
+-- TODO: Should OutputableX be included in OutputableBndrId?
-- ----------------------------------------------------------------------
--
type DataId p =
( Data p
- , ForallX Data p
+
+ , ForallXHsLit Data p
+ , ForallXPat Data p
+
+ -- AZ: The following ForAllXXXX shoulbe be unnecessary? Driven by ValBindsOut
+ -- , ForallXPat Data (GhcPass 'Parsed)
+ , ForallXPat Data (GhcPass 'Renamed)
+ -- , ForallXPat Data (GhcPass 'Typechecked)
+ , ForallXType Data (GhcPass 'Renamed)
+
+ , ForallXOverLit Data p
+ , ForallXType Data p
+ , ForallXTyVarBndr Data p
+ , ForallXAppType Data p
+ , ForallXFieldOcc Data p
+ , ForallXAmbiguousFieldOcc Data p
+
, Data (NameOrRdrName (IdP p))
, Data (IdP p)
@@ -282,10 +432,18 @@ 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
+ )
-- |Constraint type to bundle up the requirement for 'OutputableBndr' on both
-- the @id@ and the 'NameOrRdrName' type for it
type OutputableBndrId id =
( OutputableBndr (NameOrRdrName (IdP id))
, OutputableBndr (IdP id)
+ , OutputableX id
)
diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs
index 7f0864eccc..a47b0ff4fe 100644
--- a/compiler/hsSyn/HsLit.hs
+++ b/compiler/hsSyn/HsLit.hs
@@ -28,6 +28,7 @@ import Type ( Type )
import Outputable
import FastString
import HsExtension
+import PlaceHolder
import Data.ByteString (ByteString)
import Data.Data hiding ( Fixity )
@@ -77,8 +78,25 @@ data HsLit x
| HsDoublePrim (XHsDoublePrim x) FractionalLit
-- ^ Unboxed Double
+ | XLit (XXLit x)
+
deriving instance (DataId x) => Data (HsLit x)
+type instance XHsChar (GhcPass _) = SourceText
+type instance XHsCharPrim (GhcPass _) = SourceText
+type instance XHsString (GhcPass _) = SourceText
+type instance XHsStringPrim (GhcPass _) = SourceText
+type instance XHsInt (GhcPass _) = PlaceHolder
+type instance XHsIntPrim (GhcPass _) = SourceText
+type instance XHsWordPrim (GhcPass _) = SourceText
+type instance XHsInt64Prim (GhcPass _) = SourceText
+type instance XHsWord64Prim (GhcPass _) = SourceText
+type instance XHsInteger (GhcPass _) = SourceText
+type instance XHsRat (GhcPass _) = PlaceHolder
+type instance XHsFloatPrim (GhcPass _) = PlaceHolder
+type instance XHsDoublePrim (GhcPass _) = PlaceHolder
+type instance XXLit (GhcPass _) = PlaceHolder
+
instance Eq (HsLit x) where
(HsChar _ x1) == (HsChar _ x2) = x1==x2
@@ -99,11 +117,25 @@ instance Eq (HsLit x) where
-- | Haskell Overloaded Literal
data HsOverLit p
= OverLit {
- ol_val :: OverLitVal,
- ol_rebindable :: PostRn p Bool, -- Note [ol_rebindable]
- ol_witness :: HsExpr p, -- Note [Overloaded literal witnesses]
- ol_type :: PostTc p Type }
-deriving instance (DataId p) => Data (HsOverLit p)
+ ol_ext :: (XOverLit p),
+ ol_val :: OverLitVal,
+ ol_witness :: HsExpr p} -- Note [Overloaded literal witnesses]
+
+ | XOverLit
+ (XXOverLit p)
+deriving instance (DataIdLR p p) => Data (HsOverLit p)
+
+data OverLitTc
+ = OverLitTc {
+ ol_rebindable :: Bool, -- Note [ol_rebindable]
+ ol_type :: Type }
+ deriving Data
+
+type instance XOverLit GhcPs = PlaceHolder
+type instance XOverLit GhcRn = Bool -- Note [ol_rebindable]
+type instance XOverLit GhcTc = OverLitTc
+
+type instance XXOverLit (GhcPass _) = PlaceHolder
-- Note [Literal source text] in BasicTypes for SourceText fields in
-- the following
@@ -119,8 +151,9 @@ negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)
negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)
negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"
-overLitType :: HsOverLit p -> PostTc p Type
-overLitType = ol_type
+overLitType :: HsOverLit GhcTc -> Type
+overLitType (OverLit (OverLitTc _ ty) _ _) = ty
+overLitType XOverLit{} = panic "overLitType"
-- | Convert a literal from one index type to another, updating the annotations
-- according to the relevant 'Convertable' instance
@@ -138,6 +171,7 @@ convertLit (HsInteger a x b) = (HsInteger (convert a) x b)
convertLit (HsRat a x b) = (HsRat (convert a) x b)
convertLit (HsFloatPrim a x) = (HsFloatPrim (convert a) x)
convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x)
+convertLit (XLit a) = (XLit (convert a))
{-
Note [ol_rebindable]
@@ -171,8 +205,10 @@ found to have.
-- Comparison operations are needed when grouping literals
-- for compiling pattern-matching (module MatchLit)
-instance Eq (HsOverLit p) where
- (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2
+instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where
+ (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2
+ (XOverLit val1) == (XOverLit val2) = val1 == val2
+ _ == _ = panic "Eq HsOverLit"
instance Eq OverLitVal where
(HsIntegral i1) == (HsIntegral i2) = i1 == i2
@@ -180,8 +216,10 @@ instance Eq OverLitVal where
(HsIsString _ s1) == (HsIsString _ s2) = s1 == s2
_ == _ = False
-instance Ord (HsOverLit p) where
- compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2
+instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where
+ compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2
+ compare (XOverLit val1) (XOverLit val2) = val1 `compare` val2
+ compare _ _ = panic "Ord HsOverLit"
instance Ord OverLitVal where
compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2
@@ -195,7 +233,7 @@ instance Ord OverLitVal where
compare (HsIsString _ _) (HsFractional _) = GT
-- Instance specific to GhcPs, need the SourceText
-instance (SourceTextX x) => Outputable (HsLit x) where
+instance (SourceTextX (GhcPass x)) => Outputable (HsLit (GhcPass x)) where
ppr (HsChar st c) = pprWithSourceText (getSourceText st) (pprHsChar c)
ppr (HsCharPrim st c)
= pp_st_suffix (getSourceText st) primCharSuffix (pprPrimChar c)
@@ -217,16 +255,18 @@ instance (SourceTextX x) => Outputable (HsLit x) where
= pp_st_suffix (getSourceText st) primInt64Suffix (pprPrimInt64 i)
ppr (HsWord64Prim st w)
= pp_st_suffix (getSourceText st) primWord64Suffix (pprPrimWord64 w)
+ ppr (XLit x) = ppr x
pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc
pp_st_suffix NoSourceText _ doc = doc
pp_st_suffix (SourceText st) suffix _ = text st <> suffix
-- in debug mode, print the expression that it's resolved to, too
-instance (SourceTextX p, OutputableBndrId p)
- => Outputable (HsOverLit p) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsOverLit (GhcPass p)) where
ppr (OverLit {ol_val=val, ol_witness=witness})
= ppr val <+> (whenPprDebug (parens (pprExpr witness)))
+ ppr (XOverLit x) = ppr x
instance Outputable OverLitVal where
ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i))
@@ -239,7 +279,7 @@ instance Outputable OverLitVal where
-- mainly for too reasons:
-- * We do not want to expose their internal representation
-- * The warnings become too messy
-pmPprHsLit :: (SourceTextX x) => HsLit x -> SDoc
+pmPprHsLit :: (SourceTextX (GhcPass x)) => HsLit (GhcPass x) -> SDoc
pmPprHsLit (HsChar _ c) = pprHsChar c
pmPprHsLit (HsCharPrim _ c) = pprHsChar c
pmPprHsLit (HsString st s) = pprWithSourceText (getSourceText st)
@@ -254,3 +294,4 @@ pmPprHsLit (HsInteger _ i _) = integer i
pmPprHsLit (HsRat _ f _) = ppr f
pmPprHsLit (HsFloatPrim _ f) = ppr f
pmPprHsLit (HsDoublePrim _ d) = ppr d
+pmPprHsLit (XLit x) = ppr x
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index e05d8bbf68..e837f522cf 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -15,9 +15,11 @@
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
module HsPat (
Pat(..), InPat, OutPat, LPat,
+ ListPatTc(..),
HsConPatDetails, hsConPatArgs,
HsRecFields(..), HsRecField'(..), LHsRecField',
@@ -49,6 +51,7 @@ import HsExtension
import HsTypes
import TcEvidence
import BasicTypes
+import PlaceHolder
-- others:
import PprCore ( {- instance OutputableBndr TyVar -} )
import TysWiredIn
@@ -78,42 +81,49 @@ type LPat p = Located (Pat p)
-- For details on above see note [Api annotations] in ApiAnnotation
data Pat p
= ------------ Simple patterns ---------------
- WildPat (PostTc p Type) -- ^ Wildcard Pattern
+ WildPat (XWildPat p) -- ^ Wildcard Pattern
-- The sole reason for a type on a WildPat is to
-- support hsPatType :: Pat Id -> Type
-- AZ:TODO above comment needs to be updated
- | VarPat (Located (IdP p)) -- ^ Variable Pattern
+ | VarPat (XVarPat p)
+ (Located (IdP p)) -- ^ Variable Pattern
-- See Note [Located RdrNames] in HsExpr
- | LazyPat (LPat p) -- ^ Lazy Pattern
+ | LazyPat (XLazyPat p)
+ (LPat p) -- ^ Lazy Pattern
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
-- For details on above see note [Api annotations] in ApiAnnotation
- | AsPat (Located (IdP p)) (LPat p) -- ^ As pattern
+ | AsPat (XAsPat p)
+ (Located (IdP p)) (LPat p) -- ^ As pattern
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
-- For details on above see note [Api annotations] in ApiAnnotation
- | ParPat (LPat p) -- ^ Parenthesised pattern
+ | ParPat (XParPat p)
+ (LPat p) -- ^ Parenthesised pattern
-- See Note [Parens in HsSyn] in HsExpr
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | BangPat (LPat p) -- ^ Bang pattern
+ | BangPat (XBangPat p)
+ (LPat p) -- ^ Bang pattern
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
-- For details on above see note [Api annotations] in ApiAnnotation
------------ Lists, tuples, arrays ---------------
- | ListPat [LPat p]
+ | ListPat (XListPat p)
+ [LPat p]
(PostTc p Type) -- The type of the elements
(Maybe (PostTc p Type, SyntaxExpr p)) -- For rebindable syntax
-- For OverloadedLists a Just (ty,fn) gives
-- overall type of the pattern, and the toList
- -- function to convert the scrutinee to a list value
+-- function to convert the scrutinee to a list value
+
-- ^ Syntactic List
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
@@ -121,12 +131,13 @@ data Pat p
-- For details on above see note [Api annotations] in ApiAnnotation
- | TuplePat [LPat p] -- Tuple sub-patterns
+ | TuplePat (XTuplePat p)
+ -- after typechecking, holds the types of the tuple components
+ [LPat p] -- Tuple sub-patterns
Boxity -- UnitPat is TuplePat []
- [PostTc p Type] -- [] before typechecker, filled in afterwards
- -- with the types of the tuple components
- -- You might think that the PostTc p Type was redundant, because we can
- -- get the pattern type by getting the types of the sub-patterns.
+ -- You might think that the post typechecking Type was redundant,
+ -- because we can get the pattern type by getting the types of the
+ -- sub-patterns.
-- But it's essential
-- data T a where
-- T1 :: Int -> T Int
@@ -146,12 +157,12 @@ data Pat p
-- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
-- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@
- | SumPat (LPat p) -- Sum sub-pattern
- ConTag -- Alternative (one-based)
- Arity -- Arity (INVARIANT: ≥ 2)
- (PostTc p [Type]) -- PlaceHolder before typechecker, filled in
+ | SumPat (XSumPat p) -- PlaceHolder before typechecker, filled in
-- afterwards with the types of the
-- alternative
+ (LPat p) -- Sum sub-pattern
+ ConTag -- Alternative (one-based)
+ Arity -- Arity (INVARIANT: ≥ 2)
-- ^ Anonymous sum pattern
--
-- - 'ApiAnnotation.AnnKeywordId' :
@@ -159,8 +170,8 @@ data Pat p
-- 'ApiAnnotation.AnnClose' @'#)'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | PArrPat [LPat p] -- Syntactic parallel array
- (PostTc p Type) -- The type of the elements
+ | PArrPat (XPArrPat p) -- After typechecking, the type of the elements
+ [LPat p] -- Syntactic parallel array
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
-- 'ApiAnnotation.AnnClose' @':]'@
@@ -195,11 +206,11 @@ data Pat p
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
- | ViewPat (LHsExpr p)
+ | ViewPat (XViewPat p) -- The overall type of the pattern
+ -- (= the argument type of the view function)
+ -- for hsPatType.
+ (LHsExpr p)
(LPat p)
- (PostTc p Type) -- The overall type of the pattern
- -- (= the argument type of the view function)
- -- for hsPatType.
-- ^ View Pattern
------------ Pattern splices ---------------
@@ -207,31 +218,34 @@ data Pat p
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | SplicePat (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes)
+ | SplicePat (XSplicePat p)
+ (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes)
------------ Literal and n+k patterns ---------------
- | LitPat (HsLit p) -- ^ Literal Pattern
+ | LitPat (XLitPat p)
+ (HsLit p) -- ^ Literal Pattern
-- Used for *non-overloaded* literal patterns:
-- Int#, Char#, Int, Char, String, etc.
| NPat -- Natural Pattern
-- Used for all overloaded literals,
-- including overloaded strings with -XOverloadedStrings
+ (XNPat p) -- Overall type of pattern. Might be
+ -- different than the literal's type
+ -- if (==) or negate changes the type
(Located (HsOverLit p)) -- ALWAYS positive
(Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for
-- negative patterns, Nothing
-- otherwise
(SyntaxExpr p) -- Equality checker, of type t->t->Bool
- (PostTc p Type) -- Overall type of pattern. Might be
- -- different than the literal's type
- -- if (==) or negate changes the type
-- ^ Natural Pattern
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | NPlusKPat (Located (IdP p)) -- n+k pattern
+ | NPlusKPat (XNPlusKPat p) -- Type of overall pattern
+ (Located (IdP p)) -- n+k pattern
(Located (HsOverLit p)) -- It'll always be an HsIntegral
(HsOverLit p) -- See Note [NPlusK patterns] in TcPat
-- NB: This could be (PostTc ...), but that induced a
@@ -239,24 +253,22 @@ data Pat p
(SyntaxExpr p) -- (>=) function, of type t1->t2->Bool
(SyntaxExpr p) -- Name of '-' (see RnEnv.lookupSyntaxName)
- (PostTc p Type) -- Type of overall pattern
-- ^ n+k pattern
------------ Pattern type signatures ---------------
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
- | SigPatIn (LPat p) -- Pattern with a type signature
- (LHsSigWcType p) -- Signature can bind both
- -- kind and type vars
- -- ^ Pattern with a type signature
-
- | SigPatOut (LPat p)
- Type
+ | SigPat (XSigPat p) -- Before typechecker
+ -- Signature can bind both
+ -- kind and type vars
+ -- After typechecker: Type
+ (LPat p) -- Pattern with a type signature
-- ^ Pattern with a type signature
------------ Pattern coercions (translation only) ---------------
- | CoPat HsWrapper -- Coercion Pattern
+ | CoPat (XCoPat p)
+ HsWrapper -- Coercion Pattern
-- If co :: t1 ~ t2, p :: t2,
-- then (CoPat co p) :: t1
(Pat p) -- Why not LPat? Ans: existing locn will do
@@ -264,7 +276,74 @@ 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)
+
+-- | The typechecker-specific information for a 'ListPat'
+data ListPatTc =
+ ListPatTc Type -- The type of the elements
+ (Maybe (Type, SyntaxExpr GhcTc)) -- 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
+ deriving Data
+
+-- ---------------------------------------------------------------------
+
+type instance XWildPat GhcPs = PlaceHolder
+type instance XWildPat GhcRn = PlaceHolder
+type instance XWildPat GhcTc = Type
+
+type instance XVarPat (GhcPass _) = PlaceHolder
+type instance XLazyPat (GhcPass _) = PlaceHolder
+type instance XAsPat (GhcPass _) = PlaceHolder
+type instance XParPat (GhcPass _) = PlaceHolder
+type instance XBangPat (GhcPass _) = PlaceHolder
+
+-- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap
+-- compiler, as it triggers https://ghc.haskell.org/trac/ghc/ticket/14396 for
+-- `SyntaxExpr`
+type instance XListPat (GhcPass _) = PlaceHolder
+
+type instance XTuplePat GhcPs = PlaceHolder
+type instance XTuplePat GhcRn = PlaceHolder
+type instance XTuplePat GhcTc = [Type]
+
+type instance XSumPat GhcPs = PlaceHolder
+type instance XSumPat GhcRn = PlaceHolder
+type instance XSumPat GhcTc = [Type]
+
+type instance XPArrPat GhcPs = PlaceHolder
+type instance XPArrPat GhcRn = PlaceHolder
+type instance XPArrPat GhcTc = Type
+
+type instance XViewPat GhcPs = PlaceHolder
+type instance XViewPat GhcRn = PlaceHolder
+type instance XViewPat GhcTc = Type
+
+type instance XSplicePat (GhcPass _) = PlaceHolder
+type instance XLitPat (GhcPass _) = PlaceHolder
+
+type instance XNPat GhcPs = PlaceHolder
+type instance XNPat GhcRn = PlaceHolder
+type instance XNPat GhcTc = Type
+
+type instance XNPlusKPat GhcPs = PlaceHolder
+type instance XNPlusKPat GhcRn = PlaceHolder
+type instance XNPlusKPat GhcTc = Type
+
+type instance XSigPat GhcPs = (LHsSigWcType GhcPs)
+type instance XSigPat GhcRn = (LHsSigWcType GhcRn)
+type instance XSigPat GhcTc = Type
+
+type instance XCoPat (GhcPass _) = PlaceHolder
+type instance XXPat (GhcPass _) = PlaceHolder
+
+-- ---------------------------------------------------------------------
+
-- | Haskell Constructor Pattern Details
type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))
@@ -382,24 +461,24 @@ data HsRecField' id arg = HsRecField {
--
-- See also Note [Disambiguating record fields] in TcExpr.
-hsRecFields :: HsRecFields p arg -> [PostRn p (IdP p)]
+hsRecFields :: HsRecFields p arg -> [XFieldOcc p]
hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)
-- Probably won't typecheck at once, things have changed :/
hsRecFieldsArgs :: HsRecFields p arg -> [arg]
hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds)
-hsRecFieldSel :: HsRecField pass arg -> Located (PostRn pass (IdP pass))
-hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl
+hsRecFieldSel :: HsRecField pass arg -> Located (XFieldOcc pass)
+hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl
hsRecFieldId :: HsRecField GhcTc arg -> Located Id
hsRecFieldId = hsRecFieldSel
-hsRecUpdFieldRdr :: HsRecUpdField p -> Located RdrName
+hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName
hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl
hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id
-hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc
+hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc
hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
@@ -413,8 +492,8 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
************************************************************************
-}
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (Pat pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (Pat (GhcPass p)) where
ppr = pprPat
pprPatBndr :: OutputableBndr name => name -> SDoc
@@ -426,10 +505,12 @@ pprPatBndr var -- Print with type info if -dppr-debug is on
else
pprPrefixOcc var
-pprParendLPat :: (SourceTextX pass, OutputableBndrId pass) => LPat pass -> SDoc
+pprParendLPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LPat (GhcPass p) -> SDoc
pprParendLPat (L _ p) = pprParendPat p
-pprParendPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
+pprParendPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Pat (GhcPass p) -> SDoc
pprParendPat p = sdocWithDynFlags $ \ dflags ->
if need_parens dflags p
then parens (pprPat p)
@@ -443,29 +524,31 @@ pprParendPat p = sdocWithDynFlags $ \ dflags ->
-- But otherwise the CoPat is discarded, so it
-- is the pattern inside that matters. Sigh.
-pprPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
-pprPat (VarPat (L _ var)) = pprPatBndr var
+pprPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Pat (GhcPass p) -> SDoc
+pprPat (VarPat _ (L _ var)) = pprPatBndr var
pprPat (WildPat _) = char '_'
-pprPat (LazyPat pat) = char '~' <> pprParendLPat pat
-pprPat (BangPat pat) = char '!' <> pprParendLPat pat
-pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat]
-pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
-pprPat (ParPat pat) = parens (ppr pat)
-pprPat (LitPat s) = ppr s
-pprPat (NPat l Nothing _ _) = ppr l
-pprPat (NPat l (Just _) _ _) = char '-' <> ppr l
-pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k]
-pprPat (SplicePat splice) = pprSplice splice
-pprPat (CoPat co pat _) = pprHsWrapper co (\parens -> if parens
+pprPat (LazyPat _ pat) = char '~' <> pprParendLPat pat
+pprPat (BangPat _ pat) = char '!' <> pprParendLPat pat
+pprPat (AsPat _ name pat) = hcat [ pprPrefixOcc (unLoc name), char '@'
+ , pprParendLPat pat]
+pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat]
+pprPat (ParPat _ pat) = parens (ppr pat)
+pprPat (LitPat _ s) = ppr s
+pprPat (NPat _ l Nothing _) = ppr l
+pprPat (NPat _ l (Just _) _) = char '-' <> ppr l
+pprPat (NPlusKPat _ n k _ _ _)= hcat [ppr n, char '+', ppr k]
+pprPat (SplicePat _ splice) = pprSplice splice
+pprPat (CoPat _ co pat _) = pprHsWrapper co (\parens -> if parens
then pprParendPat pat
else pprPat pat)
-pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
-pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
-pprPat (ListPat pats _ _) = brackets (interpp'SP pats)
-pprPat (PArrPat pats _) = paBrackets (interpp'SP pats)
-pprPat (TuplePat pats bx _) = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
-pprPat (SumPat pat alt arity _) = sumParens (pprAlternative ppr pat alt arity)
-pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
+pprPat (SigPat ty pat) = ppr pat <+> dcolon <+> ppr ty
+pprPat (ListPat _ pats _ _) = brackets (interpp'SP pats)
+pprPat (PArrPat _ pats) = paBrackets (interpp'SP pats)
+pprPat (TuplePat _ pats bx)
+ = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
+pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)
+pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
pat_binds = binds, pat_args = details })
= sdocWithDynFlags $ \dflags ->
@@ -478,14 +561,16 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
, ppr binds])
<+> pprConArgs details
else pprUserCon (unLoc con) details
+pprPat (XPat x) = ppr x
-
-pprUserCon :: (SourceTextX p, OutputableBndr con, OutputableBndrId p)
- => con -> HsConPatDetails p -> SDoc
+pprUserCon :: (SourceTextX (GhcPass p), OutputableBndr con,
+ OutputableBndrId (GhcPass p))
+ => con -> HsConPatDetails (GhcPass p) -> SDoc
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
-pprConArgs :: (SourceTextX p, OutputableBndrId p) => HsConPatDetails p -> SDoc
+pprConArgs :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsConPatDetails (GhcPass p) -> SDoc
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
pprConArgs (RecCon rpats) = ppr rpats
@@ -524,9 +609,12 @@ mkPrefixConPat dc pats tys
mkNilPat :: Type -> OutPat p
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
-mkCharLitPat :: (SourceTextX p) => SourceText -> Char -> OutPat p
+mkCharLitPat :: (SourceTextX (GhcPass p))
+ => SourceText -> Char -> OutPat (GhcPass p)
mkCharLitPat src c = mkPrefixConPat charDataCon
- [noLoc $ LitPat (HsCharPrim (setSourceText src) c)] []
+ [noLoc $ LitPat PlaceHolder
+ (HsCharPrim (setSourceText src) c)]
+ []
{-
************************************************************************
@@ -561,7 +649,7 @@ The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
-}
isBangedLPat :: LPat p -> Bool
-isBangedLPat (L _ (ParPat p)) = isBangedLPat p
+isBangedLPat (L _ (ParPat _ p)) = isBangedLPat p
isBangedLPat (L _ (BangPat {})) = True
isBangedLPat _ = False
@@ -579,8 +667,8 @@ looksLazyPatBind _
= False
looksLazyLPat :: LPat p -> Bool
-looksLazyLPat (L _ (ParPat p)) = looksLazyLPat p
-looksLazyLPat (L _ (AsPat _ p)) = looksLazyLPat p
+looksLazyLPat (L _ (ParPat _ p)) = looksLazyLPat p
+looksLazyLPat (L _ (AsPat _ _ p)) = looksLazyLPat p
looksLazyLPat (L _ (BangPat {})) = False
looksLazyLPat (L _ (VarPat {})) = False
looksLazyLPat (L _ (WildPat {})) = False
@@ -607,15 +695,14 @@ isIrrefutableHsPat pat
go1 (WildPat {}) = True
go1 (VarPat {}) = True
go1 (LazyPat {}) = True
- go1 (BangPat pat) = go pat
- go1 (CoPat _ pat _) = go1 pat
- go1 (ParPat pat) = go pat
- go1 (AsPat _ pat) = go pat
- go1 (ViewPat _ pat _) = go pat
- go1 (SigPatIn pat _) = go pat
- go1 (SigPatOut pat _) = go pat
- go1 (TuplePat pats _ _) = all go pats
- go1 (SumPat _ _ _ _) = False
+ go1 (BangPat _ pat) = go pat
+ go1 (CoPat _ _ pat _) = go1 pat
+ go1 (ParPat _ pat) = go pat
+ go1 (AsPat _ _ pat) = go pat
+ go1 (ViewPat _ _ pat) = go pat
+ go1 (SigPat _ pat) = go pat
+ go1 (TuplePat _ pats _) = all go pats
+ go1 (SumPat {}) = False
-- See Note [Unboxed sum patterns aren't irrefutable]
go1 (ListPat {}) = False
go1 (PArrPat {}) = False -- ?
@@ -637,6 +724,8 @@ isIrrefutableHsPat pat
-- since we cannot know until the splice is evaluated.
go1 (SplicePat {}) = False
+ go1 (XPat {}) = False
+
{- Note [Unboxed sum patterns aren't irrefutable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as
@@ -664,10 +753,9 @@ hsPatNeedsParens (NPlusKPat {}) = True
hsPatNeedsParens (SplicePat {}) = False
hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p)
-hsPatNeedsParens (SigPatIn {}) = True
-hsPatNeedsParens (SigPatOut {}) = True
+hsPatNeedsParens (SigPat {}) = True
hsPatNeedsParens (ViewPat {}) = True
-hsPatNeedsParens (CoPat _ p _) = hsPatNeedsParens p
+hsPatNeedsParens (CoPat _ _ p _) = hsPatNeedsParens p
hsPatNeedsParens (WildPat {}) = False
hsPatNeedsParens (VarPat {}) = False
hsPatNeedsParens (LazyPat {}) = False
@@ -680,6 +768,7 @@ hsPatNeedsParens (ListPat {}) = False
hsPatNeedsParens (PArrPat {}) = False
hsPatNeedsParens (LitPat {}) = False
hsPatNeedsParens (NPat {}) = False
+hsPatNeedsParens (XPat {}) = True -- conservative default
conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon {}) = False
@@ -691,30 +780,29 @@ conPatNeedsParens (RecCon {}) = False
-}
-- May need to add more cases
-collectEvVarsPats :: [Pat p] -> Bag EvVar
+collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar
collectEvVarsPats = unionManyBags . map collectEvVarsPat
-collectEvVarsLPat :: LPat p -> Bag EvVar
+collectEvVarsLPat :: LPat GhcTc -> Bag EvVar
collectEvVarsLPat (L _ pat) = collectEvVarsPat pat
-collectEvVarsPat :: Pat p -> Bag EvVar
+collectEvVarsPat :: Pat GhcTc -> Bag EvVar
collectEvVarsPat pat =
case pat of
- LazyPat p -> collectEvVarsLPat p
- AsPat _ p -> collectEvVarsLPat p
- ParPat p -> collectEvVarsLPat p
- BangPat p -> collectEvVarsLPat p
- ListPat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps
- TuplePat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps
- SumPat p _ _ _ -> collectEvVarsLPat p
- PArrPat ps _ -> unionManyBags $ map collectEvVarsLPat ps
+ LazyPat _ p -> collectEvVarsLPat p
+ AsPat _ _ p -> collectEvVarsLPat p
+ ParPat _ p -> collectEvVarsLPat p
+ BangPat _ p -> collectEvVarsLPat p
+ ListPat _ ps _ _ -> unionManyBags $ map collectEvVarsLPat ps
+ TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps
+ SumPat _ p _ _ -> collectEvVarsLPat p
+ PArrPat _ ps -> unionManyBags $ map collectEvVarsLPat ps
ConPatOut {pat_dicts = dicts, pat_args = args}
- -> unionBags (listToBag dicts)
+ -> unionBags (listToBag dicts)
$ unionManyBags
$ map collectEvVarsLPat
$ hsConPatArgs args
- SigPatOut p _ -> collectEvVarsLPat p
- CoPat _ p _ -> collectEvVarsPat p
- ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn"
- SigPatIn _ _ -> panic "foldMapPatBag: SigPatIn"
- _other_pat -> emptyBag
+ SigPat _ p -> collectEvVarsLPat p
+ CoPat _ _ p _ -> collectEvVarsPat p
+ ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn"
+ _other_pat -> emptyBag
diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot
index 8cb82ed22e..eb090bdd8f 100644
--- a/compiler/hsSyn/HsPat.hs-boot
+++ b/compiler/hsSyn/HsPat.hs-boot
@@ -4,17 +4,19 @@
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE FlexibleInstances #-}
module HsPat where
import SrcLoc( Located )
import Data.Data hiding (Fixity)
import Outputable
-import HsExtension ( SourceTextX, DataId, OutputableBndrId )
+import HsExtension ( SourceTextX, DataIdLR, OutputableBndrId, GhcPass )
type role Pat nominal
data Pat (i :: *)
type LPat i = Located (Pat i)
-instance (DataId p) => Data (Pat p)
-instance (SourceTextX pass, OutputableBndrId pass) => Outputable (Pat pass)
+instance (DataIdLR p p) => Data (Pat p)
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (Pat (GhcPass p))
diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs
index 62bfa2e5c5..4a3eca31c6 100644
--- a/compiler/hsSyn/HsSyn.hs
+++ b/compiler/hsSyn/HsSyn.hs
@@ -15,6 +15,7 @@ therefore, is almost nothing but re-exporting.
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
module HsSyn (
module HsBinds,
@@ -110,10 +111,10 @@ data HsModule name
-- hsmodImports,hsmodDecls if this style is used.
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId name) => Data (HsModule name)
+deriving instance (DataIdLR name name) => Data (HsModule name)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsModule pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsModule (GhcPass p)) where
ppr (HsModule Nothing _ imports decls _ mbDoc)
= pp_mb mbDoc $$ pp_nonnull imports
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index f5b4149f99..d9c1b46d0e 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -15,9 +15,10 @@ HsTypes: Abstract syntax: user-defined types
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
module HsTypes (
- HsType(..), LHsType, HsKind, LHsKind,
+ HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,
HsTyVarBndr(..), LHsTyVarBndr,
LHsQTyVars(..),
HsImplicitBndrs(..),
@@ -44,7 +45,7 @@ module HsTypes (
rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,
unambiguousFieldOcc, ambiguousFieldOcc,
- HsWildCardInfo(..), mkAnonWildCardTy,
+ HsWildCardInfo(..), mkAnonWildCardTy, pprAnonWildCard,
wildCardName, sameWildCard,
mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
@@ -75,6 +76,7 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
import PlaceHolder ( PlaceHolder(..) )
import HsExtension
+import HsLit () -- for instances
import Id ( Id )
import Name( Name )
@@ -110,11 +112,11 @@ type LBangType pass = Located (BangType pass)
type BangType pass = HsType pass -- Bangs are in the HsType data type
getBangType :: LHsType a -> LHsType a
-getBangType (L _ (HsBangTy _ ty)) = ty
-getBangType ty = ty
+getBangType (L _ (HsBangTy _ _ ty)) = ty
+getBangType ty = ty
getBangStrictness :: LHsType a -> HsSrcBang
-getBangStrictness (L _ (HsBangTy s _)) = s
+getBangStrictness (L _ (HsBangTy _ s _)) = s
getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
{-
@@ -270,7 +272,7 @@ 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
@@ -405,9 +407,11 @@ instance OutputableBndr HsIPName where
-- | Haskell Type Variable Binder
data HsTyVarBndr pass
= UserTyVar -- no explicit kinding
+ (XUserTyVar pass)
(Located (IdP pass))
-- See Note [Located RdrNames] in HsExpr
| KindedTyVar
+ (XKindedTyVar pass)
(Located (IdP pass))
(LHsKind pass) -- The user-supplied kind signature
-- ^
@@ -415,12 +419,20 @@ data HsTyVarBndr pass
-- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (HsTyVarBndr pass)
+
+ | XTyVarBndr
+ (XXTyVarBndr pass)
+deriving instance (DataIdLR pass pass) => Data (HsTyVarBndr pass)
+
+type instance XUserTyVar (GhcPass _) = PlaceHolder
+type instance XKindedTyVar (GhcPass _) = PlaceHolder
+type instance XXTyVarBndr (GhcPass _) = PlaceHolder
-- | Does this 'HsTyVarBndr' come with an explicit kind annotation?
isHsKindedTyVar :: HsTyVarBndr pass -> Bool
isHsKindedTyVar (UserTyVar {}) = False
isHsKindedTyVar (KindedTyVar {}) = True
+isHsKindedTyVar (XTyVarBndr{}) = panic "isHsKindedTyVar"
-- | Do all type variables in this 'LHsQTyVars' come with kind annotations?
hsTvbAllKinded :: LHsQTyVars pass -> Bool
@@ -429,19 +441,22 @@ hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit
-- | Haskell Type
data HsType pass
= HsForAllTy -- See Note [HsType binders]
- { hst_bndrs :: [LHsTyVarBndr pass]
+ { hst_xforall :: XForAllTy pass,
+ hst_bndrs :: [LHsTyVarBndr pass]
-- Explicit, user-supplied 'forall a b c'
- , hst_body :: LHsType pass -- body type
+ , hst_body :: LHsType pass -- body type
}
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',
-- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
| HsQualTy -- See Note [HsType binders]
- { hst_ctxt :: LHsContext pass -- Context C => blah
- , hst_body :: LHsType pass }
+ { hst_xqual :: XQualTy pass
+ , hst_ctxt :: LHsContext pass -- Context C => blah
+ , hst_body :: LHsType pass }
- | HsTyVar Promoted -- whether explicitly promoted, for the pretty
+ | HsTyVar (XTyVar pass)
+ Promoted -- whether explicitly promoted, for the pretty
-- printer
(Located (IdP pass))
-- Type variable, type constructor, or data constructor
@@ -451,53 +466,62 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsAppsTy [LHsAppType pass] -- Used only before renaming,
+ | HsAppsTy (XAppsTy pass)
+ [LHsAppType pass] -- Used only before renaming,
-- Note [HsAppsTy]
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
- | HsAppTy (LHsType pass)
+ | HsAppTy (XAppTy pass)
+ (LHsType pass)
(LHsType pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsFunTy (LHsType pass) -- function type
+ | HsFunTy (XFunTy pass)
+ (LHsType pass) -- function type
(LHsType pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow',
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsListTy (LHsType pass) -- Element type
+ | HsListTy (XListTy pass)
+ (LHsType pass) -- Element type
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
-- 'ApiAnnotation.AnnClose' @']'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsPArrTy (LHsType pass) -- Elem. type of parallel array: [:t:]
+ | HsPArrTy (XPArrTy pass)
+ (LHsType pass) -- Elem. type of parallel array: [:t:]
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
-- 'ApiAnnotation.AnnClose' @':]'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsTupleTy HsTupleSort
+ | HsTupleTy (XTupleTy pass)
+ HsTupleSort
[LHsType pass] -- Element types (length gives arity)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@,
-- 'ApiAnnotation.AnnClose' @')' or '#)'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsSumTy [LHsType pass] -- Element types (length gives arity)
+ | HsSumTy (XSumTy pass)
+ [LHsType pass] -- Element types (length gives arity)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@,
-- 'ApiAnnotation.AnnClose' '#)'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsOpTy (LHsType pass) (Located (IdP pass)) (LHsType pass)
+ | HsOpTy (XOpTy pass)
+ (LHsType pass) (Located (IdP pass)) (LHsType pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsParTy (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr
+ | HsParTy (XParTy pass)
+ (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr
-- Parenthesis preserved for the precedence re-arrangement in RnTypes
-- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
@@ -505,7 +529,8 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsIParamTy (Located HsIPName) -- (?x :: ty)
+ | HsIParamTy (XIParamTy pass)
+ (Located HsIPName) -- (?x :: ty)
(LHsType pass) -- Implicit parameters as they occur in
-- contexts
-- ^
@@ -515,7 +540,8 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsEqTy (LHsType pass) -- ty1 ~ ty2
+ | HsEqTy (XEqTy pass)
+ (LHsType pass) -- ty1 ~ ty2
(LHsType pass) -- Always allowed even without
-- TypeOperators, and has special
-- kinding rule
@@ -526,7 +552,8 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsKindSig (LHsType pass) -- (ty :: kind)
+ | HsKindSig (XKindSig pass)
+ (LHsType pass) -- (ty :: kind)
(LHsKind pass) -- A type with a kind signature
-- ^
-- > (ty :: kind)
@@ -536,19 +563,21 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsSpliceTy (HsSplice pass) -- Includes quasi-quotes
- (PostTc pass Kind)
+ | HsSpliceTy (XSpliceTy pass)
+ (HsSplice pass) -- Includes quasi-quotes
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@,
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsDocTy (LHsType pass) LHsDocString -- A documented type
+ | HsDocTy (XDocTy pass)
+ (LHsType pass) LHsDocString -- A documented type
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsBangTy HsSrcBang (LHsType pass) -- Bang-style type annotations
+ | HsBangTy (XBangTy pass)
+ HsSrcBang (LHsType pass) -- Bang-style type annotations
-- ^ - 'ApiAnnotation.AnnKeywordId' :
-- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@,
-- 'ApiAnnotation.AnnClose' @'#-}'@
@@ -556,21 +585,22 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsRecTy [LConDeclField pass] -- Only in data type declarations
+ | HsRecTy (XRecTy pass)
+ [LConDeclField pass] -- Only in data type declarations
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
-- 'ApiAnnotation.AnnClose' @'}'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCoreTy Type -- An escape hatch for tunnelling a *closed*
- -- Core Type through HsSyn.
- -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+ -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed*
+ -- -- Core Type through HsSyn.
+ -- -- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
| HsExplicitListTy -- A promoted explicit list
+ (XExplicitListTy pass)
Promoted -- whether explcitly promoted, for pretty printer
- (PostTc pass Kind) -- See Note [Promoted lists and tuples]
[LHsType pass]
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@,
-- 'ApiAnnotation.AnnClose' @']'@
@@ -578,24 +608,78 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
| HsExplicitTupleTy -- A promoted explicit tuple
- [PostTc pass Kind] -- See Note [Promoted lists and tuples]
+ (XExplicitTupleTy pass)
[LHsType pass]
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@,
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsTyLit HsTyLit -- A promoted numeric literal.
+ | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal.
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsWildCardTy (HsWildCardInfo pass) -- A type wildcard
+ | HsWildCardTy (XWildCardTy pass) -- A type wildcard
-- See Note [The wildcard story for types]
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (HsType pass)
+
+ -- For adding new constructors via Trees that Grow
+ | XHsType
+ (XXType pass)
+deriving instance (DataIdLR pass pass) => Data (HsType pass)
+
+data NewHsTypeX
+ = NHsCoreTy Type -- An escape hatch for tunnelling a *closed*
+ -- Core Type through HsSyn.
+ deriving Data
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+instance Outputable NewHsTypeX where
+ ppr (NHsCoreTy ty) = ppr ty
+
+type instance XForAllTy (GhcPass _) = PlaceHolder
+type instance XQualTy (GhcPass _) = PlaceHolder
+type instance XTyVar (GhcPass _) = PlaceHolder
+type instance XAppsTy (GhcPass _) = PlaceHolder
+type instance XAppTy (GhcPass _) = PlaceHolder
+type instance XFunTy (GhcPass _) = PlaceHolder
+type instance XListTy (GhcPass _) = PlaceHolder
+type instance XPArrTy (GhcPass _) = PlaceHolder
+type instance XTupleTy (GhcPass _) = PlaceHolder
+type instance XSumTy (GhcPass _) = PlaceHolder
+type instance XOpTy (GhcPass _) = PlaceHolder
+type instance XParTy (GhcPass _) = PlaceHolder
+type instance XIParamTy (GhcPass _) = PlaceHolder
+type instance XEqTy (GhcPass _) = PlaceHolder
+type instance XKindSig (GhcPass _) = PlaceHolder
+
+type instance XSpliceTy GhcPs = PlaceHolder
+type instance XSpliceTy GhcRn = PlaceHolder
+type instance XSpliceTy GhcTc = Kind
+
+type instance XDocTy (GhcPass _) = PlaceHolder
+type instance XBangTy (GhcPass _) = PlaceHolder
+type instance XRecTy (GhcPass _) = PlaceHolder
+
+type instance XExplicitListTy GhcPs = PlaceHolder
+type instance XExplicitListTy GhcRn = PlaceHolder
+type instance XExplicitListTy GhcTc = Kind
+
+type instance XExplicitTupleTy GhcPs = PlaceHolder
+type instance XExplicitTupleTy GhcRn = PlaceHolder
+type instance XExplicitTupleTy GhcTc = [Kind]
+
+type instance XTyLit (GhcPass _) = PlaceHolder
+
+type instance XWildCardTy GhcPs = PlaceHolder
+type instance XWildCardTy GhcRn = HsWildCardInfo GhcRn
+type instance XWildCardTy GhcTc = HsWildCardInfo GhcTc
+
+type instance XXType (GhcPass _) = NewHsTypeX
+
-- Note [Literal source text] in BasicTypes for SourceText fields in
-- the following
@@ -605,7 +689,8 @@ data HsTyLit
| HsStrTy SourceText FastString
deriving Data
-newtype HsWildCardInfo pass -- See Note [The wildcard story for types]
+-- AZ: fold this into the XWildCardTy completely, removing the type
+newtype HsWildCardInfo pass -- See Note [The wildcard story for types]
= AnonWildCard (PostRn pass (Located Name))
-- A anonymous wild card ('_'). A fresh Name is generated for
-- each individual anonymous wildcard during renaming
@@ -617,12 +702,21 @@ type LHsAppType pass = Located (HsAppType pass)
-- | Haskell Application Type
data HsAppType pass
- = HsAppInfix (Located (IdP pass)) -- either a symbol or an id in backticks
- | HsAppPrefix (LHsType pass) -- anything else, including things like (+)
-deriving instance (DataId pass) => Data (HsAppType pass)
+ = HsAppInfix (XAppInfix pass)
+ (Located (IdP pass)) -- either a symbol or an id in backticks
+ | HsAppPrefix (XAppPrefix pass)
+ (LHsType pass) -- anything else, including things like (+)
+
+ | XAppType
+ (XXAppType pass)
+deriving instance (DataIdLR pass pass) => Data (HsAppType pass)
+
+type instance XAppInfix (GhcPass _) = PlaceHolder
+type instance XAppPrefix (GhcPass _) = PlaceHolder
+type instance XXAppType (GhcPass _) = PlaceHolder
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsAppType pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsAppType (GhcPass p)) where
ppr = ppr_app_ty
{-
@@ -764,10 +858,10 @@ data ConDeclField pass -- Record fields have Haddoc docs on them
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (ConDeclField pass)
+deriving instance (DataIdLR pass pass) => Data (ConDeclField pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ConDeclField pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (ConDeclField (GhcPass p)) where
ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
-- HsConDetails is used for patterns/expressions *and* for data type
@@ -789,11 +883,11 @@ instance (Outputable arg, Outputable rec)
-- parser and rejigs them using information about fixities from the renamer.
-- See Note [Sorting out the result type] in RdrHsSyn
updateGadtResult
- :: (Monad m)
+ :: (Monad m, OutputableX GhcRn)
=> (SDoc -> m ())
-> SDoc
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
- -- ^ Original details
+ -- ^ Original details
-> LHsType GhcRn -- ^ Original result type
-> m (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
LHsType GhcRn)
@@ -874,8 +968,9 @@ I don't know if this is a good idea, but there it is.
---------------------
hsTyVarName :: HsTyVarBndr pass -> IdP pass
-hsTyVarName (UserTyVar (L _ n)) = n
-hsTyVarName (KindedTyVar (L _ n) _) = n
+hsTyVarName (UserTyVar _ (L _ n)) = n
+hsTyVarName (KindedTyVar _ (L _ n) _) = n
+hsTyVarName (XTyVarBndr{}) = panic "hsTyVarName"
hsLTyVarName :: LHsTyVarBndr pass -> IdP pass
hsLTyVarName = hsTyVarName . unLoc
@@ -896,15 +991,17 @@ hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
-- | Convert a LHsTyVarBndr to an equivalent LHsType.
-hsLTyVarBndrToType :: LHsTyVarBndr pass -> LHsType pass
+hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
hsLTyVarBndrToType = fmap cvt
- where cvt (UserTyVar n) = HsTyVar NotPromoted n
- cvt (KindedTyVar (L name_loc n) kind)
- = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc n))) kind
+ where cvt (UserTyVar _ n) = HsTyVar noExt NotPromoted n
+ cvt (KindedTyVar _ (L name_loc n) kind)
+ = HsKindSig noExt
+ (L name_loc (HsTyVar noExt NotPromoted (L name_loc n))) kind
+ cvt (XTyVarBndr{}) = panic "hsLTyVarBndrToType"
-- | Convert a LHsTyVarBndrs to a list of types.
-- Works on *type* variable only, no kind vars.
-hsLTyVarBndrsToTypes :: LHsQTyVars pass -> [LHsType pass]
+hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)]
hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs
---------------------
@@ -917,9 +1014,9 @@ sameWildCard :: Located (HsWildCardInfo pass)
sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2
ignoreParens :: LHsType pass -> LHsType pass
-ignoreParens (L _ (HsParTy ty)) = ignoreParens ty
-ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty
-ignoreParens ty = ty
+ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty
+ignoreParens (L _ (HsAppsTy _ [L _ (HsAppPrefix _ ty)])) = ignoreParens ty
+ignoreParens ty = ty
{-
************************************************************************
@@ -930,15 +1027,17 @@ ignoreParens ty = ty
-}
mkAnonWildCardTy :: HsType GhcPs
-mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder)
+mkAnonWildCardTy = HsWildCardTy noExt
-mkHsOpTy :: LHsType pass -> Located (IdP pass) -> LHsType pass -> HsType pass
-mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2
+mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p))
+ -> LHsType (GhcPass p) -> HsType (GhcPass p)
+mkHsOpTy ty1 op ty2 = HsOpTy noExt ty1 op ty2
-mkHsAppTy :: LHsType pass -> LHsType pass -> LHsType pass
-mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
+mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy noExt t1 t2)
-mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass
+mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
+ -> LHsType (GhcPass p)
mkHsAppTys = foldl mkHsAppTy
@@ -957,36 +1056,37 @@ mkHsAppTys = foldl mkHsAppTy
-- Also deals with (->) t1 t2; that is why it only works on LHsType Name
-- (see Trac #9096)
splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn)
-splitHsFunType (L _ (HsParTy ty))
+splitHsFunType (L _ (HsParTy _ ty))
= splitHsFunType ty
-splitHsFunType (L _ (HsFunTy x y))
+splitHsFunType (L _ (HsFunTy _ x y))
| (args, res) <- splitHsFunType y
= (x:args, res)
-splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
+splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2))
= go t1 [t2]
where -- Look for (->) t1 t2, possibly with parenthesisation
- go (L _ (HsTyVar _ (L _ fn))) tys | fn == funTyConName
+ go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName
, [t1,t2] <- tys
, (args, res) <- splitHsFunType t2
= (t1:args, res)
- go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys)
- go (L _ (HsParTy ty)) tys = go ty tys
- go _ _ = ([], orig_ty) -- Failure to match
+ go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys)
+ go (L _ (HsParTy _ ty)) tys = go ty tys
+ go _ _ = ([], orig_ty) -- Failure to match
splitHsFunType other = ([], other)
--------------------------------
-- | Retrieves the head of an HsAppsTy, if this can be done unambiguously,
-- without consulting fixities.
-getAppsTyHead_maybe :: [LHsAppType pass]
- -> Maybe (LHsType pass, [LHsType pass], LexicalFixity)
+getAppsTyHead_maybe :: [LHsAppType (GhcPass p)]
+ -> Maybe ( LHsType (GhcPass p)
+ , [LHsType (GhcPass p)], LexicalFixity)
getAppsTyHead_maybe tys = case splitHsAppsTy tys of
([app1:apps], []) -> -- no symbols, some normal types
Just (mkHsAppTys app1 apps, [], Prefix)
([app1l:appsl, app1r:appsr], [L loc op]) -> -- one operator
- Just ( L loc (HsTyVar NotPromoted (L loc op))
+ Just ( L loc (HsTyVar noExt NotPromoted (L loc op))
, [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr], Infix)
_ -> -- can't figure it out
Nothing
@@ -1001,35 +1101,36 @@ splitHsAppsTy :: [LHsAppType pass] -> ([[LHsType pass]], [Located (IdP pass)])
splitHsAppsTy = go [] [] []
where
go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym)
- go acc acc_non acc_sym (L _ (HsAppPrefix ty) : rest)
+ go acc acc_non acc_sym (L _ (HsAppPrefix _ ty) : rest)
= go (ty : acc) acc_non acc_sym rest
- go acc acc_non acc_sym (L _ (HsAppInfix op) : rest)
+ go acc acc_non acc_sym (L _ (HsAppInfix _ op) : rest)
= go [] (reverse acc : acc_non) (op : acc_sym) rest
+ go _ _ _ (L _ (XAppType _):_) = panic "splitHsAppsTy"
-- Retrieve the name of the "head" of a nested type application
-- somewhat like splitHsAppTys, but a little more thorough
-- used to examine the result of a GADT-like datacon, so it doesn't handle
-- *all* cases (like lists, tuples, (~), etc.)
-hsTyGetAppHead_maybe :: LHsType pass
- -> Maybe (Located (IdP pass), [LHsType pass])
+hsTyGetAppHead_maybe :: LHsType (GhcPass p)
+ -> Maybe (Located (IdP (GhcPass p)), [LHsType (GhcPass p)])
hsTyGetAppHead_maybe = go []
where
- go tys (L _ (HsTyVar _ ln)) = Just (ln, tys)
- go tys (L _ (HsAppsTy apps))
+ go tys (L _ (HsTyVar _ _ ln)) = Just (ln, tys)
+ go tys (L _ (HsAppsTy _ apps))
| Just (head, args, _) <- getAppsTyHead_maybe apps
- = go (args ++ tys) head
- go tys (L _ (HsAppTy l r)) = go (r : tys) l
- go tys (L _ (HsOpTy l (L loc n) r)) = Just (L loc n, l : r : tys)
- go tys (L _ (HsParTy t)) = go tys t
- go tys (L _ (HsKindSig t _)) = go tys t
+ = go (args ++ tys) head
+ go tys (L _ (HsAppTy _ l r)) = go (r : tys) l
+ go tys (L _ (HsOpTy _ l (L loc n) r)) = Just (L loc n, l : r : tys)
+ go tys (L _ (HsParTy _ t)) = go tys t
+ go tys (L _ (HsKindSig _ t _)) = go tys t
go _ _ = Nothing
splitHsAppTys :: LHsType GhcRn -> [LHsType GhcRn]
-> (LHsType GhcRn, [LHsType GhcRn])
-- no need to worry about HsAppsTy here
-splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
-splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as
-splitHsAppTys f as = (f,as)
+splitHsAppTys (L _ (HsAppTy _ f a)) as = splitHsAppTys f (a:as)
+splitHsAppTys (L _ (HsParTy _ f)) as = splitHsAppTys f as
+splitHsAppTys f as = (f,as)
--------------------------------
splitLHsPatSynTy :: LHsType pass
@@ -1054,12 +1155,12 @@ splitLHsSigmaTy ty
splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)
-splitLHsForAllTy (L _ (HsParTy t)) = splitLHsForAllTy t
+splitLHsForAllTy (L _ (HsParTy _ t)) = splitLHsForAllTy t
splitLHsForAllTy body = ([], body)
splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)
splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body)
-splitLHsQualTy (L _ (HsParTy t)) = splitLHsQualTy t
+splitLHsQualTy (L _ (HsParTy _ t)) = splitLHsQualTy t
splitLHsQualTy body = (noLoc [], body)
splitLHsInstDeclTy :: LHsSigType GhcRn
@@ -1077,7 +1178,8 @@ getLHsInstDeclHead inst_ty
| (_tvs, _cxt, body_ty) <- splitLHsSigmaTy (hsSigType inst_ty)
= body_ty
-getLHsInstDeclClass_maybe :: LHsSigType pass -> Maybe (Located (IdP pass))
+getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p)
+ -> Maybe (Located (IdP (GhcPass p)))
-- Works on (HsSigType RdrName)
getLHsInstDeclClass_maybe inst_ty
= do { let head_ty = getLHsInstDeclHead inst_ty
@@ -1100,19 +1202,28 @@ type LFieldOcc pass = Located (FieldOcc pass)
-- Represents an *occurrence* of an unambiguous field. We store
-- both the 'RdrName' the user originally wrote, and after the
-- renamer, the selector function.
-data FieldOcc pass = FieldOcc { rdrNameFieldOcc :: Located RdrName
+data FieldOcc pass = FieldOcc { extFieldOcc :: XFieldOcc pass
+ , rdrNameFieldOcc :: Located RdrName
-- ^ See Note [Located RdrNames] in HsExpr
- , selectorFieldOcc :: PostRn pass (IdP pass)
}
-deriving instance Eq (PostRn pass (IdP pass)) => Eq (FieldOcc pass)
-deriving instance Ord (PostRn pass (IdP pass)) => Ord (FieldOcc pass)
+
+ | XFieldOcc
+ (XXFieldOcc pass)
+deriving instance (Eq (XFieldOcc (GhcPass p))) => Eq (FieldOcc (GhcPass p))
+deriving instance (Ord (XFieldOcc (GhcPass p))) => Ord (FieldOcc (GhcPass p))
deriving instance (DataId pass) => Data (FieldOcc pass)
+type instance XFieldOcc GhcPs = PlaceHolder
+type instance XFieldOcc GhcRn = Name
+type instance XFieldOcc GhcTc = Id
+
+type instance XXFieldOcc (GhcPass _) = PlaceHolder
+
instance Outputable (FieldOcc pass) where
ppr = ppr . rdrNameFieldOcc
mkFieldOcc :: Located RdrName -> FieldOcc GhcPs
-mkFieldOcc rdr = FieldOcc rdr PlaceHolder
+mkFieldOcc rdr = FieldOcc PlaceHolder rdr
-- | Ambiguous Field Occurrence
@@ -1128,34 +1239,51 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder
-- Note [Disambiguating record fields] in TcExpr.
-- See Note [Located RdrNames] in HsExpr
data AmbiguousFieldOcc pass
- = Unambiguous (Located RdrName) (PostRn pass (IdP pass))
- | Ambiguous (Located RdrName) (PostTc pass (IdP pass))
+ = Unambiguous (XUnambiguous pass) (Located RdrName)
+ | Ambiguous (XAmbiguous pass) (Located RdrName)
+ | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass)
deriving instance DataId pass => Data (AmbiguousFieldOcc pass)
-instance Outputable (AmbiguousFieldOcc pass) where
+type instance XUnambiguous GhcPs = PlaceHolder
+type instance XUnambiguous GhcRn = Name
+type instance XUnambiguous GhcTc = Id
+
+type instance XAmbiguous GhcPs = PlaceHolder
+type instance XAmbiguous GhcRn = PlaceHolder
+type instance XAmbiguous GhcTc = Id
+
+type instance XXAmbiguousFieldOcc (GhcPass _) = PlaceHolder
+
+instance Outputable (AmbiguousFieldOcc (GhcPass p)) where
ppr = ppr . rdrNameAmbiguousFieldOcc
-instance OutputableBndr (AmbiguousFieldOcc pass) where
+instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where
pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc
pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc
mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs
-mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder
+mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr
-rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc pass -> RdrName
-rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr
-rdrNameAmbiguousFieldOcc (Ambiguous (L _ rdr) _) = rdr
+rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName
+rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr
+rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr
+rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _)
+ = panic "rdrNameAmbiguousFieldOcc"
selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id
-selectorAmbiguousFieldOcc (Unambiguous _ sel) = sel
-selectorAmbiguousFieldOcc (Ambiguous _ sel) = sel
+selectorAmbiguousFieldOcc (Unambiguous sel _) = sel
+selectorAmbiguousFieldOcc (Ambiguous sel _) = sel
+selectorAmbiguousFieldOcc (XAmbiguousFieldOcc _)
+ = panic "selectorAmbiguousFieldOcc"
unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc
unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel
unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel
+unambiguousFieldOcc (XAmbiguousFieldOcc _) = panic "unambiguousFieldOcc"
-ambiguousFieldOcc :: FieldOcc pass -> AmbiguousFieldOcc pass
-ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
+ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc
+ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr
+ambiguousFieldOcc (XFieldOcc _) = panic "ambiguousFieldOcc"
{-
************************************************************************
@@ -1165,21 +1293,22 @@ ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
************************************************************************
-}
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsType pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsType (GhcPass p)) where
ppr ty = pprHsType ty
instance Outputable HsTyLit where
ppr = ppr_tylit
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (LHsQTyVars pass) where
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (LHsQTyVars (GhcPass p)) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsTyVarBndr pass) where
- ppr (UserTyVar n) = ppr n
- ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
+instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Outputable (HsTyVarBndr (GhcPass p)) where
+ ppr (UserTyVar _ n) = ppr n
+ ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k]
+ ppr (XTyVarBndr n) = ppr n
instance (Outputable thing) => Outputable (HsImplicitBndrs pass thing) where
ppr (HsIB { hsib_body = ty }) = ppr ty
@@ -1190,8 +1319,11 @@ instance (Outputable thing) => Outputable (HsWildCardBndrs pass thing) where
instance Outputable (HsWildCardInfo pass) where
ppr (AnonWildCard _) = char '_'
-pprHsForAll :: (SourceTextX pass, OutputableBndrId pass)
- => [LHsTyVarBndr pass] -> LHsContext pass -> SDoc
+pprAnonWildCard :: SDoc
+pprAnonWildCard = char '_'
+
+pprHsForAll :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc
pprHsForAll = pprHsForAllExtra Nothing
-- | Version of 'pprHsForAll' that can also print an extra-constraints
@@ -1201,44 +1333,44 @@ pprHsForAll = pprHsForAllExtra Nothing
-- function for this is needed, as the extra-constraints wildcard is removed
-- from the actual context and type, and stored in a separate field, thus just
-- printing the type will not print the extra-constraints wildcard.
-pprHsForAllExtra :: (SourceTextX pass, OutputableBndrId pass)
- => Maybe SrcSpan -> [LHsTyVarBndr pass] -> LHsContext pass
- -> SDoc
+pprHsForAllExtra :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)]
+ -> LHsContext (GhcPass p) -> SDoc
pprHsForAllExtra extra qtvs cxt
= pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt)
where
show_extra = isJust extra
-pprHsForAllTvs :: (SourceTextX pass, OutputableBndrId pass)
- => [LHsTyVarBndr pass] -> SDoc
+pprHsForAllTvs :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => [LHsTyVarBndr (GhcPass p)] -> SDoc
pprHsForAllTvs qtvs
| null qtvs = whenPprDebug (forAllLit <+> dot)
| otherwise = forAllLit <+> interppSP qtvs <> dot
-pprHsContext :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> SDoc
+pprHsContext :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> SDoc
pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
-pprHsContextNoArrow :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> SDoc
+pprHsContextNoArrow :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> SDoc
pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
-pprHsContextMaybe :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> Maybe SDoc
+pprHsContextMaybe :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> Maybe SDoc
pprHsContextMaybe [] = Nothing
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred
pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt)
-- For use in a HsQualTy, which always gets printed if it exists.
-pprHsContextAlways :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> SDoc
+pprHsContextAlways :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> SDoc
pprHsContextAlways [] = parens empty <+> darrow
pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow
pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow
-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
-pprHsContextExtra :: (SourceTextX pass, OutputableBndrId pass)
- => Bool -> HsContext pass -> SDoc
+pprHsContextExtra :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => Bool -> HsContext (GhcPass p) -> SDoc
pprHsContextExtra show_extra ctxt
| not show_extra
= pprHsContext ctxt
@@ -1249,8 +1381,8 @@ pprHsContextExtra show_extra ctxt
where
ctxt' = map ppr ctxt ++ [char '_']
-pprConDeclFields :: (SourceTextX pass, OutputableBndrId pass)
- => [LConDeclField pass] -> SDoc
+pprConDeclFields :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => [LConDeclField (GhcPass p)] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
@@ -1274,76 +1406,79 @@ seems like the Right Thing anyway.)
-- Printing works more-or-less as for Types
-pprHsType :: (SourceTextX pass, OutputableBndrId pass) => HsType pass -> SDoc
+pprHsType :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsType (GhcPass p) -> SDoc
pprHsType ty = ppr_mono_ty ty
-ppr_mono_lty :: (SourceTextX pass, OutputableBndrId pass)
- => LHsType pass -> SDoc
+ppr_mono_lty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsType (GhcPass p) -> SDoc
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
-ppr_mono_ty :: (SourceTextX pass, OutputableBndrId pass)
- => HsType pass -> SDoc
+ppr_mono_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsType (GhcPass p) -> SDoc
ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
= sep [pprHsForAllTvs tvs, ppr_mono_lty ty]
ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
= sep [pprHsContextAlways ctxt, ppr_mono_lty ty]
+ppr_mono_ty (XHsType t) = ppr t
-ppr_mono_ty (HsBangTy b ty) = ppr b <> ppr_mono_lty ty
-ppr_mono_ty (HsRecTy flds) = pprConDeclFields flds
-ppr_mono_ty (HsTyVar NotPromoted (L _ name))= pprPrefixOcc name
-ppr_mono_ty (HsTyVar Promoted (L _ name))
+ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty
+ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds
+ppr_mono_ty (HsTyVar _ NotPromoted (L _ name))= pprPrefixOcc name
+ppr_mono_ty (HsTyVar _ Promoted (L _ name))
= space <> quote (pprPrefixOcc name)
-- We need a space before the ' above, so the parser
-- does not attach it to the previous symbol
-ppr_mono_ty (HsFunTy ty1 ty2) = ppr_fun_ty ty1 ty2
-ppr_mono_ty (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys)
+ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2
+ppr_mono_ty (HsTupleTy _ con tys) = tupleParens std_con (pprWithCommas ppr tys)
where std_con = case con of
HsUnboxedTuple -> UnboxedTuple
_ -> BoxedTuple
-ppr_mono_ty (HsSumTy tys) = tupleParens UnboxedTuple (pprWithBars ppr tys)
-ppr_mono_ty (HsKindSig ty kind) = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind)
-ppr_mono_ty (HsListTy ty) = brackets (ppr_mono_lty ty)
-ppr_mono_ty (HsPArrTy ty) = paBrackets (ppr_mono_lty ty)
-ppr_mono_ty (HsIParamTy n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty)
-ppr_mono_ty (HsSpliceTy s _) = pprSplice s
-ppr_mono_ty (HsCoreTy ty) = ppr ty
-ppr_mono_ty (HsExplicitListTy Promoted _ tys)
+ppr_mono_ty (HsSumTy _ tys)
+ = tupleParens UnboxedTuple (pprWithBars ppr tys)
+ppr_mono_ty (HsKindSig _ ty kind)
+ = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind)
+ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty)
+ppr_mono_ty (HsPArrTy _ ty) = paBrackets (ppr_mono_lty ty)
+ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty)
+ppr_mono_ty (HsSpliceTy _ s) = pprSplice s
+ppr_mono_ty (HsExplicitListTy _ Promoted tys)
= quote $ brackets (interpp'SP tys)
-ppr_mono_ty (HsExplicitListTy NotPromoted _ tys)
+ppr_mono_ty (HsExplicitListTy _ NotPromoted tys)
= brackets (interpp'SP tys)
ppr_mono_ty (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
-ppr_mono_ty (HsTyLit t) = ppr_tylit t
-ppr_mono_ty (HsWildCardTy {}) = char '_'
+ppr_mono_ty (HsTyLit _ t) = ppr_tylit t
+ppr_mono_ty (HsWildCardTy {}) = char '_'
-ppr_mono_ty (HsEqTy ty1 ty2)
+ppr_mono_ty (HsEqTy _ ty1 ty2)
= ppr_mono_lty ty1 <+> char '~' <+> ppr_mono_lty ty2
-ppr_mono_ty (HsAppsTy tys)
+ppr_mono_ty (HsAppsTy _ tys)
= hsep (map (ppr_app_ty . unLoc) tys)
-ppr_mono_ty (HsAppTy fun_ty arg_ty)
+ppr_mono_ty (HsAppTy _ fun_ty arg_ty)
= hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]
-ppr_mono_ty (HsOpTy ty1 (L _ op) ty2)
+ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2)
= sep [ ppr_mono_lty ty1
, sep [pprInfixOcc op, ppr_mono_lty ty2 ] ]
-ppr_mono_ty (HsParTy ty)
+ppr_mono_ty (HsParTy _ ty)
= parens (ppr_mono_lty ty)
-- Put the parens in where the user did
-- But we still use the precedence stuff to add parens because
-- toHsType doesn't put in any HsParTys, so we may still need them
-ppr_mono_ty (HsDocTy ty doc)
+ppr_mono_ty (HsDocTy _ ty doc)
-- AZ: Should we add parens? Should we introduce "-- ^"?
= ppr_mono_lty ty <+> ppr (unLoc doc)
-- we pretty print Haddock comments on types as if they were
-- postfix operators
--------------------------
-ppr_fun_ty :: (SourceTextX pass, OutputableBndrId pass)
- => LHsType pass -> LHsType pass -> SDoc
+ppr_fun_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
ppr_fun_ty ty1 ty2
= let p1 = ppr_mono_lty ty1
p2 = ppr_mono_lty ty2
@@ -1351,16 +1486,17 @@ ppr_fun_ty ty1 ty2
sep [p1, text "->" <+> p2]
--------------------------
-ppr_app_ty :: (SourceTextX pass, OutputableBndrId pass)
- => HsAppType pass -> SDoc
-ppr_app_ty (HsAppInfix (L _ n)) = pprInfixOcc n
-ppr_app_ty (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n))))
+ppr_app_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
+ => HsAppType (GhcPass p) -> SDoc
+ppr_app_ty (HsAppInfix _ (L _ n)) = pprInfixOcc n
+ppr_app_ty (HsAppPrefix _ (L _ (HsTyVar _ NotPromoted (L _ n))))
= pprPrefixOcc n
-ppr_app_ty (HsAppPrefix (L _ (HsTyVar Promoted (L _ n))))
+ppr_app_ty (HsAppPrefix _ (L _ (HsTyVar _ Promoted (L _ n))))
= space <> quote (pprPrefixOcc n) -- We need a space before the ' above, so
-- the parser does not attach it to the
-- previous symbol
-ppr_app_ty (HsAppPrefix ty) = ppr_mono_lty ty
+ppr_app_ty (HsAppPrefix _ ty) = ppr_mono_lty ty
+ppr_app_ty (XAppType ty) = ppr ty
--------------------------
ppr_tylit :: HsTyLit -> SDoc
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 8e17994993..f839e4f386 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -215,22 +215,20 @@ mkLHsPar :: LHsExpr name -> LHsExpr name
mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar 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 PlaceHolder 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
@@ -255,9 +253,9 @@ 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;
@@ -270,8 +268,9 @@ mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
mkHsIf :: SourceTextX p => LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
-mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
-mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType
+mkNPat lit neg = NPat noExt lit neg noSyntaxExpr
+mkNPlusKPat id lit
+ = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr
mkTransformStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
=> [ExprLStmt idL] -> LHsExpr idR
@@ -342,8 +341,8 @@ mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e)
mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs
-mkHsSpliceTy hasParen e
- = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind
+mkHsSpliceTy hasParen e = HsSpliceTy noExt
+ (HsUntypedSplice hasParen unqualSplice e)
mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
@@ -361,13 +360,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 ]
{-
@@ -388,14 +389,14 @@ nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con))
nlHsLit :: HsLit p -> LHsExpr p
nlHsLit n = noLoc (HsLit n)
-nlHsIntLit :: HasDefaultX p => Integer -> LHsExpr p
-nlHsIntLit n = noLoc (HsLit (HsInt def (mkIntegralLit n)))
+nlHsIntLit :: Integer -> LHsExpr (GhcPass p)
+nlHsIntLit n = noLoc (HsLit (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))
@@ -477,17 +478,17 @@ nlHsIf cond true false = noLoc (HsIf Nothing cond true false)
nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches))
nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs)
-nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
-nlHsTyVar :: IdP name -> LHsType name
-nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
-nlHsParTy :: LHsType name -> LHsType name
+nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p)
+nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
-nlHsAppTy f t = noLoc (HsAppTy f t)
-nlHsTyVar x = noLoc (HsTyVar NotPromoted (noLoc x))
-nlHsFunTy a b = noLoc (HsFunTy a b)
-nlHsParTy t = noLoc (HsParTy t)
+nlHsAppTy f t = noLoc (HsAppTy noExt f t)
+nlHsTyVar x = noLoc (HsTyVar noExt NotPromoted (noLoc x))
+nlHsFunTy a b = noLoc (HsFunTy noExt a b)
+nlHsParTy t = noLoc (HsParTy noExt t)
-nlHsTyConApp :: IdP name -> [LHsType name] -> LHsType name
+nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
{-
@@ -503,16 +504,16 @@ mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
mkLHsVarTuple :: [IdP a] -> LHsExpr 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
-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
@@ -522,10 +523,10 @@ mkBigLHsTup :: [LHsExpr id] -> LHsExpr id
mkBigLHsTup = mkChunkified mkLHsTupleExpr
-- The Big equivalents for the source tuple patterns
-mkBigLHsVarPatTup :: [IdP id] -> LPat id
+mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
-mkBigLHsPatTup :: [LPat id] -> LPat id
+mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
mkBigLHsPatTup = mkChunkified mkLHsPatTup
-- $big_tuples
@@ -632,16 +633,18 @@ typeToLHsType ty
| isPredTy arg
, (theta, tau) <- tcSplitPhiTy ty
= noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
+ , hst_xqual = noExt
, hst_body = go tau })
go (FunTy arg res) = nlHsFunTy (go arg) (go res)
go ty@(ForAllTy {})
| (tvs, tau) <- tcSplitForAllTys ty
= noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
+ , hst_xforall = noExt
, hst_body = go tau })
go (TyVarTy tv) = nlHsTyVar (getRdrName tv)
go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2)
- go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy noSourceText n)
- go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy noSourceText s)
+ go (LitTy (NumTyLit n)) = noLoc $ HsTyLit noExt (HsNumTy noSourceText n)
+ go (LitTy (StrTyLit s)) = noLoc $ HsTyLit noExt (HsStrTy noSourceText s)
go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args')
where
args' = filterOutInvisibleTypes tc args
@@ -652,7 +655,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))
@@ -690,13 +693,13 @@ mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id
mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
-mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
+mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
- | otherwise = CoPat co_fn p ty
+ | otherwise = CoPat noExt co_fn p ty
-mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
+mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
- | otherwise = CoPat (mkWpCastN co) pat ty
+ | otherwise = CoPat noExt (mkWpCastN co) pat ty
mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
@@ -769,14 +772,16 @@ mkPrefixFunRhs n = FunRhs { mc_fun = n
, mc_strictness = NoSrcStrict }
------------
-mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p
- -> Located (HsLocalBinds p) -> LMatch p (LHsExpr p)
+mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
+ -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p)
+ -> Located (HsLocalBinds (GhcPass p))
+ -> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch ctxt pats expr lbinds
= noLoc (Match { m_ctxt = ctxt
, m_pats = map paren pats
, m_grhss = GRHSs (unguardedRHS noSrcSpan expr) lbinds })
where
- paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
+ paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat noExt lp)
| otherwise = lp
{-
@@ -864,13 +869,15 @@ isBangedHsBind (PatBind {pat_lhs = pat})
isBangedHsBind _
= False
-collectLocalBinders :: HsLocalBindsLR idL idR -> [IdP idL]
+collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR)
+ -> [IdP (GhcPass idL)]
collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
-- No pattern synonyms here
collectLocalBinders (HsIPBinds _) = []
collectLocalBinders EmptyLocalBinds = []
-collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [IdP idL]
+collectHsIdBinders, collectHsValBinders
+ :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
-- Collect Id binders only, or Ids + pattern synonyms, respectively
collectHsIdBinders = collect_hs_val_binders True
collectHsValBinders = collect_hs_val_binders False
@@ -886,9 +893,11 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [IdP idL]
-- Same as collectHsBindsBinders, but works over a list of bindings
collectHsBindListBinders = foldr (collect_bind False . unLoc) []
-collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [IdP idL]
-collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds []
-collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds
+collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR)
+ -> [IdP (GhcPass idL)]
+collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []
+collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))
+ = collect_out_binds ps binds
collect_out_binds :: Bool -> [(RecFlag, LHsBinds p)] -> [IdP p]
collect_out_binds ps = foldr (collect_binds ps . snd) []
@@ -903,7 +912,7 @@ collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc
collect_bind _ (VarBind { var_id = f }) acc = f : acc
collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
-- I don't think we want the binders from the abe_binds
- -- The only time we collect binders from a typechecked
+
-- binding (hence see AbsBinds) is in zonking in TcHsSyn
collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
| omitPatSyn = acc
@@ -918,16 +927,20 @@ 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
@@ -952,33 +965,33 @@ collect_lpat :: LPat pass -> [IdP pass] -> [IdP pass]
collect_lpat (L _ pat) bndrs
= go pat
where
- go (VarPat (L _ var)) = var : bndrs
+ go (VarPat _ (L _ var)) = var : bndrs
go (WildPat _) = bndrs
- go (LazyPat pat) = collect_lpat pat bndrs
- go (BangPat pat) = collect_lpat pat bndrs
- go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs
- go (ViewPat _ pat _) = collect_lpat pat bndrs
- go (ParPat pat) = collect_lpat pat bndrs
+ go (LazyPat _ pat) = collect_lpat pat bndrs
+ go (BangPat _ pat) = collect_lpat pat bndrs
+ go (AsPat _ (L _ a) pat) = a : collect_lpat pat bndrs
+ go (ViewPat _ _ pat) = collect_lpat pat bndrs
+ go (ParPat _ pat) = collect_lpat pat bndrs
- go (ListPat pats _ _) = foldr collect_lpat bndrs pats
- go (PArrPat pats _) = foldr collect_lpat bndrs pats
- go (TuplePat pats _ _) = foldr collect_lpat bndrs pats
- go (SumPat pat _ _ _) = collect_lpat pat bndrs
+ go (ListPat _ pats _ _) = foldr collect_lpat bndrs pats
+ go (PArrPat _ pats) = foldr collect_lpat bndrs pats
+ go (TuplePat _ pats _) = foldr collect_lpat bndrs pats
+ go (SumPat _ pat _ _) = collect_lpat pat bndrs
go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
-- See Note [Dictionary binders in ConPatOut]
- go (LitPat _) = bndrs
- go (NPat {}) = bndrs
- go (NPlusKPat (L _ n) _ _ _ _ _)= n : bndrs
+ go (LitPat _ _) = bndrs
+ go (NPat {}) = bndrs
+ go (NPlusKPat _ (L _ n) _ _ _ _)= n : bndrs
- go (SigPatIn pat _) = collect_lpat pat bndrs
- go (SigPatOut pat _) = collect_lpat pat bndrs
+ go (SigPat _ pat) = collect_lpat pat bndrs
- go (SplicePat (HsSpliced _ (HsSplicedPat pat)))
+ go (SplicePat _ (HsSpliced _ (HsSplicedPat pat)))
= go pat
- go (SplicePat _) = bndrs
- go (CoPat _ pat _) = go pat
+ go (SplicePat _ _) = bndrs
+ go (CoPat _ _ pat _) = go pat
+ go (XPat {}) = bndrs
{-
Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
@@ -1027,7 +1040,7 @@ hsTyClForeignBinders tycl_decls foreign_decls
foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
where
getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name]
- getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs
+ getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs
-------------------
hsLTyClDeclBinders :: Located (TyClDecl pass)
@@ -1062,11 +1075,11 @@ hsForeignDeclsBinders foreign_decls
-------------------
-hsPatSynSelectors :: HsValBinds p -> [IdP p]
+hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
-- Collects record pattern-synonym selectors only; the pattern synonym
-- names are collected by collectHsValBinders.
-hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors"
-hsPatSynSelectors (ValBindsOut binds _)
+hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
+hsPatSynSelectors (XValBindsLR (NValBinds binds _))
= foldrBag addPatSynSelector [] . unionManyBags $ map snd binds
addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
@@ -1123,11 +1136,11 @@ hsConDeclsBinders cons = go id cons
L loc (ConDeclGADT { con_names = names
, con_type = HsIB { hsib_body = res_ty}}) ->
case tau of
- L _ (HsFunTy
- (L _ (HsAppsTy
- [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty)
+ L _ (HsFunTy _
+ (L _ (HsAppsTy _
+ [L _ (HsAppPrefix _ (L _ (HsRecTy _ flds)))])) _)
-> record_gadt flds
- L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)
+ L _ (HsFunTy _ (L _ (HsRecTy _ flds)) _res_ty)
-> record_gadt flds
_other -> (map (L loc . unLoc) names ++ ns, fs)
@@ -1188,13 +1201,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
@@ -1210,10 +1226,10 @@ lStmtsImplicits = hs_lstmts
hs_local_binds (HsIPBinds _) = emptyNameSet
hs_local_binds EmptyLocalBinds = emptyNameSet
-hsValBindsImplicits :: HsValBindsLR GhcRn idR -> NameSet
-hsValBindsImplicits (ValBindsOut binds _)
+hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> NameSet
+hsValBindsImplicits (XValBindsLR (NValBinds binds _))
= foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds
-hsValBindsImplicits (ValBindsIn binds _)
+hsValBindsImplicits (ValBinds _ binds _)
= lhsBindsImplicits binds
lhsBindsImplicits :: LHsBindsLR GhcRn idR -> NameSet
@@ -1229,18 +1245,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..55778d9adf 100644
--- a/compiler/hsSyn/PlaceHolder.hs
+++ b/compiler/hsSyn/PlaceHolder.hs
@@ -6,10 +6,10 @@
module PlaceHolder where
-import GhcPrelude ()
+import GhcPrelude ( Eq(..), Ord(..) )
import Type ( Type )
-import Outputable
+import Outputable hiding ( (<>) )
import Name
import NameSet
import RdrName
@@ -31,7 +31,10 @@ import Data.Data hiding ( Fixity )
-- | used as place holder in PostTc and PostRn values
data PlaceHolder = PlaceHolder
- deriving (Data)
+ deriving (Data,Eq,Ord)
+
+instance Outputable PlaceHolder where
+ ppr _ = text "PlaceHolder"
placeHolderKind :: PlaceHolder
placeHolderKind = PlaceHolder
View Lorry Controller Status