Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: cc650b4b by Andrew Lelechenko at 2025-07-17T12:30:24-04:00 Add Data.List.NonEmpty.mapMaybe As per https://github.com/haskell/core-libraries-committee/issues/337 - - - - - 360fa82c by Duncan Coutts at 2025-07-17T12:31:14-04:00 base: Deprecate GHC.Weak.Finalize.runFinalizerBatch https://github.com/haskell/core-libraries-committee/issues/342 - - - - - 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. - - - - - e2ed9a3f by Matthew Pickering at 2025-07-21T05:46:13-04:00 level imports: Fix infinite loop with cyclic module imports I didn't anticipate that downsweep would run before we checked for cyclic imports. Therefore we need to use the reachability function which handles cyclic graphs. Fixes #26087 - - - - - 9480fe96 by Pierre Thierry at 2025-07-21T05:46:16-04:00 Fix documentation about deriving from generics - - - - - 20 changed files: - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Parser.y - compiler/GHC/Unit/Module/Graph.hs - libraries/base/changelog.md - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/GHC/Generics.hs - libraries/base/src/GHC/Weak/Finalize.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/printer/Makefile - + testsuite/tests/printer/TestLevelImports.hs - + testsuite/tests/printer/TestNamedDefaults.hs - testsuite/tests/printer/all.T - + testsuite/tests/splice-imports/T26087.stderr - + testsuite/tests/splice-imports/T26087A.hs - + testsuite/tests/splice-imports/T26087B.hs - testsuite/tests/splice-imports/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) } ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -866,7 +866,7 @@ mkTransZeroDeps = first graphReachability {- module graph is acyclic -} . module -- | Transitive dependencies, but with the stage that each module is required at. mkStageDeps :: [ModuleGraphNode] -> (ReachabilityIndex StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode) -mkStageDeps = first graphReachability . moduleGraphNodesStages +mkStageDeps = first cyclicGraphReachability . moduleGraphNodesStages type ZeroSummaryNode = Node Int ZeroScopeKey ===================================== libraries/base/changelog.md ===================================== @@ -1,6 +1,11 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) +## 4.23.0.0 *TBA* + * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337)) + ## 4.22.0.0 *TBA* + * Shipped with GHC 9.14.1 + * The internal `GHC.Weak.Finalize.runFinalizerBatch` function has been deprecated ([CLC proposal #342](https://github.com/haskell/core-libraries-committee/issues/342)) * Define `displayException` of `SomeAsyncException` to unwrap the exception. ([CLC proposal #309](https://github.com/haskell/core-libraries-committee/issues/309)) * Restrict `Data.List.NonEmpty.unzip` to `NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)`. ([CLC proposal #86](https://github.com/haskell/core-libraries-committee/issues/86)) ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -78,6 +78,7 @@ module Data.List.NonEmpty ( , span -- :: (a -> Bool) -> NonEmpty a -> ([a], [a]) , break -- :: (a -> Bool) -> NonEmpty a -> ([a], [a]) , filter -- :: (a -> Bool) -> NonEmpty a -> [a] + , mapMaybe -- :: (a -> Maybe b) -> NonEmpty a -> [b] , partition -- :: (a -> Bool) -> NonEmpty a -> ([a],[a]) , group -- :: (Foldable f, Eq a) => f a -> [NonEmpty a] , groupBy -- :: Foldable f => (a -> a -> Bool) -> f a -> [NonEmpty a] @@ -118,6 +119,7 @@ import qualified Prelude import Control.Applicative (Applicative (..), Alternative (many)) import qualified Data.List as List +import qualified Data.Maybe as List (mapMaybe) import GHC.Internal.Data.Foldable hiding (length, toList) import qualified GHC.Internal.Data.Foldable as Foldable import GHC.Internal.Data.Function (on) @@ -442,6 +444,14 @@ break p = span (not . p) filter :: (a -> Bool) -> NonEmpty a -> [a] filter p = List.filter p . toList +-- | The 'mapMaybe' function is a version of 'map' which can throw +-- out elements. In particular, the functional argument returns +-- something of type @'Maybe' b@. If this is 'Nothing', no element +-- is added on to the result list. If it is @'Just' b@, then @b@ is +-- included in the result list. +mapMaybe :: (a -> Maybe b) -> NonEmpty a -> [b] +mapMaybe f (x :| xs) = maybe id (:) (f x) $ List.mapMaybe f xs + -- | The 'partition' function takes a predicate @p@ and a stream -- @xs@, and returns a pair of lists. The first list corresponds to the -- elements of @xs@ for which @p@ holds; the second corresponds to the ===================================== libraries/base/src/GHC/Generics.hs ===================================== @@ -392,9 +392,14 @@ module GHC.Generics ( -- instance (Encode a) => Encode (Tree a) -- @ -- --- The generic default is being used. In the future, it will hopefully be --- possible to use @deriving Encode@ as well, but GHC does not yet support --- that syntax for this situation. +-- The generic default is being used. Alternatively the @DeriveAnyClass@ language extension can be +-- used to derive Encode: +-- +-- @ +-- {-# LANGUAGE DeriveAnyClass #-} +-- data Tree a = Leaf a | Node (Tree a) (Tree a) +-- deriving (Generic, Encode) +-- @ -- -- Having @Encode@ as a class has the advantage that we can define -- non-generic special cases, which is particularly useful for abstract ===================================== libraries/base/src/GHC/Weak/Finalize.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} module GHC.Weak.Finalize ( -- * Handling exceptions -- | When an exception is thrown by a finalizer called by the @@ -8,7 +9,30 @@ module GHC.Weak.Finalize , getFinalizerExceptionHandler , printToHandleFinalizerExceptionHandler -- * Internal - , runFinalizerBatch + , GHC.Weak.Finalize.runFinalizerBatch ) where import GHC.Internal.Weak.Finalize + +-- These imports can be removed once runFinalizerBatch is removed, +-- as can MagicHash above. +import GHC.Internal.Base (Int, Array#, IO, State#, RealWorld) + + +{-# DEPRECATED runFinalizerBatch + "This function is internal to GHC. It will not be exported in future." #-} +-- | Run a batch of finalizers from the garbage collector. Given an +-- array of finalizers and the length of the array, just call each one +-- in turn. +-- +-- This is an internal detail of the GHC RTS weak pointer finaliser +-- mechanism. It should no longer be exported from base. There is no +-- good reason to use it. It will be removed in the next major version +-- of base (4.23.*). +-- +-- See https://github.com/haskell/core-libraries-committee/issues/342 +-- +runFinalizerBatch :: Int + -> Array# (State# RealWorld -> State# RealWorld) + -> IO () +runFinalizerBatch = GHC.Internal.Weak.Finalize.runFinalizerBatch ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where last :: forall a. NonEmpty a -> a length :: forall a. NonEmpty a -> GHC.Internal.Types.Int map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b + mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b] nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where last :: forall a. NonEmpty a -> a length :: forall a. NonEmpty a -> GHC.Internal.Types.Int map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b + mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b] nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where last :: forall a. NonEmpty a -> a length :: forall a. NonEmpty a -> GHC.Internal.Types.Int map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b + mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b] nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where last :: forall a. NonEmpty a -> a length :: forall a. NonEmpty a -> GHC.Internal.Types.Int map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b + mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b] nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a ===================================== 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 ===================================== testsuite/tests/splice-imports/T26087.stderr ===================================== @@ -0,0 +1,6 @@ +./T26087B.hs: error: [GHC-92213] + Module graph contains a cycle: + module ‘main:T26087B’ (./T26087B.hs) + imports module ‘main:T26087A’ (T26087A.hs) + which imports module ‘main:T26087B’ (./T26087B.hs) + ===================================== testsuite/tests/splice-imports/T26087A.hs ===================================== @@ -0,0 +1,4 @@ +{-# LANGUAGE ExplicitLevelImports #-} +module T26087A where + +import quote T26087B ===================================== testsuite/tests/splice-imports/T26087B.hs ===================================== @@ -0,0 +1,4 @@ +{-# LANGUAGE ExplicitLevelImports, TemplateHaskell #-} +module T26087B where + +import T26087A ===================================== testsuite/tests/splice-imports/all.T ===================================== @@ -46,3 +46,4 @@ test('SI35', compile_and_run, ['-package ghc']) test('SI36', [extra_files(["SI36_A.hs", "SI36_B1.hs", "SI36_B2.hs", "SI36_B3.hs", "SI36_C1.hs", "SI36_C2.hs", "SI36_C3.hs"])], multimod_compile_fail, ['SI36', '-v0']) +test('T26087', [], multimod_compile_fail, ['T26087A', '']) ===================================== 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/-/compare/6e97e52bd33432a41c9257e5098248b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6e97e52bd33432a41c9257e5098248b... You're receiving this email because of your account on gitlab.haskell.org.