28 Apr
2026
28 Apr
'26
5:30 p.m.
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
df691563 by Vladislav Zavialov at 2026-04-28T13:23:29-04:00
Refactor HsWildCardTy to use HoleKind (#27111)
The payload of this patch is that the extension fields of HsWildCardTy
and HsHole now match:
type instance XWildCardTy Ghc{Ps,Rn} = HoleKind
type instance XHole Ghc{Ps,Rn} = HoleKind
This is progress towards unification of HsExpr and HsType.
Test case: T25121_status
In addition to that, exact-printing of infix holes is fixed.
Test case: PprInfixHole
- - - - -
19 changed files:
- + changelog.d/ghc-api-holes-ast-27111
- compiler/GHC/Hs/Expr.hs-boot
- compiler/GHC/Hs/Type.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/ThToHs.hs
- testsuite/tests/ghc-api/T25121_status.stdout
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/PprInfixHole.hs
- testsuite/tests/printer/all.T
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
Changes:
=====================================
changelog.d/ghc-api-holes-ast-27111
=====================================
@@ -0,0 +1,10 @@
+section: ghc-lib
+synopsis: Refactor ``HsWildCardTy`` to use ``HoleKind``
+issues: #27111
+mrs: !15817
+
+description: {
+Refactor the AST to store ``HoleKind`` not only in ``XHole``, but also in
+``XWildCardTy`` and ``XBndrWildCard``. This provides more information for exact
+printing of infix holes.
+}
=====================================
compiler/GHC/Hs/Expr.hs-boot
=====================================
@@ -54,3 +54,5 @@ data HsUntypedSpliceResult thing
type HsMatchContextRn = HsMatchContext (LIdP GhcRn)
type HsStmtContextRn = HsStmtContext (LIdP GhcRn)
+
+data HoleKind
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -55,7 +55,7 @@ module GHC.Hs.Type (
OpName(..),
- mkAnonWildCardTy, pprAnonWildCard,
+ pprAnonWildCard,
hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit,
mkHsOuterImplicit, mkHsOuterExplicit,
@@ -93,7 +93,7 @@ import GHC.Prelude
import Language.Haskell.Syntax.Type
-import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) )
+import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..), HoleKind )
import Language.Haskell.Syntax.Extension
import GHC.Core.DataCon ( SrcStrictness(..), SrcUnpackedness(..)
@@ -342,8 +342,8 @@ type instance XXBndrKind (GhcPass p) = DataConCantHappen
type instance XBndrVar (GhcPass p) = NoExtField
-type instance XBndrWildCard GhcPs = EpToken "_"
-type instance XBndrWildCard GhcRn = NoExtField
+type instance XBndrWildCard GhcPs = HoleKind
+type instance XBndrWildCard GhcRn = HoleKind
type instance XBndrWildCard GhcTc = NoExtField
type instance XXBndrVar (GhcPass p) = DataConCantHappen
@@ -476,8 +476,8 @@ type instance XExplicitTupleTy GhcTc = [Kind]
type instance XTyLit (GhcPass _) = NoExtField
-type instance XWildCardTy GhcPs = EpToken "_"
-type instance XWildCardTy GhcRn = NoExtField
+type instance XWildCardTy GhcPs = HoleKind
+type instance XWildCardTy GhcRn = HoleKind
type instance XWildCardTy GhcTc = NoExtField
type instance XXType GhcPs = HsTypeGhcPsExt
@@ -661,9 +661,6 @@ ignoreParens ty = ty
************************************************************************
-}
-mkAnonWildCardTy :: EpToken "_" -> HsType GhcPs
-mkAnonWildCardTy tok = HsWildCardTy tok
-
mkHsOpTy :: (Anno (IdOccGhcP p) ~ EpAnn a)
=> PromotionFlag
-> LHsType (GhcPass p) -> LIdOccP (GhcPass p)
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2366,13 +2366,13 @@ tyop :: { LHsType GhcPs }
| tyvarop { sL1a $1 (HsTyVar noAnn NotPromoted $1) }
| SIMPLEQUOTE qconop { sLLa $1 $> (HsTyVar (epTok $1) IsPromoted $2) }
| SIMPLEQUOTE varop { sLLa $1 $> (HsTyVar (epTok $1) IsPromoted $2) }
- | '`' '_' '`' { sLLa $1 $> (mkAnonWildCardTy (epTok $2)) } -- TODO: reuse hole_op (blocked on #27111)
+ | hole_op { sLLa $1 $> (HsWildCardTy (HoleVar $1)) }
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 (epTok $1) }
+ | '_' %shift { sL1a $1 $ HsWildCardTy (HoleVar (sL1a $1 unnamedHoleRdrName)) }
| '*' {% do { warnStarIsType (getLoc $1)
; return $ sL1a $1 (HsStarTy (epUniTok $1)) } }
@@ -2486,7 +2486,7 @@ tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs }
tyvar_wc :: { Located (HsBndrVar GhcPs) }
: tyvar { sL1 $1 (HsBndrVar noExtField $1) }
- | '_' { sL1 $1 (HsBndrWildCard (epTok $1)) }
+ | '_' { sL1 $1 (HsBndrWildCard (HoleVar (sL1a $1 unnamedHoleRdrName))) }
fds :: { Located (EpToken "|",[LHsFunDep GhcPs]) }
: {- empty -} { noLoc (NoEpTok,[]) }
@@ -4021,7 +4021,7 @@ qopm :: { forall b. DisambInfixOp b => PV (LocatedN b) } -- used in section
| hole_op { mkHsInfixHolePV $1 }
hole_op :: { LocatedN RdrName } -- used in sections
-hole_op : '`' '_' '`' {% amsr (sLL $1 $> (mkUnqual varName (fsLit "_")))
+hole_op : '`' '_' '`' {% amsr (sLL $1 $> unnamedHoleRdrName)
(NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }
qvarop :: { LocatedN RdrName }
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -2072,7 +2072,7 @@ instance DisambECP (HsExpr GhcPs) where
mkHsQualLitPV (L (EpAnn l an csIn) a) = do
!cs <- getCommentsFor (locA l)
return $ L (EpAnn l an (cs Semi.<> csIn)) (HsQualLit noExtField a)
- mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (HsHole (HoleVar (L (noAnnSrcSpan l) (mkUnqual varName (fsLit "_")))))
+ mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (HsHole (HoleVar (L (noAnnSrcSpan l) unnamedHoleRdrName)))
mkHsTySigPV l@(EpAnn anc an csIn) a sig anns = do
!cs <- getCommentsFor (locA l)
return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExprWithTySig anns a (hsTypeToHsSigWcType sig))
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -235,10 +235,10 @@ rnWcBodyTyKi level ctxt nwc_rdrs hs_ty
rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt
, hst_body = hs_ty })
| Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
- , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last
+ , L lx (HsWildCardTy h) <- ignoreParens hs_ctxt_last
= do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
; setSrcSpanA lx $ checkExtraConstraintWildCard env hs_ctxt1
- ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)]
+ ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy h)]
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
; return (HsQualTy { hst_xqual = noExtField
, hst_ctxt = L cx hs_ctxt'
@@ -732,7 +732,7 @@ rnHsTyKi env ty@(XHsType (HsRecTy {})) = do
addErr $
TcRnWithHsDocContext (rtke_ctxt env) $
TcRnIllegalRecordSyntax ty
- return (HsWildCardTy noExtField, emptyFNs) -- trick to avoid `failWithTc`
+ return (HsWildCardTy GHC.Hs.HoleError, emptyFNs) -- trick to avoid `failWithTc`
rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
= do { checkDataKinds env ty
@@ -746,9 +746,9 @@ rnHsTyKi env ty@(HsExplicitTupleTy _ ip tys)
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
; return (HsExplicitTupleTy noExtField ip tys', fvs) }
-rnHsTyKi env (HsWildCardTy _)
+rnHsTyKi env (HsWildCardTy h)
= do { checkAnonWildCard env
- ; return (HsWildCardTy noExtField, emptyFNs) }
+ ; return (HsWildCardTy h, emptyFNs) }
{-
Note [Strict level checks with ExplicitLevelImports]
@@ -1039,10 +1039,10 @@ bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside
get_bndr_loc (L l tvb) =
combineSrcSpans
(case hsBndrVar tvb of
- HsBndrWildCard tok ->
- case tok of
- NoEpTok -> locA l
- EpTok loc -> locA loc
+ HsBndrWildCard hole ->
+ case hole of
+ GHC.Hs.HoleError -> locA l
+ HoleVar (L loc _) -> locA loc
HsBndrVar _ ln -> getLocA ln)
(case hsBndrKind tvb of
HsBndrNoKind _ -> noSrcSpan
@@ -1310,8 +1310,8 @@ bindHsBndrVar mb_assoc (HsBndrVar _ lrdr@(L lv _)) thing_inside
= do { tv_nm <- newTyVarNameRn mb_assoc lrdr
; bindLocalNamesFV [tv_nm] $
thing_inside (HsBndrVar noExtField (L lv tv_nm)) }
-bindHsBndrVar _ (HsBndrWildCard _) thing_inside
- = thing_inside (HsBndrWildCard noExtField)
+bindHsBndrVar _ (HsBndrWildCard h) thing_inside
+ = thing_inside (HsBndrWildCard h)
rnHsBndrKind :: HsDocContext -> HsBndrKind GhcPs -> RnM (HsBndrKind GhcRn, FreeNames)
rnHsBndrKind _ (HsBndrNoKind _) = return (HsBndrNoKind noExtField, emptyFNs)
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -1430,8 +1430,8 @@ rn_ty_pat tyLit@(HsTyLit src lit) = do
check_data_kinds tyLit
pure (HsTyLit src (convertLit lit))
-rn_ty_pat (HsWildCardTy _) =
- pure (HsWildCardTy noExtField)
+rn_ty_pat (HsWildCardTy h) =
+ pure (HsWildCardTy h)
rn_ty_pat (HsKindSig an ty ki) = do
ctxt <- askDocContext
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -1234,8 +1234,8 @@ expr_to_type earg =
; return (L l (HsSpliceTy splice_result' splice)) }
go (L l (HsStar x))
= return (L l (HsStarTy x))
- go (L l (HsHole (HoleVar (L _ rdr))))
- | isUnderscore occ = return (L l (HsWildCardTy noExtField))
+ go (L l (HsHole h@(HoleVar (L _ rdr))))
+ | isUnderscore occ = return (L l (HsWildCardTy h))
| startsWithUnderscore occ =
-- See Note [Wildcards in the T2T translation]
do { wildcards_enabled <- xoptM LangExt.NamedWildCards
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -4772,8 +4772,8 @@ tyPatToBndr HsTP{hstp_body = (L _ hs_ty)} = go hs_ty where
go_bvar (HsTyVar _ _ tv)
| isTyVarName (getName tv)
= Just (HsBndrVar noExtField (fmap getName tv))
- go_bvar (HsWildCardTy _)
- = Just (HsBndrWildCard noExtField)
+ go_bvar (HsWildCardTy h)
+ = Just (HsBndrWildCard h)
go_bvar _ = Nothing
{- Note [Type patterns: binders and unifiers]
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -515,7 +515,7 @@ pat_to_type (VarPat _ lname) =
; return b }
where b = noLocA (HsTyVar noAnn NotPromoted $ fmap noUserRdr lname)
pat_to_type (WildPat _) = return b
- where b = noLocA (HsWildCardTy noExtField)
+ where b = noLocA (HsWildCardTy (HoleVar (noLocA unnamedHoleRdrName)))
pat_to_type (SigPat _ pat sig_ty)
= do { t <- pat_to_type (unLoc pat)
; let { !(HsPS x_hsps k) = sig_ty
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1798,7 +1798,8 @@ cvtTypeKind typeOrKind ty
-> mk_apps (HsTyLit noExtField (cvtTyLit lit)) tys'
WildCardT
- -> mk_apps (mkAnonWildCardTy noAnn) tys'
+ -> do { n' <- wrapLN (return unnamedHoleRdrName)
+ ; mk_apps (HsWildCardTy (HoleVar n')) tys' }
InfixT t1 s t2
-> do { s' <- tconName s
=====================================
testsuite/tests/ghc-api/T25121_status.stdout
=====================================
@@ -20,9 +20,7 @@ X(ExplicitList) mismatch
X(ExplicitTuple) mismatch
>>> ((EpaLocation' [GenLocated (EpaLocation' NoComments) EpaComment]),(EpaLocation' [GenLocated (EpaLocation' NoComments) EpaComment]))
<<< ((EpToken "'"),(EpToken "("),(EpToken ")"))
-X(Hole) mismatch
- >>> HoleKind
- <<< EpToken "_"
+X(Hole) match = HoleKind
Extension fields @GhcRn
-----------------------
@@ -50,9 +48,7 @@ X(UntypedSplice) mismatch
<<< HsUntypedSpliceResult (GenLocated (EpAnn AnnListItem) (HsType (GhcPass 'Renamed)))
X(ExplicitList) match = NoExtField
X(ExplicitTuple) match = NoExtField
-X(Hole) mismatch
- >>> HoleKind
- <<< NoExtField
+X(Hole) match = HoleKind
Extension fields @GhcTc
-----------------------
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -832,6 +832,11 @@ PprLetIn:
$(CHECK_PPR) $(LIBDIR) PprLetIn.hs
$(CHECK_EXACT) $(LIBDIR) PprLetIn.hs
+.PHONY: PprInfixHole
+PprInfixHole:
+ $(CHECK_PPR) $(LIBDIR) PprInfixHole.hs
+ $(CHECK_EXACT) $(LIBDIR) PprInfixHole.hs
+
.PHONY: CaseAltComments
CaseAltComments:
$(CHECK_PPR) $(LIBDIR) CaseAltComments.hs
=====================================
testsuite/tests/printer/PprInfixHole.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+module PprInfixHole where
+
+f1 a b = a `_` b
+f2 a b = a ` _ ` b
+
+t1 :: Int `_` Bool
+t2 :: Int ` _ ` Bool
+t1 = Left 0
+t2 = Left 0
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -199,6 +199,7 @@ test('ListTuplePuns', extra_files(['ListTuplePuns.hs']), ghci_script, ['ListTupl
test('AnnotationNoListTuplePuns', [ignore_stderr, req_ppr_deps], makefile_test, ['AnnotationNoListTuplePuns'])
test('Test24533', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24533'])
test('PprLetIn', [ignore_stderr, req_ppr_deps], makefile_test, ['PprLetIn'])
+test('PprInfixHole', [ignore_stderr, req_ppr_deps], makefile_test, ['PprInfixHole'])
test('CaseAltComments', [ignore_stderr, req_ppr_deps], makefile_test, ['CaseAltComments'])
test('MatchPatComments', [ignore_stderr, req_ppr_deps], makefile_test, ['MatchPatComments'])
test('Test24748', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24748'])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2844,6 +2844,14 @@ instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where
-- ---------------------------------------------------------------------
+exactHole :: (Monad m, Monoid w) => HoleKind -> EP w m HoleKind
+exactHole (HoleVar n) = do
+ n' <- markAnnotated n
+ return (HoleVar n')
+exactHole HoleError =
+ -- TODO: Adapt 'HoleError' to include the 'SourceText':
+ error "Cannot exact print HoleError"
+
instance ExactPrint (HsExpr GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _s = a
@@ -2856,14 +2864,9 @@ instance ExactPrint (HsExpr GhcPs) where
then markAnnotated n
else return n
return (HsVar x n')
- exact (HsHole (HoleVar n)) = do
- let pun_RDR = "pun-right-hand-side"
- n' <- if (showPprUnsafe n /= pun_RDR)
- then markAnnotated n
- else return n
- return (HsHole (HoleVar n'))
- -- TODO: Adapt 'HoleError' to include the 'SourceText':
- exact (HsHole HoleError) = error "Cannot exact print HoleError"
+ exact (HsHole h) = do
+ h' <- exactHole h
+ return (HsHole h')
exact x@(HsOverLabel src l) = do
printStringAdvanceA "#" >> return ()
case src of
@@ -3927,9 +3930,9 @@ instance ExactPrint (HsBndrVar GhcPs) where
exact (HsBndrVar x n) = do
n' <- markAnnotated n
return (HsBndrVar x n')
- exact (HsBndrWildCard t) = do
- t' <- markEpToken t
- return (HsBndrWildCard t')
+ exact (HsBndrWildCard h) = do
+ h' <- exactHole h
+ return (HsBndrWildCard h')
-- ---------------------------------------------------------------------
@@ -4034,7 +4037,9 @@ instance ExactPrint (HsType GhcPs) where
exact (HsTyLit an lit) = do
lit' <- withPpr lit
return (HsTyLit an lit')
- exact t@(HsWildCardTy _) = printStringAdvance "_" >> return t
+ exact (HsWildCardTy h) = do
+ h' <- exactHole h
+ return (HsWildCardTy h')
exact x = error $ "missing match for HsType:" ++ showAst x
-- ---------------------------------------------------------------------
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
=====================================
@@ -320,7 +320,7 @@ ppCtor sDocContext dat subdocs con@ConDeclH98{con_args = con_args'} =
tv, tvk :: HsType GhcRn
tv = case bvar of
HsBndrVar _ n -> HsTyVar noAnn NotPromoted (fmap noUserRdr n)
- HsBndrWildCard _ -> HsWildCardTy noExtField
+ HsBndrWildCard h -> HsWildCardTy h
tvk = case bkind of
HsBndrNoKind _ -> tv
HsBndrKind _ lty -> HsKindSig noAnn (reL tv) lty
=====================================
utils/haddock/haddock-api/src/Haddock/Convert.hs
=====================================
@@ -122,7 +122,7 @@ tyThingToLHsDecl prr t = case t of
cvt' :: HsBndrVar GhcRn -> HsType GhcRn
cvt' (HsBndrVar _ nm) = HsTyVar noAnn NotPromoted (fmap noUserRdr nm)
- cvt' (HsBndrWildCard _) = HsWildCardTy noExtField
+ cvt' (HsBndrWildCard h) = HsWildCardTy h
-- \| Convert a LHsTyVarBndr to an equivalent LHsType.
hsLTyVarBndrToType :: LHsTyVarBndr flag GhcRn -> LHsType GhcRn
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -326,10 +326,10 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]
lHsQTyVarsToTypes tvs =
- [ HsValArg noExtField $ noLocA (case hsLTyVarName tv of
- Nothing -> HsWildCardTy noExtField
- Just nm -> HsTyVar noAnn NotPromoted (noLocA $ noUserRdr nm))
- | tv <- hsq_explicit tvs
+ [ HsValArg noExtField $ noLocA (case hsBndrVar (unLoc tvb) of
+ HsBndrVar _ nm -> HsTyVar noAnn NotPromoted (fmap noUserRdr nm)
+ HsBndrWildCard h -> HsWildCardTy h)
+ | tvb <- hsq_explicit tvs
]
hsQTvExplicitBinders :: LHsQTyVars DocNameI -> [LHsTyVarBndr (HsBndrVis DocNameI) DocNameI]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df6915631ddf6fb881b8a2e5ccefb4128f243f64
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df6915631ddf6fb881b8a2e5ccefb4128f243f64
You're receiving this email because of your account on gitlab.haskell.org.