diff options
Diffstat (limited to 'compiler/hsSyn/HsTypes.hs')
| -rw-r--r-- | compiler/hsSyn/HsTypes.hs | 478 |
1 files changed, 307 insertions, 171 deletions
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 |