diff --git a/base.cabal b/base.cabal --- a/base.cabal +++ b/base.cabal @@ -4,7 +4,7 @@ -- Make sure you are editing ghc-experimental.cabal.in, not ghc-experimental.cabal name: base -version: 4.20.2.0 +version: 4.22.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause @@ -23,14 +23,14 @@ [Set](https://hackage.haskell.org/package/containers/docs/Data-Set.html) are available in the [containers](https://hackage.haskell.org/package/containers) library. To work with textual data, use the [text](https://hackage.haskell.org/package/text/docs/Data-Text.html) library. -extra-source-files: +extra-doc-files: changelog.md Library default-language: Haskell2010 default-extensions: NoImplicitPrelude build-depends: - ghc-internal == 9.1003.*, + ghc-internal == 9.1401.*, ghc-prim, exposed-modules: @@ -46,8 +46,10 @@ , Data.Bifoldable1 , Data.Bifunctor , Data.Bitraversable + , Data.Bounded , Data.Char , Data.Complex + , Data.Enum , Data.Fixed , Data.Foldable1 , Data.Functor.Classes @@ -95,7 +97,6 @@ , Data.Dynamic , Data.Either , Data.Eq - , Data.Enum , Data.Foldable , Data.Function , Data.Functor @@ -169,7 +170,6 @@ , GHC.Exception , GHC.Exception.Type , GHC.ExecutionStack - , GHC.ExecutionStack.Internal , GHC.Exts , GHC.Fingerprint , GHC.Fingerprint.Type @@ -219,9 +219,11 @@ , GHC.MVar , GHC.Natural , GHC.Num + , GHC.Num.Integer + , GHC.Num.Natural + , GHC.Num.BigNat , GHC.OldList , GHC.OverloadedLabels - , GHC.Pack , GHC.Profiling , GHC.Ptr , GHC.Read @@ -244,9 +246,7 @@ , GHC.TopHandler , GHC.TypeError , GHC.TypeLits - , GHC.TypeLits.Internal , GHC.TypeNats - , GHC.TypeNats.Internal , GHC.Unicode , GHC.Weak , GHC.Weak.Finalize @@ -271,14 +271,7 @@ , Type.Reflection , Type.Reflection.Unsafe , Unsafe.Coerce - -- TODO: remove - , GHC.IOPort - reexported-modules: - GHC.Num.Integer - , GHC.Num.Natural - , GHC.Num.BigNat - if os(windows) exposed-modules: GHC.IO.Encoding.CodePage.API @@ -323,9 +316,5 @@ System.CPUTime.Posix.ClockGetTime System.CPUTime.Posix.Times System.CPUTime.Posix.RUsage - - -- We need to set the unit id to base (without a version number) - -- as it's magic. - ghc-options: -this-unit-id base hs-source-dirs: src diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,22 +1,87 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) -## 4.20.2 *July 2025* +## 4.22.0.0 *December 2025* + * 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)) + * Modify the implementation of `Control.Exception.throw` to avoid call-sites being inferred as diverging via precise exception. + ([GHC #25066](https://gitlab.haskell.org/ghc/ghc/-/issues/25066), [CLC proposal #290](https://github.com/haskell/core-libraries-committee/issues/290)) + * `Data.List.NonEmpty.{init,last,tails1}` are now defined using only total functions (rather than partial ones). ([CLC proposal #293](https://github.com/haskell/core-libraries-committee/issues/293)) + * `Data.List.NonEmpty` functions now have the same laziness as their `Data.List` counterparts (i.e. make them more strict than they currently are) ([CLC proposal #107](https://github.com/haskell/core-libraries-committee/issues/107)) + * `instance Functor NonEmpty` is now specified using `map` (rather than duplicating code). ([CLC proposal #300](https://github.com/haskell/core-libraries-committee/issues/300)) + * `fail` from `MonadFail` now carries `HasCallStack` constraint. ([CLC proposal #327](https://github.com/haskell/core-libraries-committee/issues/327)) + * The `Data.Enum.enumerate` function was introduced ([CLC #306](https://github.com/haskell/core-libraries-committee/issues/306)) + * Worker threads used by various `base` facilities are now labelled with descriptive thread labels ([CLC proposal #305](https://github.com/haskell/core-libraries-committee/issues/305), [GHC #25452](https://gitlab.haskell.org/ghc/ghc/-/issues/25452)). Specifically, these include: + * `Control.Concurrent.threadWaitRead` + * `Control.Concurrent.threadWaitWrite` + * `Control.Concurrent.threadWaitReadSTM` + * `Control.Concurrent.threadWaitWriteSTM` + * `System.Timeout.timeout` + * `GHC.Conc.Signal.runHandlers` + * The following internal modules have been removed from `base`, as per [CLC #217](https://github.com/haskell/core-libraries-committee/issues/217): + * `GHC.TypeLits.Internal` + * `GHC.TypeNats.Internal` + * `GHC.ExecutionStack.Internal`. + * Deprecate `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329) * Fix incorrect results of `integerPowMod` when the base is 0 and the exponent is negative, and `integerRecipMod` when the modulus is zero ([#26017](https://gitlab.haskell.org/ghc/ghc/-/issues/26017)). - * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350)) + * Fix the rewrite rule for `scanl'` not being strict in the first element of the output list ([#26143](https://gitlab.haskell.org/ghc/ghc/-/issues/26143)). + * `GHC.Exts.IOPort#` and its related operations have been removed ([CLC #213](https://github.com/haskell/core-libraries-committee/issues/213)) + * Remove deprecated, unstable heap representation details from `GHC.Exts` ([CLC proposal #212](https://github.com/haskell/core-libraries-committee/issues/212)) -## 4.20.1 *Jan 2025* - * Shipped with GHC 9.10.2 +## 4.21.0.0 *December 2024* + * Shipped with GHC 9.12.1 + * Change `SrcLoc` to be a strict and unboxed (finishing [CLC proposal #55](https://github.com/haskell/core-libraries-committee/issues/55)) + * Introduce `Data.Bounded` module exporting the `Bounded` typeclass (finishing [CLC proposal #208](https://github.com/haskell/core-libraries-committee/issues/208)) + * Deprecate export of `Bounded` class from `Data.Enum` ([CLC proposal #208](https://github.com/haskell/core-libraries-committee/issues/208)) + * `GHC.Desugar` has been deprecated and should be removed in GHC 9.14. ([CLC proposal #216](https://github.com/haskell/core-libraries-committee/issues/216)) + * Add a `readTixFile` field to the `HpcFlags` record in `GHC.RTS.Flags` ([CLC proposal #276](https://github.com/haskell/core-libraries-committee/issues/276)) + * Add `compareLength` to `Data.List` and `Data.List.NonEmpty` ([CLC proposal #257](https://github.com/haskell/core-libraries-committee/issues/257)) + * Add `INLINE[1]` to `compareInt` / `compareWord` ([CLC proposal #179](https://github.com/haskell/core-libraries-committee/issues/179)) + * Refactor `GHC.RTS.Flags` in preparation for new I/O managers: introduce `data IoManagerFlag` and use it in `MiscFlags`, remove `getIoManagerFlag`, deprecate re-export of `IoSubSystem` ([CLC proposal #263](https://github.com/haskell/core-libraries-committee/issues/263)) + * Add the `MonadFix` instance for `(,) a`, similar to the one for `Writer a` ([CLC proposal #238](https://github.com/haskell/core-libraries-committee/issues/238)) + * Improve `toInteger :: Word32 -> Integer` on 64-bit platforms ([CLC proposal #259](https://github.com/haskell/core-libraries-committee/issues/259)) + * Make `flip` representation polymorphic ([CLC proposal #245](https://github.com/haskell/core-libraries-committee/issues/245)) + * The `HasField` class now supports representation polymorphism ([CLC proposal #194](https://github.com/haskell/core-libraries-committee/issues/194)) + * Make `read` accept binary integer notation ([CLC proposal #177](https://github.com/haskell/core-libraries-committee/issues/177)) + * Improve the performance of `Data.List.sort` using an improved merging strategy. Instead of `compare`, `sort` now uses `(>)` which may break *malformed* `Ord` instances ([CLC proposal #236](https://github.com/haskell/core-libraries-committee/issues/236)) + * Add `inits1` and `tails1` to `Data.List`, factored from the corresponding functions in `Data.List.NonEmpty` ([CLC proposal #252](https://github.com/haskell/core-libraries-committee/issues/252)) + * Add `firstA` and `secondA` to `Data.Bitraversable`. ([CLC proposal #172](https://github.com/haskell/core-libraries-committee/issues/172)) + * Deprecate `GHC.TypeNats.Internal`, `GHC.TypeLits.Internal`, `GHC.ExecutionStack.Internal` ([CLC proposal #217](https://github.com/haskell/core-libraries-committee/issues/217)) + * `System.IO.Error.ioError` and `Control.Exception.ioError` now both carry `HasCallStack` constraints ([CLC proposal #275](https://github.com/haskell/core-libraries-committee/issues/275)) + * Define `Eq1`, `Ord1`, `Show1` and `Read1` instances for basic `Generic` representation types. ([CLC proposal #273](https://github.com/haskell/core-libraries-committee/issues/273)) * `setNonBlockingMode` will no longer throw an exception when called on a FD associated with a unknown device type. ([CLC proposal #282](https://github.com/haskell/core-libraries-committee/issues/282)) + * Add exception type metadata to default exception handler output. + ([CLC proposal #231](https://github.com/haskell/core-libraries-committee/issues/231) + and [CLC proposal #261](https://github.com/haskell/core-libraries-committee/issues/261)) + * The [deprecation process of GHC.Pack](https://gitlab.haskell.org/ghc/ghc/-/issues/21461) has come its term. The module has now been removed from `base`. * Propagate HasCallStack from `errorCallWithCallStackException` to exception backtraces, fixing a bug in the implementation of [CLC proposal #164](https://github.com/haskell/core-libraries-committee/issues/164). - * Modify the implementation of `Control.Exception.throw` to avoid call-sites being inferred as diverging via precise exception. - ([GHC #25066](https://gitlab.haskell.org/ghc/ghc/-/issues/25066), [CLC proposal #290](https://github.com/haskell/core-libraries-committee/issues/290)) - -## 4.20.0.1 *May 2024* - * Not shipped with any GHC: This is a documentation only release to fix various issues with base-4.20.0.0 docs due to the GHC internal split - * For an accounting of the issues fixed, see [#24875](https://gitlab.haskell.org/ghc/ghc/-/issues/24875) + * Annotate re-thrown exceptions with the backtrace as per [CLC proposal #202](https://github.com/haskell/core-libraries-committee/issues/202) (introduces `WhileHandling` and modifies such as `catch` and `onException` accordingly to propagate or rethrow exceptions) + * Introduced `catchNoPropagate`, `rethrowIO` and `tryWithContext` as part of + [CLC proposal #202](https://github.com/haskell/core-libraries-committee/issues/202) to + facilitate *re*throwing exceptions without adding a `WhileHandling` + context -- if *re*throwing `e`, you don't want to add `WhileHandling e` to + the context since it will be redundant. These functions are mostly useful + for libraries that define exception-handling combinators like `catch` and + `onException`, such as `base`, or the `exceptions` package. + * Move `Lift ByteArray` and `Lift Fixed` instances into `base` from `template-haskell`. See [CLC proposal #287](https://github.com/haskell/core-libraries-committee/issues/287). + * Make `Debug.Trace.{traceEventIO,traceMarkerIO}` faster when tracing is disabled. See [CLC proposal #291](https://github.com/haskell/core-libraries-committee/issues/291). + * The exception messages were improved according to [CLC proposal #285](https://github.com/haskell/core-libraries-committee/issues/285). In particular: + * Improve the message of the uncaught exception handler + * Make `displayException (SomeException e) = displayException e`. The + additional information that is printed when exceptions are surfaced to + the top-level is added by `uncaughtExceptionHandler`. + * Get rid of the HasCallStack mechanism manually propagated by `ErrorCall` + in favour of the more general HasCallStack exception backtrace + mechanism, to remove duplicate call stacks for uncaught exceptions. + * Freeze the callstack of `error`, `undefined`, `throwIO`, `ioException`, + `ioError` to prevent leaking the implementation of these error functions + into the callstack. ## 4.20.0.0 *May 2024* * Shipped with GHC 9.10.1 + * Introduce `Data.Enum` module exporting both `Enum` and `Bounded`. Note that the export of `Bounded` will be deprecated in a future release ([CLC proposal #208](https://github.com/haskell/core-libraries-committee/issues/208)) * Deprecate `GHC.Pack` ([#21461](https://gitlab.haskell.org/ghc/ghc/-/issues/21461)) * Export `foldl'` from `Prelude` ([CLC proposal #167](https://github.com/haskell/core-libraries-committee/issues/167)) * The top-level handler for uncaught exceptions now displays the output of `displayException` rather than `show` ([CLC proposal #198](https://github.com/haskell/core-libraries-committee/issues/198)) @@ -28,11 +93,12 @@ * Implement `sconcat` for `instance Semigroup Data.Semigroup.First` and `instance Semigroup Data.Monoid.First` explicitly, increasing laziness ([CLC proposal #246](https://github.com/haskell/core-libraries-committee/issues/246)) * Add laws relating between `Foldable` / `Traversable` with `Bifoldable` / `Bitraversable` ([CLC proposal #205](https://github.com/haskell/core-libraries-committee/issues/205)) * The `Enum Int64` and `Enum Word64` instances now use native operations on 32-bit platforms, increasing performance by up to 1.5x on i386 and up to 5.6x with the JavaScript backend. ([CLC proposal #187](https://github.com/haskell/core-libraries-committee/issues/187)) - * Exceptions can now be decorated with user-defined annotations via `ExceptionContext`. + * Exceptions can now be decorated with user-defined annotations via `ExceptionContext` ([CLC proposal #200](https://github.com/haskell/core-libraries-committee/issues/200)) * Exceptions now capture backtrace information via their `ExceptionContext`. GHC supports several mechanisms by which backtraces can be collected which can be individually enabled and disabled via - `GHC.Exception.Backtrace.setBacktraceMechanismState`. + `GHC.Exception.Backtrace.setBacktraceMechanismState` ([CLC proposal #199](https://github.com/haskell/core-libraries-committee/issues/199)) + * Add `HasCallStack` constraint to `Control.Exception.throw{,IO}` ([CLC proposal #201](https://github.com/haskell/core-libraries-committee/issues/201)) * Update to [Unicode 15.1.0](https://www.unicode.org/versions/Unicode15.1.0/). * Fix `withFile`, `withFileBlocking`, and `withBinaryFile` to not incorrectly annotate exceptions raised in wrapped computation. ([CLC proposal #237](https://github.com/haskell/core-libraries-committee/issues/237)) * Fix `fdIsNonBlocking` to always be `0` for regular files and block devices on unix, regardless of `O_NONBLOCK` @@ -49,7 +115,6 @@ * Implement `many` and `some` methods of `instance Alternative (Compose f g)` explicitly. ([CLC proposal #181](https://github.com/haskell/core-libraries-committee/issues/181)) * Change the types of the `GHC.Stack.StackEntry.closureType` and `GHC.InfoProv.InfoProv.ipDesc` record fields to use `GHC.Exts.Heap.ClosureType` rather than an `Int`. To recover the old value use `fromEnum`. ([CLC proposal #210](https://github.com/haskell/core-libraries-committee/issues/210)) - * The functions `GHC.Exts.dataToTag#` and `GHC.Base.getTag` have had their types changed to the following: @@ -64,22 +129,23 @@ matches a `data` or `data instance` declaration) with all of its constructors in scope and the levity of `t` is statically known, then the constraint `DataToTag t` can always be solved. + ([CLC proposal #104](https://github.com/haskell/core-libraries-committee/issues/104)) * `GHC.Exts` no longer exports the GHC-internal `whereFrom#` primop ([CLC proposal #214](https://github.com/haskell/core-libraries-committee/issues/214)) * `GHC.InfoProv.InfoProv` now provides a `ipUnitId :: String` field encoding the unit ID of the unit defining the info table ([CLC proposal #214](https://github.com/haskell/core-libraries-committee/issues/214)) - - ([CLC proposal #104](https://github.com/haskell/core-libraries-committee/issues/104)) * Add `sortOn` to `Data.List.NonEmpty` ([CLC proposal #227](https://github.com/haskell/core-libraries-committee/issues/227)) - * Add more instances for `Compose`: `Fractional`, `RealFrac`, `Floating`, `RealFloat` ([CLC proposal #226](https://github.com/haskell/core-libraries-committee/issues/226)) - * Treat all FDs as "nonblocking" on wasm32 ([CLC proposal #234](https://github.com/haskell/core-libraries-committee/issues/234)) - * Add `HeapByEra`, `eraSelector` and `automaticEraIncrement` to `GHC.RTS.Flags` to reflect the new RTS flags: `-he` profiling mode, `-he` selector and `--automatic-era-increment`. ([CLC proposal #254](https://github.com/haskell/core-libraries-committee/issues/254)) + * Document that certain modules are unstable and not meant to be consumed by the general public ([CLC proposal #146](https://github.com/haskell/core-libraries-committee/issues/146)) + * Add unaligned `Addr#` primops ([CLC proposal #154](https://github.com/haskell/core-libraries-committee/issues/154)) + * Deprecate `stgDoubleToWord{32,64}` and `stgWord{32,64}ToDouble` in favor of new primops `castDoubleToWord{32,64}#` and `castWord{32,64}ToDouble#` ([CLC proposal #253](https://github.com/haskell/core-libraries-committee/issues/253)) + * Add `unsafeThawByteArray#`, opposite to the existing `unsafeFreezeByteArray#` ([CLC proposal #184](https://github.com/haskell/core-libraries-committee/issues/184)) ## 4.19.0.0 *October 2023* + * Shipped with GHC 9.8.1 * Add `{-# WARNING in "x-partial" #-}` to `Data.List.{head,tail}`. Use `{-# OPTIONS_GHC -Wno-x-partial #-}` to disable it. ([CLC proposal #87](https://github.com/haskell/core-libraries-committee/issues/87) and [#114](https://github.com/haskell/core-libraries-committee/issues/114)) @@ -110,12 +176,15 @@ * Add more instances for `Compose`: `Enum`, `Bounded`, `Num`, `Real`, `Integral` ([CLC proposal #160](https://github.com/haskell/core-libraries-committee/issues/160)) * Make `(&)` representation polymorphic in the return type ([CLC proposal #158](https://github.com/haskell/core-libraries-committee/issues/158)) * Implement `GHC.IORef.atomicSwapIORef` via a new dedicated primop `atomicSwapMutVar#` ([CLC proposal #139](https://github.com/haskell/core-libraries-committee/issues/139)) - * Change `BufferCodec` to use an unboxed implementation, while providing a compatibility layer using pattern synonyms. ([CLC proposal #134](https://github.com/haskell/core-libraries-committee/issues/134)) + * Change `BufferCodec` to use an unboxed implementation, while providing a compatibility layer using pattern synonyms. ([CLC proposal #134](https://github.com/haskell/core-libraries-committee/issues/134) and [#178](https://github.com/haskell/core-libraries-committee/issues/178)) * Add nominal role annotations to `SNat` / `SSymbol` / `SChar` ([CLC proposal #170](https://github.com/haskell/core-libraries-committee/issues/170)) * Make `Semigroup`'s `stimes` specializable. ([CLC proposal #8](https://github.com/haskell/core-libraries-committee/issues/8)) * Implement `copyBytes`, `fillBytes`, `moveBytes` and `stimes` for `Data.Array.Byte.ByteArray` using primops ([CLC proposal #188](https://github.com/haskell/core-libraries-committee/issues/188)) * Add rewrite rules for conversion between `Int64` / `Word64` and `Float` / `Double` on 64-bit architectures ([CLC proposal #203](https://github.com/haskell/core-libraries-committee/issues/203)). * `Generic` instances for tuples now expose `Unit`, `Tuple2`, `Tuple3`, ..., `Tuple64` as the actual names for tuple type constructors ([GHC proposal #475](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0475-tuple-syntax.rst)). + * Reject `FilePath`s containing interior `NUL`s ([CLC proposal #144](https://github.com/haskell/core-libraries-committee/issues/144)) + * Add `GHC.JS.Foreign.Callback` module for JavaScript backend ([CLC proposal #150](https://github.com/haskell/core-libraries-committee/issues/150)) + * Generalize the type of `keepAlive#` and `touch#` ([CLC proposal #152](https://github.com/haskell/core-libraries-committee/issues/152)) ## 4.18.0.0 *March 2023* * Shipped with GHC 9.6.1 @@ -247,29 +316,29 @@ * Re-export the `IsList` typeclass from the new `GHC.IsList` module. - * There's a new special function ``withDict`` in ``GHC.Exts``: :: + * There's a new special function `withDict` in `GHC.Exts`: :: withDict :: forall {rr :: RuntimeRep} cls meth (r :: TYPE rr). WithDict cls meth => meth -> (cls => r) -> r - where ``cls`` must be a class containing exactly one method, whose type - must be ``meth``. + where `cls` must be a class containing exactly one method, whose type + must be `meth`. - This function converts ``meth`` to a type class dictionary. - It removes the need for ``unsafeCoerce`` in implementation of reflection + This function converts `meth` to a type class dictionary. + It removes the need for `unsafeCoerce` in implementation of reflection libraries. It should be used with care, because it can introduce incoherent instances. - For example, the ``withTypeable`` function from the - ``Type.Reflection`` module can now be defined as: :: + For example, the `withTypeable` function from the + `Type.Reflection` module can now be defined as: :: withTypeable :: forall k (a :: k) rep (r :: TYPE rep). () => TypeRep a -> (Typeable a => r) -> r withTypeable rep k = withDict @(Typeable a) rep k Note that the explicit type application is required, as the call to - ``withDict`` would be ambiguous otherwise. + `withDict` would be ambiguous otherwise. - This replaces the old ``GHC.Exts.magicDict``, which required + This replaces the old `GHC.Exts.magicDict`, which required an intermediate data type and was less reliable. * `Data.Word.Word64` and `Data.Int.Int64` are now always represented by @@ -287,17 +356,17 @@ * Shipped with GHC 9.2.4 - * winio: make consoleReadNonBlocking not wait for any events at all. + * winio: make `consoleReadNonBlocking` not wait for any events at all. - * winio: Add support to console handles to handleToHANDLE + * winio: Add support to console handles to `handleToHANDLE` ## 4.16.2.0 *May 2022* * Shipped with GHC 9.2.2 - * Export GHC.Event.Internal on Windows (#21245) + * Export `GHC.Event.Internal` on Windows (#21245) - # Documentation Fixes + * Documentation Fixes ## 4.16.1.0 *Feb 2022* @@ -366,7 +435,7 @@ - Newtypes `And`, `Ior`, `Xor` and `Iff` which wrap their argument, and whose `Semigroup` instances are defined using `(.&.)`, `(.|.)`, `xor` - and ```\x y -> complement (x `xor` y)```, respectively. + and `\x y -> complement (x `xor` y)`, respectively. - `oneBits :: FiniteBits a => a`, `oneBits = complement zeroBits`. diff --git a/src/Control/Category.hs b/src/Control/Category.hs --- a/src/Control/Category.hs +++ b/src/Control/Category.hs @@ -11,9 +11,26 @@ -- module Control.Category - ( Category(..) + ( -- * Class + Category(..) + + -- * Combinators , (<<<) , (>>>) + + -- $namingConflicts ) where import GHC.Internal.Control.Category + +-- $namingConflicts +-- +-- == A note on naming conflicts +-- +-- The methods from 'Category' conflict with 'Prelude.id' and 'Prelude..' from the +-- prelude; you will likely want to either import this module qualified, or hide the +-- prelude functions: +-- +-- @ +-- import "Prelude" hiding (id, (.)) +-- @ diff --git a/src/Control/Concurrent.hs b/src/Control/Concurrent.hs --- a/src/Control/Concurrent.hs +++ b/src/Control/Concurrent.hs @@ -265,7 +265,7 @@ -- fdReady does the right thing, but we have to call it in a -- separate thread, otherwise threadWaitRead won't be interruptible, -- and this only works with -threaded. - | threaded = withThread (waitFd fd False) + | threaded = withThread "threadWaitRead worker" (waitFd fd False) | otherwise = case fd of 0 -> do _ <- hWaitForInput stdin (-1) return () @@ -286,7 +286,7 @@ threadWaitWrite :: Fd -> IO () threadWaitWrite fd #if defined(mingw32_HOST_OS) - | threaded = withThread (waitFd fd True) + | threaded = withThread "threadWaitWrite worker" (waitFd fd True) | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows" #else = Conc.threadWaitWrite fd @@ -302,8 +302,11 @@ threadWaitReadSTM fd #if defined(mingw32_HOST_OS) | threaded = do v <- newTVarIO Nothing - mask_ $ void $ forkIO $ do result <- try (waitFd fd False) - atomically (writeTVar v $ Just result) + mask_ $ void $ forkIO $ do + tid <- myThreadId + labelThread tid "threadWaitReadSTM worker" + result <- try (waitFd fd False) + atomically (writeTVar v $ Just result) let waitAction = do result <- readTVar v case result of Nothing -> retry @@ -326,8 +329,11 @@ threadWaitWriteSTM fd #if defined(mingw32_HOST_OS) | threaded = do v <- newTVarIO Nothing - mask_ $ void $ forkIO $ do result <- try (waitFd fd True) - atomically (writeTVar v $ Just result) + mask_ $ void $ forkIO $ do + tid <- myThreadId + labelThread tid "threadWaitWriteSTM worker" + result <- try (waitFd fd True) + atomically (writeTVar v $ Just result) let waitAction = do result <- readTVar v case result of Nothing -> retry @@ -343,10 +349,14 @@ #if defined(mingw32_HOST_OS) foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool -withThread :: IO a -> IO a -withThread io = do +withThread :: String -> IO a -> IO a +withThread label io = do m <- newEmptyMVar - _ <- mask_ $ forkIO $ try io >>= putMVar m + _ <- mask_ $ forkIO $ do + tid <- myThreadId + labelThread tid label + result <- try io + putMVar m result x <- takeMVar m case x of Right a -> return a diff --git a/src/Control/Exception.hs b/src/Control/Exception.hs --- a/src/Control/Exception.hs +++ b/src/Control/Exception.hs @@ -37,7 +37,10 @@ addExceptionContext, someExceptionContext, annotateIO, + NoBacktrace(..), ExceptionWithContext(..), + WhileHandling(..), + -- * Concrete exception types IOException, ArithException(..), @@ -65,6 +68,7 @@ -- * Throwing exceptions throw, throwIO, + rethrowIO, ioError, throwTo, -- * Catching Exceptions @@ -73,6 +77,7 @@ -- $catchall -- ** The @catch@ functions catch, + catchNoPropagate, catches, Handler(..), catchJust, @@ -81,6 +86,7 @@ handleJust, -- ** The @try@ functions try, + tryWithContext, tryJust, -- ** The @evaluate@ function evaluate, @@ -110,12 +116,14 @@ bracket_, bracketOnError, finally, - onException + onException, + -- ** Printing + displayExceptionWithInfo + ) where import GHC.Internal.Control.Exception import GHC.Internal.Exception.Type -import GHC.Internal.IO (annotateIO) {- $catching diff --git a/src/Control/Monad/Fix.hs b/src/Control/Monad/Fix.hs --- a/src/Control/Monad/Fix.hs +++ b/src/Control/Monad/Fix.hs @@ -10,11 +10,108 @@ -- Stability : stable -- Portability : portable -- --- Monadic fixpoints. +-- Monadic fixpoints, used for desugaring of @{-# LANGUAGE RecursiveDo #-}@. -- --- For a detailed discussion, see Levent Erkok's thesis, --- /Value Recursion in Monadic Computations/, Oregon Graduate Institute, 2002. +-- Consider the generalized version of so-called @repmin@ +-- (/replace with minimum/) problem: +-- accumulate elements of a container into a 'Monoid' +-- and modify each element using the final accumulator. -- +-- @ +-- repmin +-- :: (Functor t, Foldable t, Monoid b) +-- => (a -> b) -> (a -> b -> c) -> t a -> t c +-- repmin f g as = fmap (\`g\` foldMap f as) as +-- @ +-- +-- The naive implementation as above makes two traversals. Can we do better +-- and achieve the goal in a single pass? It's seemingly impossible, because we would +-- have to know the future, +-- but lazy evaluation comes to the rescue: +-- +-- @ +-- import Data.Traversable (mapAccumR) +-- +-- repmin +-- :: (Traversable t, Monoid b) +-- => (a -> b) -> (a -> b -> c) -> t a -> t c +-- repmin f g as = +-- let (b, cs) = mapAccumR (\\acc a -> (f a <> acc, g a b)) mempty as in cs +-- @ +-- +-- How can we check that @repmin@ indeed traverses only once? +-- Let's run it on an infinite input: +-- +-- >>> import Data.Monoid (All(..)) +-- >>> take 3 $ repmin All (const id) ([True, True, False] ++ undefined) +-- [All {getAll = False},All {getAll = False},All {getAll = False}] +-- +-- So far so good, but can we generalise @g@ to return a monadic value @a -> b -> m c@? +-- The following does not work, complaining that @b@ is not in scope: +-- +-- @ +-- import Data.Traversable (mapAccumM) +-- +-- repminM +-- :: (Traversable t, Monoid b, Monad m) +-- => (a -> b) -> (a -> b -> m c) -> t a -> m (t c) +-- repminM f g as = do +-- (b, cs) \<- mapAccumM (\\acc a -> (f a <> acc,) \<$\> g a b) mempty as +-- pure cs +-- @ +-- +-- To solve the riddle, let's rewrite @repmin@ via 'fix': +-- +-- @ +-- repmin +-- :: (Traversable t, Monoid b) +-- => (a -> b) -> (a -> b -> c) -> t a -> t c +-- repmin f g as = snd $ fix $ +-- \\(b, cs) -> mapAccumR (\\acc a -> (f a <> acc, g a b)) mempty as +-- @ +-- +-- Now we can replace 'fix' with 'mfix' to obtain the solution: +-- +-- @ +-- repminM +-- :: (Traversable t, Monoid b, MonadFix m) +-- => (a -> b) -> (a -> b -> m c) -> t a -> m (t c) +-- repminM f g as = fmap snd $ mfix $ +-- \\(~(b, cs)) -> mapAccumM (\\acc a -> (f a <> acc,) \<$\> g a b) mempty as +-- @ +-- +-- For example, +-- +-- >>> import Data.Monoid (Sum(..)) +-- >>> repminM Sum (\a b -> print a >> pure (a + getSum b)) [3, 5, 2] +-- 3 +-- 5 +-- 2 +-- [13,15,12] +-- +-- Incredibly, GHC is capable to do this transformation automatically, +-- when @{-# LANGUAGE RecursiveDo #-}@ is enabled. Namely, the following +-- implementation of @repminM@ works (note @mdo@ instead of @do@): +-- +-- @ +-- {-# LANGUAGE RecursiveDo #-} +-- +-- repminM +-- :: (Traversable t, Monoid b, MonadFix m) +-- => (a -> b) -> (a -> b -> m c) -> t a -> m (t c) +-- repminM f g as = mdo +-- (b, cs) \<- mapAccumM (\\acc a -> (f a <> acc,) \<$\> g a b) mempty as +-- pure cs +-- @ +-- +-- Further reading: +-- +-- * GHC User’s Guide, The recursive do-notation. +-- * Haskell Wiki, . +-- * Levent Erkök, , Oregon Graduate Institute, 2002. +-- * Levent Erkök, John Launchbury, , Haskell '02, 29-37, 2002. +-- * Richard S. Bird, , Acta Informatica 21, 239-250, 1984. +-- * Jasper Van der Jeugt, , 2023. module Control.Monad.Fix (MonadFix(mfix), diff --git a/src/Control/Monad/IO/Class.hs b/src/Control/Monad/IO/Class.hs --- a/src/Control/Monad/IO/Class.hs +++ b/src/Control/Monad/IO/Class.hs @@ -14,61 +14,8 @@ -- Class of monads based on @IO@. ----------------------------------------------------------------------------- -module Control.Monad.IO.Class ( - MonadIO(..) - ) where - -import GHC.Internal.Base - --- | Monads in which 'IO' computations may be embedded. --- Any monad built by applying a sequence of monad transformers to the --- 'IO' monad will be an instance of this class. --- --- Instances should satisfy the following laws, which state that 'liftIO' --- is a transformer of monads: --- --- * @'liftIO' . 'return' = 'return'@ --- --- * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@ - -class (Monad m) => MonadIO m where - -- | Lift a computation from the 'IO' monad. - -- This allows us to run IO computations in any monadic stack, so long as it supports these kinds of operations - -- (i.e. 'IO' is the base monad for the stack). - -- - -- === __Example__ - -- - -- - -- > import Control.Monad.Trans.State -- from the "transformers" library - -- > - -- > printState :: Show s => StateT s IO () - -- > printState = do - -- > state <- get - -- > liftIO $ print state - -- - -- - -- Had we omitted @'liftIO'@, we would have ended up with this error: - -- - -- > • Couldn't match type ‘IO’ with ‘StateT s IO’ - -- > Expected type: StateT s IO () - -- > Actual type: IO () - -- - -- The important part here is the mismatch between @StateT s IO ()@ and @'IO' ()@. - -- - -- Luckily, we know of a function that takes an @'IO' a@ and returns an @(m a)@: @'liftIO'@, - -- enabling us to run the program and see the expected results: - -- - -- @ - -- > evalStateT printState "hello" - -- "hello" - -- - -- > evalStateT printState 3 - -- 3 - -- @ - -- - liftIO :: IO a -> m a - --- | @since 4.9.0.0 -instance MonadIO IO where - liftIO = id +module Control.Monad.IO.Class + ( MonadIO(..) ) + where +import GHC.Internal.Control.Monad.IO.Class diff --git a/src/Control/Monad/Zip.hs b/src/Control/Monad/Zip.hs --- a/src/Control/Monad/Zip.hs +++ b/src/Control/Monad/Zip.hs @@ -16,125 +16,6 @@ -- ----------------------------------------------------------------------------- -module Control.Monad.Zip where - -import GHC.Internal.Control.Monad (liftM, liftM2) -import GHC.Internal.Data.Functor.Identity -import qualified GHC.Internal.Data.Functor -import GHC.Internal.Data.Monoid -import GHC.Internal.Data.Ord ( Down(..) ) -import GHC.Internal.Data.Proxy -import qualified Data.List.NonEmpty as NE -import GHC.Generics -import GHC.Tuple (Solo (..)) -import Prelude - --- | Instances should satisfy the laws: --- --- [Naturality] --- --- @'liftM' (f 'Control.Arrow.***' g) ('mzip' ma mb) --- = 'mzip' ('liftM' f ma) ('liftM' g mb)@ --- --- [Information Preservation] --- --- @'liftM' ('Prelude.const' ()) ma = 'liftM' ('Prelude.const' ()) mb@ --- implies --- @'munzip' ('mzip' ma mb) = (ma, mb)@ --- -class Monad m => MonadZip m where - {-# MINIMAL mzip | mzipWith #-} - - mzip :: m a -> m b -> m (a,b) - mzip = mzipWith (,) - - mzipWith :: (a -> b -> c) -> m a -> m b -> m c - mzipWith f ma mb = liftM (uncurry f) (mzip ma mb) - - munzip :: m (a,b) -> (m a, m b) - munzip mab = (liftM fst mab, liftM snd mab) - -- munzip is a member of the class because sometimes - -- you can implement it more efficiently than the - -- above default code. See #4370 comment by giorgidze - --- | @since 4.3.1.0 -instance MonadZip [] where - mzip = zip - mzipWith = zipWith - munzip = unzip - --- | @since 4.9.0.0 -instance MonadZip NE.NonEmpty where - mzip = NE.zip - mzipWith = NE.zipWith - munzip = GHC.Internal.Data.Functor.unzip - --- | @since 4.8.0.0 -instance MonadZip Identity where - mzipWith = liftM2 - munzip (Identity (a, b)) = (Identity a, Identity b) - --- | @since 4.15.0.0 -instance MonadZip Solo where - mzipWith = liftM2 - munzip (MkSolo (a, b)) = (MkSolo a, MkSolo b) - --- | @since 4.8.0.0 -instance MonadZip Dual where - -- Cannot use coerce, it's unsafe - mzipWith = liftM2 - --- | @since 4.8.0.0 -instance MonadZip Sum where - mzipWith = liftM2 - --- | @since 4.8.0.0 -instance MonadZip Product where - mzipWith = liftM2 - --- | @since 4.8.0.0 -instance MonadZip Maybe where - mzipWith = liftM2 - --- | @since 4.8.0.0 -instance MonadZip First where - mzipWith = liftM2 - --- | @since 4.8.0.0 -instance MonadZip Last where - mzipWith = liftM2 - --- | @since 4.8.0.0 -instance MonadZip f => MonadZip (Alt f) where - mzipWith f (Alt ma) (Alt mb) = Alt (mzipWith f ma mb) - --- | @since 4.9.0.0 -instance MonadZip Proxy where - mzipWith _ _ _ = Proxy - --- Instances for GHC.Generics --- | @since 4.9.0.0 -instance MonadZip U1 where - mzipWith _ _ _ = U1 - --- | @since 4.9.0.0 -instance MonadZip Par1 where - mzipWith = liftM2 - --- | @since 4.9.0.0 -instance MonadZip f => MonadZip (Rec1 f) where - mzipWith f (Rec1 fa) (Rec1 fb) = Rec1 (mzipWith f fa fb) - --- | @since 4.9.0.0 -instance MonadZip f => MonadZip (M1 i c f) where - mzipWith f (M1 fa) (M1 fb) = M1 (mzipWith f fa fb) - --- | @since 4.9.0.0 -instance (MonadZip f, MonadZip g) => MonadZip (f :*: g) where - mzipWith f (x1 :*: y1) (x2 :*: y2) = mzipWith f x1 x2 :*: mzipWith f y1 y2 - --- instances for GHC.Internal.Data.Ord +module Control.Monad.Zip ( MonadZip(..) ) where --- | @since 4.12.0.0 -instance MonadZip Down where - mzipWith = liftM2 +import GHC.Internal.Control.Monad.Zip(MonadZip(..)) diff --git a/src/Data/Array/Byte.hs b/src/Data/Array/Byte.hs --- a/src/Data/Array/Byte.hs +++ b/src/Data/Array/Byte.hs @@ -13,6 +13,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE TemplateHaskellQuotes #-} module Data.Array.Byte ( ByteArray(..), @@ -30,6 +31,9 @@ import GHC.Internal.Show (intToDigit) import GHC.Internal.ST (ST(..), runST) import GHC.Internal.Word (Word8(..)) +import GHC.Internal.TH.Syntax +import GHC.Internal.TH.Lift +import GHC.Internal.ForeignPtr import Prelude -- | Lifted wrapper for 'ByteArray#'. @@ -41,6 +45,22 @@ -- but wrap and unwrap 'ByteArray' internally as they please -- and use functions from "GHC.Exts". -- +-- The memory representation of a 'ByteArray' is: +-- +-- > ╭─────────────┬───╮ ╭────────┬──────┬─────────╮ +-- > │ Constructor │ * ┼─►│ Header │ Size │ Payload │ +-- > ╰─────────────┴───╯ ╰────────┴──────┴─────────╯ +-- +-- And its overhead is the following: +-- +-- * 'ByteArray' constructor: 1 word +-- * Pointer to 'ByteArray#': 1 word +-- * 'ByteArray#' Header: 1 word +-- * 'ByteArray#' Size: 1 word +-- +-- Where a word is the unit of heap allocation, +-- measuring 8 bytes on 64-bit systems, and 4 bytes on 32-bit systems. +-- -- @since 4.17.0.0 data ByteArray = ByteArray ByteArray# @@ -179,6 +199,34 @@ where comma | i == 0 = id | otherwise = showString ", " + +instance Lift ByteArray where + liftTyped = unsafeCodeCoerce . lift + lift (ByteArray b) = + [| addrToByteArray $(lift len) + $(pure . LitE . BytesPrimL $ Bytes ptr 0 (fromIntegral len)) + |] + where + len# = sizeofByteArray# b + len = I# len# + pb :: ByteArray# + !(ByteArray pb) + | isTrue# (isByteArrayPinned# b) = ByteArray b + | otherwise = runST $ ST $ + \s -> case newPinnedByteArray# len# s of + (# s', mb #) -> case copyByteArray# b 0# mb 0# len# s' of + s'' -> case unsafeFreezeByteArray# mb s'' of + (# s''', ret #) -> (# s''', ByteArray ret #) + ptr :: ForeignPtr Word8 + ptr = ForeignPtr (byteArrayContents# pb) (PlainPtr (unsafeCoerce# pb)) + +{-# NOINLINE addrToByteArray #-} +addrToByteArray :: Int -> Addr# -> ByteArray +addrToByteArray (I# len) addr = runST $ ST $ + \s -> case newByteArray# len s of + (# s', mb #) -> case copyAddrToByteArray# addr mb 0# len s' of + s'' -> case unsafeFreezeByteArray# mb s'' of + (# s''', ret #) -> (# s''', ByteArray ret #) -- | Compare prefixes of given length. compareByteArraysFromBeginning :: ByteArray -> ByteArray -> Int -> Ordering diff --git a/src/Data/Bifoldable.hs b/src/Data/Bifoldable.hs --- a/src/Data/Bifoldable.hs +++ b/src/Data/Bifoldable.hs @@ -238,8 +238,8 @@ -- -- >>> bifoldr (flip const) (:) [] (undefined :: (Int, Word)) `seq` () -- () --- >>> foldr (:) [] (undefined :: (Int, Word)) `seq` () --- *** Exception: Prelude.undefined +-- >>> foldr (:) [] (errorWithoutStackTrace "error!" :: (Int, Word)) `seq` () +-- *** Exception: error! -- -- @since 4.10.0.0 instance Bifoldable (,) where @@ -640,7 +640,13 @@ biconcat :: Bifoldable t => t [a] [a] -> [a] biconcat = bifold --- | The largest element of a non-empty structure. +-- | The largest element of a non-empty structure. This function is equivalent +-- to @'bifoldr1' 'max'@, and its behavior on structures with multiple largest +-- elements depends on the relevant implementation of 'max'. For the default +-- implementation of 'max' (@max x y = if x <= y then y else x@), structure +-- order is used as a tie-breaker: if there are multiple largest elements, the +-- rightmost of them is chosen (this is equivalent to @'bimaximumBy' +-- 'compare'@). -- -- ==== __Examples__ -- @@ -670,7 +676,13 @@ getMax . bifoldMap mj mj where mj = Max #. (Just :: a -> Maybe a) --- | The least element of a non-empty structure. +-- | The least element of a non-empty structure. This function is equivalent to +-- @'bifoldr1' 'min'@, and its behavior on structures with multiple least +-- elements depends on the relevant implementation of 'min'. For the default +-- implementation of 'min' (@min x y = if x <= y then x else y@), structure +-- order is used as a tie-breaker: if there are multiple least elements, the +-- leftmost of them is chosen (this is equivalent to @'biminimumBy' +-- 'compare'@). -- -- ==== __Examples__ -- @@ -927,7 +939,8 @@ biall p q = getAll #. bifoldMap (All . p) (All . q) -- | The largest element of a non-empty structure with respect to the --- given comparison function. +-- given comparison function. Structure order is used as a tie-breaker: if +-- there are multiple largest elements, the rightmost of them is chosen. -- -- ==== __Examples__ -- @@ -956,7 +969,8 @@ _ -> y -- | The least element of a non-empty structure with respect to the --- given comparison function. +-- given comparison function. Structure order is used as a tie-breaker: if +-- there are multiple least elements, the leftmost of them is chosen. -- -- ==== __Examples__ -- diff --git a/src/Data/Bifunctor.hs b/src/Data/Bifunctor.hs --- a/src/Data/Bifunctor.hs +++ b/src/Data/Bifunctor.hs @@ -140,8 +140,8 @@ -- () -- >>> second id (undefined :: (Int, Word)) `seq` () -- () --- >>> id (undefined :: (Int, Word)) `seq` () --- *** Exception: Prelude.undefined +-- >>> id (errorWithoutStackTrace "error!" :: (Int, Word)) `seq` () +-- *** Exception: error! -- -- @since 4.8.0.0 instance Bifunctor (,) where diff --git a/src/Data/Bitraversable.hs b/src/Data/Bitraversable.hs --- a/src/Data/Bitraversable.hs +++ b/src/Data/Bitraversable.hs @@ -18,6 +18,8 @@ , bisequenceA , bisequence , bimapM + , firstA + , secondA , bifor , biforM , bimapAccumL @@ -172,6 +174,60 @@ bisequence :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b) bisequence = bitraverse id id +-- | Traverses only over the first argument. +-- +-- @'firstA' f ≡ 'bitraverse' f 'pure'@ + +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> firstA listToMaybe (Left []) +-- Nothing +-- +-- >>> firstA listToMaybe (Left [1, 2, 3]) +-- Just (Left 1) +-- +-- >>> firstA listToMaybe (Right [4, 5]) +-- Just (Right [4, 5]) +-- +-- >>> firstA listToMaybe ([1, 2, 3], [4, 5]) +-- Just (1,[4, 5]) +-- +-- >>> firstA listToMaybe ([], [4, 5]) +-- Nothing + +-- @since 4.21.0.0 +firstA :: Bitraversable t => Applicative f => (a -> f c) -> t a b -> f (t c b) +firstA f = bitraverse f pure + +-- | Traverses only over the second argument. +-- +-- @'secondA' f ≡ 'bitraverse' 'pure' f@ +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> secondA (find odd) (Left []) +-- Just (Left []) +-- +-- >>> secondA (find odd) (Left [1, 2, 3]) +-- Just (Left [1,2,3]) +-- +-- >>> secondA (find odd) (Right [4, 5]) +-- Just (Right 5) +-- +-- >>> secondA (find odd) ([1, 2, 3], [4, 5]) +-- Just ([1,2,3],5) +-- +-- >>> secondA (find odd) ([1,2,3], [4]) +-- Nothing +-- +-- @since 4.21.0.0 +secondA :: Bitraversable t => Applicative f => (b -> f c) -> t a b -> f (t a c) +secondA f = bitraverse pure f + -- | Class laws for tuples hold only up to laziness. The -- Bitraversable methods are lazier than their Traversable counterparts. -- For example the law @'bitraverse' 'pure' ≡ 'traverse'@ does @@ -179,8 +235,8 @@ -- -- >>> (bitraverse pure pure undefined :: IO (Int, Word)) `seq` () -- () --- >>> (traverse pure undefined :: IO (Int, Word)) `seq` () --- *** Exception: Prelude.undefined +-- >>> (traverse pure (errorWithoutStackTrace "error!") :: IO (Int, Word)) `seq` () +-- *** Exception: error! -- -- @since 4.10.0.0 instance Bitraversable (,) where diff --git a/src/Data/Bounded.hs b/src/Data/Bounded.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bounded.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Bounded +-- Copyright : (c) The University of Glasgow, 1992-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : stable +-- Portability : non-portable (GHC extensions) +-- +-- The 'Bounded' class. +-- +-- @since 4.21.0.0 +-- +----------------------------------------------------------------------------- + +module Data.Bounded + ( Bounded(..) + ) where + +import GHC.Enum + diff --git a/src/Data/Complex.hs b/src/Data/Complex.hs --- a/src/Data/Complex.hs +++ b/src/Data/Complex.hs @@ -47,6 +47,9 @@ infix 6 :+ +-- $setup +-- >>> import Prelude + -- ----------------------------------------------------------------------------- -- The Complex type @@ -62,7 +65,7 @@ -- it holds that @z == 'abs' z * 'signum' z@. -- -- Note that `Complex`'s instances inherit the deficiencies from the type --- parameter's. For example, @Complex Float@'s 'Ord' instance has similar +-- parameter's. For example, @Complex Float@'s 'Eq' instance has similar -- problems to `Float`'s. -- -- As can be seen in the examples, the 'Foldable' @@ -85,6 +88,7 @@ -- >>> mapM print (1 :+ 2) -- 1 -- 2 +-- () :+ () data Complex a = !a :+ !a -- ^ forms a complex number from its real and imaginary -- rectangular components. diff --git a/src/Data/Enum.hs b/src/Data/Enum.hs --- a/src/Data/Enum.hs +++ b/src/Data/Enum.hs @@ -1,7 +1,8 @@ {-# LANGUAGE Safe #-} +{-# LANGUAGE NoImplicitPrelude #-} +----------------------------------------------------------------------------- -- | --- -- Module : Data.Enum -- Copyright : (c) The University of Glasgow, 1992-2002 -- License : see libraries/base/LICENSE @@ -10,12 +11,44 @@ -- Stability : stable -- Portability : non-portable (GHC extensions) -- --- The 'Enum' and 'Bounded' classes. +-- The 'Enum' class. -- +-- @since 4.20.0.0 +-- +----------------------------------------------------------------------------- module Data.Enum - (Bounded(..), - Enum(..) - ) where + ( Enum(..) + , {-# DEPRECATED "Bounded should be imported from Data.Bounded" #-} + Bounded(..) + , enumerate + ) where -import GHC.Internal.Data.Enum +import GHC.Internal.Enum + +-- | Returns a list of all values of an enum type +-- +-- 'enumerate' is often used to list all values of a custom enum data structure, such as a custom Color enum below: +-- +-- @ +-- data Color = Yellow | Red | Blue +-- deriving (Enum, Bounded, Show) +-- +-- allColors :: [Color] +-- allColors = enumerate +-- -- Result: [Yellow, Red, Blue] +-- @ +-- +-- Note that you need to derive the 'Bounded' type class as well, only 'Enum' is not enough. +-- 'Enum' allows for sequential enumeration, while 'Bounded' provides the 'minBound' and 'maxBound' values. +-- +-- 'enumerate' is commonly used together with the TypeApplications syntax. Here is an example of using 'enumerate' to retrieve all values of the 'Ordering' type: +-- +-- >> enumerate @Ordering +-- [LT, EQ, GT] +-- +-- The '@' symbol here is provided by the TypeApplications language extension. +-- +-- @since base-4.22.0.0 +enumerate :: (Enum a, Bounded a) => [a] +enumerate = [minBound .. maxBound] diff --git a/src/Data/Fixed.hs b/src/Data/Fixed.hs --- a/src/Data/Fixed.hs +++ b/src/Data/Fixed.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskellQuotes #-} ----------------------------------------------------------------------------- -- | @@ -90,9 +91,14 @@ import GHC.Internal.Read import GHC.Internal.Text.ParserCombinators.ReadPrec import GHC.Internal.Text.Read.Lex +import qualified GHC.Internal.TH.Syntax as TH +import qualified GHC.Internal.TH.Lift as TH import Data.Typeable import Prelude +-- $setup +-- >>> import Prelude + default () -- avoid any defaulting shenanigans -- | Generalisation of 'div' to any instance of 'Real' @@ -136,6 +142,13 @@ gunfold k z _ = k (z MkFixed) dataTypeOf _ = tyFixed toConstr _ = conMkFixed + +-- | +-- @since template-haskell-2.19.0.0 +-- @since base-4.21.0.0 +instance TH.Lift (Fixed a) where + liftTyped x = TH.unsafeCodeCoerce (TH.lift x) + lift (MkFixed x) = [| MkFixed x |] -- | Types which can be used as a resolution argument to the 'Fixed' type constructor must implement the 'HasResolution' typeclass. class HasResolution (a :: k) where diff --git a/src/Data/Foldable.hs b/src/Data/Foldable.hs --- a/src/Data/Foldable.hs +++ b/src/Data/Foldable.hs @@ -98,6 +98,10 @@ import GHC.Internal.Data.Foldable +-- $setup +-- >>> import Prelude +-- >>> import qualified Data.List as List + -- $overview -- -- #overview# @@ -141,7 +145,7 @@ -- -- >>> foldl' (+) 0 [1..100] -- 5050 --- >>> foldr (&&) True (repeat False) +-- >>> foldr (&&) True (List.repeat False) -- False -- -- The first argument of both is an explicit /operator/ that merges the @@ -405,7 +409,7 @@ -- segment. -- -- >>> myconcat = foldr (\x z -> foldr (:) z x) [] --- >>> take 15 $ myconcat $ map (\i -> [0..i]) [0..] +-- >>> List.take 15 $ myconcat $ List.map (\i -> [0..i]) [0..] -- [0,0,1,0,1,2,0,1,2,3,0,1,2,3,4] -- -- Of course in this case another way to achieve the same result is via a @@ -536,13 +540,13 @@ -- then the evaluated effects will be from an initial portion of the -- element sequence. -- --- >>> :set -XBangPatterns --- >>> import Control.Monad --- >>> import Control.Monad.Trans.Class --- >>> import Control.Monad.Trans.Maybe --- >>> import Data.Foldable --- >>> let f !_ e = when (e > 3) mzero >> lift (print e) --- >>> runMaybeT $ foldlM f () [0..] +-- > :set -XBangPatterns +-- > import Control.Monad +-- > import Control.Monad.Trans.Class +-- > import Control.Monad.Trans.Maybe +-- > import Data.Foldable +-- > let f !_ e = when (e > 3) mzero >> lift (print e) +-- > runMaybeT $ foldlM f () [0..] -- 0 -- 1 -- 2 @@ -553,16 +557,16 @@ -- to left, and therefore diverges when folding an unbounded input -- structure without ever having the opportunity to short-circuit. -- --- >>> let f e _ = when (e > 3) mzero >> lift (print e) --- >>> runMaybeT $ foldrM f () [0..] +-- > let f e _ = when (e > 3) mzero >> lift (print e) +-- > runMaybeT $ foldrM f () [0..] -- ...hangs... -- -- When the structure is finite `foldrM` performs the monadic effects from -- right to left, possibly short-circuiting after processing a tail portion -- of the element sequence. -- --- >>> let f e _ = when (e < 3) mzero >> lift (print e) --- >>> runMaybeT $ foldrM f () [0..5] +-- > let f e _ = when (e < 3) mzero >> lift (print e) +-- > runMaybeT $ foldrM f () [0..5] -- 5 -- 4 -- 3 @@ -614,14 +618,16 @@ -- Below we construct a @Foldable@ instance for a data type representing a -- (finite) binary tree with depth-first traversal. -- --- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) +-- >>> data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) -- -- a suitable instance would be: -- --- > instance Foldable Tree where --- > foldr f z Empty = z --- > foldr f z (Leaf x) = f x z --- > foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l +-- >>> :{ +-- instance Foldable Tree where +-- foldr f z Empty = z +-- foldr f z (Leaf x) = f x z +-- foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l +-- :} -- -- The 'Node' case is a right fold of the left subtree whose initial -- value is a right fold of the rest of the tree. diff --git a/src/Data/Foldable1.hs b/src/Data/Foldable1.hs --- a/src/Data/Foldable1.hs +++ b/src/Data/Foldable1.hs @@ -61,6 +61,9 @@ -- $setup -- >>> import Prelude hiding (foldr1, foldl1, head, last, minimum, maximum) +-- >>> import Data.List.NonEmpty (NonEmpty(..)) +-- >>> import Data.Monoid (Sum(..)) +-- >>> import Data.Functor.Identity ------------------------------------------------------------------------------- -- Foldable1 type class @@ -127,7 +130,13 @@ toNonEmpty :: t a -> NonEmpty a toNonEmpty = runNonEmptyDList . foldMap1 singleton - -- | The largest element of a non-empty structure. + -- | The largest element of a non-empty structure. This function is + -- equivalent to @'foldr1' 'Data.Ord.max'@, and its behavior on structures + -- with multiple largest elements depends on the relevant implementation of + -- 'Data.Ord.max'. For the default implementation of 'Data.Ord.max' (@max x + -- y = if x <= y then y else x@), structure order is used as a tie-breaker: + -- if there are multiple largest elements, the rightmost of them is chosen + -- (this is equivalent to @'maximumBy' 'Data.Ord.compare'@). -- -- >>> maximum (32 :| [64, 8, 128, 16]) -- 128 @@ -136,7 +145,13 @@ maximum :: Ord a => t a -> a maximum = getMax #. foldMap1' Max - -- | The least element of a non-empty structure. + -- | The least element of a non-empty structure. This function is + -- equivalent to @'foldr1' 'Data.Ord.min'@, and its behavior on structures + -- with multiple largest elements depends on the relevant implementation of + -- 'Data.Ord.min'. For the default implementation of 'Data.Ord.min' (@min x + -- y = if x <= y then x else y@), structure order is used as a tie-breaker: + -- if there are multiple least elements, the leftmost of them is chosen + -- (this is equivalent to @'minimumBy' 'Data.Ord.compare'@). -- -- >>> minimum (32 :| [64, 8, 128, 16]) -- 8 @@ -359,7 +374,8 @@ where x:|xs = toNonEmpty t -- | The largest element of a non-empty structure with respect to the --- given comparison function. +-- given comparison function. Structure order is used as a tie-breaker: if +-- there are multiple largest elements, the rightmost of them is chosen. -- -- @since 4.18.0.0 maximumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a @@ -369,7 +385,8 @@ _ -> y -- | The least element of a non-empty structure with respect to the --- given comparison function. +-- given comparison function. Structure order is used as a tie-breaker: if +-- there are multiple least elements, the leftmost of them is chosen. -- -- @since 4.18.0.0 minimumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a diff --git a/src/Data/Functor.hs b/src/Data/Functor.hs --- a/src/Data/Functor.hs +++ b/src/Data/Functor.hs @@ -11,32 +11,9 @@ -- Portability : portable -- -- --- A type @f@ is a Functor if it provides a function @fmap@ which, given any types @a@ and @b@, +-- A type @f@ is a Functor if it provides a function 'fmap' which, given any types @a@ and @b@, -- lets you apply any function of type @(a -> b)@ to turn an @f a@ into an @f b@, preserving the -- structure of @f@. --- --- ==== __Examples__ --- --- >>> fmap show (Just 1) -- (a -> b) -> f a -> f b --- Just "1" -- (Int -> String) -> Maybe Int -> Maybe String --- --- >>> fmap show Nothing -- (a -> b) -> f a -> f b --- Nothing -- (Int -> String) -> Maybe Int -> Maybe String --- --- >>> fmap show [1,2,3] -- (a -> b) -> f a -> f b --- ["1","2","3"] -- (Int -> String) -> [Int] -> [String] --- --- >>> fmap show [] -- (a -> b) -> f a -> f b --- [] -- (Int -> String) -> [Int] -> [String] --- --- The 'fmap' function is also available as the infix operator '<$>': --- --- >>> fmap show (Just 1) -- (Int -> String) -> Maybe Int -> Maybe String --- Just "1" --- --- >>> show <$> (Just 1) -- (Int -> String) -> Maybe Int -> Maybe String --- Just "1" - module Data.Functor (Functor(..), ($>), diff --git a/src/Data/Functor/Classes.hs b/src/Data/Functor/Classes.hs --- a/src/Data/Functor/Classes.hs +++ b/src/Data/Functor/Classes.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE Safe #-} @@ -78,12 +79,13 @@ import GHC.Internal.Data.Ord (Down(Down)) import Data.Complex (Complex((:+))) -import GHC.Generics (Generic1(..), Generically1(..)) +import GHC.Generics (Generic1(..), Generically1(..), V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) , (:+:)(..), (:*:)(..), (:.:)(..), URec(..), UAddr, UChar, UDouble, UFloat, UInt, UWord) import GHC.Tuple (Solo (..)) -import GHC.Internal.Read (expectP, list, paren) +import GHC.Internal.Read (expectP, list, paren, readField) +import GHC.Internal.Show (appPrec) -import GHC.Internal.Text.ParserCombinators.ReadPrec (ReadPrec, readPrec_to_S, readS_to_Prec) -import GHC.Internal.Text.Read (Read(..), parens, prec, step) +import GHC.Internal.Text.ParserCombinators.ReadPrec (ReadPrec, readPrec_to_S, readS_to_Prec, pfail) +import GHC.Internal.Text.Read (Read(..), parens, prec, step, reset) import GHC.Internal.Text.Read.Lex (Lexeme(..)) import GHC.Internal.Text.Show (showListWith) import Prelude @@ -1123,3 +1125,322 @@ > showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y -} + +-- | @since base-4.21.0.0 +instance Eq1 V1 where + liftEq _ = \_ _ -> True + +-- | @since base-4.21.0.0 +instance Ord1 V1 where + liftCompare _ = \_ _ -> EQ + +-- | @since base-4.21.0.0 +instance Show1 V1 where + liftShowsPrec _ _ _ = \_ -> showString "V1" + +-- | @since base-4.21.0.0 +instance Read1 V1 where + liftReadsPrec _ _ = readPrec_to_S pfail + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since base-4.21.0.0 +instance Eq1 U1 where + liftEq _ = \_ _ -> True + +-- | @since base-4.21.0.0 +instance Ord1 U1 where + liftCompare _ = \_ _ -> EQ + +-- | @since base-4.21.0.0 +instance Show1 U1 where + liftShowsPrec _ _ _ = \U1 -> showString "U1" + +-- | @since base-4.21.0.0 +instance Read1 U1 where + liftReadPrec _ _ = + parens (expectP (Ident "U1") *> pure U1) + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since base-4.21.0.0 +instance Eq1 Par1 where + liftEq eq = \(Par1 a) (Par1 a') -> eq a a' + +-- | @since base-4.21.0.0 +instance Ord1 Par1 where + liftCompare cmp = \(Par1 a) (Par1 a') -> cmp a a' + +-- | @since base-4.21.0.0 +instance Show1 Par1 where + liftShowsPrec sp _ d = \(Par1 { unPar1 = a }) -> + showsSingleFieldRecordWith sp "Par1" "unPar1" d a + +-- | @since base-4.21.0.0 +instance Read1 Par1 where + liftReadPrec rp _ = + readsSingleFieldRecordWith rp "Par1" "unPar1" Par1 + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since base-4.21.0.0 +instance Eq1 f => Eq1 (Rec1 f) where + liftEq eq = \(Rec1 a) (Rec1 a') -> liftEq eq a a' + +-- | @since base-4.21.0.0 +instance Ord1 f => Ord1 (Rec1 f) where + liftCompare cmp = \(Rec1 a) (Rec1 a') -> liftCompare cmp a a' + +-- | @since base-4.21.0.0 +instance Show1 f => Show1 (Rec1 f) where + liftShowsPrec sp sl d = \(Rec1 { unRec1 = a }) -> + showsSingleFieldRecordWith (liftShowsPrec sp sl) "Rec1" "unRec1" d a + +-- | @since base-4.21.0.0 +instance Read1 f => Read1 (Rec1 f) where + liftReadPrec rp rl = + readsSingleFieldRecordWith (liftReadPrec rp rl) "Rec1" "unRec1" Rec1 + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since base-4.21.0.0 +instance Eq c => Eq1 (K1 i c) where + liftEq _ = \(K1 a) (K1 a') -> a == a' + +-- | @since base-4.21.0.0 +instance Ord c => Ord1 (K1 i c) where + liftCompare _ = \(K1 a) (K1 a') -> compare a a' + +-- | @since base-4.21.0.0 +instance Show c => Show1 (K1 i c) where + liftShowsPrec _ _ d = \(K1 { unK1 = a }) -> + showsSingleFieldRecordWith showsPrec "K1" "unK1" d a + +-- | @since base-4.21.0.0 +instance Read c => Read1 (K1 i c) where + liftReadPrec _ _ = readData $ + readsSingleFieldRecordWith readPrec "K1" "unK1" K1 + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since base-4.21.0.0 +instance Eq1 f => Eq1 (M1 i c f) where + liftEq eq = \(M1 a) (M1 a') -> liftEq eq a a' + +-- | @since base-4.21.0.0 +instance Ord1 f => Ord1 (M1 i c f) where + liftCompare cmp = \(M1 a) (M1 a') -> liftCompare cmp a a' + +-- | @since base-4.21.0.0 +instance Show1 f => Show1 (M1 i c f) where + liftShowsPrec sp sl d = \(M1 { unM1 = a }) -> + showsSingleFieldRecordWith (liftShowsPrec sp sl) "M1" "unM1" d a + +-- | @since base-4.21.0.0 +instance Read1 f => Read1 (M1 i c f) where + liftReadPrec rp rl = readData $ + readsSingleFieldRecordWith (liftReadPrec rp rl) "M1" "unM1" M1 + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since base-4.21.0.0 +instance (Eq1 f, Eq1 g) => Eq1 (f :+: g) where + liftEq eq = \lhs rhs -> case (lhs, rhs) of + (L1 a, L1 a') -> liftEq eq a a' + (R1 b, R1 b') -> liftEq eq b b' + _ -> False + +-- | @since base-4.21.0.0 +instance (Ord1 f, Ord1 g) => Ord1 (f :+: g) where + liftCompare cmp = \lhs rhs -> case (lhs, rhs) of + (L1 _, R1 _) -> LT + (R1 _, L1 _) -> GT + (L1 a, L1 a') -> liftCompare cmp a a' + (R1 b, R1 b') -> liftCompare cmp b b' + +-- | @since base-4.21.0.0 +instance (Show1 f, Show1 g) => Show1 (f :+: g) where + liftShowsPrec sp sl d = \x -> case x of + L1 a -> showsUnaryWith (liftShowsPrec sp sl) "L1" d a + R1 b -> showsUnaryWith (liftShowsPrec sp sl) "R1" d b + +-- | @since base-4.21.0.0 +instance (Read1 f, Read1 g) => Read1 (f :+: g) where + liftReadPrec rp rl = readData $ + readUnaryWith (liftReadPrec rp rl) "L1" L1 <|> + readUnaryWith (liftReadPrec rp rl) "R1" R1 + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since base-4.21.0.0 +instance (Eq1 f, Eq1 g) => Eq1 (f :*: g) where + liftEq eq = \(f :*: g) (f' :*: g') -> liftEq eq f f' && liftEq eq g g' + +-- | @since base-4.21.0.0 +instance (Ord1 f, Ord1 g) => Ord1 (f :*: g) where + liftCompare cmp = \(f :*: g) (f' :*: g') -> liftCompare cmp f f' <> liftCompare cmp g g' + +-- | @since base-4.21.0.0 +instance (Show1 f, Show1 g) => Show1 (f :*: g) where + liftShowsPrec sp sl d = \(a :*: b) -> + showsBinaryOpWith + (liftShowsPrec sp sl) + (liftShowsPrec sp sl) + 7 + ":*:" + d + a + b + +-- | @since base-4.21.0.0 +instance (Read1 f, Read1 g) => Read1 (f :*: g) where + liftReadPrec rp rl = parens $ prec 6 $ + readBinaryOpWith (liftReadPrec rp rl) (liftReadPrec rp rl) ":*:" (:*:) + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since base-4.21.0.0 +instance (Eq1 f, Eq1 g) => Eq1 (f :.: g) where + liftEq eq = \(Comp1 a) (Comp1 a') -> liftEq (liftEq eq) a a' + +-- | @since base-4.21.0.0 +instance (Ord1 f, Ord1 g) => Ord1 (f :.: g) where + liftCompare cmp = \(Comp1 a) (Comp1 a') -> liftCompare (liftCompare cmp) a a' + +-- | @since base-4.21.0.0 +instance (Show1 f, Show1 g) => Show1 (f :.: g) where + liftShowsPrec sp sl d = \(Comp1 { unComp1 = a }) -> + showsSingleFieldRecordWith + (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl)) + "Comp1" + "unComp1" + d + a + +-- | @since base-4.21.0.0 +instance (Read1 f, Read1 g) => Read1 (f :.: g) where + liftReadPrec rp rl = readData $ + readsSingleFieldRecordWith + (liftReadPrec (liftReadPrec rp rl) (liftReadListPrec rp rl)) + "Comp1" + "unComp1" + Comp1 + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since base-4.21.0.0 +instance Eq1 UAddr where + -- NB cannot use eqAddr# because its module isn't safe + liftEq _ = \(UAddr a) (UAddr b) -> UAddr a == UAddr b + +-- | @since base-4.21.0.0 +instance Ord1 UAddr where + liftCompare _ = \(UAddr a) (UAddr b) -> compare (UAddr a) (UAddr b) + +-- | @since base-4.21.0.0 +instance Show1 UAddr where + liftShowsPrec _ _ = showsPrec + +-- NB no Read1 for URec (Ptr ()) because there's no Read for Ptr. + +-- | @since base-4.21.0.0 +instance Eq1 UChar where + liftEq _ = \(UChar a) (UChar b) -> UChar a == UChar b + +-- | @since base-4.21.0.0 +instance Ord1 UChar where + liftCompare _ = \(UChar a) (UChar b) -> compare (UChar a) (UChar b) + +-- | @since base-4.21.0.0 +instance Show1 UChar where + liftShowsPrec _ _ = showsPrec + +-- | @since base-4.21.0.0 +instance Eq1 UDouble where + liftEq _ = \(UDouble a) (UDouble b) -> UDouble a == UDouble b + +-- | @since base-4.21.0.0 +instance Ord1 UDouble where + liftCompare _ = \(UDouble a) (UDouble b) -> compare (UDouble a) (UDouble b) + +-- | @since base-4.21.0.0 +instance Show1 UDouble where + liftShowsPrec _ _ = showsPrec + +-- | @since base-4.21.0.0 +instance Eq1 UFloat where + liftEq _ = \(UFloat a) (UFloat b) -> UFloat a == UFloat b + +-- | @since base-4.21.0.0 +instance Ord1 UFloat where + liftCompare _ = \(UFloat a) (UFloat b) -> compare (UFloat a) (UFloat b) + +-- | @since base-4.21.0.0 +instance Show1 UFloat where + liftShowsPrec _ _ = showsPrec + +-- | @since base-4.21.0.0 +instance Eq1 UInt where + liftEq _ = \(UInt a) (UInt b) -> UInt a == UInt b + +-- | @since base-4.21.0.0 +instance Ord1 UInt where + liftCompare _ = \(UInt a) (UInt b) -> compare (UInt a) (UInt b) + +-- | @since base-4.21.0.0 +instance Show1 UInt where + liftShowsPrec _ _ = showsPrec + +-- | @since base-4.21.0.0 +instance Eq1 UWord where + liftEq _ = \(UWord a) (UWord b) -> UWord a == UWord b + +-- | @since base-4.21.0.0 +instance Ord1 UWord where + liftCompare _ = \(UWord a) (UWord b) -> compare (UWord a) (UWord b) + +-- | @since base-4.21.0.0 +instance Show1 UWord where + liftShowsPrec _ _ = showsPrec + +showsSingleFieldRecordWith :: (Int -> a -> ShowS) -> String -> String -> Int -> a -> ShowS +showsSingleFieldRecordWith sp name field d x = + showParen (d > appPrec) $ + showString name . showString " {" . showString field . showString " = " . sp 0 x . showChar '}' + +readsSingleFieldRecordWith :: ReadPrec a -> String -> String -> (a -> t) -> ReadPrec t +readsSingleFieldRecordWith rp name field cons = parens $ prec 11 $ do + expectP $ Ident name + expectP $ Punc "{" + x <- readField field $ reset rp + expectP $ Punc "}" + pure $ cons x + +showsBinaryOpWith + :: (Int -> a -> ShowS) + -> (Int -> b -> ShowS) + -> Int + -> String + -> Int + -> a + -> b + -> ShowS +showsBinaryOpWith sp1 sp2 opPrec name d x y = showParen (d >= opPrec) $ + sp1 opPrec x . showChar ' ' . showString name . showChar ' ' . sp2 opPrec y + +readBinaryOpWith + :: ReadPrec a + -> ReadPrec b + -> String + -> (a -> b -> t) + -> ReadPrec t +readBinaryOpWith rp1 rp2 name cons = + cons <$> step rp1 <* expectP (Symbol name) <*> step rp2 diff --git a/src/Data/Functor/Compose.hs b/src/Data/Functor/Compose.hs --- a/src/Data/Functor/Compose.hs +++ b/src/Data/Functor/Compose.hs @@ -40,6 +40,9 @@ infixr 9 `Compose` +-- $setup +-- >>> import Prelude + -- | Right-to-left composition of functors. -- The composition of applicative functors is always applicative, -- but the composition of monads is not always a monad. diff --git a/src/Data/Functor/Product.hs b/src/Data/Functor/Product.hs --- a/src/Data/Functor/Product.hs +++ b/src/Data/Functor/Product.hs @@ -31,6 +31,9 @@ import GHC.Generics (Generic, Generic1) import Prelude +-- $setup +-- >>> import Prelude + -- | Lifted product of functors. -- -- ==== __Examples__ diff --git a/src/Data/Functor/Sum.hs b/src/Data/Functor/Sum.hs --- a/src/Data/Functor/Sum.hs +++ b/src/Data/Functor/Sum.hs @@ -28,6 +28,9 @@ import GHC.Generics (Generic, Generic1) import Prelude +-- $setup +-- >>> import Prelude + -- | Lifted sum of functors. -- -- ==== __Examples__ diff --git a/src/Data/List.hs b/src/Data/List.hs --- a/src/Data/List.hs +++ b/src/Data/List.hs @@ -26,6 +26,7 @@ singleton, null, length, + compareLength, -- * List transformations map, reverse, @@ -83,7 +84,9 @@ stripPrefix, group, inits, + inits1, tails, + tails1, -- ** Predicates isPrefixOf, isSuffixOf, @@ -176,4 +179,106 @@ genericReplicate ) where +import GHC.Internal.Data.Bool (otherwise) import GHC.Internal.Data.List +import GHC.Internal.Data.List.NonEmpty (NonEmpty(..)) +import GHC.Internal.Data.Ord (Ordering(..), (<), (>)) +import GHC.Internal.Int (Int) +import GHC.Internal.Num ((-)) +import GHC.List (build) + +inits1, tails1 :: [a] -> [NonEmpty a] + +-- | The 'inits1' function returns all non-empty initial segments of the +-- argument, shortest first. +-- +-- @since 4.21.0.0 +-- +-- ==== __Laziness__ +-- +-- Note that 'inits1' has the following strictness property: +-- @inits1 (xs ++ _|_) = inits1 xs ++ _|_@ +-- +-- In particular, +-- @inits1 _|_ = _|_@ +-- +-- ==== __Examples__ +-- +-- >>> inits1 "abc" +-- ['a' :| "",'a' :| "b",'a' :| "bc"] +-- +-- >>> inits1 [] +-- [] +-- +-- inits1 is productive on infinite lists: +-- +-- >>> take 3 $ inits1 [1..] +-- [1 :| [],1 :| [2],1 :| [2,3]] +inits1 [] = [] +inits1 (x : xs) = map (x :|) (inits xs) + +-- | \(\mathcal{O}(n)\). The 'tails1' function returns all non-empty final +-- segments of the argument, longest first. +-- +-- @since 4.21.0.0 +-- +-- ==== __Laziness__ +-- +-- Note that 'tails1' has the following strictness property: +-- @tails1 _|_ = _|_@ +-- +-- >>> tails1 undefined +-- *** Exception: Prelude.undefined +-- +-- >>> drop 1 (tails1 [undefined, 1, 2]) +-- [1 :| [2],2 :| []] +-- +-- ==== __Examples__ +-- +-- >>> tails1 "abc" +-- ['a' :| "bc",'b' :| "c",'c' :| ""] +-- +-- >>> tails1 [1, 2, 3] +-- [1 :| [2,3],2 :| [3],3 :| []] +-- +-- >>> tails1 [] +-- [] +{-# INLINABLE tails1 #-} +tails1 lst = build (\c n -> + let tails1Go [] = n + tails1Go (x : xs) = (x :| xs) `c` tails1Go xs + in tails1Go lst) + +-- | Use 'compareLength' @xs@ @n@ as a safer and faster alternative +-- to 'compare' ('length' @xs@) @n@. Similarly, it's better +-- to write @compareLength xs 10 == LT@ instead of @length xs < 10@. +-- +-- While 'length' would force and traverse +-- the entire spine of @xs@ (which could even diverge if @xs@ is infinite), +-- 'compareLength' traverses at most @n@ elements to determine its result. +-- +-- >>> compareLength [] 0 +-- EQ +-- >>> compareLength [] 1 +-- LT +-- >>> compareLength ['a'] 1 +-- EQ +-- >>> compareLength ['a', 'b'] 1 +-- GT +-- >>> compareLength [0..] 100 +-- GT +-- >>> compareLength undefined (-1) +-- GT +-- >>> compareLength ('a' : undefined) 0 +-- GT +-- +-- @since 4.21.0.0 +-- +compareLength :: [a] -> Int -> Ordering +compareLength xs n + | n < 0 = GT + | otherwise = foldr + (\_ f m -> if m > 0 then f (m - 1) else GT) + (\m -> if m > 0 then LT else EQ) + xs + n diff --git a/src/Data/List/NonEmpty.hs b/src/Data/List/NonEmpty.hs --- a/src/Data/List/NonEmpty.hs +++ b/src/Data/List/NonEmpty.hs @@ -20,6 +20,13 @@ -- @since 4.9.0.0 ---------------------------------------------------------------------------- +-- Function implementations in this module adhere to the following principle: +-- +-- For every NonEmpty function that is different from a corresponding +-- List function only in the presence of NonEmpty in its type, both +-- the List and NonEmpty functions should have the same strictness +-- properties. Same applies to the class instances. + module Data.List.NonEmpty ( -- * The type of non-empty streams NonEmpty(..) @@ -36,6 +43,7 @@ , sortWith -- :: Ord o => (a -> o) -> NonEmpty a -> NonEmpty a -- * Basic functions , length -- :: NonEmpty a -> Int + , compareLength -- :: NonEmpty a -> Int -> Ordering , head -- :: NonEmpty a -> a , tail -- :: NonEmpty a -> [a] , last -- :: NonEmpty a -> a @@ -109,23 +117,55 @@ import qualified Prelude import Control.Applicative (Applicative (..), Alternative (many)) +import qualified Data.List as List import GHC.Internal.Data.Foldable hiding (length, toList) import qualified GHC.Internal.Data.Foldable as Foldable import GHC.Internal.Data.Function (on) -import qualified GHC.Internal.Data.List as List import GHC.Internal.Data.Ord (comparing) -import GHC.Internal.Base (NonEmpty(..)) import GHC.Internal.Stack.Types (HasCallStack) +import GHC.Internal.Data.List.NonEmpty (NonEmpty (..), map, zip, zipWith) infixr 5 <| -- $setup --- >>> import Prelude (negate) +-- >>> import Prelude +-- >>> import qualified Data.List as List +-- >>> import Data.Ord (comparing) -- | Number of elements in 'NonEmpty' list. length :: NonEmpty a -> Int length (_ :| xs) = 1 + Prelude.length xs +-- | Use 'compareLength' @xs@ @n@ as a safer and faster alternative +-- to 'compare' ('length' @xs@) @n@. Similarly, it's better +-- to write @compareLength xs 10 == LT@ instead of @length xs < 10@. +-- +-- While 'length' would force and traverse +-- the entire spine of @xs@ (which could even diverge if @xs@ is infinite), +-- 'compareLength' traverses at most @n@ elements to determine its result. +-- +-- >>> compareLength ('a' :| []) 1 +-- EQ +-- >>> compareLength ('a' :| ['b']) 3 +-- LT +-- >>> compareLength (0 :| [1..]) 100 +-- GT +-- >>> compareLength undefined 0 +-- GT +-- >>> compareLength ('a' :| 'b' : undefined) 1 +-- GT +-- +-- @since 4.21.0.0 +-- +compareLength :: NonEmpty a -> Int -> Ordering +compareLength xs n + | n < 1 = GT + | otherwise = foldr + (\_ f m -> if m > 0 then f (m - 1) else GT) + (\m -> if m > 0 then LT else EQ) + xs + n + -- | Compute n-ary logic exclusive OR operation on 'NonEmpty' list. xor :: NonEmpty Bool -> Bool xor (x :| xs) = foldr xor' x xs @@ -152,7 +192,7 @@ -- | 'uncons' produces the first element of the stream, and a stream of the -- remaining elements, if any. uncons :: NonEmpty a -> (a, Maybe (NonEmpty a)) -uncons ~(a :| as) = (a, nonEmpty as) +uncons (a :| as) = (a, nonEmpty as) -- | The 'unfoldr' function is analogous to "Data.List"'s -- 'GHC.Internal.Data.List.unfoldr' operation. @@ -173,11 +213,13 @@ -- | Extract the last element of the stream. last :: NonEmpty a -> a -last ~(a :| as) = List.last (a : as) +last (a :| []) = a +last (_ :| (a : as)) = last (a :| as) -- | Extract everything except the last element of the stream. init :: NonEmpty a -> [a] -init ~(a :| as) = List.init (a : as) +init (_ :| []) = [] +init (a1 :| (a2 : as)) = a1 : init (a2 :| as) -- | Construct a 'NonEmpty' list from a single element. -- @@ -187,7 +229,7 @@ -- | Prepend an element to the stream. (<|) :: a -> NonEmpty a -> NonEmpty a -a <| ~(b :| bs) = a :| b : bs +a <| bs = a :| toList bs -- | Synonym for '<|'. cons :: a -> NonEmpty a -> NonEmpty a @@ -205,7 +247,7 @@ -- >>> sortOn fst $ (2, "world") :| [(4, "!"), (1, "Hello")] -- (1,"Hello") :| [(2,"world"),(4,"!")] -- --- >>> sortOn length $ "jim" :| ["creed", "pam", "michael", "dwight", "kevin"] +-- >>> sortOn List.length ("jim" :| ["creed", "pam", "michael", "dwight", "kevin"]) -- "jim" :| ["pam","creed","kevin","dwight","michael"] -- -- ==== __Performance notes__ @@ -239,7 +281,7 @@ -- | Convert a stream to a normal list efficiently. toList :: NonEmpty a -> [a] -toList ~(a :| as) = a : as +toList (a :| as) = a : as -- | Lift list operations to work on a 'NonEmpty' stream. -- @@ -248,10 +290,6 @@ lift :: Foldable f => ([a] -> [b]) -> f a -> NonEmpty b lift f = fromList . f . Foldable.toList --- | Map a function over a 'NonEmpty' stream. -map :: (a -> b) -> NonEmpty a -> NonEmpty b -map f ~(a :| as) = f a :| fmap f as - -- | The 'inits' function takes a stream @xs@ and returns all the -- finite prefixes of @xs@, starting with the shortest. The result is -- 'NonEmpty' because the result always contains the empty list as the first @@ -271,15 +309,7 @@ -- -- @since 4.18 inits1 :: NonEmpty a -> NonEmpty (NonEmpty a) -inits1 = - -- fromList is an unsafe function, but this usage should be safe, since: - -- * `inits xs = [[], ..., init (init xs), init xs, xs]` - -- * If `xs` is nonempty, it follows that `inits xs` contains at least one nonempty - -- list, since `last (inits xs) = xs`. - -- * The only empty element of `inits xs` is the first one (by the definition of `inits`) - -- * Therefore, if we take all but the first element of `inits xs` i.e. - -- `tail (inits xs)`, we have a nonempty list of nonempty lists - fromList . Prelude.map fromList . List.drop 1 . List.inits . Foldable.toList +inits1 = fromList . List.inits1 . Foldable.toList -- | The 'tails' function takes a stream @xs@ and returns all the -- suffixes of @xs@, starting with the longest. The result is 'NonEmpty' @@ -299,15 +329,7 @@ -- -- @since 4.18 tails1 :: NonEmpty a -> NonEmpty (NonEmpty a) -tails1 = - -- fromList is an unsafe function, but this usage should be safe, since: - -- * `tails xs = [xs, tail xs, tail (tail xs), ..., []]` - -- * If `xs` is nonempty, it follows that `tails xs` contains at least one nonempty - -- list, since `head (tails xs) = xs`. - -- * The only empty element of `tails xs` is the last one (by the definition of `tails`) - -- * Therefore, if we take all but the last element of `tails xs` i.e. - -- `init (tails xs)`, we have a nonempty list of nonempty lists - fromList . Prelude.map fromList . List.init . List.tails . Foldable.toList +tails1 xs = xs :| List.tails1 (tail xs) -- | @'insert' x xs@ inserts @x@ into the last position in @xs@ where it -- is still less than or equal to the next element. In particular, if the @@ -341,17 +363,17 @@ -- -- > scanl1 f [x1, x2, ...] == x1 :| [x1 `f` x2, x1 `f` (x2 `f` x3), ...] scanl1 :: (a -> a -> a) -> NonEmpty a -> NonEmpty a -scanl1 f ~(a :| as) = fromList (List.scanl f a as) +scanl1 f (a :| as) = fromList (List.scanl f a as) -- | 'scanr1' is a variant of 'scanr' that has no starting value argument. scanr1 :: (a -> a -> a) -> NonEmpty a -> NonEmpty a -scanr1 f ~(a :| as) = fromList (List.scanr1 f (a:as)) +scanr1 f (a :| as) = fromList (List.scanr1 f (a:as)) -- | 'intersperse x xs' alternates elements of the list with copies of @x@. -- -- > intersperse 0 (1 :| [2,3]) == 1 :| [0,2,0,3] intersperse :: a -> NonEmpty a -> NonEmpty a -intersperse a ~(b :| bs) = b :| case bs of +intersperse a (b :| bs) = b :| case bs of [] -> [] _ -> a : List.intersperse a bs @@ -437,7 +459,7 @@ -- For example, in list notation: -- -- >>> group "Mississippi" --- ["M", "i", "ss", "i", "ss", "i", "pp", "i"] +-- ['M' :| "",'i' :| "",'s' :| "s",'i' :| "",'s' :| "s",'i' :| "",'p' :| "p",'i' :| ""] group :: (Foldable f, Eq a) => f a -> [NonEmpty a] group = groupBy (==) @@ -514,27 +536,17 @@ -- -- /Beware/: a negative or out-of-bounds index will cause an error. (!!) :: HasCallStack => NonEmpty a -> Int -> a -(!!) ~(x :| xs) n +(!!) (x :| xs) n | n == 0 = x | n > 0 = xs List.!! (n - 1) | otherwise = error "NonEmpty.!! negative index" infixl 9 !! --- | The 'zip' function takes two streams and returns a stream of --- corresponding pairs. -zip :: NonEmpty a -> NonEmpty b -> NonEmpty (a,b) -zip ~(x :| xs) ~(y :| ys) = (x, y) :| List.zip xs ys - --- | The 'zipWith' function generalizes 'zip'. Rather than tupling --- the elements, the elements are combined using the function --- passed as the first argument. -zipWith :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c -zipWith f ~(x :| xs) ~(y :| ys) = f x y :| List.zipWith f xs ys - -- | The 'unzip' function is the inverse of the 'zip' function. -unzip :: Functor f => f (a,b) -> (f a, f b) -unzip xs = (fst <$> xs, snd <$> xs) -{-# WARNING in "x-data-list-nonempty-unzip" unzip "This function will be made monomorphic in base-4.22, consider switching to Data.Functor.unzip" #-} +unzip :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b) +unzip ((a, b) :| asbs) = (a :| as, b :| bs) + where + (as, bs) = List.unzip asbs -- | The 'nub' function removes duplicate elements from a list. In -- particular, it keeps only the first occurrence of each element. diff --git a/src/Data/Monoid.hs b/src/Data/Monoid.hs --- a/src/Data/Monoid.hs +++ b/src/Data/Monoid.hs @@ -24,6 +24,7 @@ -- -- The 'Sum' monoid is defined by the numerical addition operator and `0` as neutral element: -- +-- >>> import Data.Int -- >>> mempty :: Sum Int -- Sum {getSum = 0} -- >>> Sum 1 <> Sum 2 <> Sum 3 <> Sum 4 :: Sum Int @@ -73,3 +74,4 @@ ) where import GHC.Internal.Data.Monoid + diff --git a/src/Data/Semigroup.hs b/src/Data/Semigroup.hs --- a/src/Data/Semigroup.hs +++ b/src/Data/Semigroup.hs @@ -38,11 +38,15 @@ -- can never be empty: -- -- >>> (1 :| []) --- 1 :| [] -- equivalent to [1] but guaranteed to be non-empty. +-- 1 :| [] -- +-- -- equivalent to [1] but guaranteed to be non-empty. +-- -- >>> (1 :| [2, 3, 4]) --- 1 :| [2,3,4] -- equivalent to [1,2,3,4] but guaranteed to be non-empty. +-- 1 :| [2,3,4] -- +-- -- equivalent to [1,2,3,4] but guaranteed to be non-empty. +-- -- Equipped with this guaranteed to be non-empty data structure, we can combine -- values using 'sconcat' and a 'Semigroup' of our choosing. We can try the 'Min' -- and 'Max' instances of 'Int' which pick the smallest, or largest number @@ -101,7 +105,7 @@ , ArgMax ) where -import GHC.Internal.Base hiding (Any) +import GHC.Internal.Base hiding (Any, NonEmpty(..)) import GHC.Internal.Enum import GHC.Internal.Show import GHC.Internal.Read @@ -112,6 +116,7 @@ import Data.Bifunctor import Data.Bitraversable import GHC.Internal.Data.Foldable +import GHC.Internal.Data.NonEmpty (NonEmpty(..)) import GHC.Internal.Data.Traversable import GHC.Internal.Data.Semigroup.Internal import GHC.Internal.Control.Monad.Fix @@ -122,6 +127,7 @@ -- $setup -- >>> import Prelude -- >>> import Data.List.NonEmpty (NonEmpty (..)) +-- >>> import GHC.Internal.Data.Semigroup.Internal -- | A generalization of 'GHC.Internal.Data.List.cycle' to an arbitrary 'Semigroup'. -- May fail to terminate for some values in some semigroups. @@ -135,7 +141,7 @@ -- Right 1 -- -- >>> cycle1 (Left 1) --- * hangs forever * +-- * Hangs forever * cycle1 :: Semigroup m => m -> m cycle1 xs = xs' where xs' = xs <> xs' @@ -143,7 +149,7 @@ -- -- ==== __Examples__ -- --- > let hello = diff "Hello, " +-- >>> let hello = diff "Hello, " -- -- >>> appEndo hello "World!" -- "Hello, World!" @@ -154,8 +160,8 @@ -- >>> appEndo (mempty <> hello) "World!" -- "Hello, World!" -- --- > let world = diff "World" --- > let excl = diff "!" +-- >>> let world = diff "World" +-- >>> let excl = diff "!" -- -- >>> appEndo (hello <> (world <> excl)) mempty -- "Hello, World!" @@ -171,7 +177,7 @@ -- ==== __Examples__ -- -- >>> Min 42 <> Min 3 --- Min 3 +-- Min {getMin = 3} -- -- >>> sconcat $ Min 1 :| [ Min n | n <- [2 .. 100]] -- Min {getMin = 1} @@ -256,7 +262,7 @@ -- ==== __Examples__ -- -- >>> Max 42 <> Max 3 --- Max 42 +-- Max {getMax = 42} -- -- >>> sconcat $ Max 1 :| [ Max n | n <- [2 .. 100]] -- Max {getMax = 100} @@ -335,7 +341,11 @@ fromInteger = Max . fromInteger -- | 'Arg' isn't itself a 'Semigroup' in its own right, but it can be --- placed inside 'Min' and 'Max' to compute an arg min or arg max. +-- placed inside 'Min' and 'Max' to compute an arg min or arg max. In +-- the event of ties, the leftmost qualifying 'Arg' is chosen; contrast +-- with the behavior of 'minimum' and 'maximum' for many other types, +-- where ties are broken by considering elements to the left in the +-- structure to be less than elements to the right. -- -- ==== __Examples__ -- @@ -392,11 +402,25 @@ instance Traversable (Arg a) where traverse f (Arg x a) = Arg x `fmap` f a --- | @since 4.9.0.0 +-- | +-- Note that `Arg`'s 'Eq' instance does not satisfy extensionality: +-- +-- >>> Arg 0 0 == Arg 0 1 +-- True +-- >>> let f (Arg _ x) = x in f (Arg 0 0) == f (Arg 0 1) +-- False +-- +-- @since 4.9.0.0 instance Eq a => Eq (Arg a b) where Arg a _ == Arg b _ = a == b --- | @since 4.9.0.0 +-- | +-- Note that `Arg`'s 'Ord' instance has 'min' and 'max' implementations that +-- differ from the tie-breaking conventions of the default implementation of +-- 'min' and 'max' in class 'Ord'; 'Arg' breaks ties by favoring the first +-- argument in both functions. +-- +-- @since 4.9.0.0 instance Ord a => Ord (Arg a b) where Arg a _ `compare` Arg b _ = compare a b min x@(Arg a _) y@(Arg b _) @@ -428,10 +452,10 @@ -- ==== __Examples__ -- -- >>> First 0 <> First 10 --- First 0 +-- First {getFirst = 0} -- -- >>> sconcat $ First 1 :| [ First n | n <- [2 ..] ] --- First 1 +-- First {getFirst = 1} newtype First a = First { getFirst :: a } deriving ( Bounded -- ^ @since 4.9.0.0 , Eq -- ^ @since 4.9.0.0 @@ -502,7 +526,7 @@ -- Last {getLast = 10} -- -- >>> sconcat $ Last 1 :| [ Last n | n <- [2..]] --- Last {getLast = * hangs forever * +-- * Hangs forever * newtype Last a = Last { getLast :: a } deriving ( Bounded -- ^ @since 4.9.0.0 , Eq -- ^ @since 4.9.0.0 @@ -629,7 +653,7 @@ -- ==== __Examples__ -- -- >>> mtimesDefault 0 "bark" --- [] +-- "" -- -- >>> mtimesDefault 3 "meow" -- "meowmeowmeow" diff --git a/src/Data/Traversable.hs b/src/Data/Traversable.hs --- a/src/Data/Traversable.hs +++ b/src/Data/Traversable.hs @@ -86,6 +86,13 @@ import GHC.Internal.Data.Traversable +-- $setup +-- >>> import Prelude +-- >>> import Data.Maybe +-- >>> import Data.Either +-- >>> import qualified Data.List as List +-- >>> :set -XExplicitForAll + -- $overview -- -- #overview# @@ -201,13 +208,13 @@ -- __@a@__), the result of __@mapM g ts@__ will contain multiple structures of -- the same shape as __@ts@__: -- --- prop> length (mapM g ts) == product (fmap (length . g) ts) +-- prop> List.length (mapM g ts) == List.product (fmap (List.length . g) ts) -- -- For example: -- --- >>> length $ mapM (\n -> [1..n]) [1..6] +-- >>> List.length $ mapM (\n -> [1..n]) [1..6] -- 720 --- >>> product $ length . (\n -> [1..n]) <$> [1..6] +-- >>> List.product $ List.length . (\n -> [1..n]) <$> [1..6] -- 720 -- -- In other words, a traversal with a function __@g :: a -> [b]@__, over an @@ -1006,14 +1013,16 @@ -- used to implicitly wrap and unwrap the @ZipList@ @newtype@ as needed, giving -- a function that operates on a list of lists: -- --- >>> {-# LANGUAGE ScopedTypeVariables #-} +-- >>> :set -XScopedTypeVariables -- >>> import Control.Applicative (ZipList(..)) -- >>> import Data.Coerce (coerce) -- >>> --- >>> transpose :: forall a. [[a]] -> [[a]] --- >>> transpose = coerce (sequenceA :: [ZipList a] -> ZipList [a]) --- >>> --- >>> transpose [[1,2,3],[4..],[7..]] +-- >>> :{ +-- >>> let +-- >>> transpose :: forall a. [[a]] -> [[a]] +-- >>> transpose = coerce (sequenceA :: [ZipList a] -> ZipList [a]) +-- >>> in transpose [[1,2,3],[4..],[7..]] +-- >>> :} -- [[1,4,7],[2,5,8],[3,6,9]] -- -- The use of [coercion](#coercion) avoids the need to explicitly wrap and diff --git a/src/GHC/Base.hs b/src/GHC/Base.hs --- a/src/GHC/Base.hs +++ b/src/GHC/Base.hs @@ -47,7 +47,7 @@ , unpackNBytes# -- * Magic combinators - , inline, noinline, lazy, oneShot, runRW#, DataToTag(..) + , inline, noinline, lazy, oneShot, runRW#, seq#, DataToTag(..) , WithDict(withDict) -- * Functions over 'Bool' @@ -138,20 +138,148 @@ , divModInt#, divModInt8#, divModInt16#, divModInt32# ) where -import GHC.Internal.Base -import GHC.Prim hiding (dataToTagLarge#, dataToTagSmall#, whereFrom#) - -- Hide dataToTagLarge# because it is expected to break for - -- GHC-internal reasons in the near future, and shouldn't - -- be exposed from base (not even GHC.Exts) - -- whereFrom# is similarly internal. +import GHC.Internal.Base hiding ( NonEmpty(..) ) +import GHC.Internal.Data.NonEmpty ( NonEmpty(..) ) +import GHC.Prim hiding + ( + -- Hide dataToTag# ops because they are expected to break for + -- GHC-internal reasons in the near future, and shouldn't + -- be exposed from base + dataToTagSmall#, dataToTagLarge# + -- whereFrom# is similarly internal. + , whereFrom# + , isByteArrayWeaklyPinned#, isMutableByteArrayWeaklyPinned# + -- Don't re-export vector FMA instructions + , fmaddFloatX4# + , fmsubFloatX4# + , fnmaddFloatX4# + , fnmsubFloatX4# + , fmaddFloatX8# + , fmsubFloatX8# + , fnmaddFloatX8# + , fnmsubFloatX8# + , fmaddFloatX16# + , fmsubFloatX16# + , fnmaddFloatX16# + , fnmsubFloatX16# + , fmaddDoubleX2# + , fmsubDoubleX2# + , fnmaddDoubleX2# + , fnmsubDoubleX2# + , fmaddDoubleX4# + , fmsubDoubleX4# + , fnmaddDoubleX4# + , fnmsubDoubleX4# + , fmaddDoubleX8# + , fmsubDoubleX8# + , fnmaddDoubleX8# + , fnmsubDoubleX8# + -- Don't re-export SIMD shuffle primops + , shuffleDoubleX2# + , shuffleDoubleX4# + , shuffleDoubleX8# + , shuffleFloatX16# + , shuffleFloatX4# + , shuffleFloatX8# + , shuffleInt16X16# + , shuffleInt16X32# + , shuffleInt16X8# + , shuffleInt32X16# + , shuffleInt32X4# + , shuffleInt32X8# + , shuffleInt64X2# + , shuffleInt64X4# + , shuffleInt64X8# + , shuffleInt8X16# + , shuffleInt8X32# + , shuffleInt8X64# + , shuffleWord16X16# + , shuffleWord16X32# + , shuffleWord16X8# + , shuffleWord32X16# + , shuffleWord32X4# + , shuffleWord32X8# + , shuffleWord64X2# + , shuffleWord64X4# + , shuffleWord64X8# + , shuffleWord8X16# + , shuffleWord8X32# + , shuffleWord8X64# + -- Don't re-export min/max primops + , maxDouble# + , maxDoubleX2# + , maxDoubleX4# + , maxDoubleX8# + , maxFloat# + , maxFloatX16# + , maxFloatX4# + , maxFloatX8# + , maxInt16X16# + , maxInt16X32# + , maxInt16X8# + , maxInt32X16# + , maxInt32X4# + , maxInt32X8# + , maxInt64X2# + , maxInt64X4# + , maxInt64X8# + , maxInt8X16# + , maxInt8X32# + , maxInt8X64# + , maxWord16X16# + , maxWord16X32# + , maxWord16X8# + , maxWord32X16# + , maxWord32X4# + , maxWord32X8# + , maxWord64X2# + , maxWord64X4# + , maxWord64X8# + , maxWord8X16# + , maxWord8X32# + , maxWord8X64# + , minDouble# + , minDoubleX2# + , minDoubleX4# + , minDoubleX8# + , minFloat# + , minFloatX16# + , minFloatX4# + , minFloatX8# + , minInt16X16# + , minInt16X32# + , minInt16X8# + , minInt32X16# + , minInt32X4# + , minInt32X8# + , minInt64X2# + , minInt64X4# + , minInt64X8# + , minInt8X16# + , minInt8X32# + , minInt8X64# + , minWord16X16# + , minWord16X32# + , minWord16X8# + , minWord32X16# + , minWord32X4# + , minWord32X8# + , minWord64X2# + , minWord64X4# + , minWord64X8# + , minWord8X16# + , minWord8X32# + , minWord8X64# + ) import GHC.Prim.Ext import GHC.Prim.PtrEq import GHC.Internal.Err +import GHC.Internal.IO (seq#) import GHC.Internal.Maybe import GHC.Types hiding ( Unit#, - Solo#, + Solo#(..), Tuple0#, Tuple1#, Tuple2#, diff --git a/src/GHC/Desugar.hs b/src/GHC/Desugar.hs --- a/src/GHC/Desugar.hs +++ b/src/GHC/Desugar.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# OPTIONS_HADDOCK not-home #-} +----------------------------------------------------------------------------- -- | -- -- Module : GHC.Desugar @@ -8,7 +10,7 @@ -- License : see libraries/base/LICENSE -- -- Maintainer : ghc-devs@haskell.org --- Stability : internal +-- Stability : deprecated () -- Portability : non-portable (GHC extensions) -- -- Support code for desugaring in GHC @@ -18,11 +20,14 @@ -- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can -- change rapidly without much warning. -- +----------------------------------------------------------------------------- +#if __GLASGOW_HASKELL >= 914 +#error "GHC.Desugar should be removed in GHC 9.14" +#endif + module GHC.Desugar - ((>>>), - AnnotationWrapper(..), - toAnnotationWrapper - ) where + {-# DEPRECATED ["GHC.Desugar is deprecated and will be removed in GHC 9.14.", "(>>>) should be imported from Control.Arrow.", "AnnotationWrapper is internal to GHC and should not be used externally."] #-} + ((>>>), AnnotationWrapper(..), toAnnotationWrapper) where import GHC.Internal.Desugar diff --git a/src/GHC/Exception.hs b/src/GHC/Exception.hs --- a/src/GHC/Exception.hs +++ b/src/GHC/Exception.hs @@ -44,7 +44,7 @@ -- * Reexports -- Re-export CallStack and SrcLoc from GHC.Types , CallStack, fromCallSiteList, getCallStack, prettyCallStack - , prettyCallStackLines, showCCSStack + , prettyCallStackLines , SrcLoc(..), prettySrcLoc ) where diff --git a/src/GHC/ExecutionStack/Internal.hs b/src/GHC/ExecutionStack/Internal.hs deleted file mode 100644 --- a/src/GHC/ExecutionStack/Internal.hs +++ /dev/null @@ -1,31 +0,0 @@ --- | --- Module : GHC.Internal.ExecutionStack.Internal --- Copyright : (c) The University of Glasgow 2013-2015 --- License : see libraries/base/LICENSE --- --- Maintainer : ghc-devs@haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- Internals of the "GHC.ExecutionStack" module. --- --- /The API of this module is unstable and not meant to be consumed by the general public./ --- If you absolutely must depend on it, make sure to use a tight upper --- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can --- change rapidly without much warning. --- --- @since 4.9.0.0 - -module GHC.ExecutionStack.Internal ( - -- * Internal - Location (..) - , SrcLoc (..) - , StackTrace - , stackFrames - , stackDepth - , collectStackTrace - , showStackFrames - , invalidateDebugCache - ) where - -import GHC.Internal.ExecutionStack.Internal diff --git a/src/GHC/Exts.hs b/src/GHC/Exts.hs --- a/src/GHC/Exts.hs +++ b/src/GHC/Exts.hs @@ -49,7 +49,6 @@ sameMVar#, sameMutVar#, sameTVar#, - sameIOPort#, samePromptTag#, -- ** Compat wrapper atomicModifyMutVar#, @@ -93,6 +92,7 @@ lazy, oneShot, considerAccessible, + seq#, -- * SpecConstr annotations SpecConstrAnnotation(..), SPEC(..), @@ -114,12 +114,139 @@ import GHC.Internal.Exts import GHC.Internal.ArrayArray -import GHC.Prim hiding ( coerce, dataToTagSmall#, dataToTagLarge#, whereFrom# ) +import GHC.Prim hiding + ( coerce -- Hide dataToTag# ops because they are expected to break for -- GHC-internal reasons in the near future, and shouldn't -- be exposed from base (not even GHC.Exts) - -- whereFrom# is similarly internal. + , dataToTagSmall#, dataToTagLarge# + -- whereFrom# is similarly internal. + , whereFrom# + , isByteArrayWeaklyPinned#, isMutableByteArrayWeaklyPinned# + -- Don't re-export vector FMA instructions + , fmaddFloatX4# + , fmsubFloatX4# + , fnmaddFloatX4# + , fnmsubFloatX4# + , fmaddFloatX8# + , fmsubFloatX8# + , fnmaddFloatX8# + , fnmsubFloatX8# + , fmaddFloatX16# + , fmsubFloatX16# + , fnmaddFloatX16# + , fnmsubFloatX16# + , fmaddDoubleX2# + , fmsubDoubleX2# + , fnmaddDoubleX2# + , fnmsubDoubleX2# + , fmaddDoubleX4# + , fmsubDoubleX4# + , fnmaddDoubleX4# + , fnmsubDoubleX4# + , fmaddDoubleX8# + , fmsubDoubleX8# + , fnmaddDoubleX8# + , fnmsubDoubleX8# + -- Don't re-export SIMD shuffle primops + , shuffleDoubleX2# + , shuffleDoubleX4# + , shuffleDoubleX8# + , shuffleFloatX16# + , shuffleFloatX4# + , shuffleFloatX8# + , shuffleInt16X16# + , shuffleInt16X32# + , shuffleInt16X8# + , shuffleInt32X16# + , shuffleInt32X4# + , shuffleInt32X8# + , shuffleInt64X2# + , shuffleInt64X4# + , shuffleInt64X8# + , shuffleInt8X16# + , shuffleInt8X32# + , shuffleInt8X64# + , shuffleWord16X16# + , shuffleWord16X32# + , shuffleWord16X8# + , shuffleWord32X16# + , shuffleWord32X4# + , shuffleWord32X8# + , shuffleWord64X2# + , shuffleWord64X4# + , shuffleWord64X8# + , shuffleWord8X16# + , shuffleWord8X32# + , shuffleWord8X64# + -- Don't re-export min/max primops + , maxDouble# + , maxDoubleX2# + , maxDoubleX4# + , maxDoubleX8# + , maxFloat# + , maxFloatX16# + , maxFloatX4# + , maxFloatX8# + , maxInt16X16# + , maxInt16X32# + , maxInt16X8# + , maxInt32X16# + , maxInt32X4# + , maxInt32X8# + , maxInt64X2# + , maxInt64X4# + , maxInt64X8# + , maxInt8X16# + , maxInt8X32# + , maxInt8X64# + , maxWord16X16# + , maxWord16X32# + , maxWord16X8# + , maxWord32X16# + , maxWord32X4# + , maxWord32X8# + , maxWord64X2# + , maxWord64X4# + , maxWord64X8# + , maxWord8X16# + , maxWord8X32# + , maxWord8X64# + , minDouble# + , minDoubleX2# + , minDoubleX4# + , minDoubleX8# + , minFloat# + , minFloatX16# + , minFloatX4# + , minFloatX8# + , minInt16X16# + , minInt16X32# + , minInt16X8# + , minInt32X16# + , minInt32X4# + , minInt32X8# + , minInt64X2# + , minInt64X4# + , minInt64X8# + , minInt8X16# + , minInt8X32# + , minInt8X64# + , minWord16X16# + , minWord16X32# + , minWord16X8# + , minWord32X16# + , minWord32X4# + , minWord32X8# + , minWord64X2# + , minWord64X4# + , minWord64X8# + , minWord8X16# + , minWord8X32# + , minWord8X64# + ) + import GHC.Prim.Ext import GHC.Types hiding ( @@ -128,7 +255,7 @@ -- GHC's internal representation of 'TyCon's, for 'Typeable' Module, TrName, TyCon, TypeLitSort, KindRep, KindBndr, Unit#, - Solo#, + Solo#(..), Tuple0#, Tuple1#, Tuple2#, diff --git a/src/GHC/IO/Encoding/Iconv.hs b/src/GHC/IO/Encoding/Iconv.hs --- a/src/GHC/IO/Encoding/Iconv.hs +++ b/src/GHC/IO/Encoding/Iconv.hs @@ -27,5 +27,4 @@ #else ( ) where -import Prelude () -- for build ordering (#23942) #endif diff --git a/src/GHC/IO/Handle.hs b/src/GHC/IO/Handle.hs --- a/src/GHC/IO/Handle.hs +++ b/src/GHC/IO/Handle.hs diff --git a/src/GHC/IO/StdHandles.hs b/src/GHC/IO/StdHandles.hs --- a/src/GHC/IO/StdHandles.hs +++ b/src/GHC/IO/StdHandles.hs diff --git a/src/GHC/IOPort.hs b/src/GHC/IOPort.hs deleted file mode 100644 --- a/src/GHC/IOPort.hs +++ /dev/null @@ -1,39 +0,0 @@ --- | --- --- Module : GHC.IOPort --- Copyright : (c) Tamar Christina 2019 --- License : see libraries/base/LICENSE --- --- Maintainer : ghc-devs@haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- The 'IOPort' type. This is a facility used by the Windows IO subsystem. --- --- /The API of this module is unstable and not meant to be consumed by the general public./ --- If you absolutely must depend on it, make sure to use a tight upper --- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can --- change rapidly without much warning. --- --- We have strict rules with an I/O Port: --- * writing more than once is an error --- * reading more than once is an error --- --- It gives us the ability to have one thread to block, wait for a result from --- another thread and then being woken up. *Nothing* more. --- --- This type is very much GHC internal. It might be changed or removed without --- notice in future releases. --- - -module GHC.IOPort - (-- * IOPorts - IOPort(..), - newIOPort, - newEmptyIOPort, - readIOPort, - writeIOPort, - doubleReadException - ) where - -import GHC.Internal.IOPort diff --git a/src/GHC/JS/Prim/Internal/Build.hs b/src/GHC/JS/Prim/Internal/Build.hs --- a/src/GHC/JS/Prim/Internal/Build.hs +++ b/src/GHC/JS/Prim/Internal/Build.hs @@ -1,12 +1,12 @@ {-# LANGUAGE CPP #-} +module GHC.JS.Prim.Internal.Build + {-# DEPRECATED "Use ghc-internal:GHC.Internal.JS.Prim.Internal.Build instead" #-} + -- deprecated for now. To be fully removed in GHC 9.16 + -- see https://github.com/haskell/core-libraries-committee/issues/329 and #23432 #if !defined(javascript_HOST_ARCH) - -module GHC.JS.Prim.Internal.Build () where - + () where #else - -module GHC.JS.Prim.Internal.Build ( buildArrayI , buildArrayM , buildObjectI diff --git a/src/GHC/Num/BigNat.hs b/src/GHC/Num/BigNat.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Num/BigNat.hs @@ -0,0 +1,6 @@ +module GHC.Num.BigNat + ( module GHC.Internal.Bignum.BigNat + ) +where + +import GHC.Internal.Bignum.BigNat diff --git a/src/GHC/Num/Integer.hs b/src/GHC/Num/Integer.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Num/Integer.hs @@ -0,0 +1,6 @@ +module GHC.Num.Integer + ( module GHC.Internal.Bignum.Integer + ) +where + +import GHC.Internal.Bignum.Integer diff --git a/src/GHC/Num/Natural.hs b/src/GHC/Num/Natural.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Num/Natural.hs @@ -0,0 +1,6 @@ +module GHC.Num.Natural + ( module GHC.Internal.Bignum.Natural + ) +where + +import GHC.Internal.Bignum.Natural diff --git a/src/GHC/Pack.hs b/src/GHC/Pack.hs deleted file mode 100644 --- a/src/GHC/Pack.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# OPTIONS_HADDOCK not-home #-} - --- | --- --- Module : GHC.Pack --- Copyright : (c) The University of Glasgow 1997-2002 --- License : see libraries/base/LICENSE --- --- Maintainer : ghc-devs@haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- ⚠ Warning: Starting @base-4.18@, this module is being deprecated. --- See https://gitlab.haskell.org/ghc/ghc/-/issues/21461 for more information. --- --- --- --- This module provides a small set of low-level functions for packing --- and unpacking a chunk of bytes. Used by code emitted by the compiler --- plus the prelude libraries. --- --- The programmer level view of packed strings is provided by a GHC --- system library PackedString. --- - -module GHC.Pack - {-# DEPRECATED "The exports of this module should be instead imported from GHC.Exts" #-} - (packCString#, - unpackCString, - unpackCString#, - unpackNBytes#, - unpackFoldrCString#, - unpackAppendCString# - ) where - -import GHC.Internal.Pack diff --git a/src/GHC/RTS/Flags.hs b/src/GHC/RTS/Flags.hs --- a/src/GHC/RTS/Flags.hs +++ b/src/GHC/RTS/Flags.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} + -- | -- Module : GHC.RTS.Flags -- Copyright : (c) The University of Glasgow, 1994-2000 @@ -17,6 +20,7 @@ -- -- @since 4.8.0.0 -- +-- This module is a compatibility layer. It is meant to be temporary to allow for the eventual deprecation of these declarations as described in [CLC proposal #289](https://github.com/haskell/core-libraries-committee/issues/289). These declarations are now instead available from the @ghc-experimental@ package. module GHC.RTS.Flags ( RtsTime @@ -25,6 +29,7 @@ , GCFlags (..) , ConcFlags (..) , MiscFlags (..) + , IoManagerFlag (..) , DebugFlags (..) , DoCostCentres (..) , CCFlags (..) @@ -35,12 +40,12 @@ , TickyFlags (..) , ParFlags (..) , HpcFlags (..) - , IoSubSystem (..) + , {-# DEPRECATED "import GHC.IO.SubSystem (IoSubSystem (..))" #-} + IoSubSystem (..) , getRTSFlags , getGCFlags , getConcFlags , getMiscFlags - , getIoManagerFlag , getDebugFlags , getCCFlags , getProfFlags @@ -50,4 +55,420 @@ , getHpcFlags ) where -import GHC.Internal.RTS.Flags +import Prelude (Show,IO,Bool,Maybe,String,Int,Enum,FilePath,Double,Eq,(<$>)) + +import GHC.Generics (Generic) +import qualified GHC.Internal.RTS.Flags as Internal +import GHC.Internal.IO.SubSystem (IoSubSystem(..)) + +import Data.Word (Word32,Word64,Word) + +-- | 'RtsTime' is defined as a @StgWord64@ in @stg/Types.h@ +-- +-- @since base-4.8.2.0 +type RtsTime = Word64 + +-- | Should we produce a summary of the garbage collector statistics after the +-- program has exited? +-- +-- @since base-4.8.2.0 +data GiveGCStats + = NoGCStats + | CollectGCStats + | OneLineGCStats + | SummaryGCStats + | VerboseGCStats + deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- | Parameters of the garbage collector. +-- +-- @since base-4.8.0.0 +data GCFlags = GCFlags + { statsFile :: Maybe FilePath + , giveStats :: GiveGCStats + , maxStkSize :: Word32 + , initialStkSize :: Word32 + , stkChunkSize :: Word32 + , stkChunkBufferSize :: Word32 + , maxHeapSize :: Word32 + , minAllocAreaSize :: Word32 + , largeAllocLim :: Word32 + , nurseryChunkSize :: Word32 + , minOldGenSize :: Word32 + , heapSizeSuggestion :: Word32 + , heapSizeSuggestionAuto :: Bool + , oldGenFactor :: Double + , returnDecayFactor :: Double + , pcFreeHeap :: Double + , generations :: Word32 + , squeezeUpdFrames :: Bool + , compact :: Bool -- ^ True <=> "compact all the time" + , compactThreshold :: Double + , sweep :: Bool + -- ^ use "mostly mark-sweep" instead of copying for the oldest generation + , ringBell :: Bool + , idleGCDelayTime :: RtsTime + , doIdleGC :: Bool + , heapBase :: Word -- ^ address to ask the OS for memory + , allocLimitGrace :: Word + , numa :: Bool + , numaMask :: Word + } deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- | Parameters concerning context switching +-- +-- @since base-4.8.0.0 +data ConcFlags = ConcFlags + { ctxtSwitchTime :: RtsTime + , ctxtSwitchTicks :: Int + } deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- | Miscellaneous parameters +-- +-- @since base-4.8.0.0 +data MiscFlags = MiscFlags + { tickInterval :: RtsTime + , installSignalHandlers :: Bool + , installSEHHandlers :: Bool + , generateCrashDumpFile :: Bool + , generateStackTrace :: Bool + , machineReadable :: Bool + , disableDelayedOsMemoryReturn :: Bool + , internalCounters :: Bool + , linkerAlwaysPic :: Bool + , linkerMemBase :: Word + -- ^ address to ask the OS for memory for the linker, 0 ==> off + , ioManager :: IoManagerFlag + , numIoWorkerThreads :: Word32 + } deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- | +-- +-- @since base-4.21.0.0 +data IoManagerFlag = + IoManagerFlagAuto + | IoManagerFlagSelect -- ^ Unix only, non-threaded RTS only + | IoManagerFlagMIO -- ^ cross-platform, threaded RTS only + | IoManagerFlagWinIO -- ^ Windows only + | IoManagerFlagWin32Legacy -- ^ Windows only, non-threaded RTS only + deriving (Eq, Enum, Show) + +-- | Flags to control debugging output & extra checking in various +-- subsystems. +-- +-- @since base-4.8.0.0 +data DebugFlags = DebugFlags + { scheduler :: Bool -- ^ @s@ + , interpreter :: Bool -- ^ @i@ + , weak :: Bool -- ^ @w@ + , gccafs :: Bool -- ^ @G@ + , gc :: Bool -- ^ @g@ + , nonmoving_gc :: Bool -- ^ @n@ + , block_alloc :: Bool -- ^ @b@ + , sanity :: Bool -- ^ @S@ + , stable :: Bool -- ^ @t@ + , prof :: Bool -- ^ @p@ + , linker :: Bool -- ^ @l@ the object linker + , apply :: Bool -- ^ @a@ + , stm :: Bool -- ^ @m@ + , squeeze :: Bool -- ^ @z@ stack squeezing & lazy blackholing + , hpc :: Bool -- ^ @c@ coverage + , sparks :: Bool -- ^ @r@ + } deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- | Should the RTS produce a cost-center summary? +-- +-- @since base-4.8.2.0 +data DoCostCentres + = CostCentresNone + | CostCentresSummary + | CostCentresVerbose + | CostCentresAll + | CostCentresJSON + deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- | Parameters pertaining to the cost-center profiler. +-- +-- @since base-4.8.0.0 +data CCFlags = CCFlags + { doCostCentres :: DoCostCentres + , profilerTicks :: Int + , msecsPerTick :: Int + } deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- | What sort of heap profile are we collecting? +-- +-- @since base-4.8.2.0 +data DoHeapProfile + = NoHeapProfiling + | HeapByCCS + | HeapByMod + | HeapByDescr + | HeapByType + | HeapByRetainer + | HeapByLDV + | HeapByClosureType + | HeapByInfoTable + | HeapByEra -- ^ @since base-4.20.0.0 + deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- | Parameters of the cost-center profiler +-- +-- @since base-4.8.0.0 +data ProfFlags = ProfFlags + { doHeapProfile :: DoHeapProfile + , heapProfileInterval :: RtsTime -- ^ time between samples + , heapProfileIntervalTicks :: Word -- ^ ticks between samples (derived) + , startHeapProfileAtStartup :: Bool + , startTimeProfileAtStartup :: Bool -- ^ @since base-4.20.0.0 + , showCCSOnException :: Bool + , automaticEraIncrement :: Bool -- ^ @since 4.20.0.0 + , maxRetainerSetSize :: Word + , ccsLength :: Word + , modSelector :: Maybe String + , descrSelector :: Maybe String + , typeSelector :: Maybe String + , ccSelector :: Maybe String + , ccsSelector :: Maybe String + , retainerSelector :: Maybe String + , bioSelector :: Maybe String + , eraSelector :: Word -- ^ @since base-4.20.0.0 + } deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- | Is event tracing enabled? +-- +-- @since base-4.8.2.0 +data DoTrace + = TraceNone -- ^ no tracing + | TraceEventLog -- ^ send tracing events to the event log + | TraceStderr -- ^ send tracing events to @stderr@ + deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- | Parameters pertaining to event tracing +-- +-- @since base-4.8.0.0 +data TraceFlags = TraceFlags + { tracing :: DoTrace + , timestamp :: Bool -- ^ show timestamp in stderr output + , traceScheduler :: Bool -- ^ trace scheduler events + , traceGc :: Bool -- ^ trace GC events + , traceNonmovingGc + :: Bool -- ^ trace nonmoving GC heap census samples + , sparksSampled :: Bool -- ^ trace spark events by a sampled method + , sparksFull :: Bool -- ^ trace spark events 100% accurately + , user :: Bool -- ^ trace user events (emitted from Haskell code) + } deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- | Parameters pertaining to ticky-ticky profiler +-- +-- @since base-4.8.0.0 +data TickyFlags = TickyFlags + { showTickyStats :: Bool + , tickyFile :: Maybe FilePath + } deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- | Parameters pertaining to parallelism +-- +-- @since base-4.8.0.0 +data ParFlags = ParFlags + { nCapabilities :: Word32 + , migrate :: Bool + , maxLocalSparks :: Word32 + , parGcEnabled :: Bool + , parGcGen :: Word32 + , parGcLoadBalancingEnabled :: Bool + , parGcLoadBalancingGen :: Word32 + , parGcNoSyncWithIdle :: Word32 + , parGcThreads :: Word32 + , setAffinity :: Bool + } + deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- | Parameters pertaining to Haskell program coverage (HPC) +-- +-- @since base-4.20.0.0 +data HpcFlags = HpcFlags + { readTixFile :: Bool + -- ^ Controls whether a @.tix@ file is read at + -- the start of execution to initialize the RTS internal + -- HPC datastructures. + , writeTixFile :: Bool + -- ^ Controls whether the @.tix@ file should be + -- written after the execution of the program. + } + deriving (Show -- ^ @since base-4.20.0.0 + , Generic -- ^ @since base-4.20.0.0 + ) +-- | Parameters of the runtime system +-- +-- @since base-4.8.0.0 +data RTSFlags = RTSFlags + { gcFlags :: GCFlags + , concurrentFlags :: ConcFlags + , miscFlags :: MiscFlags + , debugFlags :: DebugFlags + , costCentreFlags :: CCFlags + , profilingFlags :: ProfFlags + , traceFlags :: TraceFlags + , tickyFlags :: TickyFlags + , parFlags :: ParFlags + , hpcFlags :: HpcFlags + } deriving ( Show -- ^ @since base-4.8.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-------------------------------- compat ---------------------------------------- + +internal_to_base_RTSFlags :: Internal.RTSFlags -> RTSFlags +internal_to_base_RTSFlags Internal.RTSFlags{..} = + RTSFlags{ gcFlags = internal_to_base_GCFlags gcFlags + , concurrentFlags = internal_to_base_ConcFlags concurrentFlags + , miscFlags = internal_to_base_MiscFlags miscFlags + , debugFlags = internal_to_base_DebugFlags debugFlags + , costCentreFlags = internal_to_base_CCFlags costCentreFlags + , profilingFlags = internal_to_base_ProfFlags profilingFlags + , traceFlags = internal_to_base_TraceFlags traceFlags + , tickyFlags = internal_to_base_TickyFlags tickyFlags + , parFlags = internal_to_base_ParFlags parFlags + , hpcFlags = internal_to_base_HpcFlags hpcFlags + } + +internal_to_base_GCFlags :: Internal.GCFlags -> GCFlags +internal_to_base_GCFlags i@Internal.GCFlags{..} = + let give_stats = internal_to_base_giveStats (Internal.giveStats i) + in GCFlags{ giveStats = give_stats, .. } + where + internal_to_base_giveStats :: Internal.GiveGCStats -> GiveGCStats + internal_to_base_giveStats Internal.NoGCStats = NoGCStats + internal_to_base_giveStats Internal.CollectGCStats = CollectGCStats + internal_to_base_giveStats Internal.OneLineGCStats = OneLineGCStats + internal_to_base_giveStats Internal.SummaryGCStats = SummaryGCStats + internal_to_base_giveStats Internal.VerboseGCStats = VerboseGCStats + +internal_to_base_ParFlags :: Internal.ParFlags -> ParFlags +internal_to_base_ParFlags Internal.ParFlags{..} = ParFlags{..} + +internal_to_base_HpcFlags :: Internal.HpcFlags -> HpcFlags +internal_to_base_HpcFlags Internal.HpcFlags{..} = HpcFlags{..} + +internal_to_base_ConcFlags :: Internal.ConcFlags -> ConcFlags +internal_to_base_ConcFlags Internal.ConcFlags{..} = ConcFlags{..} + +internal_to_base_MiscFlags :: Internal.MiscFlags -> MiscFlags +internal_to_base_MiscFlags i@Internal.MiscFlags{..} = + let io_manager = internal_to_base_ioManager (Internal.ioManager i) + in MiscFlags{ ioManager = io_manager, ..} + where + internal_to_base_ioManager :: Internal.IoManagerFlag -> IoManagerFlag + internal_to_base_ioManager Internal.IoManagerFlagAuto = IoManagerFlagAuto + internal_to_base_ioManager Internal.IoManagerFlagSelect = IoManagerFlagSelect + internal_to_base_ioManager Internal.IoManagerFlagMIO = IoManagerFlagMIO + internal_to_base_ioManager Internal.IoManagerFlagWinIO = IoManagerFlagWinIO + internal_to_base_ioManager Internal.IoManagerFlagWin32Legacy = IoManagerFlagWin32Legacy + +internal_to_base_DebugFlags :: Internal.DebugFlags -> DebugFlags +internal_to_base_DebugFlags Internal.DebugFlags{..} = DebugFlags{..} + +internal_to_base_CCFlags :: Internal.CCFlags -> CCFlags +internal_to_base_CCFlags i@Internal.CCFlags{..} = + let do_cost_centres = internal_to_base_costCentres (Internal.doCostCentres i) + in CCFlags{ doCostCentres = do_cost_centres, ..} + where + internal_to_base_costCentres :: Internal.DoCostCentres -> DoCostCentres + internal_to_base_costCentres Internal.CostCentresNone = CostCentresNone + internal_to_base_costCentres Internal.CostCentresSummary = CostCentresSummary + internal_to_base_costCentres Internal.CostCentresVerbose = CostCentresVerbose + internal_to_base_costCentres Internal.CostCentresAll = CostCentresAll + internal_to_base_costCentres Internal.CostCentresJSON = CostCentresJSON + +internal_to_base_ProfFlags :: Internal.ProfFlags -> ProfFlags +internal_to_base_ProfFlags i@Internal.ProfFlags{..} = + let do_heap_profile = internal_to_base_doHeapProfile (Internal.doHeapProfile i) + in ProfFlags{ doHeapProfile = do_heap_profile,..} + where + internal_to_base_doHeapProfile :: Internal.DoHeapProfile -> DoHeapProfile + internal_to_base_doHeapProfile Internal.NoHeapProfiling = NoHeapProfiling + internal_to_base_doHeapProfile Internal.HeapByCCS = HeapByCCS + internal_to_base_doHeapProfile Internal.HeapByMod = HeapByMod + internal_to_base_doHeapProfile Internal.HeapByDescr = HeapByDescr + internal_to_base_doHeapProfile Internal.HeapByType = HeapByType + internal_to_base_doHeapProfile Internal.HeapByRetainer = HeapByRetainer + internal_to_base_doHeapProfile Internal.HeapByLDV = HeapByLDV + internal_to_base_doHeapProfile Internal.HeapByClosureType = HeapByClosureType + internal_to_base_doHeapProfile Internal.HeapByInfoTable = HeapByInfoTable + internal_to_base_doHeapProfile Internal.HeapByEra = HeapByEra + +internal_to_base_TraceFlags :: Internal.TraceFlags -> TraceFlags +internal_to_base_TraceFlags i@Internal.TraceFlags{..} = + let do_trace = internal_to_base_doTrace (Internal.tracing i) + in TraceFlags{ tracing = do_trace,..} + where + internal_to_base_doTrace :: Internal.DoTrace -> DoTrace + internal_to_base_doTrace Internal.TraceNone = TraceNone + internal_to_base_doTrace Internal.TraceEventLog = TraceEventLog + internal_to_base_doTrace Internal.TraceStderr = TraceStderr + +internal_to_base_TickyFlags :: Internal.TickyFlags -> TickyFlags +internal_to_base_TickyFlags Internal.TickyFlags{..} = TickyFlags{..} + +-------------------------------- shims ----------------------------------------- + +getRTSFlags :: IO RTSFlags +getRTSFlags = internal_to_base_RTSFlags <$> Internal.getRTSFlags + +getGCFlags :: IO GCFlags +getGCFlags = internal_to_base_GCFlags <$> Internal.getGCFlags + +getParFlags :: IO ParFlags +getParFlags = internal_to_base_ParFlags <$> Internal.getParFlags + +getHpcFlags :: IO HpcFlags +getHpcFlags = internal_to_base_HpcFlags <$> Internal.getHpcFlags + +getConcFlags :: IO ConcFlags +getConcFlags = internal_to_base_ConcFlags <$> Internal.getConcFlags + +{-# INLINEABLE getMiscFlags #-} +getMiscFlags :: IO MiscFlags +getMiscFlags = internal_to_base_MiscFlags <$> Internal.getMiscFlags + +getDebugFlags :: IO DebugFlags +getDebugFlags = internal_to_base_DebugFlags <$> Internal.getDebugFlags + +getCCFlags :: IO CCFlags +getCCFlags = internal_to_base_CCFlags <$> Internal.getCCFlags + +getProfFlags :: IO ProfFlags +getProfFlags = internal_to_base_ProfFlags <$> Internal.getProfFlags + +getTraceFlags :: IO TraceFlags +getTraceFlags = internal_to_base_TraceFlags <$> Internal.getTraceFlags + +getTickyFlags :: IO TickyFlags +getTickyFlags = internal_to_base_TickyFlags <$> Internal.getTickyFlags diff --git a/src/GHC/Records.hs b/src/GHC/Records.hs --- a/src/GHC/Records.hs +++ b/src/GHC/Records.hs @@ -11,10 +11,11 @@ -- Portability : non-portable (GHC extensions) -- -- This module defines the 'HasField' class used by the --- @OverloadedRecordFields@ extension. See the --- for more details. +-- @OverloadedRecordDot@ extension. See the +-- [wiki page](https://gitlab.haskell.org/ghc/ghc/wikis/records/overloaded-record-fields) +-- for more details. -- +-- @since 4.10.0.0 module GHC.Records (HasField(..) diff --git a/src/GHC/Stack/CloneStack.hs b/src/GHC/Stack/CloneStack.hs --- a/src/GHC/Stack/CloneStack.hs +++ b/src/GHC/Stack/CloneStack.hs @@ -17,3 +17,4 @@ ) where import GHC.Internal.Stack.CloneStack +import GHC.Internal.Stack.Decode diff --git a/src/GHC/Stats.hs b/src/GHC/Stats.hs --- a/src/GHC/Stats.hs +++ b/src/GHC/Stats.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} -- | -- Module : RTS.Stats @@ -18,6 +20,12 @@ -- than @base < 5@, because the interface can change rapidly without much warning. -- -- @since 4.5.0.0 +-- +-- This module is a compatibility layer. It is meant to be temporary to allow +-- for the eventual deprecation of these declarations as described in [CLC +-- proposal +-- #289](https://github.com/haskell/core-libraries-committee/issues/289). These +-- declarations are now instead available from the @ghc-experimental@ package. module GHC.Stats ( -- * Runtime statistics @@ -26,5 +34,172 @@ , getRTSStatsEnabled ) where -import GHC.Internal.Stats +import Prelude (Bool,IO,Read,Show,(<$>)) + +import qualified GHC.Internal.Stats as Internal +import GHC.Generics (Generic) +import Data.Word (Word64,Word32) +import Data.Int (Int64) + +-- | Time values from the RTS, using a fixed resolution of nanoseconds. +type RtsTime = Int64 + +-- +-- | Statistics about runtime activity since the start of the +-- program. This is a mirror of the C @struct RTSStats@ in @RtsAPI.h@ +-- +-- @since base-4.10.0.0 +-- +data RTSStats = RTSStats { + -- ----------------------------------- + -- Cumulative stats about memory use + + -- | Total number of GCs + gcs :: Word32 + -- | Total number of major (oldest generation) GCs + , major_gcs :: Word32 + -- | Total bytes allocated + , allocated_bytes :: Word64 + -- | Maximum live data (including large objects + compact regions) in the + -- heap. Updated after a major GC. + , max_live_bytes :: Word64 + -- | Maximum live data in large objects + , max_large_objects_bytes :: Word64 + -- | Maximum live data in compact regions + , max_compact_bytes :: Word64 + -- | Maximum slop + , max_slop_bytes :: Word64 + -- | Maximum memory in use by the RTS + , max_mem_in_use_bytes :: Word64 + -- | Sum of live bytes across all major GCs. Divided by major_gcs + -- gives the average live data over the lifetime of the program. + , cumulative_live_bytes :: Word64 + -- | Sum of copied_bytes across all GCs + , copied_bytes :: Word64 + -- | Sum of copied_bytes across all parallel GCs + , par_copied_bytes :: Word64 + -- | Sum of par_max_copied_bytes across all parallel GCs. Deprecated. + , cumulative_par_max_copied_bytes :: Word64 + -- | Sum of par_balanced_copied bytes across all parallel GCs + , cumulative_par_balanced_copied_bytes :: Word64 + + -- ----------------------------------- + -- Cumulative stats about time use + -- (we use signed values here because due to inaccuracies in timers + -- the values can occasionally go slightly negative) + + -- | Total CPU time used by the init phase + -- @since base-4.12.0.0 + , init_cpu_ns :: RtsTime + -- | Total elapsed time used by the init phase + -- @since base-4.12.0.0 + , init_elapsed_ns :: RtsTime + -- | Total CPU time used by the mutator + , mutator_cpu_ns :: RtsTime + -- | Total elapsed time used by the mutator + , mutator_elapsed_ns :: RtsTime + -- | Total CPU time used by the GC + , gc_cpu_ns :: RtsTime + -- | Total elapsed time used by the GC + , gc_elapsed_ns :: RtsTime + -- | Total CPU time (at the previous GC) + , cpu_ns :: RtsTime + -- | Total elapsed time (at the previous GC) + , elapsed_ns :: RtsTime + + -- | The total CPU time used during the post-mark pause phase of the + -- concurrent nonmoving GC. + , nonmoving_gc_sync_cpu_ns :: RtsTime + -- | The total time elapsed during the post-mark pause phase of the + -- concurrent nonmoving GC. + , nonmoving_gc_sync_elapsed_ns :: RtsTime + -- | The maximum elapsed length of any post-mark pause phase of the + -- concurrent nonmoving GC. + , nonmoving_gc_sync_max_elapsed_ns :: RtsTime + -- | The total CPU time used by the nonmoving GC. + , nonmoving_gc_cpu_ns :: RtsTime + -- | The total time elapsed during which there is a nonmoving GC active. + , nonmoving_gc_elapsed_ns :: RtsTime + -- | The maximum time elapsed during any nonmoving GC cycle. + , nonmoving_gc_max_elapsed_ns :: RtsTime + + -- | Details about the most recent GC + , gc :: GCDetails + } deriving ( Read -- ^ @since base-4.10.0.0 + , Show -- ^ @since base-4.10.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-- +-- | Statistics about a single GC. This is a mirror of the C @struct +-- GCDetails@ in @RtsAPI.h@, with the field prefixed with @gc_@ to +-- avoid collisions with 'RTSStats'. +-- +data GCDetails = GCDetails { + -- | The generation number of this GC + gcdetails_gen :: Word32 + -- | Number of threads used in this GC + , gcdetails_threads :: Word32 + -- | Number of bytes allocated since the previous GC + , gcdetails_allocated_bytes :: Word64 + -- | Total amount of live data in the heap (includes large + compact data). + -- Updated after every GC. Data in uncollected generations (in minor GCs) + -- are considered live. + , gcdetails_live_bytes :: Word64 + -- | Total amount of live data in large objects + , gcdetails_large_objects_bytes :: Word64 + -- | Total amount of live data in compact regions + , gcdetails_compact_bytes :: Word64 + -- | Total amount of slop (wasted memory) + , gcdetails_slop_bytes :: Word64 + -- | Total amount of memory in use by the RTS + , gcdetails_mem_in_use_bytes :: Word64 + -- | Total amount of data copied during this GC + , gcdetails_copied_bytes :: Word64 + -- | In parallel GC, the max amount of data copied by any one thread. + -- Deprecated. + , gcdetails_par_max_copied_bytes :: Word64 + -- | In parallel GC, the amount of balanced data copied by all threads + , gcdetails_par_balanced_copied_bytes :: Word64 + -- | The amount of memory lost due to block fragmentation in bytes. + -- Block fragmentation is the difference between the amount of blocks retained by the RTS and the blocks that are in use. + -- This occurs when megablocks are only sparsely used, eg, when data that cannot be moved retains a megablock. + -- + -- @since base-4.18.0.0 + , gcdetails_block_fragmentation_bytes :: Word64 + -- | The time elapsed during synchronisation before GC + , gcdetails_sync_elapsed_ns :: RtsTime + -- | The CPU time used during GC itself + , gcdetails_cpu_ns :: RtsTime + -- | The time elapsed during GC itself + , gcdetails_elapsed_ns :: RtsTime + + -- | The CPU time used during the post-mark pause phase of the concurrent + -- nonmoving GC. + , gcdetails_nonmoving_gc_sync_cpu_ns :: RtsTime + -- | The time elapsed during the post-mark pause phase of the concurrent + -- nonmoving GC. + , gcdetails_nonmoving_gc_sync_elapsed_ns :: RtsTime + } deriving ( Read -- ^ @since base-4.10.0.0 + , Show -- ^ @since base-4.10.0.0 + , Generic -- ^ @since base-4.15.0.0 + ) + +-------------------------------- compat ---------------------------------------- + +internal_to_base_RTSStats :: Internal.RTSStats -> RTSStats +internal_to_base_RTSStats i@Internal.RTSStats{..} = + let gc_details = internal_to_base_GCDetails (Internal.gc i) + in RTSStats{gc = gc_details,..} + +internal_to_base_GCDetails :: Internal.GCDetails -> GCDetails +internal_to_base_GCDetails Internal.GCDetails{..} = GCDetails{..} + +-------------------------------- shims ----------------------------------------- + +getRTSStats :: IO RTSStats +getRTSStats = internal_to_base_RTSStats <$> Internal.getRTSStats + +getRTSStatsEnabled :: IO Bool +getRTSStatsEnabled = Internal.getRTSStatsEnabled diff --git a/src/GHC/TypeLits/Internal.hs b/src/GHC/TypeLits/Internal.hs deleted file mode 100644 --- a/src/GHC/TypeLits/Internal.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# OPTIONS_HADDOCK not-home #-} - --- | --- --- Module : GHC.TypeLits.Internal --- Copyright : (c) The University of Glasgow, 1994-2000 --- License : see libraries/base/LICENSE --- --- Maintainer : ghc-devs@haskell.org --- Stability : internal --- Portability : non-portable (GHC extensions) --- --- __Do not use this module.__ Use "GHC.TypeLits" instead. --- --- This module is internal-only and was exposed by accident. It may be --- removed without warning in a future version. --- --- /The API of this module is unstable and is tightly coupled to GHC's internals./ --- If depend on it, make sure to use a tight upper bound, e.g., @base < 4.X@ rather --- than @base < 5@, because the interface can change rapidly without much warning. --- --- The technical reason for this module's existence is that it is needed --- to prevent module cycles while still allowing these identifiers to be --- imported in "Data.Type.Ord". --- --- @since 4.16.0.0 - -module GHC.TypeLits.Internal - (Symbol, - CmpSymbol, - CmpChar - ) where - -import GHC.Internal.TypeLits.Internal diff --git a/src/GHC/TypeNats/Internal.hs b/src/GHC/TypeNats/Internal.hs deleted file mode 100644 --- a/src/GHC/TypeNats/Internal.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# OPTIONS_HADDOCK not-home #-} - -module GHC.TypeNats.Internal - (Natural, - CmpNat - ) where - -import GHC.Internal.TypeNats.Internal diff --git a/src/GHC/Weak/Finalize.hs b/src/GHC/Weak/Finalize.hs --- a/src/GHC/Weak/Finalize.hs +++ b/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 @@ , 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 +-- +runFinalizerBatch :: Int + -> Array# (State# RealWorld -> State# RealWorld) + -> IO () +runFinalizerBatch = GHC.Internal.Weak.Finalize.runFinalizerBatch diff --git a/src/System/CPUTime/Windows.hsc b/src/System/CPUTime/Windows.hsc --- a/src/System/CPUTime/Windows.hsc +++ b/src/System/CPUTime/Windows.hsc @@ -60,7 +60,7 @@ #if defined(i386_HOST_ARCH) foreign import stdcall unsafe "GetCurrentProcess" getCurrentProcess :: IO (Ptr HANDLE) foreign import stdcall unsafe "GetProcessTimes" getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt -#elif defined(x86_64_HOST_ARCH) +#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) foreign import ccall unsafe "GetCurrentProcess" getCurrentProcess :: IO (Ptr HANDLE) foreign import ccall unsafe "GetProcessTimes" getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt #else diff --git a/src/System/IO.hs b/src/System/IO.hs --- a/src/System/IO.hs +++ b/src/System/IO.hs @@ -14,7 +14,10 @@ -- module System.IO - (-- * The IO monad + (-- * Examples + -- $stdio_examples + + -- * The IO monad IO, fixIO, -- * Files and handles @@ -199,3 +202,18 @@ -- It follows that an attempt to write to a file (using 'writeFile', for -- example) that was earlier opened by 'readFile' will usually result in -- failure with 'GHC.Internal.System.IO.Error.isAlreadyInUseError'. + +-- $stdio_examples +-- Note: Some of the examples in this module do not work "as is" in ghci. +-- This is because using 'stdin' in combination with lazy IO +-- does not work well in interactive mode. +-- +-- Lines starting with @>@ indicate 'stdin' and @^D@ signales EOF. +-- +-- ==== __Example__ +-- +-- ghci> foo +-- > input +-- output +-- > input^D +-- output diff --git a/src/System/Timeout.hs b/src/System/Timeout.hs --- a/src/System/Timeout.hs +++ b/src/System/Timeout.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} ------------------------------------------------------------------------------- -- | @@ -29,6 +29,7 @@ asyncExceptionToException, asyncExceptionFromException) import GHC.Internal.Data.Unique (Unique, newUnique) +import GHC.Conc (labelThread) import Prelude -- $setup @@ -119,7 +120,9 @@ let handleTimeout = do v <- isEmptyMVar lock when v $ void $ forkIOWithUnmask $ \unmask -> unmask $ do - v2 <- tryPutMVar lock =<< myThreadId + tid <- myThreadId + labelThread tid "timeout worker" + v2 <- tryPutMVar lock tid when v2 $ throwTo pid ex cleanupTimeout key = uninterruptibleMask_ $ do v <- tryPutMVar lock undefined @@ -136,7 +139,9 @@ ex <- fmap Timeout newUnique handleJust (\e -> if e == ex then Just () else Nothing) (\_ -> return Nothing) - (bracket (forkIOWithUnmask $ \unmask -> + (bracket (forkIOWithUnmask $ \unmask -> do + tid <- myThreadId + labelThread tid "timeout worker" unmask $ threadDelay n >> throwTo pid ex) (uninterruptibleMask_ . killThread) (\_ -> fmap Just f))