Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: f4e8466c by Alan Zimmerman at 2025-07-17T12:31:55-04:00 EPA: Update exact printing based on GHC 9.14 tests As a result of migrating the GHC ghc-9.14 branch tests to ghc-exactprint in https://github.com/alanz/ghc-exactprint/tree/ghc-9.14, a couple of discrepancies were picked up - The opening paren for a DefaultDecl was printed in the wrong place - The import declaration level specifiers were not printed. This commit adds those fixes, and some tests for them. The tests brought to light that the ImportDecl ppr instance had not been updated for level specifiers, so it updates that too. - - - - - 7 changed files: - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Parser.y - testsuite/tests/printer/Makefile - + testsuite/tests/printer/TestLevelImports.hs - + testsuite/tests/printer/TestNamedDefaults.hs - testsuite/tests/printer/all.T - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/ImpExp.hs ===================================== @@ -149,10 +149,14 @@ instance (OutputableBndrId p ppr (ImportDecl { ideclExt = impExt, ideclName = mod' , ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe + , ideclLevelSpec = level , ideclQualified = qual , ideclAs = as, ideclImportList = spec }) - = hang (hsep [text "import", ppr_imp impExt from, pp_implicit impExt, pp_safe safe, - pp_qual qual False, ppr pkg, ppr mod', pp_qual qual True, pp_as as]) + = hang (hsep [text "import", ppr_imp impExt from, pp_implicit impExt, + pp_level level False, pp_safe safe, pp_qual qual False, + ppr pkg, ppr mod', + pp_level level True, pp_qual qual True, + pp_as as]) 4 (pp_spec spec) where pp_implicit ext = @@ -169,6 +173,15 @@ instance (OutputableBndrId p pp_qual QualifiedPost False = empty -- Postpositive qualifier/prepositive position. pp_qual NotQualified _ = empty + pp_level (LevelStylePre sty) False = pp_level_style sty + pp_level (LevelStylePost _) False = empty + pp_level (LevelStylePre _) True = empty + pp_level (LevelStylePost sty) True = pp_level_style sty + pp_level NotLevelled _ = empty + + pp_level_style ImportDeclQuote = text "quote" + pp_level_style ImportDeclSplice = text "splice" + pp_safe False = empty pp_safe True = text "safe" ===================================== compiler/GHC/Parser.y ===================================== @@ -1123,7 +1123,7 @@ importdecls_semi | {- empty -} { [] } importdecl :: { LImportDecl GhcPs } - : 'import' maybe_src maybe_splice maybe_safe optqualified maybe_pkg modid maybe_splice optqualified maybeas maybeimpspec + : 'import' maybe_src maybe_level maybe_safe optqualified maybe_pkg modid maybe_level optqualified maybeas maybeimpspec {% do { ; let { ; mPreQual = $5 ; mPostQual = $9 @@ -1163,7 +1163,7 @@ maybe_safe :: { (Maybe (EpToken "safe"),Bool) } : 'safe' { (Just (epTok $1),True) } | {- empty -} { (Nothing, False) } -maybe_splice :: { (Maybe EpAnnLevel) } +maybe_level :: { (Maybe EpAnnLevel) } : 'splice' { (Just (EpAnnLevelSplice (epTok $1))) } | 'quote' { (Just (EpAnnLevelQuote (epTok $1))) } | {- empty -} { (Nothing) } ===================================== testsuite/tests/printer/Makefile ===================================== @@ -901,3 +901,14 @@ Test25467: Test25885: $(CHECK_PPR) $(LIBDIR) Test25885.hs $(CHECK_EXACT) $(LIBDIR) Test25885.hs + +.PHONY: TestLevelImports +TestLevelImports: + $(CHECK_PPR) $(LIBDIR) TestLevelImports.hs + $(CHECK_EXACT) $(LIBDIR) TestLevelImports.hs + + +.PHONY: TestNamedDefaults +TestNamedDefaults: + $(CHECK_PPR) $(LIBDIR) TestNamedDefaults.hs + $(CHECK_EXACT) $(LIBDIR) TestNamedDefaults.hs ===================================== testsuite/tests/printer/TestLevelImports.hs ===================================== @@ -0,0 +1,42 @@ + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module TestLevelImports where +-- Based on test SI26 and SI01 + +------------------------------------------------ +-- SI26 + +-- Test using 'quote' as a post-qualifier in imports +import Prelude quote +import Prelude quote qualified as P +import quote Prelude qualified as P2 +import quote qualified Prelude as P3 + +-- Test using 'splice' as a post-qualifier in imports +import Language.Haskell.TH.Syntax splice + +import splice Language.Haskell.TH.Syntax qualified as TH +import Language.Haskell.TH.Syntax splice qualified as TH2 + +-- Using a splice imported thing, inside an untyped and typed splice works +import splice SI01A + +-- Use the imported modules +testQuote = [| id |] +testQuote2 = [| P.id |] +testQuote3 = [| P2.id |] + +testSplice = $(lift "Hello from splice") +testSplice2 = $(TH.lift "Hello from splice2") +testSplice3 = $(TH2.lift "Hello from splice3") + +------------------------------------------------ +-- SI01 + +main :: IO () +main = $( sid [| pure () |]) >> $$( sid [|| pure () ||]) ===================================== testsuite/tests/printer/TestNamedDefaults.hs ===================================== @@ -0,0 +1,35 @@ +{-# LANGUAGE NamedDefaults #-} +module NamedDefaults ( + Stringify(..), + default Stringify, + Bingify(..), + default Bingify + ) where + +class Stringify a where + stringify :: a -> String + +instance Stringify Int where + stringify n = "Int" + +instance Stringify Bool where + stringify b = "Bool" + +instance Stringify [Char] where + stringify s = "String" + +class Bingify a where + bingify :: a -> String + +instance Bingify Int where + bingify n = "Int" + +instance Bingify Bool where + bingify b = "Bool" + +instance Bingify [Char] where + bingify s = "String" + +default Stringify (Int) +default Bingify (Int) + ===================================== testsuite/tests/printer/all.T ===================================== @@ -215,4 +215,7 @@ test('Test25467', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25467']) test('T24237', normal, compile_fail, ['']) test('Test25454', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25454']) -test('Test25885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25885']) \ No newline at end of file +test('Test25885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25885']) + +test('TestLevelImports', [ignore_stderr, req_ppr_deps], makefile_test, ['TestLevelImports']) +test('TestNamedDefaults', [ignore_stderr, req_ppr_deps], makefile_test, ['TestNamedDefaults']) \ No newline at end of file ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -802,6 +802,7 @@ markLensBracketsC' a l = c' <- markEpUniToken c return (set l (ListBanana o c') a) ListNone -> return (set l ListNone a) + -- ------------------------------------- markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) @@ -937,6 +938,7 @@ lam_where k annsModule = fmap (\newAnns -> annsModule { am_where = newAnns }) -- { importDeclAnnImport :: EpToken "import" -- ^ The location of the @import@ keyword -- , importDeclAnnPragma :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively -- , importDeclAnnSafe :: Maybe (EpToken "safe") -- ^ The location of the @safe@ keyword +-- , importDeclAnnLevel :: Maybe EpAnnLevel -- ^ The location of the @splice@ or @quote@ keyword -- , importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword -- , importDeclAnnPackage :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@) -- , importDeclAnnAs :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword @@ -954,6 +956,10 @@ limportDeclAnnSafe :: Lens EpAnnImportDecl (Maybe (EpToken "safe")) limportDeclAnnSafe k annImp = fmap (\new -> annImp { importDeclAnnSafe = new }) (k (importDeclAnnSafe annImp)) +limportDeclAnnLevel :: Lens EpAnnImportDecl (Maybe EpAnnLevel) +limportDeclAnnLevel k annImp = fmap (\new -> annImp { importDeclAnnLevel = new }) + (k (importDeclAnnLevel annImp)) + limportDeclAnnQualified :: Lens EpAnnImportDecl (Maybe (EpToken "qualified")) limportDeclAnnQualified k annImp = fmap (\new -> annImp { importDeclAnnQualified = new }) (k (importDeclAnnQualified annImp)) @@ -1625,9 +1631,15 @@ instance ExactPrint (ImportDecl GhcPs) where printStringAtLsDelta (SameLine 1) "#-}" return Nothing NoSourceText -> return (importDeclAnnPragma an) + -- pre level + ann0' <- case st of + LevelStylePre _ -> markLensFun' ann0 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt) + _ -> return ann0 + + ann1 <- if safeflag - then markLensFun' ann0 limportDeclAnnSafe (\mt -> mapM markEpToken mt) - else return ann0 + then markLensFun' ann0' limportDeclAnnSafe (\mt -> mapM markEpToken mt) + else return ann0' ann2 <- case qualFlag of QualifiedPre -- 'qualified' appears in prepositive position. @@ -1640,11 +1652,16 @@ instance ExactPrint (ImportDecl GhcPs) where _ -> return ann2 modname' <- markAnnotated modname + -- post level + ann3' <- case st of + LevelStylePost _ -> markLensFun' ann3 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt) + _ -> return ann3 + ann4 <- case qualFlag of QualifiedPost -- 'qualified' appears in postpositive position. - -> markLensFun' ann3 limportDeclAnnQualified (\ml -> mapM markEpToken ml) - _ -> return ann3 + -> markLensFun' ann3' limportDeclAnnQualified (\ml -> mapM markEpToken ml) + _ -> return ann3' (importDeclAnnAs', mAs') <- case mAs of @@ -1669,6 +1686,9 @@ instance ExactPrint (ImportDecl GhcPs) where return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl) modname' mpkg src st safeflag qualFlag mAs' hiding') +markEpAnnLevel :: (Monad m, Monoid w) => EpAnnLevel -> EP w m EpAnnLevel +markEpAnnLevel (EpAnnLevelSplice tok) = EpAnnLevelSplice <$> markEpToken tok +markEpAnnLevel (EpAnnLevelQuote tok) = EpAnnLevelQuote <$> markEpToken tok -- --------------------------------------------------------------------- @@ -2717,8 +2737,8 @@ instance ExactPrint (DefaultDecl GhcPs) where exact (DefaultDecl (d,op,cp) cl tys) = do d' <- markEpToken d - op' <- markEpToken op cl' <- markAnnotated cl + op' <- markEpToken op tys' <- markAnnotated tys cp' <- markEpToken cp return (DefaultDecl (d',op',cp') cl' tys') View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4e8466cf2164fd9ecf8d02d8cb417c0... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4e8466cf2164fd9ecf8d02d8cb417c0... You're receiving this email because of your account on gitlab.haskell.org.