[Git][ghc/ghc][master] EPA: Capture location of '_' for wild card type binder
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Nov 12 06:27:07 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
9ad9ac63 by Alan Zimmerman at 2024-11-12T01:24:39-05:00
EPA: Capture location of '_' for wild card type binder
And keep track of promotion status in HsExplicitTupleTy, so the
round-trip ppr test works for it.
Updates Haddock output too, using the PromotionFlag in
HsExplicitTupleTy.
Closes #25454
- - - - -
25 changed files:
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Type.hs
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test25454.hs
- testsuite/tests/printer/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
Changes:
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -365,7 +365,11 @@ type instance XBndrNoKind (GhcPass p) = NoExtField
type instance XXBndrKind (GhcPass p) = DataConCantHappen
type instance XBndrVar (GhcPass p) = NoExtField
-type instance XBndrWildCard (GhcPass p) = NoExtField
+
+type instance XBndrWildCard GhcPs = EpToken "_"
+type instance XBndrWildCard GhcRn = NoExtField
+type instance XBndrWildCard GhcTc = NoExtField
+
type instance XXBndrVar (GhcPass p) = DataConCantHappen
data AnnTyVarBndr
@@ -491,7 +495,9 @@ type instance XExplicitTupleTy GhcTc = [Kind]
type instance XTyLit (GhcPass _) = NoExtField
-type instance XWildCardTy (GhcPass _) = NoExtField
+type instance XWildCardTy GhcPs = EpToken "_"
+type instance XWildCardTy GhcRn = NoExtField
+type instance XWildCardTy GhcTc = NoExtField
type instance XXType (GhcPass _) = HsCoreTy
@@ -674,8 +680,8 @@ ignoreParens ty = ty
************************************************************************
-}
-mkAnonWildCardTy :: HsType GhcPs
-mkAnonWildCardTy = HsWildCardTy noExtField
+mkAnonWildCardTy :: EpToken "_" -> HsType GhcPs
+mkAnonWildCardTy tok = HsWildCardTy tok
mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnN)
=> PromotionFlag
@@ -1413,13 +1419,13 @@ ppr_mono_ty (HsSpliceTy ext s) =
ppr_mono_ty (HsExplicitListTy _ prom tys)
| isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys)
| otherwise = brackets (interpp'SP tys)
-ppr_mono_ty (HsExplicitTupleTy _ tys)
+ppr_mono_ty (HsExplicitTupleTy _ prom tys)
-- Special-case unary boxed tuples so that they are pretty-printed as
-- `'MkSolo x`, not `'(x)`
| [ty] <- tys
- = quoteIfPunsEnabled $ sep [text (mkTupleStr Boxed dataName 1), ppr_mono_lty ty]
+ = quote_tuple prom $ sep [text (mkTupleStr Boxed dataName 1), ppr_mono_lty ty]
| otherwise
- = quoteIfPunsEnabled $ parens (maybeAddSpace tys $ interpp'SP tys)
+ = quote_tuple prom $ parens (maybeAddSpace tys $ interpp'SP tys)
ppr_mono_ty (HsTyLit _ t) = ppr t
ppr_mono_ty (HsWildCardTy {}) = char '_'
@@ -1453,6 +1459,10 @@ ppr_fun_ty mult ty1 ty2
in
sep [p1, arr <+> p2]
+quote_tuple :: PromotionFlag -> SDoc -> SDoc
+quote_tuple IsPromoted doc = quote doc
+quote_tuple NotPromoted doc = doc
+
--------------------------
-- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses
-- under precedence @p at .
@@ -1482,7 +1492,7 @@ hsTypeNeedsParens p = go_hs_ty
-- Special-case unary boxed tuple applications so that they are
-- parenthesized as `Proxy ('MkSolo x)`, not `Proxy 'MkSolo x` (#18612)
-- See Note [One-tuples] in GHC.Builtin.Types
- go_hs_ty (HsExplicitTupleTy _ [_])
+ go_hs_ty (HsExplicitTupleTy _ _ [_])
= p >= appPrec
go_hs_ty (HsExplicitTupleTy{}) = False
go_hs_ty (HsTyLit{}) = False
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1464,7 +1464,7 @@ repTy t@(HsSpliceTy (HsUntypedSpliceTop _ _) _) = pprPanic "repTy: top level spl
repTy (HsExplicitListTy _ _ tys) = do
tys1 <- repLTys tys
repTPromotedList tys1
-repTy (HsExplicitTupleTy _ tys) = do
+repTy (HsExplicitTupleTy _ _ tys) = do
tys1 <- repLTys tys
tcon <- repPromotedTupleTyCon (length tys)
repTapps tcon tys1
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1952,7 +1952,7 @@ instance ToHie (LocatedA (HsType GhcRn)) where
HsExplicitListTy _ _ tys ->
[ toHie tys
]
- HsExplicitTupleTy _ tys ->
+ HsExplicitTupleTy _ _ tys ->
[ toHie tys
]
HsTyLit _ _ -> []
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2316,7 +2316,7 @@ atype :: { LHsType GhcPs }
: ntgtycon {% amsA' (sL1 $1 (HsTyVar noAnn NotPromoted $1)) } -- Not including unit tuples
-- See Note [%shift: atype -> tyvar]
| tyvar %shift {% amsA' (sL1 $1 (HsTyVar noAnn NotPromoted $1)) } -- (See Note [Unit tuples])
- | '_' %shift { sL1a $1 $ mkAnonWildCardTy }
+ | '_' %shift { sL1a $1 $ mkAnonWildCardTy (epTok $1) }
| '*' {% do { warnStarIsType (getLoc $1)
; return $ sL1a $1 (HsStarTy noExtField (isUnicode $1)) } }
@@ -2342,14 +2342,14 @@ atype :: { LHsType GhcPs }
| '(' ktype ')' {% amsA' (sLL $1 $> $ HsParTy (epTok $1, epTok $3) $2) }
-- see Note [Promotion] for the followings
| SIMPLEQUOTE '(' ')' {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>
- ; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1,epTok $2,epTok $3) []) }}
+ ; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1,epTok $2,epTok $3) IsPromoted []) }}
| SIMPLEQUOTE gen_qcon {% amsA' (sLL $1 $> $ HsTyVar (epTok $1) IsPromoted $2) }
| SIMPLEQUOTE sysdcon_nolist {% do { requireLTPuns PEP_QuoteDisambiguation $1 (reLoc $>)
; amsA' (sLL $1 $> $ HsTyVar (epTok $1) IsPromoted (L (getLoc $2) $ nameRdrName (dataConName (unLoc $2)))) }}
| SIMPLEQUOTE '(' ktype ',' comma_types1 ')'
{% do { requireLTPuns PEP_QuoteDisambiguation $1 $>
; h <- addTrailingCommaA $3 (epTok $4)
- ; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1,epTok $2,epTok $6) (h : $5)) }}
+ ; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1,epTok $2,epTok $6) IsPromoted (h : $5)) }}
| '[' ']' {% withCombinedComments $1 $> (mkListSyntaxTy0 (epTok $1) (epTok $2)) }
| SIMPLEQUOTE '[' comma_types0 ']' {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>
; amsA' (sLL $1 $> $ HsExplicitListTy (epTok $1, epTok $2, epTok $4) IsPromoted $3) }}
@@ -2435,7 +2435,7 @@ tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs }
tyvar_wc :: { Located (HsBndrVar GhcPs) }
: tyvar { sL1 $1 (HsBndrVar noExtField $1) }
- | '_' { sL1 $1 (HsBndrWildCard noExtField) }
+ | '_' { sL1 $1 (HsBndrWildCard (epTok $1)) }
fds :: { Located (EpToken "|",[LHsFunDep GhcPs]) }
: {- empty -} { noLoc (NoEpTok,[]) }
@@ -4704,4 +4704,4 @@ combineHasLocs a b = combineSrcSpans (getHasLoc a) (getHasLoc b)
fromTrailingN :: SrcSpanAnnN -> SrcSpanAnnA
fromTrailingN (EpAnn anc ann cs)
= EpAnn anc (AnnListItem (nann_trailing ann)) cs
-}
\ No newline at end of file
+}
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -980,8 +980,8 @@ checkTyVars pp_what equals_or_where tc tparms
match_bndr_var :: HsType GhcPs -> Maybe (EpToken "'", HsBndrVar GhcPs)
match_bndr_var (HsTyVar ann _ tv) | isRdrTyVar (unLoc tv)
= Just (ann, HsBndrVar noExtField tv)
- match_bndr_var (HsWildCardTy _)
- = Just (noAnn, HsBndrWildCard noExtField)
+ match_bndr_var (HsWildCardTy tok)
+ = Just (noAnn, HsBndrWildCard tok)
match_bndr_var _ = Nothing
-- Return a EpaLocation for use in widenLocatedAnL.
@@ -1159,7 +1159,7 @@ checkContext orig_t@(L (EpAnn l _ cs) _orig_t) =
-- With NoListTuplePuns, contexts are parsed as data constructors, which causes failure
-- downstream.
-- This converts them just like when they are parsed as types in the punned case.
- check (oparens,cparens,cs) (L _l (HsExplicitTupleTy (q,o,c) ts))
+ check (oparens,cparens,cs) (L _l (HsExplicitTupleTy (q,o,c) _ ts))
= punsAllowed >>= \case
True -> unprocessed
False -> do
@@ -3622,7 +3622,7 @@ mkTupleSyntaxTy parOpen args parClose =
enabled =
HsTupleTy annParen HsBoxedOrConstraintTuple args
disabled =
- HsExplicitTupleTy annsKeyword args
+ HsExplicitTupleTy annsKeyword NotPromoted args
annParen = AnnParens parOpen parClose
annsKeyword = (NoEpTok, parOpen, parClose)
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -684,10 +684,10 @@ rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList)
; return (HsExplicitListTy noExtField ip tys', fvs) }
-rnHsTyKi env ty@(HsExplicitTupleTy _ tys)
+rnHsTyKi env ty@(HsExplicitTupleTy _ ip tys)
= do { checkDataKinds env ty
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
- ; return (HsExplicitTupleTy noExtField tys', fvs) }
+ ; return (HsExplicitTupleTy noExtField ip tys', fvs) }
rnHsTyKi env (HsWildCardTy _)
= do { checkAnonWildCard env
@@ -955,9 +955,10 @@ bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside
get_bndr_loc (L l tvb) =
combineSrcSpans
(case hsBndrVar tvb of
- HsBndrWildCard _ ->
- locA l -- this should rather be the location of the wildcard,
- -- but we don't have it
+ HsBndrWildCard tok ->
+ case tok of
+ NoEpTok -> locA l
+ EpTok loc -> locA loc
HsBndrVar _ ln -> getLocA ln)
(case hsBndrKind tvb of
HsBndrNoKind _ -> noSrcSpan
@@ -2083,7 +2084,7 @@ extract_lty (L _ ty) acc
HsSpliceTy {} -> acc -- Type splices mention no tvs
HsDocTy _ ty _ -> extract_lty ty acc
HsExplicitListTy _ _ tys -> extract_ltys tys acc
- HsExplicitTupleTy _ tys -> extract_ltys tys acc
+ HsExplicitTupleTy _ _ tys -> extract_ltys tys acc
HsTyLit _ _ -> acc
HsStarTy _ _ -> acc
HsKindSig _ ty ki -> extract_kind_sig ty ki acc
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -1375,10 +1375,10 @@ rn_ty_pat ty@(HsExplicitListTy _ prom tys) = do
tys' <- mapM rn_lty_pat tys
pure (HsExplicitListTy noExtField prom tys')
-rn_ty_pat ty@(HsExplicitTupleTy _ tys) = do
+rn_ty_pat ty@(HsExplicitTupleTy _ prom tys) = do
check_data_kinds ty
tys' <- mapM rn_lty_pat tys
- pure (HsExplicitTupleTy noExtField tys')
+ pure (HsExplicitTupleTy noExtField prom tys')
rn_ty_pat tyLit@(HsTyLit src t) = do
check_data_kinds tyLit
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -1027,7 +1027,7 @@ expr_to_type earg =
| isBoxed boxity
, Just es <- tupArgsPresent_maybe tup_args
= do { ts <- traverse go es
- ; return (L l (HsExplicitTupleTy noExtField ts)) }
+ ; return (L l (HsExplicitTupleTy noExtField NotPromoted ts)) }
go (L l (ExplicitList _ es)) =
do { ts <- traverse go es
; return (L l (HsExplicitListTy noExtField NotPromoted ts)) }
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1214,7 +1214,7 @@ tcHsType mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind
mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]
mk_nil k = mkTyConApp (promoteDataCon nilDataCon) [k]
-tcHsType mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind
+tcHsType mode rn_ty@(HsExplicitTupleTy _ _ tys) exp_kind
-- using newMetaKindVar means that we force instantiations of any polykinded
-- types. At first, I just used tc_infer_lhs_type, but that led to #11255.
= do { ks <- replicateM arity newMetaKindVar
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -536,7 +536,7 @@ pat_to_type (SplicePat (HsUntypedSpliceTop mod_finalizers pat) splice) = do
pat_to_type (TuplePat _ pats Boxed)
= do { tys <- traverse (pat_to_type . unLoc) pats
- ; let t = noLocA (HsExplicitTupleTy noExtField tys)
+ ; let t = noLocA (HsExplicitTupleTy noExtField NotPromoted tys)
; pure t }
pat_to_type (ListPat _ pats)
= do { tys <- traverse (pat_to_type . unLoc) pats
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -285,7 +285,7 @@ no_anon_wc_ty lty = go lty
HsBangTy _ _ ty -> go ty
HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds
HsExplicitListTy _ _ tys -> gos tys
- HsExplicitTupleTy _ tys -> gos tys
+ HsExplicitTupleTy _ _ tys -> gos tys
HsForAllTy { hst_tele = tele
, hst_body = ty } -> no_anon_wc_tele tele
&& go ty
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1756,7 +1756,7 @@ cvtTypeKind typeOrKind ty
-> mk_apps (HsTyLit noExtField (cvtTyLit lit)) tys'
WildCardT
- -> mk_apps mkAnonWildCardTy tys'
+ -> mk_apps (mkAnonWildCardTy noAnn) tys'
InfixT t1 s t2
-> do { s' <- tconName s
@@ -1805,7 +1805,7 @@ cvtTypeKind typeOrKind ty
PromotedTupleT n
| Just normals <- m_normals
, normals `lengthIs` n -- Saturated
- -> returnLA (HsExplicitTupleTy noAnn normals)
+ -> returnLA (HsExplicitTupleTy noAnn IsPromoted normals)
| otherwise
-> do { tuple_tc <- returnLA $ getRdrName $ tupleDataCon Boxed n
; mk_apps (HsTyVar noAnn IsPromoted tuple_tc) tys' }
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -917,6 +917,7 @@ data HsType pass
| HsExplicitTupleTy -- A promoted explicit tuple
(XExplicitTupleTy pass)
+ PromotionFlag -- whether explicitly promoted, for pretty printer
[LHsType pass]
| HsTyLit (XTyLit pass) (HsTyLit pass) -- A promoted numeric literal.
=====================================
testsuite/tests/parser/should_compile/KindSigs.stderr
=====================================
@@ -1418,6 +1418,7 @@
(EpaSpan { KindSigs.hs:28:17 }))
(EpTok
(EpaSpan { KindSigs.hs:28:44 })))
+ (IsPromoted)
[(L
(EpAnn
(EpaSpan { KindSigs.hs:28:19-39 })
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -886,3 +886,8 @@ Test24159:
Test25132:
$(CHECK_PPR) $(LIBDIR) Test25132.hs
$(CHECK_EXACT) $(LIBDIR) Test25132.hs
+
+.PHONY: Test25454
+Test25454:
+ $(CHECK_PPR) $(LIBDIR) Test25454.hs
+ $(CHECK_EXACT) $(LIBDIR) Test25454.hs
=====================================
testsuite/tests/printer/Test25454.hs
=====================================
@@ -0,0 +1,139 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeAbstractions #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds, NoListTuplePuns #-}
+
+module T23501a where
+
+import Prelude.Experimental (List, Unit)
+import Data.Kind (Type, Constraint)
+
+----------------------------
+-- Class declarations --
+----------------------------
+
+class C1 (_ :: k) _ -- no SAKS
+ where f1 :: k -> Unit
+
+f1' :: C1 @k a b => k -> Unit
+f1' @_ @a @b = f1 @_ @a @b
+
+type C2 :: k1 -> k2 -> Constraint
+class C2 (_ :: k) _ where
+ f2 :: k -> Unit
+
+f2' :: C2 @k1 @k2 a b => k1 -> Unit
+f2' @_ @_ @a @b = f2 @_ @_ @a @b
+
+type C3 :: k1 -> k2 -> Constraint
+class C3 @k @_ _ _ where
+ f3 :: k -> Unit
+
+f3' :: C3 @k1 @k2 a b => k1 -> Unit
+f3' @_ @_ @a @b = f3 @_ @_ @a @b
+
+---------------------------
+-- Data declarations --
+---------------------------
+
+data D1 k (_ :: k) _ -- no SAKS
+ where MkD1 :: k -> D1 k a b
+
+mkD1 :: k -> D1 k a b
+mkD1 = MkD1
+
+type D2 :: forall (k1 :: Type) -> k1 -> k2 -> Type
+data D2 k (_ :: k) _ where
+ MkD2 :: k -> D2 k a b
+
+mkD2 :: k -> D2 k a b
+mkD2 = MkD2
+
+type D3 :: k1 -> k2 -> Type
+data D3 @k @_ _ _ = MkD3 k
+
+data MProxy (_ :: Type) = MPrx
+data CProxy (_ :: k -> Constraint) = CPrx
+
+type Rec :: (k -> Type) -> List k -> Type
+data Rec _ _ where
+ RNil :: Rec f []
+ (:&) :: f x -> Rec f xs -> Rec f (x:xs)
+
+------------------
+-- Newtypes --
+------------------
+
+newtype N1 k (_ :: k) _ -- no SAKS
+ = MkN1 k
+
+mkN1 :: k -> N1 k a b
+mkN1 = MkN1
+
+type N2 :: forall (k1 :: Type) -> k1 -> k2 -> Type
+newtype N2 k (_ :: k) _ = MkN2 k
+
+mkN2 :: k -> N2 k a b
+mkN2 = MkN2
+
+----------------------------
+-- Open type families --
+----------------------------
+
+type family OTF1 (_ :: Type -> Type) _ -- no SAKS
+
+type instance OTF1 f x = f x
+
+otf1 :: OTF1 Maybe Int -> Int
+otf1 Nothing = 0
+otf1 (Just x) = x
+
+type OTF2 :: (Type -> Type) -> Type -> Type
+type family OTF2 (_ :: Type -> Type) _
+
+type instance OTF2 f x = f x
+
+otf2 :: OTF2 Maybe Int -> Int
+otf2 Nothing = 0
+otf2 (Just x) = x
+
+------------------------------
+-- Closed type families --
+------------------------------
+
+type family CTF1 (_ :: Type -> Type) _ -- no SAKS
+ where CTF1 f x = f x
+
+ctf1 :: CTF1 Maybe Int -> Int
+ctf1 Nothing = 0
+ctf1 (Just x) = x
+
+type CTF2 :: (Type -> Type) -> Type -> Type
+type family CTF2 (_ :: Type -> Type) _ where
+ CTF2 f x = f x
+
+ctf2 :: CTF2 Maybe Int -> Int
+ctf2 Nothing = 0
+ctf2 (Just x) = x
+
+type CTF3 :: k1 -> k2 -> Type
+type family CTF3 @_ @k _ _
+ where CTF3 @_ @k _ _ = k
+
+ctf3 :: CTF3 a True -> Bool
+ctf3 = id
+
+-----------------------
+-- Type synonyms --
+-----------------------
+
+type T1 (_ :: Type -> Type) _ = () -- no SAKS
+
+type T2 :: (Type -> Type) -> k -> Type
+type T2 (_ :: Type -> Type) _ = Unit
+
+type T3 :: k1 -> k2 -> Type
+type T3 @_ @k _ _ = k
+
+type FConst _ = ()
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -212,3 +212,5 @@ test('Test24159', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24159'])
test('Test25132', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25132'])
test('T24237', normal, compile_fail, [''])
+
+test('Test25454', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25454'])
\ No newline at end of file
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -3935,9 +3935,9 @@ instance ExactPrint (HsBndrVar GhcPs) where
exact (HsBndrVar x n) = do
n' <- markAnnotated n
return (HsBndrVar x n')
- exact (HsBndrWildCard x) = do
- printStringAdvance "_"
- return (HsBndrWildCard x)
+ exact (HsBndrWildCard t) = do
+ t' <- markEpToken t
+ return (HsBndrWildCard t')
-- ---------------------------------------------------------------------
@@ -4046,12 +4046,14 @@ instance ExactPrint (HsType GhcPs) where
tys' <- markAnnotated tys
c' <- markEpToken c
return (HsExplicitListTy (sq',o',c') prom tys')
- exact (HsExplicitTupleTy (sq, o, c) tys) = do
- sq' <- markEpToken sq
+ exact (HsExplicitTupleTy (sq, o, c) prom tys) = do
+ sq' <- if (isPromoted prom)
+ then markEpToken sq
+ else return sq
o' <- markEpToken o
tys' <- markAnnotated tys
c' <- markEpToken c
- return (HsExplicitTupleTy (sq', o', c') tys')
+ return (HsExplicitTupleTy (sq', o', c') prom tys')
exact (HsTyLit a lit) = do
case lit of
(HsNumTy src v) -> printSourceText src (show v)
=====================================
utils/check-exact/Main.hs
=====================================
@@ -89,7 +89,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_buil
-- "../../testsuite/tests/parser/should_compile/T14189.hs" Nothing
-- "../../testsuite/tests/printer/AnnotationLet.hs" Nothing
- "../../testsuite/tests/printer/AnnotationTuple.hs" Nothing
+ -- "../../testsuite/tests/printer/AnnotationTuple.hs" Nothing
-- "../../testsuite/tests/printer/Ppr001.hs" Nothing
-- "../../testsuite/tests/printer/Ppr002.hs" Nothing
-- "../../testsuite/tests/printer/Ppr002a.hs" Nothing
@@ -216,6 +216,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_buil
-- "../../testsuite/tests/printer/Test22765.hs" Nothing
-- "../../testsuite/tests/printer/Test22771.hs" Nothing
-- "../../testsuite/tests/printer/Test23465.hs" Nothing
+ "../../testsuite/tests/printer/Test25454.hs" Nothing
-- cloneT does not need a test, function can be retired
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
=====================================
@@ -1327,7 +1327,8 @@ ppr_mono_ty (HsRecTy{}) _ = text "{..}"
ppr_mono_ty (XHsType{}) _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
-ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
+ppr_mono_ty (HsExplicitTupleTy _ IsPromoted tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
+ppr_mono_ty (HsExplicitTupleTy _ NotPromoted tys) u = parenList $ map (ppLType u) tys
ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode =
hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode]
ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode =
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
=====================================
@@ -1836,7 +1836,8 @@ ppr_mono_ty (HsRecTy{}) _ _ _ = toHtml "{..}"
ppr_mono_ty (XHsType{}) _ _ _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
-ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty (HsExplicitTupleTy _ IsPromoted tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty (HsExplicitTupleTy _ NotPromoted tys) u q _ = parenList $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode qual _ =
hsep
[ ppr_mono_lty fun_ty unicode qual HideEmptyContexts
=====================================
utils/haddock/haddock-api/src/Haddock/Convert.hs
=====================================
@@ -742,7 +742,7 @@ synifyType _ vs (TyConApp tc tys) =
| Just dc <- isPromotedDataCon_maybe tc
, isTupleDataCon dc
, dataConSourceArity dc == length vis_tys =
- noLocA $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys)
+ noLocA $ HsExplicitTupleTy noExtField IsPromoted (map (synifyType WithinType vs) vis_tys)
-- ditto for lists
| getName tc == listTyConName
, [ty] <- vis_tys =
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -417,7 +417,7 @@ reparenTypePrec = go
go _ (HsRecTy x flds) = HsRecTy x (map (mapXRec @a reparenConDeclField) flds)
go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d
go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)
- go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)
+ go _ (HsExplicitTupleTy x p tys) = HsExplicitTupleTy x p (map reparenLType tys)
go p (HsKindSig x ty kind) =
paren p PREC_SIG $ HsKindSig x (goL PREC_SIG ty) (goL PREC_SIG kind)
go p (HsIParamTy x n ty) =
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -408,12 +408,12 @@ renameType t = case t of
HsExplicitListTy _ a b -> HsExplicitListTy noAnn a <$> mapM renameLType b
-- Special-case unary boxed tuples so that they are pretty-printed as
-- `'MkSolo x`, not `'(x)`
- HsExplicitTupleTy _ [ty] -> do
+ HsExplicitTupleTy _ ip [ty] -> do
name <- renameName (tupleDataConName Boxed 1)
- let lhs = noLocA $ HsTyVar noAnn IsPromoted (noLocA name)
+ let lhs = noLocA $ HsTyVar noAnn ip (noLocA name)
rhs <- renameLType ty
return (HsAppTy noAnn lhs rhs)
- HsExplicitTupleTy _ b -> HsExplicitTupleTy noAnn <$> mapM renameLType b
+ HsExplicitTupleTy _ ip b -> HsExplicitTupleTy noAnn ip <$> mapM renameLType b
HsSpliceTy (HsUntypedSpliceTop _ st) _ -> renameType (unLoc st)
HsSpliceTy (HsUntypedSpliceNested _) _ -> error "renameType: not an top level type splice"
HsWildCardTy _ -> pure (HsWildCardTy noAnn)
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
=====================================
@@ -116,8 +116,8 @@ renameType t@(HsRecTy _ _) = pure t
renameType t@(XHsType _) = pure t
renameType (HsExplicitListTy x ip ltys) =
HsExplicitListTy x ip <$> renameLTypes ltys
-renameType (HsExplicitTupleTy x ltys) =
- HsExplicitTupleTy x <$> renameLTypes ltys
+renameType (HsExplicitTupleTy x ip ltys) =
+ HsExplicitTupleTy x ip <$> renameLTypes ltys
renameType t@(HsTyLit _ _) = pure t
renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ad9ac63abed33aa48d4df40142d2809bdfd1ff0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ad9ac63abed33aa48d4df40142d2809bdfd1ff0
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241112/86c2bb85/attachment-0001.html>
More information about the ghc-commits
mailing list