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.