Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 6f9d7c71 by Markus Läll at 2026-05-21T15:25:34-04:00 Use "grimily" instead of "grimly" Fixes https://gitlab.haskell.org/ghc/ghc/-/issues/27221 - - - - - 50e999ca by fendor at 2026-05-21T15:26:18-04:00 Speed up 'closure' computation in `ghc-pkg` Cache the set of already seen `UnitId`s and use `Set` operations to speed up 'closure' computation. Further simplify the implementation of 'closure' to account for the actual usage. As a consequence, we rename 'closure' to 'brokenPackages' to reflect its purpose better after the simplification. - - - - - 7ecc6184 by sheaf at 2026-05-21T15:27:10-04:00 TcMPluginHandling: be more lenient when no plugins This change ensures that, if a function such as 'typecheckModule' was invoked with 'NoTcMPlugins', GHC doesn't spuriously complain about TcM plugins having already been stopped, as there were none to start with. - - - - - 478c6325 by Alan Zimmerman at 2026-05-23T10:17:35+01:00 EPA: Fix span for qualified multiline string Fix the span for a qualified multiline string like Text.""" I'm a multiline Text value ! """ to extend to the end of the entire string, not just the first line. Closes #27274 - - - - - c3dec45b by Alan Zimmerman at 2026-05-23T11:19:31-04:00 EPA: Fix exact printing namespace-specified wildcards Ensures correct printing of imports of the form import Data.Bool (data True(data ..)) import Data.Bool (data True(type ..)) Closes #27291 - - - - - 21 changed files: - + changelog.d/ghc-pkg-faster-closure - compiler/GHC/CmmToLlvm/Base.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/StgToJS/Ids.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/Supply.hs - + testsuite/tests/ghc-api/T27273.hs - testsuite/tests/ghc-api/all.T - testsuite/tests/printer/Makefile - + testsuite/tests/printer/PprQualifiedStrings.hs - + testsuite/tests/printer/Test27291.hs - testsuite/tests/printer/all.T - utils/check-exact/ExactPrint.hs - utils/ghc-pkg/Main.hs Changes: ===================================== changelog.d/ghc-pkg-faster-closure ===================================== @@ -0,0 +1,10 @@ +section: ghc-pkg +synopsis: Improve performance of `ghc-pkg list` command +issues: #27275 +mrs: !16062 + +description: { +`ghc-pkg list` was quadratic in the number of packages due to an inefficient `closure` computation. +We cache the set of seen packages, allowing us to speed up the `closure` computation, improving run-time +for the commands `list`, `check`, `distrust`, `expose`, `hide`, `trust` and `unregister`. +} ===================================== compiler/GHC/CmmToLlvm/Base.hs ===================================== @@ -318,7 +318,7 @@ instance DSM.MonadGetUnique LlvmM where tag <- getEnv envTag liftUDSMT $! do uq <- DSM.getUniqueM - return (newTagUniqueGrimly uq tag) + return (newTagUniqueGrimily uq tag) -- | Lifting of IO actions. Not exported, as we want to encapsulate IO. liftIO :: IO a -> LlvmM a ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -175,11 +175,11 @@ instance MonadPlus CoreM instance MonadUnique CoreM where getUniqueSupplyM = do tag <- read cr_uniq_tag - liftIO $! mkSplitUniqSupplyGrimly tag + liftIO $! mkSplitUniqSupplyGrimily tag getUniqueM = do tag <- read cr_uniq_tag - liftIO $! uniqFromTagGrimly tag + liftIO $! uniqFromTagGrimily tag runCoreM :: HscEnv -> RuleBase ===================================== compiler/GHC/HsToCore/Foreign/JavaScript.hs ===================================== @@ -144,7 +144,7 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv | otherwise = unpackHObj res_hty header_bits = maybe mempty idTag maybe_target - idTag i = let (tag, u) = unpkUniqueGrimly (getUnique i) + idTag i = let (tag, u) = unpkUniqueGrimily (getUnique i) in CHeader (char tag <> word64 u) normal_args = map (\(nm,_ty,_,_) -> nm) arg_info ===================================== compiler/GHC/Iface/Binary.hs ===================================== @@ -707,7 +707,7 @@ putName BinSymbolTable{ bin_symtab_next = symtab_next } bh name | isKnownKeyName name - , let (c, u) = unpkUniqueGrimly (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits + , let (c, u) = unpkUniqueGrimily (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits = -- assert (u < 2^(22 :: Int)) put_ bh (0x80000000 .|. (fromIntegral (ord c) `shiftL` 22) ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -2274,8 +2274,9 @@ tok_quoted_label span buf len _buf2 = do tok_qstrings :: Action -> Action tok_qstrings lex_str span0 buf0 len0 endBuf0 = do let modName = ModuleName $ lexemeToFastString buf0 modNameLen - (src, meta, s) <- unITstring <$> lex_str strSpan strBuf strLen endBuf0 - pure $ L span0 $ ITstring src meta{strMetaQualified = Just modName} s + (span1, src, meta, s) <- unITstring <$> lex_str strSpan strBuf strLen endBuf0 + let span2 = mkPsSpan (psSpanStart span0) (psSpanEnd span1) + pure $ L span2 $ ITstring src meta{strMetaQualified = Just modName} s where -- The buffer/span starting at the string literal (strBuf, strSpanStart) = @@ -2298,7 +2299,7 @@ tok_qstrings lex_str span0 buf0 len0 endBuf0 = do strSpan = mkPsSpan strSpanStart (psSpanEnd span0) unITstring = \case - L _ (ITstring src meta s) -> (src, meta, s) + L span1 (ITstring src meta s) -> (span1, src, meta, s) tok -> panic $ "tok_qstrings got unexpected token: " ++ show tok tok_char :: Action ===================================== compiler/GHC/Stg/Pipeline.hs ===================================== @@ -66,9 +66,9 @@ newtype StgM a = StgM { _unStgM :: ReaderT Char IO a } instance MonadUnique StgM where getUniqueSupplyM = StgM $ do { tag <- ask - ; liftIO $! mkSplitUniqSupplyGrimly tag} + ; liftIO $! mkSplitUniqSupplyGrimily tag} getUniqueM = StgM $ do { tag <- ask - ; liftIO $! uniqFromTagGrimly tag} + ; liftIO $! uniqFromTagGrimily tag} runStgM :: UniqueTag -> StgM a -> IO a runStgM mask (StgM m) = runReaderT m (uniqueTag mask) ===================================== compiler/GHC/StgToJS/Ids.hs ===================================== @@ -130,7 +130,7 @@ makeIdentForId i num id_type current_module = name ident -- unique suffix for non-exported Ids , if exported then mempty - else let (c,u) = unpkUniqueGrimly (getUnique i) + else let (c,u) = unpkUniqueGrimily (getUnique i) in mconcat [BSC.pack ['_',c,'_'], word64BS u] ] @@ -235,4 +235,3 @@ declVarsForId i = case typeSize (idType i) of 0 -> return mempty 1 -> decl <$> identForId i s -> mconcat <$> mapM (\n -> decl <$> identForIdN i n) [1..s] - ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -1250,14 +1250,17 @@ emptyTcMPluginsShutdown = TcMPluginsShutdown data TcMPluginsState -- | The 'TcM' plugins have not been started. = TcMPluginsUninitialised - -- | The 'TcM' plugins have been initialised and not yet stopped. + -- | The 'TcM' plugins have been initialised and not yet stopped, + -- or there were no 'TcM' plugins to start with. -- -- We may be in the middle of typechecker, or have finished typechecking -- and be in the middle of desugaring. | TcMPluginsRunning !RunningTcMPlugins - -- | The 'TcM' plugins have been stopped. + -- | There were 'TcM' plugins that were running, but they have been stopped. | TcMPluginsStopped +-- | A (possibly empty) collection of 'TcM' plugin @run@, @post-tc@ and +-- @shutdown@ actions. data RunningTcMPlugins = RunningTcMPlugins { rtcmp_run :: TcMPluginsRun @@ -1281,11 +1284,20 @@ tcMPluginsShutdownActions = rtcmp_shutdown -- | Retrieve the 'TcM' plugins from a 'TcMPluginsState'. -- --- Assumes the plugins have been already started and not yet stopped. +-- Assumes the plugins (if any) have been already started and not yet stopped. runningTcMPlugins :: HasDebugCallStack => TcMPluginsState -> RunningTcMPlugins runningTcMPlugins = \case - TcMPluginsUninitialised -> panic "runningTcMPlugins: TcM plugins not started" - TcMPluginsStopped -> panic "runningTcMPlugins: TcM plugins already stopped" + TcMPluginsUninitialised -> + pprPanic "TcM plugins have not been started" $ + vcat [ text "If you are a GHC API user, make sure to use an appropriate 'TcMPluginHandling'" + , text "to ensure that TcM plugins (if any) are initialised before typechecking." + ] + TcMPluginsStopped -> + pprPanic "TcM plugins already stopped" $ + vcat [ text "If you are a GHC API user and want to proceed to desugaring after typechecking," + , text "make sure you are not using the 'StartAndStopTcMPlugins' 'TcMPluginHandling'," + , text "as that stops TcM plugins after typechecking." + ] TcMPluginsRunning plugins -> plugins ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -790,9 +790,10 @@ withoutTcMPlugins thing_inside = do tcg_env <- getGblEnv writeTcRef (tcg_plugins tcg_env) $ TcMPluginsRunning emptyRunningTcMPlugins - teardown = do - tcg_env <- getGblEnv - writeTcRef (tcg_plugins tcg_env) TcMPluginsStopped + teardown = + -- Don't set 'tcg_plugins' to 'TcMPluginsStopped', as that should only + -- be used when there were 'TcM' plugins to start with (#27273). + return () -- | Initialise 'TcM' plugins. initTcMPlugins :: HscEnv -> TcM () @@ -946,32 +947,20 @@ shutdownTcMPlugins = \case runPluginShutdowns (tcs ++ defs) solverTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [TcPluginSolver] -solverTcMPlugins = \case - TcMPluginsUninitialised -> panic "solverTcMPlugins: TcM plugins not started" - TcMPluginsStopped -> panic "solverTcMPlugins: TcM plugins already stopped" - TcMPluginsRunning plugins -> - tcmp_solvers (tcMPluginsRunActions plugins) +solverTcMPlugins = + tcmp_solvers . tcMPluginsRunActions . runningTcMPlugins rewriterTcMPlugins :: HasDebugCallStack => TcMPluginsState -> UniqFM TyCon [TcPluginRewriter] -rewriterTcMPlugins = \case - TcMPluginsUninitialised -> panic "rewriterTcMPlugins: TcM plugins not started" - TcMPluginsStopped -> panic "rewriterTcMPlugins: TcM plugins already stopped" - TcMPluginsRunning plugins -> - tcmp_rewriters (tcMPluginsRunActions plugins) +rewriterTcMPlugins = + tcmp_rewriters . tcMPluginsRunActions . runningTcMPlugins defaultingTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [FillDefaulting] -defaultingTcMPlugins = \case - TcMPluginsUninitialised -> panic "defaultingTcMPlugins: TcM plugins not started" - TcMPluginsStopped -> panic "defaultingTcMPlugins: TcM plugins already stopped" - TcMPluginsRunning plugins -> - tcmp_defaulters (tcMPluginsRunActions plugins) +defaultingTcMPlugins = + tcmp_defaulters . tcMPluginsRunActions . runningTcMPlugins holeFitTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [HoleFitPlugin] -holeFitTcMPlugins = \case - TcMPluginsUninitialised -> panic "holeFitTcMPlugins: TcM plugins not started" - TcMPluginsStopped -> panic "holeFitTcMPlugins: TcM plugins already stopped" - TcMPluginsRunning plugins -> - tcmp_hole_fits (tcMPluginsRunActions plugins) +holeFitTcMPlugins = + tcmp_hole_fits . tcMPluginsRunActions . runningTcMPlugins {- ************************************************************************ @@ -1008,13 +997,13 @@ newUnique :: TcRnIf gbl lcl Unique newUnique = do { env <- getEnv ; let tag = env_ut env - ; liftIO $! uniqFromTagGrimly tag } + ; liftIO $! uniqFromTagGrimily tag } newUniqueSupply :: TcRnIf gbl lcl UniqSupply newUniqueSupply = do { env <- getEnv ; let tag = env_ut env - ; liftIO $! mkSplitUniqSupplyGrimly tag } + ; liftIO $! mkSplitUniqSupplyGrimily tag } cloneLocalName :: Name -> TcM Name -- Make a fresh Internal name with the same OccName and SrcSpan ===================================== compiler/GHC/Types/Name/Cache.hs ===================================== @@ -122,7 +122,7 @@ data NameCache = NameCache type OrigNameCache = ModuleEnv (OccEnv Name) takeUniqFromNameCache :: NameCache -> IO Unique -takeUniqFromNameCache (NameCache c _) = uniqFromTagGrimly c +takeUniqFromNameCache (NameCache c _) = uniqFromTagGrimily c lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name lookupOrigNameCache nc mod occ = lookup_infinite <|> lookup_normal ===================================== compiler/GHC/Types/Unique.hs ===================================== @@ -38,12 +38,12 @@ module GHC.Types.Unique ( mkUniqueIntGrimily, getKey, mkUnique, unpkUnique, - unpkUniqueGrimly, + unpkUniqueGrimily, mkUniqueInt, eqUnique, ltUnique, incrUnique, stepUnique, - newTagUnique, newTagUniqueGrimly, + newTagUnique, newTagUniqueGrimily, nonDetCmpUnique, isValidKnownKeyUnique, @@ -99,7 +99,7 @@ Note [Performance implications of UniqueTag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The UniqueTag ADT is meant to be ephemeral and eliminated by the simplifier, so for long term storage (i.e. in monadic environments or data structures) we -want to store the raw 'Char's. Working with the raw tags is done via the *Grimly +want to store the raw 'Char's. Working with the raw tags is done via the *Grimily class of functions For instance, if we are generating a unique for a concrete tag, we should use @@ -116,7 +116,7 @@ newUnique ; liftIO $! uniqFromTag tag } Prefer `env_ut :: Char` and - ; liftIO $! uniqFromTagGrimly tag } + ; liftIO $! uniqFromTagGrimily tag } -} @@ -295,7 +295,7 @@ The stuff about unique *supplies* is handled further down this module. -} unpkUnique :: Unique -> (UniqueTag, Word64) -- The reverse -unpkUniqueGrimly :: Unique -> (Char, Word64) -- The reverse +unpkUniqueGrimily :: Unique -> (Char, Word64) -- The reverse mkUniqueGrimily :: Word64 -> Unique -- A trap-door for UniqSupply getKey :: Unique -> Word64 -- for Var @@ -303,7 +303,7 @@ getKey :: Unique -> Word64 -- for Var incrUnique :: Unique -> Unique stepUnique :: Unique -> Word64 -> Unique newTagUnique :: Unique -> UniqueTag -> Unique -newTagUniqueGrimly :: Unique -> Char -> Unique +newTagUniqueGrimily :: Unique -> Char -> Unique mkUniqueGrimily = MkUnique @@ -323,9 +323,9 @@ maxLocalUnique :: Unique maxLocalUnique = mkLocalUnique uniqueMask -- newTagUnique changes the "domain" of a unique to a different char -newTagUnique u c = newTagUniqueGrimly u (uniqueTag c) +newTagUnique u c = newTagUniqueGrimily u (uniqueTag c) -newTagUniqueGrimly u c = mkUniqueGrimilyWithTag c i where (_,i) = unpkUniqueGrimly u +newTagUniqueGrimily u c = mkUniqueGrimilyWithTag c i where (_,i) = unpkUniqueGrimily u -- | Bitmask that has zeros for the tag bits and ones for the rest. uniqueMask :: Word64 @@ -368,7 +368,7 @@ mkUniqueIntGrimily = MkUnique . intToWord64 {-# INLINE mkUniqueIntGrimily #-} -unpkUniqueGrimly (MkUnique u) +unpkUniqueGrimily (MkUnique u) = let -- The potentially truncating use of fromIntegral here is safe -- because the argument is just the tag bits after shifting. @@ -376,10 +376,10 @@ unpkUniqueGrimly (MkUnique u) i = u .&. uniqueMask in (tag, i) -{-# INLINE unpkUniqueGrimly #-} +{-# INLINE unpkUniqueGrimily #-} -unpkUnique u = case unpkUniqueGrimly u of +unpkUnique u = case unpkUniqueGrimily u of (c, i) -> ( charToUniqueTag c, i) {-# INLINE unpkUnique #-} @@ -389,7 +389,7 @@ unpkUnique u = case unpkUniqueGrimly u of -- See Note [Symbol table representation of names] in "GHC.Iface.Binary" for details. isValidKnownKeyUnique :: Unique -> Bool isValidKnownKeyUnique u = - case unpkUniqueGrimly u of + case unpkUniqueGrimily u of (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22) {- @@ -512,7 +512,7 @@ showUnique :: Unique -> String showUnique uniq = tagStr ++ w64ToBase62 u where - (tag, u) = unpkUniqueGrimly uniq + (tag, u) = unpkUniqueGrimily uniq -- Avoid emitting non-printable characters in pretty uniques. -- See #25989. tagStr ===================================== compiler/GHC/Types/Unique/Supply.hs ===================================== @@ -16,10 +16,10 @@ module GHC.Types.Unique.Supply ( -- ** Operations on supplies uniqFromSupply, uniqsFromSupply, -- basic ops takeUniqFromSupply, - uniqFromTag, uniqFromTagGrimly, + uniqFromTag, uniqFromTagGrimily, UniqueTag(..), - mkSplitUniqSupply, mkSplitUniqSupplyGrimly, + mkSplitUniqSupply, mkSplitUniqSupplyGrimily, splitUniqSupply, listSplitUniqSupply, -- * Unique supply monad and its abstraction @@ -203,10 +203,10 @@ data UniqSupply -- when split => these two supplies mkSplitUniqSupply :: UniqueTag -> IO UniqSupply -mkSplitUniqSupply ut = mkSplitUniqSupplyGrimly (uniqueTag ut) +mkSplitUniqSupply ut = mkSplitUniqSupplyGrimily (uniqueTag ut) {-# INLINE mkSplitUniqSupply #-} -mkSplitUniqSupplyGrimly :: Char -> IO UniqSupply +mkSplitUniqSupplyGrimily :: Char -> IO UniqSupply -- ^ Create a unique supply out of thin air. -- The "tag" (Char) supplied is mostly cosmetic, making it easier -- to figure out where a Unique was born. See Note [Uniques and tags]. @@ -219,7 +219,7 @@ mkSplitUniqSupplyGrimly :: Char -> IO UniqSupply -- See Note [How the unique supply works] -- See Note [Optimising the unique supply] -mkSplitUniqSupplyGrimly ut +mkSplitUniqSupplyGrimily ut = unsafeDupableInterleaveIO (IO mk_supply) where @@ -286,15 +286,15 @@ initUniqSupply counter inc = do poke ghc_unique_inc inc uniqFromTag :: UniqueTag -> IO Unique -uniqFromTag !ut = uniqFromTagGrimly (uniqueTag ut) +uniqFromTag !ut = uniqFromTagGrimily (uniqueTag ut) {-# INLINE uniqFromTag #-} -uniqFromTagGrimly :: Char -> IO Unique -uniqFromTagGrimly !tag +uniqFromTagGrimily :: Char -> IO Unique +uniqFromTagGrimily !tag = do { uqNum <- genSym ; return $! mkUniqueGrimilyWithTag tag uqNum } -{-# NOINLINE uniqFromTagGrimly #-} -- We'll unbox everything, but we don't want to inline it +{-# NOINLINE uniqFromTagGrimily #-} -- We'll unbox everything, but we don't want to inline it splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) -- ^ Build two 'UniqSupply' from a single one, each of which ===================================== testsuite/tests/ghc-api/T27273.hs ===================================== @@ -0,0 +1,56 @@ +module Main where + +-- base +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import System.Environment (getArgs) + +-- time +import Data.Time (getCurrentTime) + +-- ghc +import qualified GHC as GHC +import qualified GHC.Core as GHC +import qualified GHC.Data.StringBuffer as GHC +import qualified GHC.Unit.Module.ModGuts as GHC +import qualified GHC.Unit.Types as GHC + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + let inputSource = unlines + [ "module NumLitDesugaring where" + , "f :: Num a => a" -- !!! Succeeds if type signature is f :: Int + , "f = 1" + ] + + void $ compileToCore "NumLitDesugaring" inputSource + +compileToCore :: String -> String -> IO [GHC.CoreBind] +compileToCore modName inputSource = do + [libdir] <- getArgs + GHC.runGhc (Just libdir) $ do + (_ms, tcMod) <- typecheckSourceCode modName inputSource + dsMod <- GHC.desugarModule tcMod + return $ GHC.mg_binds $ GHC.dm_core_module dsMod + +typecheckSourceCode + :: GHC.GhcMonad m => String -> String -> m (GHC.ModSummary, GHC.TypecheckedModule) +typecheckSourceCode modName inputSource = do + now <- liftIO getCurrentTime + df1 <- GHC.getSessionDynFlags + GHC.setSessionDynFlags $ df1 { GHC.backend = GHC.bytecodeBackend } + let target = GHC.Target + { GHC.targetId = GHC.TargetFile (modName ++ ".hs") Nothing + , GHC.targetUnitId = GHC.homeUnitId_ df1 + , GHC.targetAllowObjCode = False + , GHC.targetContents = Just (GHC.stringToStringBuffer inputSource, now) + } + GHC.setTargets [target] + void $ GHC.depanal [] False + + ms <- GHC.getModSummary + (GHC.mkModule GHC.mainUnit (GHC.mkModuleName modName)) + tm <- GHC.parseModule ms >>= GHC.typecheckModule GHC.NoTcMPlugins + return (ms, tm) ===================================== testsuite/tests/ghc-api/all.T ===================================== @@ -82,3 +82,6 @@ test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc']) test('T25121_status', normal, compile_and_run, ['-package ghc']) test('T24386', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-package ghc']) +test('T27273', [extra_run_opts(f'"{config.libdir}"')], + compile_and_run, + ['-package ghc']) ===================================== testsuite/tests/printer/Makefile ===================================== @@ -907,6 +907,11 @@ Test25885: $(CHECK_PPR) $(LIBDIR) Test25885.hs $(CHECK_EXACT) $(LIBDIR) Test25885.hs +.PHONY: Test27291 +Test27291: + $(CHECK_PPR) $(LIBDIR) Test27291.hs + $(CHECK_EXACT) $(LIBDIR) Test27291.hs + .PHONY: TestLevelImports TestLevelImports: $(CHECK_PPR) $(LIBDIR) TestLevelImports.hs @@ -922,3 +927,8 @@ TestNamedDefaults: PprModifiers: $(CHECK_PPR) $(LIBDIR) PprModifiers.hs $(CHECK_EXACT) $(LIBDIR) PprModifiers.hs + +.PHONY: PprQualifiedStrings +PprQualifiedStrings: + $(CHECK_PPR) $(LIBDIR) PprQualifiedStrings.hs + $(CHECK_EXACT) $(LIBDIR) PprQualifiedStrings.hs ===================================== testsuite/tests/printer/PprQualifiedStrings.hs ===================================== @@ -0,0 +1,75 @@ +{-# LANGUAGE MultilineStrings #-} +{-# LANGUAGE QualifiedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- These are harvested from ../qualified-strings + +module PprQualifiedStrings where + +import Data.Typeable (Typeable, typeOf) +import qualified Example.ByteStringAscii as Ascii +import qualified Example.ByteStringUtf8 as Utf8 +import qualified Example.Text as Text + +exprs :: IO () +exprs = do + inspect "I'm a String" -- would be an ambiguous type error with OverloadedStrings + inspect Text."I'm a Text" + inspect Ascii."I'm an ASCII bytestring: 語" + inspect Utf8."I'm a UTF8 bytestring: 語" + + inspect """ + I'm a multiline + String value + ! + """ + + inspect Text.""" + I'm a multiline + Text value + ! + """ + + inspect Text . """ + I'm a multiline + Text value + """ + + inspect Text . + """ + I'm a multiline + Text value + """ + +pats :: IO () +pats = do + let text = Text."foo" :: Text + case text of + Text."foo" -> putStrLn "Text.\"foo\" matched" + _ -> putStrLn "Text.\"foo\" did not match" + + let ascii = Ascii."語" :: ByteString + case ascii of + Ascii."語" -> putStrLn "Ascii.\"語\" matched" + _ -> putStrLn "Ascii.\"語\" did not match" + + let utf = Utf8."語" :: ByteString + case utf of + Utf8."語" -> putStrLn "Utf8.\"語\" matched" + _ -> putStrLn "Utf8.\"語\" did not match" + +th :: IO () +th = + $(do + foldr (\stmt acc -> [| $stmt >> $acc |]) [| pure () |] $ + [ [| inspect Text."I'm a Text" |] + , [| inspect Ascii."I'm an ASCII bytestring: 語" |] + , [| inspect Utf8."I'm a Utf8 bytestring: 語" |] + , [| + inspect Text.""" + I'm a multiline + Text string + """ + |] + ] + ) ===================================== testsuite/tests/printer/Test27291.hs ===================================== @@ -0,0 +1,35 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +module Test27291 + ( C(type ..) -- exports class C and data family D + , C(data ..) -- exports class C and method m + , D(type ..) -- exports data family D + , type T (..) -- exports type T and all its data constructors D, D2 + , type T (type ..) -- exports type T + , type K (type ..) -- exports type K and its constructor K1 + ) where + +import Control.Applicative qualified as A (type Applicative (data ..)) +import Data.Either qualified as E (type Either (data ..)) + +import Data.Bool (data True (..)) +import Data.Bool (data True( data .. ) ) +import Data.Bool (data True( type ..)) + +import DodgyImports03_helper (C( .. )) +import DodgyImports03_helper (C (data .. )) +import DodgyImports03_helper (C( type ..) ) + +import DodgyImports03_helper (T ( .. ) ) +import DodgyImports03_helper (T(data ..)) +import DodgyImports03_helper (T(type ..)) + +import Control.Applicative (type Applicative (type ..)) -- dodgy: no associated types +import Data.Either (type Either (type ..)) -- dodgy: not a class + +import Data.Proxy (type Proxy(data ..)) -- ok +import Data.Proxy (type Proxy(type ..)) -- dodgy: not a class + +import T25901_sub_g_helper qualified as T1 (T (data ..)) -- T and MkT +import T25901_sub_g_helper qualified as T2 (T (type ..)) -- T only +import T25901_sub_g_helper qualified as T3 (type T (..)) -- T and MkT ===================================== testsuite/tests/printer/all.T ===================================== @@ -217,7 +217,9 @@ 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']) +test('Test27291', [ignore_stderr, req_ppr_deps], makefile_test, ['Test27291']) test('TestLevelImports', [ignore_stderr, req_ppr_deps], makefile_test, ['TestLevelImports']) test('TestNamedDefaults', [ignore_stderr, req_ppr_deps], makefile_test, ['TestNamedDefaults']) test('PprModifiers', [ignore_stderr,req_ppr_deps], makefile_test, ['PprModifiers']) +test('PprQualifiedStrings', [ignore_stderr,req_ppr_deps], makefile_test, ['PprQualifiedStrings']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -3145,6 +3145,12 @@ instance ExactPrint (HsExpr GhcPs) where body' <- markAnnotated body return (HsQual noExtField ctxt' body') + exact (HsQualLit _ (QualLit _ modu (HsQualString src fs))) = do + modu' <- markAnnotated modu + printStringAdvanceA "." + printSourceTextAA src (show (unpackFS fs)) + return (HsQualLit noExtField (QualLit noExtField modu' (HsQualString src fs))) + exact x = error $ "exact HsExpr for:" ++ showAst x -- --------------------------------------------------------------------- @@ -4581,9 +4587,9 @@ instance ExactPrint (IE GhcPs) where return (IEThingAbs depr' thing' doc') exact (IEThingAll x ns_spec thing doc) = do depr' <- markAnnotated (ieta_warning x) - ns_spec' <- markAnnotated ns_spec thing' <- markAnnotated thing op' <- markEpToken (ieta_tok_lpar x) + ns_spec' <- markAnnotated ns_spec dd' <- markEpToken (ieta_tok_wc x) cp' <- markEpToken (ieta_tok_rpar x) doc' <- markAnnotated doc ===================================== utils/ghc-pkg/Main.hs ===================================== @@ -1826,7 +1826,7 @@ checkConsistency verbosity my_flags = do all_ps = map mungedId pkgs1 let not_broken_pkgs = filterOut broken_pkgs pkgs - (_, trans_broken_pkgs) = closure [] not_broken_pkgs + trans_broken_pkgs = brokenPackages not_broken_pkgs all_broken_pkgs :: [InstalledPackageInfo] all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs @@ -1845,26 +1845,26 @@ checkConsistency verbosity my_flags = do when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1) -closure :: [InstalledPackageInfo] -> [InstalledPackageInfo] - -> ([InstalledPackageInfo], [InstalledPackageInfo]) -closure pkgs db_stack = go pkgs db_stack - where - go avail not_avail = - case partition (depsAvailable avail) not_avail of - ([], not_avail') -> (avail, not_avail') - (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' +-- | Compute the set of transitive broken packages. +-- +-- A package is assumed to be broken if any of its dependencies is not +-- found in the 'db_stack' after a transitive reduction. +brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] +brokenPackages db_stack = go Set.empty db_stack + where + go avail_ids not_avail = + case partition (depsAvailable avail_ids) not_avail of + ([], not_avail') -> not_avail' + (new_avail, not_avail') -> go (add new_avail avail_ids) not_avail' - depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo - -> Bool - depsAvailable pkgs_ok pkg = null dangling - where dangling = filter (`notElem` pids) (depends pkg) - pids = map installedUnitId pkgs_ok + add new_avail avail_ids = + foldl' (flip Set.insert) avail_ids (map installedUnitId new_avail) - -- we want mutually recursive groups of package to show up - -- as broken. (#1750) + depsAvailable :: Set.Set UnitId -> InstalledPackageInfo -> Bool + depsAvailable pids pkg = all (`Set.member` pids) (depends pkg) -brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] -brokenPackages pkgs = snd (closure [] pkgs) + -- we want mutually recursive groups of package to show up + -- as broken. (#1750) ----------------------------------------------------------------------------- -- Sanity-check a new package config, and automatically build GHCi libs View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a56de36e2fed3577462bb1266489be3... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a56de36e2fed3577462bb1266489be3... You're receiving this email because of your account on gitlab.haskell.org.