diff options
author | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2022-12-04 21:50:40 +0300 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-01-05 23:01:55 -0500 |
commit | 9e077999eb3d09af6f31eb92233d4d757ece75f8 (patch) | |
tree | 295211c6306683eb4c41455bf9900f8fc3038267 | |
parent | 22bb89989fc0a907ef6b8f6ae99aa8907f67e438 (diff) | |
download | haskell-9e077999eb3d09af6f31eb92233d4d757ece75f8.tar.gz |
HsToken in TypeArg (#19623)
Updates the haddock submodule.
-rw-r--r-- | compiler/GHC/Hs/Instances.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Hs/Type.hs | 30 | ||||
-rw-r--r-- | compiler/GHC/Hs/Utils.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Iface/Ext/Ast.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Parser.y | 2 | ||||
-rw-r--r-- | compiler/GHC/Parser/Annotation.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/Rename/HsType.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/HsType.hs | 16 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Sig.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/TyCl.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/ThToHs.hs | 7 | ||||
-rw-r--r-- | compiler/Language/Haskell/Syntax/Type.hs | 8 | ||||
-rw-r--r-- | testsuite/tests/parser/should_compile/DumpParsedAst.stderr | 11 | ||||
-rw-r--r-- | testsuite/tests/parser/should_compile/DumpRenamedAst.stderr | 11 | ||||
-rw-r--r-- | utils/check-exact/ExactPrint.hs | 14 | ||||
m--------- | utils/haddock | 0 |
18 files changed, 84 insertions, 61 deletions
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 41dd33bee9..74d75fb7be 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -510,10 +510,10 @@ deriving instance Data thing => Data (HsScaled GhcPs thing) deriving instance Data thing => Data (HsScaled GhcRn thing) deriving instance Data thing => Data (HsScaled GhcTc thing) -deriving instance (Data a, Data b) => Data (HsArg a b) --- deriving instance Data (HsArg (Located (HsType GhcPs)) (Located (HsKind GhcPs))) --- deriving instance Data (HsArg (Located (HsType GhcRn)) (Located (HsKind GhcRn))) --- deriving instance Data (HsArg (Located (HsType GhcTc)) (Located (HsKind GhcTc))) +-- deriving instance (Data a, Data b) => Data (HsArg p a b) +deriving instance (Data a, Data b) => Data (HsArg GhcPs a b) +deriving instance (Data a, Data b) => Data (HsArg GhcRn a b) +deriving instance (Data a, Data b) => Data (HsArg GhcTc a b) -- deriving instance (DataIdLR p p) => Data (ConDeclField p) deriving instance Data (ConDeclField GhcPs) diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 9004f8dacb..053042d4a1 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -94,6 +95,7 @@ import Language.Haskell.Syntax.Type import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) ) +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import GHC.Core.DataCon( SrcStrictness(..), SrcUnpackedness(..), HsImplBang(..) ) import GHC.Hs.Extension @@ -312,7 +314,7 @@ type instance XIParamTy (GhcPass _) = EpAnn [AddEpAnn] type instance XStarTy (GhcPass _) = NoExtField type instance XKindSig (GhcPass _) = EpAnn [AddEpAnn] -type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives +type instance XAppKindTy (GhcPass _) = NoExtField type instance XSpliceTy GhcPs = NoExtField type instance XSpliceTy GhcRn = HsUntypedSpliceResult (LHsType GhcRn) @@ -489,10 +491,10 @@ mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) mkHsAppTys = foldl' mkHsAppTy -mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +mkHsAppKindTy :: LHsType (GhcPass p) -> LHsToken "@" (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -mkHsAppKindTy ext ty k - = addCLocAA ty k (HsAppKindTy ext ty k) +mkHsAppKindTy ty at k + = addCLocAA ty k (HsAppKindTy noExtField ty at k) {- ************************************************************************ @@ -541,7 +543,7 @@ hsTyGetAppHead_maybe = go where go (L _ (HsTyVar _ _ ln)) = Just ln go (L _ (HsAppTy _ l _)) = go l - go (L _ (HsAppKindTy _ t _)) = go t + go (L _ (HsAppKindTy _ t _ _)) = go t go (L _ (HsOpTy _ _ _ ln _)) = Just ln go (L _ (HsParTy _ t)) = go t go (L _ (HsKindSig _ t _)) = go t @@ -553,12 +555,12 @@ hsTyGetAppHead_maybe = go lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan lhsTypeArgSrcSpan arg = case arg of HsValArg tm -> getLocA tm - HsTypeArg at ty -> at `combineSrcSpans` getLocA ty + HsTypeArg at ty -> getTokenSrcSpan (getLoc at) `combineSrcSpans` getLocA ty HsArgPar sp -> sp -------------------------------- -numVisibleArgs :: [HsArg tm ty] -> Arity +numVisibleArgs :: [HsArg p tm ty] -> Arity numVisibleArgs = count is_vis where is_vis (HsValArg _) = True is_vis _ = False @@ -576,7 +578,7 @@ numVisibleArgs = count is_vis -- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering -- @ pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty) - => id -> LexicalFixity -> [HsArg tm ty] -> SDoc + => id -> LexicalFixity -> [HsArg p tm ty] -> SDoc pprHsArgsApp thing fixity (argl:argr:args) | Infix <- fixity = let pp_op_app = hsep [ ppr_single_hs_arg argl @@ -591,7 +593,7 @@ pprHsArgsApp thing _fixity args -- | Pretty-print a prefix identifier to a list of 'HsArg's. ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty) - => SDoc -> [HsArg tm ty] -> SDoc + => SDoc -> [HsArg p tm ty] -> SDoc ppr_hs_args_prefix_app acc [] = acc ppr_hs_args_prefix_app acc (arg:args) = case arg of @@ -601,7 +603,7 @@ ppr_hs_args_prefix_app acc (arg:args) = -- | Pretty-print an 'HsArg' in isolation. ppr_single_hs_arg :: (Outputable tm, Outputable ty) - => HsArg tm ty -> SDoc + => HsArg p tm ty -> SDoc ppr_single_hs_arg (HsValArg tm) = ppr tm ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty -- GHC shouldn't be constructing ASTs such that this case is ever reached. @@ -611,9 +613,9 @@ ppr_single_hs_arg (HsArgPar{}) = empty -- | This instance is meant for debug-printing purposes. If you wish to -- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead. -instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where +instance (Outputable tm, Outputable ty) => Outputable (HsArg (GhcPass p) tm ty) where ppr (HsValArg tm) = text "HsValArg" <+> ppr tm - ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty + ppr (HsTypeArg at ty) = text "HsTypeArg" <+> ppr at <+> ppr ty ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp -------------------------------- @@ -1180,7 +1182,7 @@ ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*') ppr_mono_ty (HsAppTy _ fun_ty arg_ty) = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] -ppr_mono_ty (HsAppKindTy _ ty k) +ppr_mono_ty (HsAppKindTy _ ty _ k) = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2) = sep [ ppr_mono_lty ty1 @@ -1295,7 +1297,7 @@ lhsTypeHasLeadingPromotionQuote ty go (HsWildCardTy{}) = False go (HsStarTy{}) = False go (HsAppTy _ t _) = goL t - go (HsAppKindTy _ t _) = goL t + go (HsAppKindTy _ t _ _) = goL t go (HsParTy{}) = False go (HsDocTy _ t _) = goL t go (XHsType{}) = False diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 8e934d7c29..486e4810d4 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -628,13 +628,13 @@ nlHsTyConApp prom fixity tycon tys mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn fun) arg -- parenthesize things like `(A + B) C` mk_app fun (HsValArg ty) = noLocA (HsAppTy noExtField fun (parenthesizeHsType appPrec ty)) - mk_app fun (HsTypeArg _ ki) = noLocA (HsAppKindTy noSrcSpan fun (parenthesizeHsType appPrec ki)) + mk_app fun (HsTypeArg at ki) = noLocA (HsAppKindTy noExtField fun at (parenthesizeHsType appPrec ki)) mk_app fun (HsArgPar _) = noLocA (HsParTy noAnn fun) nlHsAppKindTy :: LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) nlHsAppKindTy f k - = noLocA (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k)) + = noLocA (HsAppKindTy noExtField f noHsTok (parenthesizeHsType appPrec k)) {- Tuples. All these functions are *pre-typechecker* because they lack diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 045de30ed6..f6cf36101b 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1389,7 +1389,7 @@ repTy (HsAppTy _ f a) = do f1 <- repLTy f a1 <- repLTy a repTapp f1 a1 -repTy (HsAppKindTy _ ty ki) = do +repTy (HsAppKindTy _ ty _ ki) = do ty1 <- repLTy ty ki1 <- repLTy ki repTappKind ty1 ki1 diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 8f97f51833..bf9a38e279 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -570,7 +570,7 @@ instance (HasLoc a, HiePass p) => HasLoc (FamEqn (GhcPass p) a) where HsOuterExplicit{hso_bndrs = tvs} -> foldl1' combineSrcSpans [loc a, loc tvs, loc b, loc c] -instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where +instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg p tm ty) where loc (HsValArg tm) = loc tm loc (HsTypeArg _ ty) = loc ty loc (HsArgPar sp) = sp @@ -1773,7 +1773,7 @@ instance ToHie (LocatedA (HsType GhcRn)) where [ toHie a , toHie b ] - HsAppKindTy _ ty ki -> + HsAppKindTy _ ty _ ki -> [ toHie ty , toHie ki ] @@ -1831,7 +1831,7 @@ instance ToHie (LocatedA (HsType GhcRn)) where HsStarTy _ _ -> [] XHsType _ -> [] -instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where +instance (ToHie tm, ToHie ty) => ToHie (HsArg p tm ty) where toHie (HsValArg tm) = toHie tm toHie (HsTypeArg _ ty) = toHie ty toHie (HsArgPar sp) = locOnly sp diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index c56fae7b29..1d081d1071 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -2199,7 +2199,7 @@ ftype :: { forall b. DisambTD b => PV (LocatedA b) } | ftype tyarg { $1 >>= \ $1 -> mkHsAppTyPV $1 $2 } | ftype PREFIX_AT atype { $1 >>= \ $1 -> - mkHsAppKindTyPV $1 (getLoc $2) $3 } + mkHsAppKindTyPV $1 (hsTok $2) $3 } tyarg :: { LHsType GhcPs } : atype { $1 } diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index 7b7fccc862..f4e1a06198 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -15,6 +15,7 @@ module GHC.Parser.Annotation ( AddEpAnn(..), EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn, TokenLocation(..), + getTokenSrcSpan, DeltaPos(..), deltaPos, getDeltaLine, EpAnn(..), Anchor(..), AnchorOperation(..), @@ -412,6 +413,11 @@ data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan) data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation deriving (Data,Eq) +getTokenSrcSpan :: TokenLocation -> SrcSpan +getTokenSrcSpan NoTokenLoc = noSrcSpan +getTokenSrcSpan (TokenLoc EpaDelta{}) = noSrcSpan +getTokenSrcSpan (TokenLoc (EpaSpan rspan mbufpos)) = RealSrcSpan rspan mbufpos + instance Outputable a => Outputable (GenLocated TokenLocation a) where ppr (L _ x) = ppr x diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 309fe2b8a7..9c0a5df0aa 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1020,7 +1020,7 @@ checkTyClHdr is_cls ty where (o,c) = mkParensEpAnn (realSrcSpan l) go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg t2:acc) ops cps fix - go _ (HsAppKindTy l ty ki) acc ops cps fix = goL ty (HsTypeArg l ki:acc) ops cps fix + go _ (HsAppKindTy _ ty at ki) acc ops cps fix = goL ty (HsTypeArg at ki:acc) ops cps fix go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix = return (L (noAnnSrcSpan l) (nameRdrName tup_name) , map HsValArg ts, fix, (reverse ops)++cps) @@ -1957,7 +1957,7 @@ class DisambTD b where -- | Disambiguate @f x@ (function application or prefix data constructor). mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @f \@t@ (visible kind application) - mkHsAppKindTyPV :: LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b) + mkHsAppKindTyPV :: LocatedA b -> LHsToken "@" GhcPs -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @f \# x@ (infix operator) mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma) @@ -1966,7 +1966,7 @@ class DisambTD b where instance DisambTD (HsType GhcPs) where mkHsAppTyHeadPV = return mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2) - mkHsAppKindTyPV t l_at ki = return (mkHsAppKindTy l_at t ki) + mkHsAppKindTyPV t at ki = return (mkHsAppKindTy t at ki) mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2) mkUnpackednessPV = addUnpackednessP @@ -2002,8 +2002,8 @@ instance DisambTD DataConBuilder where -- the grammar in Parser.y is written (see infixtype/ftype). panic "mkHsAppTyPV: InfixDataConBuilder" - mkHsAppKindTyPV lhs l_at ki = - addFatalError $ mkPlainErrorMsgEnvelope l_at $ + mkHsAppKindTyPV lhs at ki = + addFatalError $ mkPlainErrorMsgEnvelope (getTokenSrcSpan (getLoc at)) $ (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) mkHsOpTyPV prom lhs tc rhs = do diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index df53523597..989a8bf3d8 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -693,12 +693,12 @@ rnHsTyKi env (HsAppTy _ ty1 ty2) ; (ty2', fvs2) <- rnLHsTyKi env ty2 ; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) } -rnHsTyKi env (HsAppKindTy l ty k) +rnHsTyKi env (HsAppKindTy _ ty at k) = do { kind_app <- xoptM LangExt.TypeApplications ; unless kind_app (addErr (typeAppErr "kind" k)) ; (ty', fvs1) <- rnLHsTyKi env ty ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k - ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) } + ; return (HsAppKindTy noExtField ty' at k', fvs1 `plusFV` fvs2) } rnHsTyKi env t@(HsIParamTy x n ty) = do { notInKinds env t @@ -1929,7 +1929,7 @@ extract_lty (L _ ty) acc flds HsAppTy _ ty1 ty2 -> extract_lty ty1 $ extract_lty ty2 acc - HsAppKindTy _ ty k -> extract_lty ty $ + HsAppKindTy _ ty _ k -> extract_lty ty $ extract_lty k acc HsListTy _ ty -> extract_lty ty acc HsTupleTy _ _ tys -> extract_ltys tys acc diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index a0a2a51cee..0ea0412339 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -1517,11 +1517,11 @@ splitHsAppTys hs_ty is_app _ = False go :: LHsType GhcRn - -> [HsArg (LHsType GhcRn) (LHsKind GhcRn)] + -> [HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)] -> (LHsType GhcRn, - [HsArg (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp + [HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as) - go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as) + go (L _ (HsAppKindTy _ ty at k)) as = go ty (HsTypeArg at k : as) go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as) go (L _ (HsOpTy _ prom l op@(L sp _) r)) as = ( L (na2la sp) (HsTyVar noAnn prom op) @@ -1698,7 +1698,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args substed_fun_ki = substTy subst fun_ki hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args) - n_initial_val_args :: [HsArg tm ty] -> Arity + n_initial_val_args :: [HsArg p tm ty] -> Arity -- Count how many leading HsValArgs we have n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args @@ -1890,10 +1890,10 @@ unsaturated arguments: see #11246. Hence doing this in tcInferApps. appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn appTypeToArg f [] = f -appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args -appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args -appTypeToArg f (HsTypeArg l arg : args) - = appTypeToArg (mkHsAppKindTy l f arg) args +appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args +appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args +appTypeToArg f (HsTypeArg at arg : args) + = appTypeToArg (mkHsAppKindTy f at arg) args {- ********************************************************************* diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 0c74bd54f6..77d61941fc 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -299,7 +299,7 @@ no_anon_wc_ty lty = go lty go (L _ ty) = case ty of HsWildCardTy _ -> False HsAppTy _ ty1 ty2 -> go ty1 && go ty2 - HsAppKindTy _ ty ki -> go ty && go ki + HsAppKindTy _ ty _ ki -> go ty && go ki HsFunTy _ w ty1 ty2 -> go ty1 && go ty2 && go (arrowToHsType w) HsListTy _ ty -> go ty HsTupleTy _ _ tys -> gos tys diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 32c64b6c7f..19b19e36c7 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -3045,7 +3045,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo (map (const Nominal) qtvs) (locA loc)) } -checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg tm ty] -> TcM () +checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg p tm ty] -> TcM () checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats = do { -- Ensure that each equation's type constructor is for the right -- type family. E.g. barf on diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index bc6cbe0da1..5223d2f7df 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -1795,8 +1795,9 @@ mk_apps head_ty type_args = do case arg of HsValArg ty -> do p_ty <- add_parens ty mk_apps (HsAppTy noExtField phead_ty p_ty) args - HsTypeArg l ki -> do p_ki <- add_parens ki - mk_apps (HsAppKindTy l phead_ty p_ki) args + HsTypeArg at ki -> + do p_ki <- add_parens ki + mk_apps (HsAppKindTy noExtField phead_ty at p_ki) args HsArgPar _ -> mk_apps (HsParTy noAnn phead_ty) args go type_args @@ -1841,7 +1842,7 @@ split_ty_app ty = go ty [] where go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') } go (AppKindT ty ki) as' = do { ki' <- cvtKind ki - ; go ty (HsTypeArg noSrcSpan ki':as') } + ; go ty (HsTypeArg noHsTok ki' : as') } go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') } go f as = return (f,as) diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs index 69cf084421..8898d2400b 100644 --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -756,6 +756,7 @@ data HsType pass | HsAppKindTy (XAppKindTy pass) -- type level type app (LHsType pass) + !(LHsToken "@" pass) (LHsKind pass) | HsFunTy (XFunTy pass) @@ -1181,14 +1182,13 @@ if they correspond to a visible 'forall'. -} -- | Arguments in an expression/type after splitting -data HsArg tm ty +data HsArg p tm ty = HsValArg tm -- Argument is an ordinary expression (f arg) - | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty) - -- SrcSpan is location of the `@` + | HsTypeArg !(LHsToken "@" p) ty -- Argument is a visible type application (f @ty) | HsArgPar SrcSpan -- See Note [HsArgPar] -- type level equivalent -type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) +type LHsTypeArg p = HsArg p (LHsType p) (LHsKind p) {- Note [HsArgPar] diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 1e48180185..677988f0df 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -656,7 +656,10 @@ (HsOuterImplicit (NoExtField)) [(HsTypeArg - { DumpParsedAst.hs:18:6 } + (L + (TokenLoc + (EpaSpan { DumpParsedAst.hs:18:6 })) + (HsTok)) (L (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAst.hs:18:7-11 }) (HsTyVar @@ -716,7 +719,7 @@ (L (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAst.hs:18:19-26 }) (HsAppKindTy - { DumpParsedAst.hs:18:21 } + (NoExtField) (L (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAst.hs:18:19 }) (HsTyVar @@ -733,6 +736,10 @@ (Unqual {OccName: T})))) (L + (TokenLoc + (EpaSpan { DumpParsedAst.hs:18:21 })) + (HsTok)) + (L (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAst.hs:18:22-26 }) (HsTyVar (EpAnn diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index cd5c002a6a..e297ee8b84 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -868,7 +868,10 @@ [{Name: a} ,{Name: f}]) [(HsTypeArg - { DumpRenamedAst.hs:25:6 } + (L + (TokenLoc + (EpaSpan { DumpRenamedAst.hs:25:6 })) + (HsTok)) (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:25:7-11 }) (HsTyVar @@ -907,7 +910,7 @@ (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:25:19-26 }) (HsAppKindTy - { DumpRenamedAst.hs:25:21 } + (NoExtField) (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:25:19 }) (HsTyVar @@ -917,6 +920,10 @@ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:25:19 }) {Name: DumpRenamedAst.T}))) (L + (TokenLoc + (EpaSpan { DumpRenamedAst.hs:25:21 })) + (HsTok)) + (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:25:22-26 }) (HsTyVar (EpAnnNotUsed) diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index c3d10b1f56..30a3234ee0 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -1998,12 +1998,12 @@ exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do -- --------------------------------------------------------------------- instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty) - => ExactPrint (HsArg tm ty) where + => ExactPrint (HsArg GhcPs tm ty) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ = a exact a@(HsValArg tm) = markAnnotated tm >> return a - exact a@(HsTypeArg ss ty) = printStringAtSs ss "@" >> markAnnotated ty >> return a + exact a@(HsTypeArg at ty) = markToken at >> markAnnotated ty >> return a exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source -- --------------------------------------------------------------------- @@ -3777,7 +3777,7 @@ instance ExactPrint (HsType GhcPs) where getAnnotationEntry (HsQualTy _ _ _) = NoEntryVal getAnnotationEntry (HsTyVar an _ _) = fromAnn an getAnnotationEntry (HsAppTy _ _ _) = NoEntryVal - getAnnotationEntry (HsAppKindTy _ _ _) = NoEntryVal + getAnnotationEntry (HsAppKindTy _ _ _ _) = NoEntryVal getAnnotationEntry (HsFunTy an _ _ _) = fromAnn an getAnnotationEntry (HsListTy an _) = fromAnn an getAnnotationEntry (HsTupleTy an _ _) = fromAnn an @@ -3801,7 +3801,7 @@ instance ExactPrint (HsType GhcPs) where setAnnotationAnchor a@(HsQualTy _ _ _) _ _s = a setAnnotationAnchor (HsTyVar an a b) anc cs = (HsTyVar (setAnchorEpa an anc cs) a b) setAnnotationAnchor a@(HsAppTy _ _ _) _ _s = a - setAnnotationAnchor a@(HsAppKindTy _ _ _) _ _s = a + setAnnotationAnchor a@(HsAppKindTy _ _ _ _) _ _s = a setAnnotationAnchor (HsFunTy an a b c) anc cs = (HsFunTy (setAnchorEpa an anc cs) a b c) setAnnotationAnchor (HsListTy an a) anc cs = (HsListTy (setAnchorEpa an anc cs) a) setAnnotationAnchor (HsTupleTy an a b) anc cs = (HsTupleTy (setAnchorEpa an anc cs) a b) @@ -3842,11 +3842,11 @@ instance ExactPrint (HsType GhcPs) where t1' <- markAnnotated t1 t2' <- markAnnotated t2 return (HsAppTy an t1' t2') - exact (HsAppKindTy ss ty ki) = do + exact (HsAppKindTy ss ty at ki) = do ty' <- markAnnotated ty - printStringAtSs ss "@" + at' <- markToken at ki' <- markAnnotated ki - return (HsAppKindTy ss ty' ki') + return (HsAppKindTy ss ty' at' ki') exact (HsFunTy an mult ty1 ty2) = do ty1' <- markAnnotated ty1 mult' <- markArrow mult diff --git a/utils/haddock b/utils/haddock -Subproject 261a7c8ac5b5ff29e6e0380690cbb6ee9730f98 +Subproject 519a95998b09a2c9c7a42c3a0cf2ca0c4358bb4 |