Vladislav Zavialov pushed to branch wip/int-index/unify-status at Glasgow Haskell Compiler / GHC Commits: 13fdff31 by Vladislav Zavialov at 2026-03-28T01:44:57+03:00 Status check for the HsType~HsExpr refactoring (#25121) Add a test case to track the status of a refactoring project within GHC whose goal is to arrive at the following declaration: type HsType = HsExpr The rationale for this is to increase code reuse between the term- and type-level code in the compiler front-end (AST, parser, renamer, type checker). The status report is saved to testsuite/tests/ghc-api/T25121_status.stdout and provides useful insights into what needs to happen to make progress on the ticket. - - - - - 3 changed files: - + testsuite/tests/ghc-api/T25121_status.hs - + testsuite/tests/ghc-api/T25121_status.stdout - testsuite/tests/ghc-api/all.T Changes: ===================================== testsuite/tests/ghc-api/T25121_status.hs ===================================== @@ -0,0 +1,127 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RequiredTypeArguments #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE UndecidableInstances #-} + +module Main where + +import Type.Reflection +import GHC.Hs + +main :: IO () +main = do + checkAllExtFields + checkAllDirectFields + +checkAllExtFields :: IO () +checkAllExtFields = do + -- No corresponding HsExpr: HsListTy HsTupleTy HsSumTy HsIParamTy HsDocTy + + putStrLn "Extension fields @GhcPs\n-----------------------" + checkExtField "Var" (HsVar @GhcPs) (HsTyVar @GhcPs) + checkExtField "LitE" (HsLit @GhcPs) (HsTyLit @GhcPs) + checkExtField "Par" (HsPar @GhcPs) (HsParTy @GhcPs) + checkExtField "App" (HsApp @GhcPs) (HsAppTy @GhcPs) + checkExtField "AppTypeE" (HsAppType @GhcPs) (HsAppKindTy @GhcPs) + checkExtField "OpApp" (OpApp @GhcPs) (HsOpTy @GhcPs) + checkExtField "ForAll" (HsForAll @GhcPs) (HsForAllTy @GhcPs) + checkExtField "Qual" (HsQual @GhcPs) (HsQualTy @GhcPs) + checkExtField "Star" (HsStar @GhcPs) (HsStarTy @GhcPs) + checkExtField "FunArr" (HsFunArr @GhcPs) (HsFunTy @GhcPs) + checkExtField "ExprWithTySig" (ExprWithTySig @GhcPs) (HsKindSig @GhcPs) + checkExtField "UntypedSplice" (HsUntypedSplice @GhcPs) (HsSpliceTy @GhcPs) + checkExtField "ExplicitList" (ExplicitList @GhcPs) (HsExplicitListTy @GhcPs) + checkExtField "ExplicitTuple" (ExplicitTuple @GhcPs) (HsExplicitTupleTy @GhcPs) + checkExtField "Hole" (HsHole @GhcPs) (HsWildCardTy @GhcPs) + + putStrLn "\nExtension fields @GhcRn\n-----------------------" + checkExtField "Var" (HsVar @GhcRn) (HsTyVar @GhcRn) + checkExtField "LitE" (HsLit @GhcRn) (HsTyLit @GhcRn) + checkExtField "Par" (HsPar @GhcRn) (HsParTy @GhcRn) + checkExtField "App" (HsApp @GhcRn) (HsAppTy @GhcRn) + checkExtField "AppTypeE" (HsAppType @GhcRn) (HsAppKindTy @GhcRn) + checkExtField "OpApp" (OpApp @GhcRn) (HsOpTy @GhcRn) + checkExtField "ForAll" (HsForAll @GhcRn) (HsForAllTy @GhcRn) + checkExtField "Qual" (HsQual @GhcRn) (HsQualTy @GhcRn) + checkExtField "Star" (HsStar @GhcRn) (HsStarTy @GhcRn) + checkExtField "FunArr" (HsFunArr @GhcRn) (HsFunTy @GhcRn) + checkExtField "ExprWithTySig" (ExprWithTySig @GhcRn) (HsKindSig @GhcRn) + checkExtField "UntypedSplice" (HsUntypedSplice @GhcRn) (HsSpliceTy @GhcRn) + checkExtField "ExplicitList" (ExplicitList @GhcRn) (HsExplicitListTy @GhcRn) + checkExtField "ExplicitTuple" (ExplicitTuple @GhcRn) (HsExplicitTupleTy @GhcRn) + checkExtField "Hole" (HsHole @GhcRn) (HsWildCardTy @GhcRn) + + putStrLn "\nExtension fields @GhcTc\n-----------------------" + checkExtField "Var" (HsVar @GhcTc) (HsTyVar @GhcTc) + checkExtField "LitE" (HsLit @GhcTc) (HsTyLit @GhcTc) + checkExtField "Par" (HsPar @GhcTc) (HsParTy @GhcTc) + checkExtField "App" (HsApp @GhcTc) (HsAppTy @GhcTc) + checkExtField "AppTypeE" (HsAppType @GhcTc) (HsAppKindTy @GhcTc) + checkExtField "OpApp" (OpApp @GhcTc) (HsOpTy @GhcTc) + checkExtField "ForAll" (HsForAll @GhcTc) (HsForAllTy @GhcTc) + checkExtField "Qual" (HsQual @GhcTc) (HsQualTy @GhcTc) + checkExtField "Star" (HsStar @GhcTc) (HsStarTy @GhcTc) + checkExtField "FunArr" (HsFunArr @GhcTc) (HsFunTy @GhcTc) + checkExtField "ExprWithTySig" (ExprWithTySig @GhcTc) (HsKindSig @GhcTc) + checkExtField "UntypedSplice" (HsUntypedSplice @GhcTc) (HsSpliceTy @GhcTc) + checkExtField "ExplicitList" (ExplicitList @GhcTc) (HsExplicitListTy @GhcTc) + checkExtField "ExplicitTuple" (ExplicitTuple @GhcTc) (HsExplicitTupleTy @GhcTc) + checkExtField "Hole" (HsHole @GhcTc) (HsWildCardTy @GhcTc) + +checkAllDirectFields :: IO () +checkAllDirectFields = do + -- No corresponding HsExpr: HsListTy HsTupleTy HsSumTy HsIParamTy HsDocTy + putStrLn "\nDirect fields\n-------------" + checkDirectFields "Var" (HsVar @GhcPs) (HsTyVar @GhcPs) + checkDirectFields "LitE" (HsLit @GhcPs) (HsTyLit @GhcPs) + checkDirectFields "Par" (HsPar @GhcPs) (HsParTy @GhcPs) + checkDirectFields "App" (HsApp @GhcPs) (HsAppTy @GhcPs) + checkDirectFields "AppTypeE" (HsAppType @GhcPs) (HsAppKindTy @GhcPs) + checkDirectFields "OpApp" (OpApp @GhcPs) (HsOpTy @GhcPs) + checkDirectFields "ForAll" (HsForAll @GhcPs) (HsForAllTy @GhcPs) + checkDirectFields "Qual" (HsQual @GhcPs) (HsQualTy @GhcPs) + checkDirectFields "Star" (HsStar @GhcPs) (HsStarTy @GhcPs) + checkDirectFields "FunArr" (HsFunArr @GhcPs) (HsFunTy @GhcPs) + checkDirectFields "ExprWithTySig" (ExprWithTySig @GhcPs) (HsKindSig @GhcPs) + checkDirectFields "UntypedSplice" (HsUntypedSplice @GhcPs) (HsSpliceTy @GhcPs) + checkDirectFields "ExplicitList" (ExplicitList @GhcPs) (HsExplicitListTy @GhcPs) + checkDirectFields "ExplicitTuple" (ExplicitTuple @GhcPs) (HsExplicitTupleTy @GhcPs) + checkDirectFields "Hole" (HsHole @GhcPs) (HsWildCardTy @GhcPs) + +data P -- placeholder for the pass + +type Replace :: k -> k +type family Replace t where + Replace (GhcPass _) = P + Replace HsType = HsExpr + Replace (f a) = Replace f (Replace a) + Replace t = t + +checkDirectFields :: forall r1 r2. String -> + forall x1 x2. forall (con1 :: x1 -> r1) (con2 :: x2 -> r2) -> + (Typeable (Replace r1), Typeable (Replace r2)) => IO () +checkDirectFields @r1 @r2 ctx _ _ = + let aRep = typeRep @(Replace r1) + bRep = typeRep @(Replace r2) + in case eqTypeRep aRep bRep of + Nothing -> do + putStrLn $ "T(" ++ ctx ++ ") mismatch" + putStrLn $ " >>> " ++ show aRep + putStrLn $ " <<< " ++ show bRep + Just HRefl -> do + putStrLn $ "T(" ++ ctx ++ ") match = " ++ show aRep + +checkExtField :: forall x1 x2. String -> + forall r1 r2. forall (con1 :: x1 -> r1) (con2 :: x2 -> r2) -> + (Typeable x1, Typeable x2) => IO () +checkExtField @x1 @x2 ctx _ _ = + let aRep = typeRep @x1 + bRep = typeRep @x2 + in case eqTypeRep aRep bRep of + Nothing -> do + putStrLn $ "X(" ++ ctx ++ ") mismatch" + putStrLn $ " >>> " ++ show aRep + putStrLn $ " <<< " ++ show bRep + Just HRefl -> do + putStrLn $ "X(" ++ ctx ++ ") match = " ++ show aRep ===================================== testsuite/tests/ghc-api/T25121_status.stdout ===================================== @@ -0,0 +1,125 @@ +Extension fields @GhcPs +----------------------- +X(Var) mismatch + >>> NoExtField + <<< EpToken "'" +X(LitE) match = NoExtField +X(Par) match = ((EpToken "("),(EpToken ")")) +X(App) match = NoExtField +X(AppTypeE) match = EpToken "@" +X(OpApp) match = NoExtField +X(ForAll) match = NoExtField +X(Qual) match = NoExtField +X(Star) match = EpUniToken "*" "\9733" +X(FunArr) match = NoExtField +X(ExprWithTySig) match = EpUniToken "::" "\8759" +X(UntypedSplice) match = NoExtField +X(ExplicitList) mismatch + >>> AnnList () + <<< ((EpToken "'"),(EpToken "["),(EpToken "]")) +X(ExplicitTuple) mismatch + >>> ((EpaLocation' [GenLocated (EpaLocation' NoComments) EpaComment]),(EpaLocation' [GenLocated (EpaLocation' NoComments) EpaComment])) + <<< ((EpToken "'"),(EpToken "("),(EpToken ")")) +X(Hole) mismatch + >>> HoleKind + <<< EpToken "_" + +Extension fields @GhcRn +----------------------- +X(Var) mismatch + >>> NoExtField + <<< EpToken "'" +X(LitE) match = NoExtField +X(Par) mismatch + >>> NoExtField + <<< ((EpToken "("),(EpToken ")")) +X(App) match = NoExtField +X(AppTypeE) match = NoExtField +X(OpApp) mismatch + >>> Fixity + <<< NoExtField +X(ForAll) match = NoExtField +X(Qual) match = NoExtField +X(Star) match = EpUniToken "*" "\9733" +X(FunArr) match = NoExtField +X(ExprWithTySig) mismatch + >>> NoExtField + <<< EpUniToken "::" "\8759" +X(UntypedSplice) mismatch + >>> HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed)) + <<< HsUntypedSpliceResult (GenLocated (EpAnn AnnListItem) (HsType (GhcPass 'Renamed))) +X(ExplicitList) match = NoExtField +X(ExplicitTuple) match = NoExtField +X(Hole) mismatch + >>> HoleKind + <<< NoExtField + +Extension fields @GhcTc +----------------------- +X(Var) mismatch + >>> NoExtField + <<< EpToken "'" +X(LitE) match = NoExtField +X(Par) mismatch + >>> NoExtField + <<< ((EpToken "("),(EpToken ")")) +X(App) match = NoExtField +X(AppTypeE) mismatch + >>> Type + <<< NoExtField +X(OpApp) mismatch + >>> DataConCantHappen + <<< NoExtField +X(ForAll) mismatch + >>> DataConCantHappen + <<< NoExtField +X(Qual) mismatch + >>> DataConCantHappen + <<< NoExtField +X(Star) mismatch + >>> DataConCantHappen + <<< EpUniToken "*" "\9733" +X(FunArr) mismatch + >>> DataConCantHappen + <<< NoExtField +X(ExprWithTySig) mismatch + >>> NoExtField + <<< EpUniToken "::" "\8759" +X(UntypedSplice) mismatch + >>> DataConCantHappen + <<< Type +X(ExplicitList) match = Type +X(ExplicitTuple) mismatch + >>> NoExtField + <<< [Type] +X(Hole) mismatch + >>> (HoleKind,HoleExprRef) + <<< NoExtField + +Direct fields +------------- +T(Var) mismatch + >>> GenLocated (EpAnn NameAnn) RdrName -> HsExpr P + <<< PromotionFlag -> GenLocated (EpAnn NameAnn) RdrName -> HsExpr P +T(LitE) match = HsLit P -> HsExpr P +T(Par) match = GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P +T(App) match = GenLocated (EpAnn AnnListItem) (HsExpr P) -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P +T(AppTypeE) mismatch + >>> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsWildCardBndrs P (GenLocated (EpAnn AnnListItem) (HsExpr P)) -> HsExpr P + <<< GenLocated (EpAnn AnnListItem) (HsExpr P) -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P +T(OpApp) match = GenLocated (EpAnn AnnListItem) (HsExpr P) -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P +T(ForAll) match = HsForAllTelescope P -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P +T(Qual) match = GenLocated (EpAnn AnnContext) [GenLocated (EpAnn AnnListItem) (HsExpr P)] -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P +T(Star) match = HsExpr P +T(FunArr) match = HsMultAnnOf (GenLocated (EpAnn AnnListItem) (HsExpr P)) P -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P +T(ExprWithTySig) mismatch + >>> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsWildCardBndrs P (GenLocated (EpAnn AnnListItem) (HsSigType P)) -> HsExpr P + <<< GenLocated (EpAnn AnnListItem) (HsExpr P) -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P +T(UntypedSplice) match = HsUntypedSplice P -> HsExpr P +T(ExplicitList) mismatch + >>> [GenLocated (EpAnn AnnListItem) (HsExpr P)] -> HsExpr P + <<< PromotionFlag -> [GenLocated (EpAnn AnnListItem) (HsExpr P)] -> HsExpr P +T(ExplicitTuple) mismatch + >>> [HsTupArg P] -> Boxity -> HsExpr P + <<< PromotionFlag -> [GenLocated (EpAnn AnnListItem) (HsExpr P)] -> HsExpr P +T(Hole) match = HsExpr P ===================================== testsuite/tests/ghc-api/all.T ===================================== @@ -79,3 +79,5 @@ test('T26910', [ extra_run_opts(f'"{config.libdir}"') , when(arch('wasm32') or arch('javascript'), skip) ], compile_and_run, ['-package ghc -package template-haskell']) test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc']) + +test('T25121_status', normal, compile_and_run, ['-package ghc']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13fdff31c0940cc0a13c843d18c4ee30... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13fdff31c0940cc0a13c843d18c4ee30... You're receiving this email because of your account on gitlab.haskell.org.