diff --git a/Control/Applicative.hs b/Control/Applicative.hs deleted file mode 100644 --- a/Control/Applicative.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Applicative (module X___) where -import "base" Control.Applicative as X___ diff --git a/Control/Arrow.hs b/Control/Arrow.hs deleted file mode 100644 --- a/Control/Arrow.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Arrow (module X___) where -import "base" Control.Arrow as X___ diff --git a/Control/Category.hs b/Control/Category.hs deleted file mode 100644 --- a/Control/Category.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Category (module X___) where -import "base" Control.Category as X___ diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs deleted file mode 100644 --- a/Control/Concurrent.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Concurrent (module X___) where -import "base" Control.Concurrent as X___ diff --git a/Control/Concurrent/Chan.hs b/Control/Concurrent/Chan.hs deleted file mode 100644 --- a/Control/Concurrent/Chan.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Concurrent.Chan (module X___) where -import "base" Control.Concurrent.Chan as X___ diff --git a/Control/Concurrent/MVar.hs b/Control/Concurrent/MVar.hs deleted file mode 100644 --- a/Control/Concurrent/MVar.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Concurrent.MVar (module X___) where -import "base" Control.Concurrent.MVar as X___ diff --git a/Control/Concurrent/QSem.hs b/Control/Concurrent/QSem.hs deleted file mode 100644 --- a/Control/Concurrent/QSem.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Concurrent.QSem (module X___) where -import "base" Control.Concurrent.QSem as X___ diff --git a/Control/Concurrent/QSemN.hs b/Control/Concurrent/QSemN.hs deleted file mode 100644 --- a/Control/Concurrent/QSemN.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Concurrent.QSemN (module X___) where -import "base" Control.Concurrent.QSemN as X___ diff --git a/Control/Concurrent/SampleVar.hs b/Control/Concurrent/SampleVar.hs deleted file mode 100644 --- a/Control/Concurrent/SampleVar.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Concurrent.SampleVar (module X___) where -import "base" Control.Concurrent.SampleVar as X___ diff --git a/Control/Exception.hs b/Control/Exception.hs deleted file mode 100644 --- a/Control/Exception.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Exception (module Control.OldException) where -import Control.OldException diff --git a/Control/Monad.hs b/Control/Monad.hs deleted file mode 100644 --- a/Control/Monad.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Monad (module X___) where -import "base" Control.Monad as X___ diff --git a/Control/Monad/Fix.hs b/Control/Monad/Fix.hs deleted file mode 100644 --- a/Control/Monad/Fix.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Monad.Fix (module X___) where -import "base" Control.Monad.Fix as X___ diff --git a/Control/Monad/Instances.hs b/Control/Monad/Instances.hs deleted file mode 100644 --- a/Control/Monad/Instances.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Monad.Instances (module X___) where -import "base" Control.Monad.Instances as X___ diff --git a/Control/Monad/ST.hs b/Control/Monad/ST.hs deleted file mode 100644 --- a/Control/Monad/ST.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Monad.ST (module X___) where -import "base" Control.Monad.ST as X___ diff --git a/Control/Monad/ST/Lazy.hs b/Control/Monad/ST/Lazy.hs deleted file mode 100644 --- a/Control/Monad/ST/Lazy.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Monad.ST.Lazy (module X___) where -import "base" Control.Monad.ST.Lazy as X___ diff --git a/Control/Monad/ST/Strict.hs b/Control/Monad/ST/Strict.hs deleted file mode 100644 --- a/Control/Monad/ST/Strict.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Control.Monad.ST.Strict (module X___) where -import "base" Control.Monad.ST.Strict as X___ diff --git a/Data/Bits.hs b/Data/Bits.hs deleted file mode 100644 --- a/Data/Bits.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Bits (module X___) where -import "base" Data.Bits as X___ diff --git a/Data/Bool.hs b/Data/Bool.hs deleted file mode 100644 --- a/Data/Bool.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Bool (module X___) where -import "base" Data.Bool as X___ diff --git a/Data/Char.hs b/Data/Char.hs deleted file mode 100644 --- a/Data/Char.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Char (module X___) where -import "base" Data.Char as X___ diff --git a/Data/Complex.hs b/Data/Complex.hs deleted file mode 100644 --- a/Data/Complex.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Complex (module X___) where -import "base" Data.Complex as X___ diff --git a/Data/Dynamic.hs b/Data/Dynamic.hs deleted file mode 100644 --- a/Data/Dynamic.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Dynamic (module X___) where -import "base" Data.Dynamic as X___ diff --git a/Data/Either.hs b/Data/Either.hs deleted file mode 100644 --- a/Data/Either.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Either (module X___) where -import "base" Data.Either as X___ diff --git a/Data/Eq.hs b/Data/Eq.hs deleted file mode 100644 --- a/Data/Eq.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Eq (module X___) where -import "base" Data.Eq as X___ diff --git a/Data/Fixed.hs b/Data/Fixed.hs deleted file mode 100644 --- a/Data/Fixed.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Fixed (module X___) where -import "base" Data.Fixed as X___ diff --git a/Data/Foldable.hs b/Data/Foldable.hs deleted file mode 100644 --- a/Data/Foldable.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Foldable (module X___) where -import "base" Data.Foldable as X___ diff --git a/Data/Function.hs b/Data/Function.hs deleted file mode 100644 --- a/Data/Function.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Function (module X___) where -import "base" Data.Function as X___ diff --git a/Data/Generics.hs b/Data/Generics.hs deleted file mode 100644 --- a/Data/Generics.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Generics (module X___) where -import "syb" Data.Generics as X___ diff --git a/Data/Generics/Aliases.hs b/Data/Generics/Aliases.hs deleted file mode 100644 --- a/Data/Generics/Aliases.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Generics.Aliases (module X___) where -import "syb" Data.Generics.Aliases as X___ diff --git a/Data/Generics/Basics.hs b/Data/Generics/Basics.hs deleted file mode 100644 --- a/Data/Generics/Basics.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Generics.Basics (module X___) where -import "syb" Data.Generics.Basics as X___ diff --git a/Data/Generics/Instances.hs b/Data/Generics/Instances.hs deleted file mode 100644 --- a/Data/Generics/Instances.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Generics.Instances () where -import "syb" Data.Generics.Instances as X___ () diff --git a/Data/Generics/Schemes.hs b/Data/Generics/Schemes.hs deleted file mode 100644 --- a/Data/Generics/Schemes.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Generics.Schemes (module X___) where -import "syb" Data.Generics.Schemes as X___ diff --git a/Data/Generics/Text.hs b/Data/Generics/Text.hs deleted file mode 100644 --- a/Data/Generics/Text.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Generics.Text (module X___) where -import "syb" Data.Generics.Text as X___ diff --git a/Data/Generics/Twins.hs b/Data/Generics/Twins.hs deleted file mode 100644 --- a/Data/Generics/Twins.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Generics.Twins (module X___) where -import "syb" Data.Generics.Twins as X___ diff --git a/Data/HashTable.hs b/Data/HashTable.hs deleted file mode 100644 --- a/Data/HashTable.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.HashTable (module X___) where -import "base" Data.HashTable as X___ diff --git a/Data/IORef.hs b/Data/IORef.hs deleted file mode 100644 --- a/Data/IORef.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.IORef (module X___) where -import "base" Data.IORef as X___ diff --git a/Data/Int.hs b/Data/Int.hs deleted file mode 100644 --- a/Data/Int.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Int (module X___) where -import "base" Data.Int as X___ diff --git a/Data/Ix.hs b/Data/Ix.hs deleted file mode 100644 --- a/Data/Ix.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Ix (module X___) where -import "base" Data.Ix as X___ diff --git a/Data/List.hs b/Data/List.hs deleted file mode 100644 --- a/Data/List.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.List (module X___) where -import "base" Data.List as X___ diff --git a/Data/Maybe.hs b/Data/Maybe.hs deleted file mode 100644 --- a/Data/Maybe.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Maybe (module X___) where -import "base" Data.Maybe as X___ diff --git a/Data/Monoid.hs b/Data/Monoid.hs deleted file mode 100644 --- a/Data/Monoid.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Monoid (module X___) where -import "base" Data.Monoid as X___ diff --git a/Data/Ord.hs b/Data/Ord.hs deleted file mode 100644 --- a/Data/Ord.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Ord (module X___) where -import "base" Data.Ord as X___ diff --git a/Data/Ratio.hs b/Data/Ratio.hs deleted file mode 100644 --- a/Data/Ratio.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Ratio (module X___) where -import "base" Data.Ratio as X___ diff --git a/Data/STRef.hs b/Data/STRef.hs deleted file mode 100644 --- a/Data/STRef.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.STRef (module X___) where -import "base" Data.STRef as X___ diff --git a/Data/STRef/Lazy.hs b/Data/STRef/Lazy.hs deleted file mode 100644 --- a/Data/STRef/Lazy.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.STRef.Lazy (module X___) where -import "base" Data.STRef.Lazy as X___ diff --git a/Data/STRef/Strict.hs b/Data/STRef/Strict.hs deleted file mode 100644 --- a/Data/STRef/Strict.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.STRef.Strict (module X___) where -import "base" Data.STRef.Strict as X___ diff --git a/Data/String.hs b/Data/String.hs deleted file mode 100644 --- a/Data/String.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.String (module X___) where -import "base" Data.String as X___ diff --git a/Data/Traversable.hs b/Data/Traversable.hs deleted file mode 100644 --- a/Data/Traversable.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Traversable (module X___) where -import "base" Data.Traversable as X___ diff --git a/Data/Tuple.hs b/Data/Tuple.hs deleted file mode 100644 --- a/Data/Tuple.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Tuple (module X___) where -import "base" Data.Tuple as X___ diff --git a/Data/Typeable.hs b/Data/Typeable.hs deleted file mode 100644 --- a/Data/Typeable.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Typeable (module X___) where -import "base" Data.Typeable as X___ diff --git a/Data/Unique.hs b/Data/Unique.hs deleted file mode 100644 --- a/Data/Unique.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Unique (module X___) where -import "base" Data.Unique as X___ diff --git a/Data/Version.hs b/Data/Version.hs deleted file mode 100644 --- a/Data/Version.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Version (module X___) where -import "base" Data.Version as X___ diff --git a/Data/Word.hs b/Data/Word.hs deleted file mode 100644 --- a/Data/Word.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Data.Word (module X___) where -import "base" Data.Word as X___ diff --git a/Debug/Trace.hs b/Debug/Trace.hs deleted file mode 100644 --- a/Debug/Trace.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Debug.Trace (module X___) where -import "base" Debug.Trace as X___ diff --git a/Foreign.hs b/Foreign.hs deleted file mode 100644 --- a/Foreign.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign (module X___) where -import "base" Foreign as X___ diff --git a/Foreign/C.hs b/Foreign/C.hs deleted file mode 100644 --- a/Foreign/C.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.C (module X___) where -import "base" Foreign.C as X___ diff --git a/Foreign/C/Error.hs b/Foreign/C/Error.hs deleted file mode 100644 --- a/Foreign/C/Error.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.C.Error (module X___) where -import "base" Foreign.C.Error as X___ diff --git a/Foreign/C/String.hs b/Foreign/C/String.hs deleted file mode 100644 --- a/Foreign/C/String.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.C.String (module X___) where -import "base" Foreign.C.String as X___ diff --git a/Foreign/C/Types.hs b/Foreign/C/Types.hs deleted file mode 100644 --- a/Foreign/C/Types.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.C.Types (module X___) where -import "base" Foreign.C.Types as X___ diff --git a/Foreign/Concurrent.hs b/Foreign/Concurrent.hs deleted file mode 100644 --- a/Foreign/Concurrent.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.Concurrent (module X___) where -import "base" Foreign.Concurrent as X___ diff --git a/Foreign/ForeignPtr.hs b/Foreign/ForeignPtr.hs deleted file mode 100644 --- a/Foreign/ForeignPtr.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.ForeignPtr (module X___) where -import "base" Foreign.ForeignPtr as X___ diff --git a/Foreign/Marshal.hs b/Foreign/Marshal.hs deleted file mode 100644 --- a/Foreign/Marshal.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.Marshal (module X___) where -import "base" Foreign.Marshal as X___ diff --git a/Foreign/Marshal/Alloc.hs b/Foreign/Marshal/Alloc.hs deleted file mode 100644 --- a/Foreign/Marshal/Alloc.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.Marshal.Alloc (module X___) where -import "base" Foreign.Marshal.Alloc as X___ diff --git a/Foreign/Marshal/Array.hs b/Foreign/Marshal/Array.hs deleted file mode 100644 --- a/Foreign/Marshal/Array.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.Marshal.Array (module X___) where -import "base" Foreign.Marshal.Array as X___ diff --git a/Foreign/Marshal/Error.hs b/Foreign/Marshal/Error.hs deleted file mode 100644 --- a/Foreign/Marshal/Error.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.Marshal.Error (module X___) where -import "base" Foreign.Marshal.Error as X___ diff --git a/Foreign/Marshal/Pool.hs b/Foreign/Marshal/Pool.hs deleted file mode 100644 --- a/Foreign/Marshal/Pool.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.Marshal.Pool (module X___) where -import "base" Foreign.Marshal.Pool as X___ diff --git a/Foreign/Marshal/Utils.hs b/Foreign/Marshal/Utils.hs deleted file mode 100644 --- a/Foreign/Marshal/Utils.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.Marshal.Utils (module X___) where -import "base" Foreign.Marshal.Utils as X___ diff --git a/Foreign/Ptr.hs b/Foreign/Ptr.hs deleted file mode 100644 --- a/Foreign/Ptr.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.Ptr (module X___) where -import "base" Foreign.Ptr as X___ diff --git a/Foreign/StablePtr.hs b/Foreign/StablePtr.hs deleted file mode 100644 --- a/Foreign/StablePtr.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.StablePtr (module X___) where -import "base" Foreign.StablePtr as X___ diff --git a/Foreign/Storable.hs b/Foreign/Storable.hs deleted file mode 100644 --- a/Foreign/Storable.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Foreign.Storable (module X___) where -import "base" Foreign.Storable as X___ diff --git a/GHC/Arr.hs b/GHC/Arr.hs deleted file mode 100644 --- a/GHC/Arr.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Arr (module X___) where -import "base" GHC.Arr as X___ diff --git a/GHC/Base.hs b/GHC/Base.hs deleted file mode 100644 --- a/GHC/Base.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Base (module X___) where -import "base" GHC.Base as X___ diff --git a/GHC/Conc.hs b/GHC/Conc.hs deleted file mode 100644 --- a/GHC/Conc.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Conc (module X___) where -import "base" GHC.Conc as X___ diff --git a/GHC/ConsoleHandler.hs b/GHC/ConsoleHandler.hs deleted file mode 100644 --- a/GHC/ConsoleHandler.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.ConsoleHandler ({- empty: module X___ -}) where -import "base" GHC.ConsoleHandler as X___ () diff --git a/GHC/Desugar.hs b/GHC/Desugar.hs deleted file mode 100644 --- a/GHC/Desugar.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Desugar (module X___) where -import "base" GHC.Desugar as X___ diff --git a/GHC/Dotnet.hs b/GHC/Dotnet.hs deleted file mode 100644 --- a/GHC/Dotnet.hs +++ /dev/null @@ -1,1 +0,0 @@ -module GHC.Dotnet () where diff --git a/GHC/Enum.hs b/GHC/Enum.hs deleted file mode 100644 --- a/GHC/Enum.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Enum (module X___) where -import "base" GHC.Enum as X___ diff --git a/GHC/Environment.hs b/GHC/Environment.hs deleted file mode 100644 --- a/GHC/Environment.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Environment (module X___) where -import "base" GHC.Environment as X___ diff --git a/GHC/Err.hs b/GHC/Err.hs deleted file mode 100644 --- a/GHC/Err.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Err (module X___) where -import "base" GHC.Err as X___ diff --git a/GHC/Exception.hs b/GHC/Exception.hs deleted file mode 100644 --- a/GHC/Exception.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Exception (module X___) where -import "base" GHC.Exception as X___ diff --git a/GHC/Exts.hs b/GHC/Exts.hs deleted file mode 100644 --- a/GHC/Exts.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Exts (module X___) where -import "base" GHC.Exts as X___ diff --git a/GHC/Float.hs b/GHC/Float.hs deleted file mode 100644 --- a/GHC/Float.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Float (module X___) where -import "base" GHC.Float as X___ diff --git a/GHC/ForeignPtr.hs b/GHC/ForeignPtr.hs deleted file mode 100644 --- a/GHC/ForeignPtr.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.ForeignPtr (module X___) where -import "base" GHC.ForeignPtr as X___ diff --git a/GHC/Handle.hs b/GHC/Handle.hs deleted file mode 100644 --- a/GHC/Handle.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module GHC.Handle ( - withHandle, withHandle', withHandle_, - wantWritableHandle, wantReadableHandle, wantSeekableHandle, - - --newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, - --flushWriteBufferOnly, - flushWriteBuffer, --flushReadBuffer, - --fillReadBuffer, fillReadBufferWithoutBlocking, - --readRawBuffer, readRawBufferPtr, - --readRawBufferNoBlock, readRawBufferPtrNoBlock, - --writeRawBuffer, writeRawBufferPtr, - -#ifndef mingw32_HOST_OS - unlockFile, -#endif - - ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, - - stdin, stdout, stderr, - IOMode(..), openFile, openBinaryFile, - --fdToHandle_stat, - fdToHandle, fdToHandle', - hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode, - -- hLookAhead', - hFlush, hDuplicate, hDuplicateTo, - - hClose, hClose_help, - - HandlePosition, HandlePosn(..), hGetPosn, hSetPosn, - SeekMode(..), hSeek, hTell, - - hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable, - hSetEcho, hGetEcho, hIsTerminalDevice, - - hShow, - - ) where - -import "base" GHC.IO.IOMode -import "base" GHC.IO.Handle -import "base" GHC.IO.Handle.Internals -import "base" GHC.IO.Handle.FD -#ifndef mingw32_HOST_OS -import "base" Foreign.C -#endif - -#ifndef mingw32_HOST_OS -foreign import ccall unsafe "unlockFile" - unlockFile :: CInt -> IO CInt -#endif - diff --git a/GHC/IO.hs b/GHC/IO.hs deleted file mode 100644 --- a/GHC/IO.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.IO (module X___) where -import "base" GHC.IO as X___ diff --git a/GHC/IOBase.hs b/GHC/IOBase.hs deleted file mode 100644 --- a/GHC/IOBase.hs +++ /dev/null @@ -1,40 +0,0 @@ -module GHC.IOBase( - IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, - unsafePerformIO, unsafeInterleaveIO, - unsafeDupablePerformIO, unsafeDupableInterleaveIO, - noDuplicate, - - -- To and from from ST - stToIO, ioToST, unsafeIOToST, unsafeSTToIO, - - -- References - IORef(..), newIORef, readIORef, writeIORef, - IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray, - MVar(..), - - -- Handles, file descriptors, - FilePath, - Handle(..), Handle__(..), HandleType(..), IOMode(..), FD, - isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle, - - -- Buffers - -- Buffer(..), RawBuffer, BufferState(..), - BufferList(..), BufferMode(..), - --bufferIsWritable, bufferEmpty, bufferFull, - - -- Exceptions - Exception(..), ArithException(..), AsyncException(..), ArrayException(..), - stackOverflow, heapOverflow, ioException, - IOError, IOException(..), IOErrorType(..), ioError, userError, - ExitCode(..), - throwIO, block, unblock, blocked, catchAny, catchException, - evaluate, - ErrorCall(..), AssertionFailed(..), assertError, untangle, - BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..), - blockedOnDeadMVar, blockedIndefinitely - ) where - -import "base" GHC.Base -import "base" GHC.Exception -import "base" GHC.IO -import "base" GHC.IOBase diff --git a/GHC/Int.hs b/GHC/Int.hs deleted file mode 100644 --- a/GHC/Int.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Int (module X___) where -import "base" GHC.Int as X___ diff --git a/GHC/List.hs b/GHC/List.hs deleted file mode 100644 --- a/GHC/List.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.List (module X___) where -import "base" GHC.List as X___ diff --git a/GHC/Num.hs b/GHC/Num.hs deleted file mode 100644 --- a/GHC/Num.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Num (module X___) where -import "base" GHC.Num as X___ diff --git a/GHC/PArr.hs b/GHC/PArr.hs deleted file mode 100644 --- a/GHC/PArr.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.PArr (module X___) where -import "base" GHC.PArr as X___ diff --git a/GHC/Pack.hs b/GHC/Pack.hs deleted file mode 100644 --- a/GHC/Pack.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Pack (module X___) where -import "base" GHC.Pack as X___ diff --git a/GHC/Ptr.hs b/GHC/Ptr.hs deleted file mode 100644 --- a/GHC/Ptr.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Ptr (module X___) where -import "base" GHC.Ptr as X___ diff --git a/GHC/Read.hs b/GHC/Read.hs deleted file mode 100644 --- a/GHC/Read.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Read (module X___) where -import "base" GHC.Read as X___ diff --git a/GHC/Real.hs b/GHC/Real.hs deleted file mode 100644 --- a/GHC/Real.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Real (module X___) where -import "base" GHC.Real as X___ diff --git a/GHC/ST.hs b/GHC/ST.hs deleted file mode 100644 --- a/GHC/ST.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.ST (module X___) where -import "base" GHC.ST as X___ diff --git a/GHC/STRef.hs b/GHC/STRef.hs deleted file mode 100644 --- a/GHC/STRef.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.STRef (module X___) where -import "base" GHC.STRef as X___ diff --git a/GHC/Show.hs b/GHC/Show.hs deleted file mode 100644 --- a/GHC/Show.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Show (module X___) where -import "base" GHC.Show as X___ diff --git a/GHC/Stable.hs b/GHC/Stable.hs deleted file mode 100644 --- a/GHC/Stable.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Stable (module X___) where -import "base" GHC.Stable as X___ diff --git a/GHC/Storable.hs b/GHC/Storable.hs deleted file mode 100644 --- a/GHC/Storable.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Storable (module X___) where -import "base" GHC.Storable as X___ diff --git a/GHC/TopHandler.hs b/GHC/TopHandler.hs deleted file mode 100644 --- a/GHC/TopHandler.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.TopHandler (module X___) where -import "base" GHC.TopHandler as X___ diff --git a/GHC/Unicode.hs b/GHC/Unicode.hs deleted file mode 100644 --- a/GHC/Unicode.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Unicode (module X___) where -import "base" GHC.Unicode as X___ diff --git a/GHC/Weak.hs b/GHC/Weak.hs deleted file mode 100644 --- a/GHC/Weak.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Weak (module X___) where -import "base" GHC.Weak as X___ diff --git a/GHC/Word.hs b/GHC/Word.hs deleted file mode 100644 --- a/GHC/Word.hs +++ /dev/null @@ -1,2 +0,0 @@ -module GHC.Word (module X___) where -import "base" GHC.Word as X___ diff --git a/Numeric.hs b/Numeric.hs deleted file mode 100644 --- a/Numeric.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Numeric (module X___) where -import "base" Numeric as X___ diff --git a/Prelude.hs b/Prelude.hs deleted file mode 100644 --- a/Prelude.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} -module Prelude -{-# DEPRECATED - ["You are using the old package `base' version 3.x." - ,"Future GHC versions will not support base version 3.x. You" - ,"should update your code to use the new base version 4.x."] - #-} - (module X___) where -import "base" Prelude as X___ diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/System/CPUTime.hs b/System/CPUTime.hs deleted file mode 100644 --- a/System/CPUTime.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.CPUTime (module X___) where -import "base" System.CPUTime as X___ diff --git a/System/Console/GetOpt.hs b/System/Console/GetOpt.hs deleted file mode 100644 --- a/System/Console/GetOpt.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.Console.GetOpt (module X___) where -import "base" System.Console.GetOpt as X___ diff --git a/System/Environment.hs b/System/Environment.hs deleted file mode 100644 --- a/System/Environment.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.Environment (module X___) where -import "base" System.Environment as X___ diff --git a/System/Exit.hs b/System/Exit.hs deleted file mode 100644 --- a/System/Exit.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.Exit (module X___) where -import "base" System.Exit as X___ diff --git a/System/IO.hs b/System/IO.hs deleted file mode 100644 --- a/System/IO.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.IO (module X___) where -import "base" System.IO as X___ diff --git a/System/IO/Error.hs b/System/IO/Error.hs deleted file mode 100644 --- a/System/IO/Error.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.IO.Error (module X___) where -import "base" System.IO.Error as X___ diff --git a/System/IO/Unsafe.hs b/System/IO/Unsafe.hs deleted file mode 100644 --- a/System/IO/Unsafe.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.IO.Unsafe (module X___) where -import "base" System.IO.Unsafe as X___ diff --git a/System/Info.hs b/System/Info.hs deleted file mode 100644 --- a/System/Info.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.Info (module X___) where -import "base" System.Info as X___ diff --git a/System/Mem.hs b/System/Mem.hs deleted file mode 100644 --- a/System/Mem.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.Mem (module X___) where -import "base" System.Mem as X___ diff --git a/System/Mem/StableName.hs b/System/Mem/StableName.hs deleted file mode 100644 --- a/System/Mem/StableName.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.Mem.StableName (module X___) where -import "base" System.Mem.StableName as X___ diff --git a/System/Mem/Weak.hs b/System/Mem/Weak.hs deleted file mode 100644 --- a/System/Mem/Weak.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.Mem.Weak (module X___) where -import "base" System.Mem.Weak as X___ diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs deleted file mode 100644 --- a/System/Posix/Internals.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.Posix.Internals (module X___) where -import "base" System.Posix.Internals as X___ diff --git a/System/Posix/Types.hs b/System/Posix/Types.hs deleted file mode 100644 --- a/System/Posix/Types.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.Posix.Types (module X___) where -import "base" System.Posix.Types as X___ diff --git a/System/Timeout.hs b/System/Timeout.hs deleted file mode 100644 --- a/System/Timeout.hs +++ /dev/null @@ -1,2 +0,0 @@ -module System.Timeout (module X___) where -import "base" System.Timeout as X___ diff --git a/Text/ParserCombinators/ReadP.hs b/Text/ParserCombinators/ReadP.hs deleted file mode 100644 --- a/Text/ParserCombinators/ReadP.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Text.ParserCombinators.ReadP (module X___) where -import "base" Text.ParserCombinators.ReadP as X___ diff --git a/Text/ParserCombinators/ReadPrec.hs b/Text/ParserCombinators/ReadPrec.hs deleted file mode 100644 --- a/Text/ParserCombinators/ReadPrec.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Text.ParserCombinators.ReadPrec (module X___) where -import "base" Text.ParserCombinators.ReadPrec as X___ diff --git a/Text/Printf.hs b/Text/Printf.hs deleted file mode 100644 --- a/Text/Printf.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Text.Printf (module X___) where -import "base" Text.Printf as X___ diff --git a/Text/Read.hs b/Text/Read.hs deleted file mode 100644 --- a/Text/Read.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Text.Read (module X___) where -import "base" Text.Read as X___ diff --git a/Text/Read/Lex.hs b/Text/Read/Lex.hs deleted file mode 100644 --- a/Text/Read/Lex.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Text.Read.Lex (module X___) where -import "base" Text.Read.Lex as X___ diff --git a/Text/Show.hs b/Text/Show.hs deleted file mode 100644 --- a/Text/Show.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Text.Show (module X___) where -import "base" Text.Show as X___ diff --git a/Text/Show/Functions.hs b/Text/Show/Functions.hs deleted file mode 100644 --- a/Text/Show/Functions.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Text.Show.Functions ({- empty: module X___ -}) where -import "base" Text.Show.Functions as X___ () diff --git a/Unsafe/Coerce.hs b/Unsafe/Coerce.hs deleted file mode 100644 --- a/Unsafe/Coerce.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Unsafe.Coerce (module X___) where -import "base" Unsafe.Coerce as X___ diff --git a/base.cabal b/base.cabal --- a/base.cabal +++ b/base.cabal @@ -1,160 +1,320 @@ +cabal-version: 3.0 + +-- WARNING: ghc-experimental.cabal is automatically generated from ghc-experimental.cabal.in +-- Make sure you are editing ghc-experimental.cabal.in, not ghc-experimental.cabal + name: base -version: 3.0.3.2 -license: BSD3 +version: 4.22.0.0 +-- NOTE: Don't forget to update ./changelog.md + +license: BSD-3-Clause license-file: LICENSE -maintainer: libraries@haskell.org -bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/base -synopsis: Basic libraries (backwards-compatibility version) -description: - This is a backwards-compatible version of the base package. - It depends on a later version of base, and was probably supplied - with your compiler when it was installed. - -cabal-version: >=1.6 -build-type: Simple +maintainer: Core Libraries Committee +bug-reports: https://github.com/haskell/core-libraries-committee/issues +synopsis: Core data structures and operations +category: Prelude +build-type: Simple +description: Haskell's base library provides, among other things, core types (e.g. [Bool]("Data.Bool") and [Int]("Data.Int")), + data structures (e.g. [List]("Data.List"), [Tuple]("Data.Tuple") and [Maybe]("Data.Maybe")), + the [Exception]("Control.Exception") mechanism, and the [IO]("System.IO") & [Concurrency]("Control.Concurrent") operations. + The "Prelude" module, which is imported by default, exposes a curated set of types and functions from other modules. -source-repository head - type: darcs - location: http://darcs.haskell.org/packages/base3-compat + Other data structures like [Map](https://hackage.haskell.org/package/containers/docs/Data-Map.html), + [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. -Library { - build-depends: base >= 4.0 && < 4.3, - syb >= 0.1 && < 0.2 - extensions: PackageImports,CPP - ghc-options: -fno-warn-deprecations +extra-doc-files: + changelog.md - if impl(ghc < 6.9) { - buildable: False - } +Library + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + build-depends: + ghc-internal == 9.1401.*, + ghc-prim, - if impl(ghc) { - exposed-modules: - Data.Generics, - Data.Generics.Aliases, - Data.Generics.Basics, - Data.Generics.Instances, - Data.Generics.Schemes, - Data.Generics.Text, - Data.Generics.Twins, - Foreign.Concurrent, - GHC.Arr, - GHC.Base, - GHC.Conc, - GHC.ConsoleHandler, - GHC.Desugar, - GHC.Dotnet, - GHC.Enum, - GHC.Environment, - GHC.Err, - GHC.Exception, - GHC.Exts, - GHC.Float, - GHC.ForeignPtr, - GHC.Handle, - GHC.IO, - GHC.IOBase, - GHC.Int, - GHC.List, - GHC.Num, - GHC.PArr, - GHC.Pack, - GHC.Ptr, - GHC.Read, - GHC.Real, - GHC.ST, - GHC.STRef, - GHC.Show, - GHC.Stable, - GHC.Storable, - GHC.TopHandler, - GHC.Unicode, - GHC.Weak, - GHC.Word, - System.Timeout - } exposed-modules: - Control.Applicative, - Control.Arrow, - Control.Category, - Control.Concurrent, - Control.Concurrent.Chan, - Control.Concurrent.MVar, - Control.Concurrent.QSem, - Control.Concurrent.QSemN, - Control.Concurrent.SampleVar, - Control.Exception, - Control.Monad, - Control.Monad.Fix, - Control.Monad.Instances, - Control.Monad.ST, - Control.Monad.ST.Lazy, - Control.Monad.ST.Strict, - Data.Bits, - Data.Bool, - Data.Char, - Data.Complex, - Data.Dynamic, - Data.Either, - Data.Eq, - Data.Fixed, - Data.Foldable - Data.Function, - Data.HashTable, - Data.IORef, - Data.Int, - Data.Ix, - Data.List, - Data.Maybe, - Data.Monoid, - Data.Ord, - Data.Ratio, - Data.STRef, - Data.STRef.Lazy, - Data.STRef.Strict, - Data.String, - Data.Traversable - Data.Tuple, - Data.Typeable, - Data.Unique, - Data.Version, - Data.Word, - Debug.Trace, - Foreign, - Foreign.C, - Foreign.C.Error, - Foreign.C.String, - Foreign.C.Types, - Foreign.ForeignPtr, - Foreign.Marshal, - Foreign.Marshal.Alloc, - Foreign.Marshal.Array, - Foreign.Marshal.Error, - Foreign.Marshal.Pool, - Foreign.Marshal.Utils, - Foreign.Ptr, - Foreign.StablePtr, - Foreign.Storable, - Numeric, - Prelude, - System.Console.GetOpt, - System.CPUTime, - System.Environment, - System.Exit, - System.IO, - System.IO.Error, - System.IO.Unsafe, - System.Info, - System.Mem, - System.Mem.StableName, - System.Mem.Weak, - System.Posix.Internals, - System.Posix.Types, - Text.ParserCombinators.ReadP, - Text.ParserCombinators.ReadPrec, - Text.Printf, - Text.Read, - Text.Read.Lex, - Text.Show, - Text.Show.Functions - Unsafe.Coerce -} + Control.Applicative + , Control.Concurrent + , Control.Concurrent.Chan + , Control.Concurrent.QSem + , Control.Concurrent.QSemN + , Control.Monad.IO.Class + , Control.Monad.Zip + , Data.Array.Byte + , Data.Bifoldable + , Data.Bifoldable1 + , Data.Bifunctor + , Data.Bitraversable + , Data.Bounded + , Data.Char + , Data.Complex + , Data.Enum + , Data.Fixed + , Data.Foldable1 + , Data.Functor.Classes + , Data.Functor.Compose + , Data.Functor.Contravariant + , Data.Functor.Sum + , Data.Functor.Product + , Data.List.NonEmpty + , Data.Ratio + , Data.STRef.Lazy + , Data.Semigroup + , Prelude + , Text.Printf + , System.CPUTime + , System.Console.GetOpt + , System.IO.Unsafe + , System.Info + , System.Mem.Weak + , System.Timeout + + exposed-modules: + , Control.Arrow + , Control.Category + , Control.Concurrent.MVar + , Control.Exception + , Control.Exception.Annotation + , Control.Exception.Backtrace + , Control.Exception.Base + , Control.Exception.Context + , Control.Monad + , Control.Monad.Fail + , Control.Monad.Fix + , Control.Monad.Instances + , Control.Monad.ST + , Control.Monad.ST.Lazy + , Control.Monad.ST.Lazy.Safe + , Control.Monad.ST.Lazy.Unsafe + , Control.Monad.ST.Safe + , Control.Monad.ST.Strict + , Control.Monad.ST.Unsafe + , Data.Bits + , Data.Bool + , Data.Coerce + , Data.Data + , Data.Dynamic + , Data.Either + , Data.Eq + , Data.Foldable + , Data.Function + , Data.Functor + , Data.Functor.Const + , Data.Functor.Identity + , Data.IORef + , Data.Int + , Data.Ix + , Data.Kind + , Data.List + , Data.Maybe + , Data.Monoid + , Data.Ord + , Data.Proxy + , Data.STRef + , Data.STRef.Strict + , Data.String + , Data.Traversable + , Data.Tuple + , Data.Type.Bool + , Data.Type.Coercion + , Data.Type.Equality + , Data.Type.Ord + , Data.Typeable + , Data.Unique + , Data.Version + , Data.Void + , Data.Word + , Debug.Trace + , Foreign + , Foreign.C + , Foreign.C.ConstPtr + , Foreign.C.Error + , Foreign.C.String + , Foreign.C.Types + , Foreign.Concurrent + , Foreign.ForeignPtr + , Foreign.ForeignPtr.Safe + , Foreign.ForeignPtr.Unsafe + , Foreign.Marshal + , Foreign.Marshal.Alloc + , Foreign.Marshal.Array + , Foreign.Marshal.Error + , Foreign.Marshal.Pool + , Foreign.Marshal.Safe + , Foreign.Marshal.Unsafe + , Foreign.Marshal.Utils + , Foreign.Ptr + , Foreign.Safe + , Foreign.StablePtr + , Foreign.Storable + , GHC.Arr + , GHC.ArrayArray + , GHC.Base + , GHC.Bits + , GHC.ByteOrder + , GHC.Char + , GHC.Clock + , GHC.Conc + , GHC.Conc.IO + , GHC.Conc.Signal + , GHC.Conc.Sync + , GHC.ConsoleHandler + , GHC.Constants + , GHC.Desugar + , GHC.Encoding.UTF8 + , GHC.Enum + , GHC.Environment + , GHC.Err + , GHC.Event.TimeOut + , GHC.Exception + , GHC.Exception.Type + , GHC.ExecutionStack + , GHC.Exts + , GHC.Fingerprint + , GHC.Fingerprint.Type + , GHC.Float + , GHC.Float.ConversionUtils + , GHC.Float.RealFracMethods + , GHC.Foreign + , GHC.ForeignPtr + , GHC.GHCi + , GHC.GHCi.Helpers + , GHC.Generics + , GHC.InfoProv + , GHC.IO + , GHC.IO.Buffer + , GHC.IO.BufferedIO + , GHC.IO.Device + , GHC.IO.Encoding + , GHC.IO.Encoding.CodePage + , GHC.IO.Encoding.Failure + , GHC.IO.Encoding.Iconv + , GHC.IO.Encoding.Latin1 + , GHC.IO.Encoding.Types + , GHC.IO.Encoding.UTF16 + , GHC.IO.Encoding.UTF32 + , GHC.IO.Encoding.UTF8 + , GHC.IO.Exception + , GHC.IO.FD + , GHC.IO.Handle + , GHC.IO.Handle.FD + , GHC.IO.Handle.Internals + , GHC.IO.Handle.Lock + , GHC.IO.Handle.Text + , GHC.IO.Handle.Types + , GHC.IO.IOMode + , GHC.IO.Unsafe + , GHC.IO.StdHandles + , GHC.IO.SubSystem + , GHC.IOArray + , GHC.IORef + , GHC.Int + , GHC.Integer + , GHC.Integer.Logarithms + , GHC.IsList + , GHC.Ix + , GHC.List + , GHC.Maybe + , GHC.MVar + , GHC.Natural + , GHC.Num + , GHC.Num.Integer + , GHC.Num.Natural + , GHC.Num.BigNat + , GHC.OldList + , GHC.OverloadedLabels + , GHC.Profiling + , GHC.Ptr + , GHC.Read + , GHC.Real + , GHC.Records + , GHC.ResponseFile + , GHC.RTS.Flags + , GHC.ST + , GHC.Stack.CloneStack + , GHC.StaticPtr + , GHC.STRef + , GHC.Show + , GHC.Stable + , GHC.StableName + , GHC.Stack + , GHC.Stack.CCS + , GHC.Stack.Types + , GHC.Stats + , GHC.Storable + , GHC.TopHandler + , GHC.TypeError + , GHC.TypeLits + , GHC.TypeNats + , GHC.Unicode + , GHC.Weak + , GHC.Weak.Finalize + , GHC.Word + , Numeric + , Numeric.Natural + , System.Environment + , System.Environment.Blank + , System.Exit + , System.IO + , System.IO.Error + , System.Mem + , System.Mem.StableName + , System.Posix.Internals + , System.Posix.Types + , Text.ParserCombinators.ReadP + , Text.ParserCombinators.ReadPrec + , Text.Read + , Text.Read.Lex + , Text.Show + , Text.Show.Functions + , Type.Reflection + , Type.Reflection.Unsafe + , Unsafe.Coerce + + if os(windows) + exposed-modules: + GHC.IO.Encoding.CodePage.API + , GHC.IO.Encoding.CodePage.Table + , GHC.Conc.Windows + , GHC.Conc.WinIO + , GHC.Conc.POSIX + , GHC.Conc.POSIX.Const + , GHC.Windows + , GHC.Event.Windows + , GHC.Event.Windows.Clock + , GHC.Event.Windows.ConsoleEvent + , GHC.Event.Windows.FFI + , GHC.Event.Windows.ManagedThreadPool + , GHC.Event.Windows.Thread + , GHC.IO.Handle.Windows + , GHC.IO.Windows.Handle + , GHC.IO.Windows.Encoding + , GHC.IO.Windows.Paths + else + exposed-modules: + GHC.Event + + if arch(javascript) + exposed-modules: + GHC.JS.Prim + , GHC.JS.Prim.Internal + , GHC.JS.Prim.Internal.Build + , GHC.JS.Foreign.Callback + + other-modules: + System.CPUTime.Unsupported + System.CPUTime.Utils + if os(windows) + other-modules: + System.CPUTime.Windows + elif arch(javascript) + other-modules: + System.CPUTime.Javascript + else + other-modules: + System.CPUTime.Posix.ClockGetTime + System.CPUTime.Posix.Times + System.CPUTime.Posix.RUsage + + hs-source-dirs: src diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,1317 @@ +# Changelog for [`base` package](http://hackage.haskell.org/package/base) + +## 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 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.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). + * 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)) + * Add `permutations` and `permutations1` to `Data.List.NonEmpty` ([CLC proposal #68](https://github.com/haskell/core-libraries-committee/issues/68)) + * Add a `RULE` to `Prelude.lookup`, allowing it to participate in list fusion ([CLC proposal #175](https://github.com/haskell/core-libraries-committee/issues/175)) + * Implement `stimes` for `instance Semigroup (Endo a)` explicitly ([CLC proposal #4](https://github.com/haskell/core-libraries-committee/issues/4)) + * Add `startTimeProfileAtStartup` to `GHC.RTS.Flags` to expose new RTS flag + `--no-automatic-heap-samples` in the Haskell API ([CLC proposal #243](https://github.com/haskell/core-libraries-committee/issues/243)). + * 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` ([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` ([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` + * Always use `safe` call to `read` for regular files and block devices on unix if the RTS is multi-threaded, regardless of `O_NONBLOCK`. + ([CLC proposal #166](https://github.com/haskell/core-libraries-committee/issues/166)) + * Export List from Data.List ([CLC proposal #182](https://github.com/haskell/core-libraries-committee/issues/182)). + * Add `{-# WARNING in "x-data-list-nonempty-unzip" #-}` to `Data.List.NonEmpty.unzip`. + Use `{-# OPTIONS_GHC -Wno-x-data-list-nonempty-unzip #-}` to disable it. + ([CLC proposal #86](https://github.com/haskell/core-libraries-committee/issues/86) + and [CLC proposal #258](https://github.com/haskell/core-libraries-committee/issues/258)) + * Add `System.Mem.performMajorGC` ([CLC proposal #230](https://github.com/haskell/core-libraries-committee/issues/230)) + * Fix exponent overflow/underflow bugs in the `Read` instances for `Float` and `Double` ([CLC proposal #192](https://github.com/haskell/core-libraries-committee/issues/192)) + * `Foreign.C.Error.errnoToIOError` now uses the reentrant `strerror_r` to render system errors when possible ([CLC proposal #249](https://github.com/haskell/core-libraries-committee/issues/249)) + * 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: + + ```haskell + dataToTag#, getTag + :: forall {lev :: Levity} (a :: TYPE (BoxedRep lev)) + . DataToTag a => a -> Int# + ``` + + In particular, they are now applicable only at some (not all) + lifted types. However, if `t` is an algebraic data type (i.e. `t` + 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)) + * 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)) + * Add `fromThreadId :: ThreadId -> Word64` to `GHC.Conc.Sync`, which maps a thread to a per-process-unique identifier ([CLC proposal #117](https://github.com/haskell/core-libraries-committee/issues/117)) + * Add `Data.List.!?` ([CLC proposal #110](https://github.com/haskell/core-libraries-committee/issues/110)) + * Mark `maximumBy`/`minimumBy` as `INLINE` improving performance for unpackable + types significantly. + * Add INLINABLE pragmas to `generic*` functions in Data.OldList ([CLC proposal #129](https://github.com/haskell/core-libraries-committee/issues/130)) + * Export `getSolo` from `Data.Tuple`. + ([CLC proposal #113](https://github.com/haskell/core-libraries-committee/issues/113)) + * Add `Type.Reflection.decTypeRep`, `Data.Typeable.decT` and `Data.Typeable.hdecT` equality decisions functions. + ([CLC proposal #98](https://github.com/haskell/core-libraries-committee/issues/98)) + * Add `Data.Functor.unzip` ([CLC proposal #88](https://github.com/haskell/core-libraries-committee/issues/88)) + * Add `System.Mem.Weak.{get,set}FinalizerExceptionHandler`, which allows the user to set the global handler invoked by when a `Weak` pointer finalizer throws an exception. ([CLC proposal #126](https://github.com/haskell/core-libraries-committee/issues/126)) + * Add `System.Mem.Weak.printToHandleFinalizerExceptionHandler`, which can be used with `setFinalizerExceptionHandler` to print exceptions thrown by finalizers to the given `Handle`. ([CLC proposal #126](https://github.com/haskell/core-libraries-committee/issues/126)) + * Add `Data.List.unsnoc` ([CLC proposal #165](https://github.com/haskell/core-libraries-committee/issues/165)) + * Implement more members of `instance Foldable (Compose f g)` explicitly. + ([CLC proposal #57](https://github.com/haskell/core-libraries-committee/issues/57)) + * Add `Eq` and `Ord` instances for `SSymbol`, `SChar`, and `SNat`. + ([CLC proposal #148](https://github.com/haskell/core-libraries-committee/issues/148)) + * Add `COMPLETE` pragmas to the `TypeRep`, `SSymbol`, `SChar`, and `SNat` pattern synonyms. + ([CLC proposal #149](https://github.com/haskell/core-libraries-committee/issues/149)) + * Make `($)` representation polymorphic ([CLC proposal #132](https://github.com/haskell/core-libraries-committee/issues/132)) + * Implement [GHC Proposal #433](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-unsatisfiable.rst), + adding the class `Unsatisfiable :: ErrorMessage -> TypeError` to `GHC.TypeError`, + which provides a mechanism for custom type errors that reports the errors in + a more predictable behaviour than `TypeError`. + * 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) 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 + * `Foreign.C.ConstPtr.ConstrPtr` was added to encode `const`-qualified + pointer types in foreign declarations when using `CApiFFI` extension. ([CLC proposal #117](https://github.com/haskell/core-libraries-committee/issues/117)) + * Add `forall a. Functor (p a)` superclass for `Bifunctor p` ([CLC proposal #91](https://github.com/haskell/core-libraries-committee/issues/91)) + * Add `forall a. Functor (p a)` superclass for `Bifunctor p`. + * Add Functor instances for `(,,,,) a b c d`, `(,,,,,) a b c d e` and + `(,,,,,) a b c d e f`. + * Exceptions thrown by weak pointer finalizers can now be reported by setting + a global exception handler, using `System.Mem.Weak.setFinalizerExceptionHandler`. + The default behaviour is unchanged (exceptions are ignored and not reported). + * `Numeric.Natural` re-exports `GHC.Natural.minusNaturalMaybe` + ([CLC proposal #45](https://github.com/haskell/core-libraries-committee/issues/45)) + * Add `Data.Foldable1` and `Data.Bifoldable1` + ([CLC proposal #9](https://github.com/haskell/core-libraries-committee/issues/9)) + * Add `applyWhen` to `Data.Function` + ([CLC proposal #71](https://github.com/haskell/core-libraries-committee/issues/71)) + * Add functions `mapAccumM` and `forAccumM` to `Data.Traversable` + ([CLC proposal #65](https://github.com/haskell/core-libraries-committee/issues/65)) + * Add default implementation of `(<>)` in terms of `sconcat` and `mempty` in + terms of `mconcat` ([CLC proposal #61](https://github.com/haskell/core-libraries-committee/issues/61)). + * `GHC.Conc.Sync.listThreads` was added, allowing the user to list the threads + (both running and blocked) of the program. + * `GHC.Conc.Sync.labelThreadByteArray#` was added, allowing the user to specify + a thread label by way of a `ByteArray#` containing a UTF-8-encoded string. + The old `GHC.Conc.Sync.labelThread` is now implemented in terms of this + function. + * `GHC.Conc.Sync.threadLabel` was added, allowing the user to query the label + of a given `ThreadId`. + * Add `inits1` and `tails1` to `Data.List.NonEmpty` + ([CLC proposal #67](https://github.com/haskell/core-libraries-committee/issues/67)) + * Change default `Ord` implementation of `(>=)`, `(>)`, and `(<)` to use + `(<=)` instead of `compare` ([CLC proposal #24](https://github.com/haskell/core-libraries-committee/issues/24)). + * Export `liftA2` from `Prelude`. This means that the entirety of `Applicative` + is now exported from `Prelude` + ([CLC proposal #50](https://github.com/haskell/core-libraries-committee/issues/50), + [the migration + guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/export-lifta2-prelude.md)) + * Switch to a pure Haskell implementation of `GHC.Unicode` + ([CLC proposals #59](https://github.com/haskell/core-libraries-committee/issues/59) + and [#130](https://github.com/haskell/core-libraries-committee/issues/130)) + * Update to [Unicode 15.0.0](https://www.unicode.org/versions/Unicode15.0.0/). + * Add standard Unicode case predicates `isUpperCase` and `isLowerCase` to + `GHC.Unicode` and `Data.Char`. These predicates use the standard Unicode + case properties and are more intuitive than `isUpper` and `isLower` + ([CLC proposal #90](https://github.com/haskell/core-libraries-committee/issues/90)) + * Add `Eq` and `Ord` instances for `Generically1`. + * Relax instances for Functor combinators; put superclass on Class1 and Class2 + to make non-breaking ([CLC proposal #10](https://github.com/haskell/core-libraries-committee/issues/10), + [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/functor-combinator-instances-and-class1s.md)) + * Add `gcdetails_block_fragmentation_bytes` to `GHC.Stats.GCDetails` to track heap fragmentation. + * `GHC.TypeLits` and `GHC.TypeNats` now export the `natSing`, `symbolSing`, + and `charSing` methods of `KnownNat`, `KnownSymbol`, and `KnownChar`, + respectively. They also export the `SNat`, `SSymbol`, and `SChar` types + that are used in these methods and provide an API to interact with these + types, per + [CLC proposal #85](https://github.com/haskell/core-libraries-committee/issues/85). + * The `Enum` instance of `Down a` now enumerates values in the opposite + order as the `Enum a` instance ([CLC proposal #51](https://github.com/haskell/core-libraries-committee/issues/51)) + * `Foreign.Marshal.Pool` now uses the RTS internal arena instead of libc + `malloc` for allocation. It avoids the O(n) overhead of maintaining a list + of individually allocated pointers as well as freeing each one of them when + freeing a `Pool` (#14762, #18338) + * `Type.Reflection.Unsafe` is now marked as unsafe. + * Add `Data.Typeable.heqT`, a kind-heterogeneous version of + `Data.Typeable.eqT` + ([CLC proposal #99](https://github.com/haskell/core-libraries-committee/issues/99)) + * Various declarations GHC's new info-table provenance feature have been + moved from `GHC.Stack.CCS` to a new `GHC.InfoProv` module: + * The `InfoProv`, along its `ipName`, `ipDesc`, `ipTyDesc`, `ipLabel`, + `ipMod`, and `ipLoc` fields, have been moved. + * `InfoProv` now has additional `ipSrcFile` and `ipSrcSpan` fields. `ipLoc` + is now a function computed from these fields. + * The `whereFrom` function has been moved + * Add functions `traceWith`, `traceShowWith`, `traceEventWith` to + `Debug.Trace`, per + [CLC proposal #36](https://github.com/haskell/core-libraries-committee/issues/36). + * Export `List` from `GHC.List` + ([CLC proposal #186](https://github.com/haskell/core-libraries-committee/issues/186)). + +## 4.17.0.0 *August 2022* + + * Shipped with GHC 9.4.1 + + * Add explicitly bidirectional `pattern TypeRep` to `Type.Reflection`. + + * Add `Generically` and `Generically1` to `GHC.Generics` for deriving generic + instances with `DerivingVia`. `Generically` instances include `Semigroup` and + `Monoid`. `Generically1` instances: `Functor`, `Applicative`, `Alternative`, + `Eq1` and `Ord1`. + + * Introduce `GHC.ExecutablePath.executablePath`, which is more robust than + `getExecutablePath` in cases when the executable has been deleted. + + * Add `Data.Array.Byte` module, providing boxed `ByteArray#` and `MutableByteArray#` wrappers. + + * `fromEnum` for `Natural` now throws an error for any number that cannot be + repesented exactly by an `Int` (#20291). + + * `returnA` is defined as `Control.Category.id` instead of `arr id`. + + * Added symbolic synonyms for `xor` and shift operators to `Data.Bits`: + + - `.^.` (`xor`), + - `.>>.` and `!>>.` (`shiftR` and `unsafeShiftR`), + - `.<<.` and `!<<.` (`shiftL` and `unsafeShiftL`). + + These new operators have the same fixity as the originals. + + * `GHC.Exts` now re-exports `Multiplicity` and `MultMul`. + + * A large number of partial functions in `Data.List` and `Data.List.NonEmpty` now + have an HasCallStack constraint. Hopefully providing better error messages in case + they are used in unexpected ways. + + * Fix the `Ord1` instance for `Data.Ord.Down` to reverse sort order. + + * Any Haskell type that wraps a C pointer type has been changed from + `Ptr ()` to `CUIntPtr`. For typical glibc based platforms, the + affected type is `CTimer`. + + * Remove instances of `MonadFail` for the `ST` monad (lazy and strict) as per + the [Core Libraries proposal](https://github.com/haskell/core-libraries-committee/issues/33). + A [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/no-monadfail-st-inst.md) + is available. + + * Re-export `augment` and `build` function from `GHC.List` + + * Re-export the `IsList` typeclass from the new `GHC.IsList` module. + + * 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`. + + 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: :: + + 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. + + 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 + `Word64#` and `Int64#`, respectively. Previously on 32-bit platforms these + were rather represented by `Word#` and `Int#`. See GHC #11953. + + * Add `GHC.TypeError` module to contain functionality related to custom type + errors. `TypeError` is re-exported from `GHC.TypeLits` for backwards + compatibility. + + * Comparison constraints in `Data.Type.Ord` (e.g. `<=`) now use the new + `GHC.TypeError.Assert` type family instead of type equality with `~`. + +## 4.16.3.0 *May 2022* + + * Shipped with GHC 9.2.4 + + * winio: make `consoleReadNonBlocking` not wait for any events at all. + + * 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) + + * Documentation Fixes + +## 4.16.1.0 *Feb 2022* + + * Shipped with GHC 9.2.2 + + * The following Foreign C types now have an instance of `Ix`: + CChar, CSChar, CUChar, CShort, CUShort, CInt, CUInt, CLong, CULong, + CPtrdiff, CSize, CWchar, CSigAtomic, CLLong, CULLong, CBool, CIntPtr, CUIntPtr, + CIntMax, CUIntMax. + +## 4.16.0.0 *Nov 2021* + + * Shipped with GHC 9.2.1 + + * The unary tuple type, `Solo`, is now exported by `Data.Tuple`. + + * Add a `Typeable` constraint to `fromStaticPtr` in the class `GHC.StaticPtr.IsStatic`. + + * Make it possible to promote `Natural`s and remove the separate `Nat` kind. + For backwards compatibility, `Nat` is now a type synonym for `Natural`. + As a consequence, one must enable `TypeSynonymInstances` + in order to define instances for `Nat`. Also, different instances for `Nat` and `Natural` + won't typecheck anymore. + + * Add `Data.Type.Ord` as a module for type-level comparison operations. The + `(<=?)` type operator from `GHC.TypeNats`, previously kind-specific to + `Nat`, is now kind-polymorphic and governed by the `Compare` type family in + `Data.Type.Ord`. Note that this means GHC will no longer deduce `0 <= n` + for all `n` any more. + + * Add `cmpNat`, `cmpSymbol`, and `cmpChar` to `GHC.TypeNats` and `GHC.TypeLits`. + + * Add `CmpChar`, `ConsSymbol`, `UnconsSymbol`, `CharToNat`, and `NatToChar` + type families to `GHC.TypeLits`. + + * Add the `KnownChar` class, `charVal` and `charVal'` to `GHC.TypeLits`. + + * Add `Semigroup` and `Monoid` instances for `Data.Functor.Product` and + `Data.Functor.Compose`. + + * Add `Functor`, `Applicative`, `Monad`, `MonadFix`, `Foldable`, `Traversable`, + `Eq`, `Ord`, `Show`, `Read`, `Eq1`, `Ord1`, `Show1`, `Read1`, `Generic`, + `Generic1`, and `Data` instances for `GHC.Tuple.Solo`. + + * Add `Eq1`, `Read1` and `Show1` instances for `Complex`; + add `Eq1/2`, `Ord1/2`, `Show1/2` and `Read1/2` instances for 3 and 4-tuples. + + * Remove `Data.Semigroup.Option` and the accompanying `option` function. + + * Make `allocaBytesAligned` and `alloca` throw an IOError when the + alignment is not a power-of-two. The underlying primop + `newAlignedPinnedByteArray#` actually always assumed this but we didn't + document this fact in the user facing API until now. + + `Generic1`, and `Data` instances for `GHC.Tuple.Solo`. + + * Under POSIX, `System.IO.openFile` will no longer leak a file descriptor if it + is interrupted by an asynchronous exception (#19114, #19115). + + * Additionally export `asum` from `Control.Applicative` + + * `fromInteger :: Integer -> Float/Double` now consistently round to the + nearest value, with ties to even. + + * Additions to `Data.Bits`: + + - 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. + + - `oneBits :: FiniteBits a => a`, `oneBits = complement zeroBits`. + + * Various folding operations in `GHC.List` are now implemented via strict + folds: + - `sum` + - `product` + - `maximum` + - `minimum` + +## 4.15.0.0 *Feb 2021* + + * Shipped with GHC 9.0.1 + + * `openFile` now calls the `open` system call with an `interruptible` FFI + call, ensuring that the call can be interrupted with `SIGINT` on POSIX + systems. + + * Make `openFile` more tolerant of asynchronous exceptions: more care taken + to release the file descriptor and the read/write lock (#18832) + + * Add `hGetContents'`, `getContents'`, and `readFile'` in `System.IO`: + Strict IO variants of `hGetContents`, `getContents`, and `readFile`. + + * Add `singleton` function for `Data.List.NonEmpty`. + + * The planned deprecation of `Data.Monoid.First` and `Data.Monoid.Last` + is scrapped due to difficulties with the suggested migration path. + + * `Data.Semigroup.Option` and the accompanying `option` function are + deprecated and scheduled for removal in 4.16. + + * Add `Generic` instances to `Fingerprint`, `GiveGCStats`, `GCFlags`, + `ConcFlags`, `DebugFlags`, `CCFlags`, `DoHeapProfile`, `ProfFlags`, + `DoTrace`, `TraceFlags`, `TickyFlags`, `ParFlags`, `RTSFlags`, `RTSStats`, + `GCStats`, `ByteOrder`, `GeneralCategory`, `SrcLoc` + + * Add rules `unpackUtf8`, `unpack-listUtf8` and `unpack-appendUtf8` to `GHC.Base`. + They correspond to their ascii versions and hopefully make it easier + for libraries to handle utf8 encoded strings efficiently. + + * An issue with list fusion and `elem` was fixed. `elem` applied to known + small lists will now compile to a simple case statement more often. + + * Add `MonadFix` and `MonadZip` instances for `Complex` + + * Add `Ix` instances for tuples of size 6 through 15 + + * Correct `Bounded` instance and remove `Enum` and `Integral` instances for + `Data.Ord.Down`. + + * `catMaybes` is now implemented using `mapMaybe`, so that it is both a "good + consumer" and "good producer" for list-fusion (#18574) + + * `Foreign.ForeignPtr.withForeignPtr` is now less aggressively optimised, + avoiding the soundness issue reported in + [#17760](https://gitlab.haskell.org/ghc/ghc/-/issues/17760) in exchange for + a small amount more allocation. If your application regresses significantly + *and* the continuation given to `withForeignPtr` will *not* provably + diverge then the previous optimisation behavior can be recovered by instead + using `GHC.ForeignPtr.unsafeWithForeignPtr`. + + * Correct `Bounded` instance and remove `Enum` and `Integral` instances for + `Data.Ord.Down`. + + * `Data.Foldable` methods `maximum{,By}`, `minimum{,By}`, `product` and `sum` + are now stricter by default, as well as in the class implementation for List. + +## 4.14.0.0 *Jan 2020* + * Bundled with GHC 8.10.1 + + * Add a `TestEquality` instance for the `Compose` newtype. + + * `Data.Ord.Down` now has a field name, `getDown` + + * Add `Bits`, `Bounded`, `Enum`, `FiniteBits`, `Floating`, `Fractional`, + `Integral`, `Ix`, `Real`, `RealFrac`, `RealFloat` and `Storable` instances + to `Data.Ord.Down`. + + * Fix the `integer-gmp` variant of `isValidNatural`: Previously it would fail + to detect values `<= maxBound::Word` that were incorrectly encoded using + the `NatJ#` constructor. + + * The type of `coerce` has been generalized. It is now runtime-representation + polymorphic: + `forall {r :: RuntimeRep} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b`. + The type argument `r` is marked as `Inferred` to prevent it from + interfering with visible type application. + + * Make `Fixed` and `HasResolution` poly-kinded. + + * Add `HasResolution` instances for `Nat`s. + + * Add `Functor`, `Applicative`, `Monad`, `Alternative`, `MonadPlus`, + `Generic` and `Generic1` instances to `Kleisli` + + * `openTempFile` is now fully atomic and thread-safe on Windows. + + * Add `isResourceVanishedError`, `resourceVanishedErrorType`, and + `isResourceVanishedErrorType` to `System.IO.Error`. + + * Add newtypes for `CSocklen` (`socklen_t`) and `CNfds` (`nfds_t`) to + `System.Posix.Types`. + + * Add `Functor`, `Applicative` and `Monad` instances to `(,,) a b` + and `(,,,) a b c`. + + * Add `resizeSmallMutableArray#` to `GHC.Exts`. + + * Add a `Data` instance to `WrappedArrow`, `WrappedMonad`, and `ZipList`. + + * Add `IsList` instance for `ZipList`. + +## 4.13.0.0 *July 2019* + * Bundled with GHC 8.8.1 + + * The final phase of the `MonadFail` proposal has been implemented: + + * The `fail` method of `Monad` has been removed in favor of the method of + the same name in the `MonadFail` class. + + * `MonadFail(fail)` is now re-exported from the `Prelude` and + `Control.Monad` modules. + + * Fix `Show` instance of `Data.Fixed`: Negative numbers are now parenthesized + according to their surrounding context. I.e. `Data.Fixed.show` produces + syntactically correct Haskell for expressions like `Just (-1 :: Fixed E2)`. + (#16031) + + * Support the characters from recent versions of Unicode (up to v. 12) in + literals (#5518). + + * The `StableName` type parameter now has a phantom role instead of + a representational one. There is really no reason to care about the + type of the underlying object. + + * Add `foldMap'`, a strict version of `foldMap`, to `Foldable`. + + * The `shiftL` and `shiftR` methods in the `Bits` instances of `Int`, `IntN`, + `Word`, and `WordN` now throw an overflow exception for negative shift + values (instead of being undefined behaviour). + + * `scanr` no longer crashes when passed a fusable, infinite list. (#16943) + +## 4.12.0.0 *21 September 2018* + * Bundled with GHC 8.6.1 + + * The STM invariant-checking mechanism (`always` and `alwaysSucceeds`), which + was deprecated in GHC 8.4, has been removed (as proposed in + ). + This is a bit earlier than proposed in the deprecation pragma included in + GHC 8.4, but due to community feedback we decided to move ahead with the + early removal. + + Existing users are encouraged to encapsulate their STM operations in safe + abstractions which can perform the invariant checking without help from the + runtime system. + + * Add a new module `GHC.ResponseFile` (previously defined in the `haddock` + package). (#13896) + + * Move the module `Data.Functor.Contravariant` from the + `contravariant` package to `base`. + + * `($!)` is now representation-polymorphic like `($)`. + + * Add `Applicative` (for `K1`), `Semigroup` and `Monoid` instances in + `GHC.Generics`. (#14849) + + * `asinh` for `Float` and `Double` is now numerically stable in the face of + non-small negative arguments and enormous arguments of either sign. (#14927) + + * `Numeric.showEFloat (Just 0)` now respects the user's requested precision. + (#15115) + + * `Data.Monoid.Alt` now has `Foldable` and `Traversable` instances. (#15099) + + * `Data.Monoid.Ap` has been introduced + + * `Control.Exception.throw` is now levity polymorphic. (#15180) + + * `Data.Ord.Down` now has a number of new instances. These include: + `MonadFix`, `MonadZip`, `Data`, `Foldable`, `Traversable`, `Eq1`, `Ord1`, + `Read1`, `Show1`, `Generic`, `Generic1`. (#15098) + + +## 4.11.1.0 *19 April 2018* + * Bundled with GHC 8.4.2 + + * Add the `readFieldHash` function to `GHC.Read` which behaves like + `readField`, but for a field that ends with a `#` symbol (#14918). + +## 4.11.0.0 *8 March 2018* + * Bundled with GHC 8.4.1 + + * `System.IO.openTempFile` is now thread-safe on Windows. + + * Deprecated `GHC.Stats.GCStats` interface has been removed. + + * Add `showHFloat` to `Numeric` + + * Add `Div`, `Mod`, and `Log2` functions on type-level naturals + in `GHC.TypeLits`. + + * Add `Alternative` instance for `ZipList` (#13520) + + * Add instances `Num`, `Functor`, `Applicative`, `Monad`, `Semigroup` + and `Monoid` for `Data.Ord.Down` (#13097). + + * Add `Semigroup` instance for `EventLifetime`. + + * Make `Semigroup` a superclass of `Monoid`; + export `Semigroup((<>))` from `Prelude`; remove `Monoid` reexport + from `Data.Semigroup` (#14191). + + * Generalise `instance Monoid a => Monoid (Maybe a)` to + `instance Semigroup a => Monoid (Maybe a)`. + + * Add `infixl 9 !!` declaration for `Data.List.NonEmpty.!!` + + * Add `<&>` operator to `Data.Functor` (#14029) + + * Remove the deprecated `Typeable{1..7}` type synonyms (#14047) + + * Make `Data.Type.Equality.==` a closed type family. It now works for all + kinds out of the box. Any modules that previously declared instances of this + family will need to remove them. Whereas the previous definition was somewhat + ad hoc, the behavior is now completely uniform. As a result, some applications + that used to reduce no longer do, and conversely. Most notably, `(==)` no + longer treats the `*`, `j -> k`, or `()` kinds specially; equality is + tested structurally in all cases. + + * Add instances `Semigroup` and `Monoid` for `Control.Monad.ST` (#14107). + + * The `Read` instances for `Proxy`, `Coercion`, `(:~:)`, `(:~~:)`, and `U1` + now ignore the parsing precedence. The effect of this is that `read` will + be able to successfully parse more strings containing `"Proxy"` _et al._ + without surrounding parentheses (e.g., `"Thing Proxy"`) (#12874). + + * Add `iterate'`, a strict version of `iterate`, to `Data.List` + and `Data.OldList` (#3474) + + * Add `Data` instances for `IntPtr` and `WordPtr` (#13115) + + * Add missing `MonadFail` instance for `Control.Monad.Strict.ST.ST` + + * Make `zipWith` and `zipWith3` inlinable (#14224) + + * `Type.Reflection.App` now matches on function types (fixes #14236) + + * `Type.Reflection.withTypeable` is now polymorphic in the `RuntimeRep` of + its result. + + * Add `installSEHHandlers` to `MiscFlags` in `GHC.RTS.Flags` to determine if + exception handling is enabled. + + * The deprecated functions `isEmptyChan` and `unGetChan` in + `Control.Concurrent.Chan` have been removed (#13561). + + * Add `generateCrashDumpFile` to `MiscFlags` in `GHC.RTS.Flags` to determine + if a core dump will be generated on crashes. + + * Add `generateStackTrace` to `MiscFlags` in `GHC.RTS.Flags` to determine if + stack traces will be generated on unhandled exceptions by the RTS. + + * `getExecutablePath` now resolves symlinks on Windows (#14483) + + * Deprecated STM invariant checking primitives (`checkInv`, `always`, and + `alwaysSucceeds`) in `GHC.Conc.Sync` (#14324). + + * Add a `FixIOException` data type to `Control.Exception.Base`, and change + `fixIO` to throw that instead of a `BlockedIndefinitelyOnMVar` exception + (#14356). + +## 4.10.1.0 *November 2017* + * Bundled with GHC 8.2.2 + + * The file locking primitives provided by `GHC.IO.Handle` now use + Linux open file descriptor locking if available. + + * Fixed bottoming definition of `clearBit` for `Natural` + +## 4.10.0.0 *July 2017* + * Bundled with GHC 8.2.1 + + * `Data.Type.Bool.Not` given a type family dependency (#12057). + + * `Foreign.Ptr` now exports the constructors for `IntPtr` and `WordPtr` + (#11983) + + * `Generic1`, as well as the associated datatypes and typeclasses in + `GHC.Generics`, are now poly-kinded (#10604) + + * `New modules `Data.Bifoldable` and `Data.Bitraversable` (previously defined + in the `bifunctors` package) (#10448) + + * `Data.Either` now provides `fromLeft` and `fromRight` (#12402) + + * `Data.Type.Coercion` now provides `gcoerceWith` (#12493) + + * New methods `liftReadList(2)` and `liftReadListPrec(2)` in the + `Read1`/`Read2` classes that are defined in terms of `ReadPrec` instead of + `ReadS`, as well as related combinators, have been added to + `Data.Functor.Classes` (#12358) + + * Add `Semigroup` instance for `IO`, as well as for `Event` and `Lifetime` + from `GHC.Event` (#12464) + + * Add `Data` instance for `Const` (#12438) + + * Added `Eq1`, `Ord1`, `Read1` and `Show1` instances for `NonEmpty`. + + * Add wrappers for `blksize_t`, `blkcnt_t`, `clockid_t`, `fsblkcnt_t`, + `fsfilcnt_t`, `id_t`, `key_t`, and `timer_t` to System.Posix.Types (#12795) + + * Add `CBool`, a wrapper around C's `bool` type, to `Foreign.C.Types` + (#13136) + + * Raw buffer operations in `GHC.IO.FD` are now strict in the buffer, offset, and length operations (#9696) + + * Add `plusForeignPtr` to `Foreign.ForeignPtr`. + + * Add `type family AppendSymbol (m :: Symbol) (n :: Symbol) :: Symbol` to `GHC.TypeLits` + (#12162) + + * Add `GHC.TypeNats` module with `Natural`-based `KnownNat`. The `Nat` + operations in `GHC.TypeLits` are a thin compatibility layer on top. + Note: the `KnownNat` evidence is changed from an `Integer` to a `Natural`. + + * The type of `asProxyTypeOf` in `Data.Proxy` has been generalized (#12805) + + * `liftA2` is now a method of the `Applicative` class. `liftA2` and + `<*>` each have a default implementation based on the other. Various + library functions have been updated to use `liftA2` where it might offer + some benefit. `liftA2` is not yet in the `Prelude`, and must currently be + imported from `Control.Applicative`. It is likely to be added to the + `Prelude` in the future. (#13191) + + * A new module, `Type.Reflection`, exposing GHC's new type-indexed type + representation mechanism is now provided. + + * `Data.Dynamic` now exports the `Dyn` data constructor, enabled by the new + type-indexed type representation mechanism. + + * `Data.Type.Equality` now provides a kind heterogeneous type equality + evidence type, `(:~~:)`. + + * The `CostCentresXML` constructor of `GHC.RTS.Flags.DoCostCentres` has been + replaced by `CostCentresJSON` due to the new JSON export format supported by + the cost centre profiler. + + * The `ErrorCall` pattern synonym has been given a `COMPLETE` pragma so that + functions which solely match again `ErrorCall` do not produce + non-exhaustive pattern-match warnings (#8779) + + * Change the implementations of `maximumBy` and `minimumBy` from + `Data.Foldable` to use `foldl1` instead of `foldr1`. This makes them run + in constant space when applied to lists. (#10830) + + * `mkFunTy`, `mkAppTy`, and `mkTyConApp` from `Data.Typeable` no longer exist. + This functionality is superceded by the interfaces provided by + `Type.Reflection`. + + * `mkTyCon3` is no longer exported by `Data.Typeable`. This function is + replaced by `Type.Reflection.Unsafe.mkTyCon`. + + * `Data.List.NonEmpty.unfold` has been deprecated in favor of `unfoldr`, + which is functionally equivalent. + +## 4.9.0.0 *May 2016* + + * Bundled with GHC 8.0 + + * `error` and `undefined` now print a partial stack-trace alongside the error message. + + * New `errorWithoutStackTrace` function throws an error without printing the stack trace. + + * The restore operation provided by `mask` and `uninterruptibleMask` now + restores the previous masking state whatever the current masking state is. + + * New `GHC.Generics.packageName` operation + + * Redesigned `GHC.Stack.CallStack` data type. As a result, `CallStack`'s + `Show` instance produces different output, and `CallStack` no longer has an + `Eq` instance. + + * New `GHC.Generics.packageName` operation + + * New `GHC.Stack.Types` module now contains the definition of + `CallStack` and `SrcLoc` + + * New `GHC.Stack.Types.emptyCallStack` function builds an empty `CallStack` + + * New `GHC.Stack.Types.freezeCallStack` function freezes a `CallStack` preventing future `pushCallStack` operations from having any effect + + * New `GHC.Stack.Types.pushCallStack` function pushes a call-site onto a `CallStack` + + * New `GHC.Stack.Types.fromCallSiteList` function creates a `CallStack` from + a list of call-sites (i.e., `[(String, SrcLoc)]`) + + * `GHC.SrcLoc` has been removed + + * `GHC.Stack.showCallStack` and `GHC.SrcLoc.showSrcLoc` are now called + `GHC.Stack.prettyCallStack` and `GHC.Stack.prettySrcLoc` respectively + + * add `Data.List.NonEmpty` and `Data.Semigroup` (to become + super-class of `Monoid` in the future). These modules were + provided by the `semigroups` package previously. (#10365) + + * Add `selSourceUnpackedness`, `selSourceStrictness`, and + `selDecidedStrictness`, three functions which look up strictness + information of a field in a data constructor, to the `Selector` type class + in `GHC.Generics` (#10716) + + * Add `URec`, `UAddr`, `UChar`, `UDouble`, `UFloat`, `UInt`, and `UWord` to + `GHC.Generics` as part of making GHC generics capable of handling + unlifted types (#10868) + + * The `Eq`, `Ord`, `Read`, and `Show` instances for `U1` now use lazier + pattern-matching + + * Keep `shift{L,R}` on `Integer` with negative shift-arguments from + segfaulting (#10571) + + * Add `forkOSWithUnmask` to `Control.Concurrent`, which is like + `forkIOWithUnmask`, but the child is run in a bound thread. + + * The `MINIMAL` definition of `Arrow` is now `arr AND (first OR (***))`. + + * The `MINIMAL` definition of `ArrowChoice` is now `left OR (+++)`. + + * Exported `GiveGCStats`, `DoCostCentres`, `DoHeapProfile`, `DoTrace`, + `RtsTime`, and `RtsNat` from `GHC.RTS.Flags` + + * New function `GHC.IO.interruptible` used to correctly implement + `Control.Exception.allowInterrupt` (#9516) + + * Made `PatternMatchFail`, `RecSelError`, `RecConError`, `RecUpdError`, + `NoMethodError`, and `AssertionFailed` newtypes (#10738) + + * New module `Control.Monad.IO.Class` (previously provided by `transformers` + package). (#10773) + + * New modules `Data.Functor.Classes`, `Data.Functor.Compose`, + `Data.Functor.Product`, and `Data.Functor.Sum` (previously provided by + `transformers` package). (#11135) + + * New instances for `Proxy`: `Eq1`, `Ord1`, `Show1`, `Read1`. All + of the classes are from `Data.Functor.Classes` (#11756). + + * New module `Control.Monad.Fail` providing new `MonadFail(fail)` + class (#10751) + + * Add `GHC.TypeLits.TypeError` and `ErrorMessage` to allow users + to define custom compile-time error messages. + + * Redesign `GHC.Generics` to use type-level literals to represent the + metadata of generic representation types (#9766) + + * The `IsString` instance for `[Char]` has been modified to eliminate + ambiguity arising from overloaded strings and functions like `(++)`. + + * Move `Const` from `Control.Applicative` to its own module in + `Data.Functor.Const`. (#11135) + + * Re-export `Const` from `Control.Applicative` for backwards compatibility. + + * Expand `Floating` class to include operations that allow for better + precision: `log1p`, `expm1`, `log1pexp` and `log1mexp`. These are not + available from `Prelude`, but the full class is exported from `Numeric`. + + * New `Control.Exception.TypeError` datatype, which is thrown when an + expression fails to typecheck when run using `-fdefer-type-errors` (#10284) + + * The `bitSize` method of `Data.Bits.Bits` now has a (partial!) + default implementation based on `bitSizeMaybe`. (#12970) + +### New instances + + * `Alt`, `Dual`, `First`, `Last`, `Product`, and `Sum` now have `Data`, + `MonadZip`, and `MonadFix` instances + + * The datatypes in `GHC.Generics` now have `Enum`, `Bounded`, `Ix`, + `Functor`, `Applicative`, `Monad`, `MonadFix`, `MonadPlus`, `MonadZip`, + `Foldable`, `Foldable`, `Traversable`, `Generic1`, and `Data` instances + as appropriate. + + * `Maybe` now has a `MonadZip` instance + + * `All` and `Any` now have `Data` instances + + * `Dual`, `First`, `Last`, `Product`, and `Sum` now have `Foldable` and + `Traversable` instances + + * `Dual`, `Product`, and `Sum` now have `Functor`, `Applicative`, and + `Monad` instances + + * `(,) a` now has a `Monad` instance + + * `ZipList` now has `Foldable` and `Traversable` instances + + * `Identity` now has `Semigroup` and `Monoid` instances + + * `Identity` and `Const` now have `Bits`, `Bounded`, `Enum`, `FiniteBits`, + `Floating`, `Fractional`, `Integral`, `IsString`, `Ix`, `Num`, `Real`, + `RealFloat`, `RealFrac` and `Storable` instances. (#11210, #11790) + + * `()` now has a `Storable` instance + + * `Complex` now has `Generic`, `Generic1`, `Functor`, `Foldable`, `Traversable`, + `Applicative`, and `Monad` instances + + * `System.Exit.ExitCode` now has a `Generic` instance + + * `Data.Version.Version` now has a `Generic` instance + + * `IO` now has a `Monoid` instance + + * Add `MonadPlus IO` and `Alternative IO` instances + (previously orphans in `transformers`) (#10755) + + * `CallStack` now has an `IsList` instance + + * The field `spInfoName` of `GHC.StaticPtr.StaticPtrInfo` has been removed. + The value is no longer available when constructing the `StaticPtr`. + + * `VecElem` and `VecCount` now have `Enum` and `Bounded` instances. + +### Generalizations + + * Generalize `Debug.Trace.{traceM, traceShowM}` from `Monad` to `Applicative` + (#10023) + + * Redundant typeclass constraints have been removed: + - `Data.Ratio.{denominator,numerator}` have no `Integral` constraint anymore + - **TODO** + + * Generalise `forever` from `Monad` to `Applicative` + + * Generalize `filterM`, `mapAndUnzipM`, `zipWithM`, `zipWithM_`, `replicateM`, + `replicateM_` from `Monad` to `Applicative` (#10168) + + * The `Generic` instance for `Proxy` is now poly-kinded (#10775) + + * Enable `PolyKinds` in the `Data.Functor.Const` module to give `Const` + the kind `* -> k -> *`. (#10039) + + +## 4.8.2.0 *Oct 2015* + + * Bundled with GHC 7.10.3 + + * The restore operation provided by `mask` and `uninterruptibleMask` now + restores the previous masking state whatever the current masking state is. + + * Exported `GiveGCStats`, `DoCostCentres`, `DoHeapProfile`, `DoTrace`, + `RtsTime`, and `RtsNat` from `GHC.RTS.Flags` + +## 4.8.1.0 *Jul 2015* + + * Bundled with GHC 7.10.2 + + * `Lifetime` is now exported from `GHC.Event` + + * Implicit-parameter based source location support exposed in `GHC.SrcLoc` and `GHC.Stack`. + See GHC User's Manual for more information. + +## 4.8.0.0 *Mar 2015* + + * Bundled with GHC 7.10.1 + + * Make `Applicative` a superclass of `Monad` + + * Add reverse application operator `Data.Function.(&)` + + * Add `Data.List.sortOn` sorting function + + * Add `System.Exit.die` + + * Deprecate `versionTags` field of `Data.Version.Version`. + Add `makeVersion :: [Int] -> Version` constructor function to aid + migration to a future `versionTags`-less `Version`. + + * Add `IsList Version` instance + + * Weaken RealFloat constraints on some `Data.Complex` functions + + * Add `Control.Monad.(<$!>)` as a strict version of `(<$>)` + + * The `Data.Monoid` module now has the `PolyKinds` extension + enabled, so that the `Monoid` instance for `Proxy` are polykinded + like `Proxy` itself is. + + * Make `abs` and `signum` handle (-0.0) correctly per IEEE-754. + + * Re-export `Data.Word.Word` from `Prelude` + + * Add `countLeadingZeros` and `countTrailingZeros` methods to + `Data.Bits.FiniteBits` class + + * Add `Data.List.uncons` list destructor (#9550) + + * Export `Monoid(..)` from `Prelude` + + * Export `Foldable(..)` from `Prelude` + (hiding `fold`, `foldl'`, `foldr'`, and `toList`) + + * Export `Traversable(..)` from `Prelude` + + * Set fixity for `Data.Foldable.{elem,notElem}` to match the + conventional one set for `Data.List.{elem,notElem}` (#9610) + + * Turn `toList`, `elem`, `sum`, `product`, `maximum`, and `minimum` + into `Foldable` methods (#9621) + + * Replace the `Data.List`-exported functions + + ``` + all, and, any, concat, concatMap, elem, find, product, sum, + mapAccumL, mapAccumR + ``` + + by re-exports of their generalised `Data.Foldable`/`Data.Traversable` + counterparts. In other words, unqualified imports of `Data.List` + and `Data.Foldable`/`Data.Traversable` no longer lead to conflicting + definitions. (#9586) + + * New (unofficial) module `GHC.OldList` containing only list-specialised + versions of the functions from `Data.List` (in other words, `GHC.OldList` + corresponds to `base-4.7.0.2`'s `Data.List`) + + * Replace the `Control.Monad`-exported functions + + ``` + sequence_, msum, mapM_, forM_, + forM, mapM, sequence + ``` + + by re-exports of their generalised `Data.Foldable`/`Data.Traversable` + counterparts. In other words, unqualified imports of `Control.Monad` + and `Data.Foldable`/`Data.Traversable` no longer lead to conflicting + definitions. (#9586) + + * Generalise `Control.Monad.{when,unless,guard}` from `Monad` to + `Applicative` and from `MonadPlus` to `Alternative` respectively. + + * Generalise `Control.Monad.{foldM,foldM_}` to `Foldable` + + * `scanr`, `mapAccumL` and `filterM` now take part in list fusion (#9355, + #9502, #9546) + + * Remove deprecated `Data.OldTypeable` (#9639) + + * New module `Data.Bifunctor` providing the `Bifunctor(bimap,first,second)` + class (previously defined in `bifunctors` package) (#9682) + + * New module `Data.Void` providing the canonical uninhabited type `Void` + (previously defined in `void` package) (#9814) + + * Update Unicode class definitions to Unicode version 7.0 + + * Add `Alt`, an `Alternative` wrapper, to `Data.Monoid`. (#9759) + + * Add `isSubsequenceOf` to `Data.List` (#9767) + + * The arguments to `==` and `eq` in `Data.List.nub` and `Data.List.nubBy` + are swapped, such that `Data.List.nubBy (<) [1,2]` now returns `[1]` + instead of `[1,2]` (#2528, #3280, #7913) + + * New module `Data.Functor.Identity` (previously provided by `transformers` + package). (#9664) + + * Add `scanl'`, a strictly accumulating version of `scanl`, to `Data.List` + and `Data.OldList`. (#9368) + + * Add `fillBytes` to `Foreign.Marshal.Utils`. + + * Add new `displayException` method to `Exception` typeclass. (#9822) + + * Add `Data.Bits.toIntegralSized`, a size-checked version of + `fromIntegral`. (#9816) + + * New module `Numeric.Natural` providing new `Natural` type + representing non-negative arbitrary-precision integers. The `GHC.Natural` + module exposes additional GHC-specific primitives. (#9818) + + * Add `(Storable a, Integeral a) => Storable (Ratio a)` instance (#9826) + + * Add `Storable a => Storable (Complex a)` instance (#9826) + + * New module `GHC.RTS.Flags` that provides accessors to runtime flags. + + * Expose functions for per-thread allocation counters and limits in `GHC.Conc` + + disableAllocationLimit :: IO () + enableAllocationLimit :: IO () + getAllocationCounter :: IO Int64 + setAllocationCounter :: Int64 -> IO () + + together with a new exception `AllocationLimitExceeded`. + + * Make `read . show = id` for `Data.Fixed` (#9240) + + * Add `calloc` and `callocBytes` to `Foreign.Marshal.Alloc`. (#9859) + + * Add `callocArray` and `callocArray0` to `Foreign.Marshal.Array`. (#9859) + + * Restore invariant in `Data (Ratio a)` instance (#10011) + + * Add/expose `rnfTypeRep`, `rnfTyCon`, `typeRepFingerprint`, and + `tyConFingerprint` helpers to `Data.Typeable`. + + * Define proper `MINIMAL` pragma for `class Ix`. (#10142) + +## 4.7.0.2 *Dec 2014* + + * Bundled with GHC 7.8.4 + + * Fix performance bug in `Data.List.inits` (#9345) + + * Fix handling of null bytes in `Debug.Trace.trace` (#9395) + +## 4.7.0.1 *Jul 2014* + + * Bundled with GHC 7.8.3 + + * Unhide `Foreign.ForeignPtr` in Haddock (#8475) + + * Fix recomputation of `TypeRep` in `Typeable` type-application instance + (#9203) + + * Fix regression in Data.Fixed Read instance (#9231) + + * Fix `fdReady` to honor `FD_SETSIZE` (#9168) + +## 4.7.0.0 *Apr 2014* + + * Bundled with GHC 7.8.1 + + * Add `/Since: 4.[4567].0.0/` Haddock annotations to entities + denoting the package version, when the given entity was introduced + (or its type signature changed in a non-compatible way) + + * The `Control.Category` module now has the `PolyKinds` extension + enabled, meaning that instances of `Category` no longer need be of + kind `* -> * -> *`. + + * There are now `Foldable` and `Traversable` instances for `Either a`, + `Const r`, and `(,) a`. + + * There are now `Show`, `Read`, `Eq`, `Ord`, `Monoid`, `Generic`, and + `Generic1` instances for `Const`. + + * There is now a `Data` instance for `Data.Version`. + + * A new `Data.Bits.FiniteBits` class has been added to represent + types with fixed bit-count. The existing `Bits` class is extended + with a `bitSizeMaybe` method to replace the now obsolete + `bitsize` method. + + * `Data.Bits.Bits` gained a new `zeroBits` method which completes the + `Bits` API with a direct way to introduce a value with all bits cleared. + + * There are now `Bits` and `FiniteBits` instances for `Bool`. + + * There are now `Eq`, `Ord`, `Show`, `Read`, `Generic`. and `Generic1` + instances for `ZipList`. + + * There are now `Eq`, `Ord`, `Show` and `Read` instances for `Down`. + + * There are now `Eq`, `Ord`, `Show`, `Read` and `Generic` instances + for types in GHC.Generics (`U1`, `Par1`, `Rec1`, `K1`, `M1`, + `(:+:)`, `(:*:)`, `(:.:)`). + + * `Data.Monoid`: There are now `Generic` instances for `Dual`, `Endo`, + `All`, `Any`, `Sum`, `Product`, `First`, and `Last`; as well as + `Generic1` instances for `Dual`, `Sum`, `Product`, `First`, and `Last`. + + * The `Data.Monoid.{Product,Sum}` newtype wrappers now have `Num` instances. + + * There are now `Functor` instances for `System.Console.GetOpt`'s + `ArgOrder`, `OptDescr`, and `ArgDescr`. + + * A zero-width unboxed poly-kinded `Proxy#` was added to + `GHC.Prim`. It can be used to make it so that there is no the + operational overhead for passing around proxy arguments to model + type application. + + * New `Data.Proxy` module providing a concrete, poly-kinded proxy type. + + * New `Data.Coerce` module which exports the new `Coercible` class + together with the `coerce` primitive which provide safe coercion + (wrt role checking) between types with same representation. + + * `Control.Concurrent.MVar` has a new implementation of `readMVar`, + which fixes a long-standing bug where `readMVar` is only atomic if + there are no other threads running `putMVar`. `readMVar` now is + atomic, and is guaranteed to return the value from the first + `putMVar`. There is also a new `tryReadMVar` which is a + non-blocking version. + + * New `Control.Concurrent.MVar.withMVarMasked` which executes + `IO` action with asynchronous exceptions masked in the same style + as the existing `modifyMVarMasked` and `modifyMVarMasked_`. + + * New `threadWait{Read,Write}STM :: Fd -> IO (STM (), IO ())` + functions added to `Control.Concurrent` for waiting on FD + readiness with STM actions. + + * Expose `Data.Fixed.Fixed`'s constructor. + + * There are now byte endian-swapping primitives + `byteSwap{16,32,64}` available in `Data.Word`, which use + optimized machine instructions when available. + + * `Data.Bool` now exports `bool :: a -> a -> Bool -> a`, analogously + to `maybe` and `either` in their respective modules. + + * `Data.Either` now exports `isLeft, isRight :: Either a b -> Bool`. + + * `Debug.Trace` now exports `traceId`, `traceShowId`, `traceM`, + and `traceShowM`. + + * `Data.Functor` now exports `($>)` and `void`. + + * Rewrote portions of `Text.Printf`, and made changes to `Numeric` + (added `Numeric.showFFloatAlt` and `Numeric.showGFloatAlt`) and + `GHC.Float` (added `formatRealFloatAlt`) to support it. The + rewritten version is extensible to user types, adds a "generic" + format specifier "`%v`", extends the `printf` spec to support much + of C's `printf(3)` functionality, and fixes the spurious warnings + about using `Text.Printf.printf` at `(IO a)` while ignoring the + return value. These changes were contributed by Bart Massey. + + * The minimal complete definitions for all type-classes with cyclic + default implementations have been explicitly annotated with the + new `{-# MINIMAL #-}` pragma. + + * `Control.Applicative.WrappedMonad`, which can be used to convert a + `Monad` to an `Applicative`, has now a + `Monad m => Monad (WrappedMonad m)` instance. + + * There is now a `Generic` and a `Generic1` instance for `WrappedMonad` + and `WrappedArrow`. + + * Handle `ExitFailure (-sig)` on Unix by killing process with signal `sig`. + + * New module `Data.Type.Bool` providing operations on type-level booleans. + + * Expose `System.Mem.performMinorGC` for triggering minor GCs. + + * New `System.Environment.{set,unset}Env` for manipulating + environment variables. + + * Add `Typeable` instance for `(->)` and `RealWorld`. + + * Declare CPP header `` officially obsolete as GHC 7.8+ + does not support hand-written `Typeable` instances anymore. + + * Remove (unmaintained) Hugs98 and NHC98 specific code. + + * Optimize `System.Timeout.timeout` for the threaded RTS. + + * Remove deprecated functions `unsafeInterleaveST`, `unsafeIOToST`, + and `unsafeSTToIO` from `Control.Monad.ST`. + + * Add a new superclass `SomeAsyncException` for all asynchronous exceptions + and makes the existing `AsyncException` and `Timeout` exception children + of `SomeAsyncException` in the hierarchy. + + * Remove deprecated functions `blocked`, `unblock`, and `block` from + `Control.Exception`. + + * Remove deprecated function `forkIOUnmasked` from `Control.Concurrent`. + + * Remove deprecated function `unsafePerformIO` export from `Foreign` + (still available via `System.IO.Unsafe.unsafePerformIO`). + + * Various fixes and other improvements (see Git history for full details). diff --git a/src/Control/Applicative.hs b/src/Control/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative +-- Copyright : Conor McBride and Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- This module describes a structure intermediate between a functor and +-- a monad (technically, a strong lax monoidal functor). Compared with +-- monads, this interface lacks the full power of the binding operation +-- '>>=', but +-- +-- * it has more instances. +-- +-- * it is sufficient for many uses, e.g. context-free parsing, or the +-- 'Data.Traversable.Traversable' class. +-- +-- * instances can perform analysis of computations before they are +-- executed, and thus produce shared optimizations. +-- +-- This interface was introduced for parsers by Niklas Röjemo, because +-- it admits more sharing than the monadic interface. The names here are +-- mostly based on parsing work by Doaitse Swierstra. +-- +-- For more details, see +-- , +-- by Conor McBride and Ross Paterson. + +module Control.Applicative ( + -- * Applicative functors + Applicative(..), + -- * Alternatives + Alternative(..), + -- * Instances + Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..), + -- * Utility functions + (<$>), (<$), (<**>), + liftA, liftA3, + optional, + asum, + ) where + +import GHC.Internal.Control.Category hiding ((.), id) +import GHC.Internal.Control.Arrow +import GHC.Internal.Data.Maybe +import GHC.Internal.Data.Tuple +import GHC.Internal.Data.Foldable (asum) +import GHC.Internal.Data.Functor ((<$>)) +import GHC.Internal.Data.Functor.Const (Const(..)) +import GHC.Internal.Data.Typeable (Typeable) +import GHC.Internal.Data.Data (Data) + +import GHC.Internal.Base +import GHC.Internal.Functor.ZipList (ZipList(..)) +import GHC.Generics + +-- $setup +-- >>> import Prelude + +newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a } + deriving ( Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Monad -- ^ @since 4.7.0.0 + ) + +-- | @since 2.01 +instance Monad m => Functor (WrappedMonad m) where + fmap f (WrapMonad v) = WrapMonad (liftM f v) + +-- | @since 2.01 +instance Monad m => Applicative (WrappedMonad m) where + pure = WrapMonad . pure + WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v) + liftA2 f (WrapMonad x) (WrapMonad y) = WrapMonad (liftM2 f x y) + +-- | @since 2.01 +instance MonadPlus m => Alternative (WrappedMonad m) where + empty = WrapMonad mzero + WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v) + +-- | @since 4.14.0.0 +deriving instance (Typeable (m :: Type -> Type), Typeable a, Data (m a)) + => Data (WrappedMonad m a) + +newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c } + deriving ( Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + ) + +-- | @since 2.01 +instance Arrow a => Functor (WrappedArrow a b) where + fmap f (WrapArrow a) = WrapArrow (a >>> arr f) + +-- | @since 2.01 +instance Arrow a => Applicative (WrappedArrow a b) where + pure x = WrapArrow (arr (const x)) + liftA2 f (WrapArrow u) (WrapArrow v) = + WrapArrow (u &&& v >>> arr (uncurry f)) + +-- | @since 2.01 +instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where + empty = WrapArrow zeroArrow + WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v) + +-- | @since 4.14.0.0 +deriving instance (Typeable (a :: Type -> Type -> Type), Typeable b, Typeable c, + Data (a b c)) + => Data (WrappedArrow a b c) + +-- extra functions + +-- | One or none. +-- +-- It is useful for modelling any computation that is allowed to fail. +-- +-- ==== __Examples__ +-- +-- Using the 'Alternative' instance of "Control.Monad.Except", the following functions: +-- +-- >>> import Control.Monad.Except +-- +-- >>> canFail = throwError "it failed" :: Except String Int +-- >>> final = return 42 :: Except String Int +-- +-- Can be combined by allowing the first function to fail: +-- +-- >>> runExcept $ canFail *> final +-- Left "it failed" +-- +-- >>> runExcept $ optional canFail *> final +-- Right 42 + +optional :: Alternative f => f a -> f (Maybe a) +optional v = Just <$> v <|> pure Nothing diff --git a/src/Control/Arrow.hs b/src/Control/Arrow.hs new file mode 100644 --- /dev/null +++ b/src/Control/Arrow.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Control.Arrow +-- Copyright : (c) Ross Paterson 2002 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Basic arrow definitions, based on +-- +-- * /Generalising Monads to Arrows/, by John Hughes, +-- /Science of Computer Programming/ 37, pp67-111, May 2000. +-- +-- plus a couple of definitions ('returnA' and 'loop') from +-- +-- * /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/, +-- Firenze, Italy, pp229-240. +-- +-- These papers and more information on arrows can be found at +-- . + +module Control.Arrow + (-- * Arrows + Arrow(..), + Kleisli(..), + -- ** Derived combinators + returnA, + (^>>), + (>>^), + (>>>), + (<<<), + -- ** Right-to-left variants + (<<^), + (^<<), + -- * Monoid operations + ArrowZero(..), + ArrowPlus(..), + -- * Conditionals + ArrowChoice(..), + -- * Arrow application + ArrowApply(..), + ArrowMonad(..), + leftApp, + -- * Feedback + ArrowLoop(..) + ) where + +import GHC.Internal.Control.Arrow diff --git a/src/Control/Category.hs b/src/Control/Category.hs new file mode 100644 --- /dev/null +++ b/src/Control/Category.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : Control.Category +-- Copyright : (c) Ashley Yakeley 2007 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ashley@semantic.org +-- Stability : stable +-- Portability : portable +-- + +module Control.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 new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent.hs @@ -0,0 +1,534 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , MagicHash + , UnboxedTuples + , ScopedTypeVariables + , RankNTypes + #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +-- kludge for the Control.Concurrent.QSem, Control.Concurrent.QSemN +-- and Control.Concurrent.SampleVar imports. + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (concurrency) +-- +-- A common interface to a collection of useful concurrency +-- abstractions. +-- +----------------------------------------------------------------------------- + +module Control.Concurrent ( + -- * Concurrent Haskell + + -- $conc_intro + + -- * Basic concurrency operations + + ThreadId, + myThreadId, + + forkIO, + forkFinally, + forkIOWithUnmask, + killThread, + throwTo, + + -- ** Threads with affinity + forkOn, + forkOnWithUnmask, + getNumCapabilities, + setNumCapabilities, + threadCapability, + + -- * Scheduling + + -- $conc_scheduling + yield, + + -- ** Blocking + + -- $blocking + + -- ** Waiting + threadDelay, + threadWaitRead, + threadWaitWrite, + threadWaitReadSTM, + threadWaitWriteSTM, + + -- * Communication abstractions + + module GHC.Internal.Control.Concurrent.MVar, + module Control.Concurrent.Chan, + module Control.Concurrent.QSem, + module Control.Concurrent.QSemN, + + -- * Bound Threads + -- $boundthreads + rtsSupportsBoundThreads, + forkOS, + forkOSWithUnmask, + isCurrentThreadBound, + runInBoundThread, + runInUnboundThread, + + -- * Weak references to ThreadIds + mkWeakThreadId, + + -- * GHC's implementation of concurrency + + -- |This section describes features specific to GHC's + -- implementation of Concurrent Haskell. + + -- ** Haskell threads and Operating System threads + + -- $osthreads + + -- ** Terminating the program + + -- $termination + + -- ** Pre-emption + + -- $preemption + + -- ** Deadlock + + -- $deadlock + + ) where + +import Prelude +import GHC.Internal.Control.Exception.Base as Exception + +import GHC.Internal.Conc.Bound +import GHC.Conc hiding (threadWaitRead, threadWaitWrite, + threadWaitReadSTM, threadWaitWriteSTM) + +import GHC.Internal.System.Posix.Types ( Fd ) + +#if defined(mingw32_HOST_OS) +import GHC.Internal.Foreign.C.Error +import GHC.Internal.Foreign.C.Types +import GHC.Internal.System.IO +import GHC.Internal.Data.Functor ( void ) +import GHC.Internal.Int ( Int64 ) +#else +import qualified GHC.Internal.Conc.IO as Conc +#endif + +import GHC.Internal.Control.Concurrent.MVar +import Control.Concurrent.Chan +import Control.Concurrent.QSem +import Control.Concurrent.QSemN + +{- $conc_intro + +The concurrency extension for Haskell is described in the paper +/Concurrent Haskell/ +. + +Concurrency is \"lightweight\", which means that both thread creation +and context switching overheads are extremely low. Scheduling of +Haskell threads is done internally in the Haskell runtime system, and +doesn't make use of any operating system-supplied thread packages. + +However, if you want to interact with a foreign library that expects your +program to use the operating system-supplied thread package, you can do so +by using 'forkOS' instead of 'forkIO'. + +Haskell threads can communicate via 'MVar's, a kind of synchronised +mutable variable (see "Control.Concurrent.MVar"). Several common +concurrency abstractions can be built from 'MVar's, and these are +provided by the "Control.Concurrent" module. +In GHC, threads may also communicate via exceptions. +-} + +{- $conc_scheduling + + Scheduling may be either pre-emptive or co-operative, + depending on the implementation of Concurrent Haskell (see below + for information related to specific compilers). In a co-operative + system, context switches only occur when you use one of the + primitives defined in this module. This means that programs such + as: + + +> main = forkIO (write 'a') >> write 'b' +> where write c = putChar c >> write c + + will print either @aaaaaaaaaaaaaa...@ or @bbbbbbbbbbbb...@, + instead of some random interleaving of @a@s and @b@s. In + practice, cooperative multitasking is sufficient for writing + simple graphical user interfaces. +-} + +{- $blocking +Different Haskell implementations have different characteristics with +regard to which operations block /all/ threads. + +Using GHC without the @-threaded@ option, all foreign calls will block +all other Haskell threads in the system, although I\/O operations will +not. With the @-threaded@ option, only foreign calls with the @unsafe@ +attribute will block all other threads. + +-} + +-- | Fork a thread and call the supplied function when the thread is about +-- to terminate, with an exception or a returned value. The function is +-- called with asynchronous exceptions masked. +-- +-- > forkFinally action and_then = +-- > mask $ \restore -> +-- > forkIO $ try (restore action) >>= and_then +-- +-- This function is useful for informing the parent when a child +-- terminates, for example. +-- +-- @since 4.6.0.0 +forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId +forkFinally action and_then = + mask $ \restore -> + forkIO $ try (restore action) >>= and_then + +-- --------------------------------------------------------------------------- +-- Bound Threads + +{- $boundthreads + #boundthreads# + +Support for multiple operating system threads and bound threads as described +below is currently only available in the GHC runtime system if you use the +/-threaded/ option when linking. + +Other Haskell systems do not currently support multiple operating system threads. + +A bound thread is a haskell thread that is /bound/ to an operating system +thread. While the bound thread is still scheduled by the Haskell run-time +system, the operating system thread takes care of all the foreign calls made +by the bound thread. + +To a foreign library, the bound thread will look exactly like an ordinary +operating system thread created using OS functions like @pthread_create@ +or @CreateThread@. + +Bound threads can be created using the 'forkOS' function below. All foreign +exported functions are run in a bound thread (bound to the OS thread that +called the function). Also, the @main@ action of every Haskell program is +run in a bound thread. + +Why do we need this? Because if a foreign library is called from a thread +created using 'forkIO', it won't have access to any /thread-local state/ - +state variables that have specific values for each OS thread +(see POSIX's @pthread_key_create@ or Win32's @TlsAlloc@). Therefore, some +libraries (OpenGL, for example) will not work from a thread created using +'forkIO'. They work fine in threads created using 'forkOS' or when called +from @main@ or from a @foreign export@. + +In terms of performance, 'forkOS' (aka bound) threads are much more +expensive than 'forkIO' (aka unbound) threads, because a 'forkOS' +thread is tied to a particular OS thread, whereas a 'forkIO' thread +can be run by any OS thread. Context-switching between a 'forkOS' +thread and a 'forkIO' thread is many times more expensive than between +two 'forkIO' threads. + +Note in particular that the main program thread (the thread running +@Main.main@) is always a bound thread, so for good concurrency +performance you should ensure that the main thread is not doing +repeated communication with other threads in the system. Typically +this means forking subthreads to do the work using 'forkIO', and +waiting for the results in the main thread. + +-} + +-- --------------------------------------------------------------------------- +-- threadWaitRead/threadWaitWrite + +-- | Block the current thread until data is available to read on the +-- given file descriptor (GHC only). +-- +-- This will throw an 'IOError' if the file descriptor was closed +-- while this thread was blocked. To safely close a file descriptor +-- that has been used with 'threadWaitRead', use +-- 'GHC.Conc.closeFdWith'. +threadWaitRead :: Fd -> IO () +threadWaitRead fd +#if defined(mingw32_HOST_OS) + -- we have no IO manager implementing threadWaitRead on Windows. + -- 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 "threadWaitRead worker" (waitFd fd False) + | otherwise = case fd of + 0 -> do _ <- hWaitForInput stdin (-1) + return () + -- hWaitForInput does work properly, but we can only + -- do this for stdin since we know its FD. + _ -> errorWithoutStackTrace "threadWaitRead requires -threaded on Windows, or use GHC.System.IO.hWaitForInput" +#else + = Conc.threadWaitRead fd +#endif + +-- | Block the current thread until data can be written to the +-- given file descriptor (GHC only). +-- +-- This will throw an 'IOError' if the file descriptor was closed +-- while this thread was blocked. To safely close a file descriptor +-- that has been used with 'threadWaitWrite', use +-- 'GHC.Conc.closeFdWith'. +threadWaitWrite :: Fd -> IO () +threadWaitWrite fd +#if defined(mingw32_HOST_OS) + | threaded = withThread "threadWaitWrite worker" (waitFd fd True) + | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows" +#else + = Conc.threadWaitWrite fd +#endif + +-- | Returns an STM action that can be used to wait for data +-- to read from a file descriptor. The second returned value +-- is an IO action that can be used to deregister interest +-- in the file descriptor. +-- +-- @since 4.7.0.0 +threadWaitReadSTM :: Fd -> IO (STM (), IO ()) +threadWaitReadSTM fd +#if defined(mingw32_HOST_OS) + | threaded = do v <- newTVarIO Nothing + 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 + Just (Right ()) -> return () + Just (Left e) -> throwSTM (e :: IOException) + let killAction = return () + return (waitAction, killAction) + | otherwise = errorWithoutStackTrace "threadWaitReadSTM requires -threaded on Windows" +#else + = Conc.threadWaitReadSTM fd +#endif + +-- | Returns an STM action that can be used to wait until data +-- can be written to a file descriptor. The second returned value +-- is an IO action that can be used to deregister interest +-- in the file descriptor. +-- +-- @since 4.7.0.0 +threadWaitWriteSTM :: Fd -> IO (STM (), IO ()) +threadWaitWriteSTM fd +#if defined(mingw32_HOST_OS) + | threaded = do v <- newTVarIO Nothing + 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 + Just (Right ()) -> return () + Just (Left e) -> throwSTM (e :: IOException) + let killAction = return () + return (waitAction, killAction) + | otherwise = errorWithoutStackTrace "threadWaitWriteSTM requires -threaded on Windows" +#else + = Conc.threadWaitWriteSTM fd +#endif + +#if defined(mingw32_HOST_OS) +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool + +withThread :: String -> IO a -> IO a +withThread label io = do + m <- newEmptyMVar + _ <- mask_ $ forkIO $ do + tid <- myThreadId + labelThread tid label + result <- try io + putMVar m result + x <- takeMVar m + case x of + Right a -> return a + Left e -> throwIO (e :: IOException) + +waitFd :: Fd -> Bool -> IO () +waitFd fd write = do + throwErrnoIfMinus1_ "fdReady" $ + fdReady (fromIntegral fd) (if write then 1 else 0) (-1) 0 + +foreign import ccall safe "fdReady" + fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt +#endif + +-- --------------------------------------------------------------------------- +-- More docs + +{- $osthreads + + #osthreads# In GHC, threads created by 'forkIO' are lightweight threads, and + are managed entirely by the GHC runtime. Typically Haskell + threads are an order of magnitude or two more efficient (in + terms of both time and space) than operating system threads. + + The downside of having lightweight threads is that only one can + run at a time, so if one thread blocks in a foreign call, for + example, the other threads cannot continue. The GHC runtime + works around this by making use of full OS threads where + necessary. When the program is built with the @-threaded@ + option (to link against the multithreaded version of the + runtime), a thread making a @safe@ foreign call will not block + the other threads in the system; another OS thread will take + over running Haskell threads until the original call returns. + The runtime maintains a pool of these /worker/ threads so that + multiple Haskell threads can be involved in external calls + simultaneously. + + The "System.IO" module manages multiplexing in its own way. On + Windows systems it uses @safe@ foreign calls to ensure that + threads doing I\/O operations don't block the whole runtime, + whereas on Unix systems all the currently blocked I\/O requests + are managed by a single thread (the /IO manager thread/) using + a mechanism such as @epoll@ or @kqueue@, depending on what is + provided by the host operating system. + + The runtime will run a Haskell thread using any of the available + worker OS threads. If you need control over which particular OS + thread is used to run a given Haskell thread, perhaps because + you need to call a foreign library that uses OS-thread-local + state, then you need bound threads (see "Control.Concurrent#boundthreads"). + + If you don't use the @-threaded@ option, then the runtime does + not make use of multiple OS threads. Foreign calls will block + all other running Haskell threads until the call returns. The + "System.IO" module still does multiplexing, so there can be multiple + threads doing I\/O, and this is handled internally by the runtime using + @select@. +-} + +{- $termination + + In a standalone GHC program, only the main thread is + required to terminate in order for the process to terminate. + Thus all other forked threads will simply terminate at the same + time as the main thread (the terminology for this kind of + behaviour is \"daemonic threads\"). + + If you want the program to wait for child threads to + finish before exiting, you need to program this yourself. A + simple mechanism is to have each child thread write to an + 'MVar' when it completes, and have the main + thread wait on all the 'MVar's before + exiting: + +> myForkIO :: IO () -> IO (MVar ()) +> myForkIO io = do +> mvar <- newEmptyMVar +> forkFinally io (\_ -> putMVar mvar ()) +> return mvar + + Note that we use 'forkFinally' to make sure that the + 'MVar' is written to even if the thread dies or + is killed for some reason. + + A better method is to keep a global list of all child + threads which we should wait for at the end of the program: + +> children :: MVar [MVar ()] +> children = unsafePerformIO (newMVar []) +> +> waitForChildren :: IO () +> waitForChildren = do +> cs <- takeMVar children +> case cs of +> [] -> return () +> m:ms -> do +> putMVar children ms +> takeMVar m +> waitForChildren +> +> forkChild :: IO () -> IO ThreadId +> forkChild io = do +> mvar <- newEmptyMVar +> childs <- takeMVar children +> putMVar children (mvar:childs) +> forkFinally io (\_ -> putMVar mvar ()) +> +> main = +> later waitForChildren $ +> ... + + The main thread principle also applies to calls to Haskell from + outside, using @foreign export@. When the @foreign export@ed + function is invoked, it starts a new main thread, and it returns + when this main thread terminates. If the call causes new + threads to be forked, they may remain in the system after the + @foreign export@ed function has returned. +-} + +{- $preemption + + GHC implements pre-emptive multitasking: the execution of + threads are interleaved in a random fashion. More specifically, + a thread may be pre-empted whenever it allocates some memory, + which unfortunately means that tight loops which do no + allocation tend to lock out other threads (this only seems to + happen with pathological benchmark-style code, however). + + The rescheduling timer runs on a 20ms granularity by + default, but this may be altered using the + @-i\@ RTS option. After a rescheduling + \"tick\" the running thread is pre-empted as soon as + possible. + + One final note: the + @aaaa@ @bbbb@ example may not + work too well on GHC (see Scheduling, above), due + to the locking on a 'System.IO.Handle'. Only one thread + may hold the lock on a 'System.IO.Handle' at any one + time, so if a reschedule happens while a thread is holding the + lock, the other thread won't be able to run. The upshot is that + the switch from @aaaa@ to + @bbbbb@ happens infrequently. It can be + improved by lowering the reschedule tick period. We also have a + patch that causes a reschedule whenever a thread waiting on a + lock is woken up, but haven't found it to be useful for anything + other than this example :-) +-} + +{- $deadlock + +GHC attempts to detect when threads are deadlocked using the garbage +collector. A thread that is not reachable (cannot be found by +following pointers from live objects) must be deadlocked, and in this +case the thread is sent an exception. The exception is either +'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', +'NonTermination', or 'Deadlock', depending on the way in which the +thread is deadlocked. + +Note that this feature is intended for debugging, and should not be +relied on for the correct operation of your program. There is no +guarantee that the garbage collector will be accurate enough to detect +your deadlock, and no guarantee that the garbage collector will run in +a timely enough manner. Basically, the same caveats as for finalizers +apply to deadlock detection. + +There is a subtle interaction between deadlock detection and +finalizers (as created by 'GHC.Foreign.Concurrent.newForeignPtr' or the +functions in "System.Mem.Weak"): if a thread is blocked waiting for a +finalizer to run, then the thread will be considered deadlocked and +sent an exception. So preferably don't do this, but if you have no +alternative then it is possible to prevent the thread from being +considered deadlocked by making a 'StablePtr' pointing to it. Don't +forget to release the 'StablePtr' later with 'freeStablePtr'. +-} diff --git a/src/Control/Concurrent/Chan.hs b/src/Control/Concurrent/Chan.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Chan.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.Chan +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (concurrency) +-- +-- Unbounded channels. +-- +-- The channels are implemented with 'Control.Concurrent.MVar's and therefore inherit all the +-- caveats that apply to @MVar@s (possibility of races, deadlocks etc). The +-- @stm@ (software transactional memory) library has a more robust implementation +-- of channels called @TChan@s. +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.Chan + ( + -- * The 'Chan' type + Chan, -- abstract + + -- * Operations + newChan, + writeChan, + readChan, + dupChan, + + -- * Stream interface + getChanContents, + writeList2Chan, + ) where + +import Prelude +import System.IO.Unsafe ( unsafeInterleaveIO ) +import GHC.Internal.Control.Concurrent.MVar +import GHC.Internal.Control.Exception (mask_) + +#define _UPK_(x) {-# UNPACK #-} !(x) + +-- A channel is represented by two @MVar@s keeping track of the two ends +-- of the channel contents, i.e., the read- and write ends. Empty @MVar@s +-- are used to handle consumers trying to read from an empty channel. + +-- |'Chan' is an abstract type representing an unbounded FIFO channel. +data Chan a + = Chan _UPK_(MVar (Stream a)) + _UPK_(MVar (Stream a)) -- Invariant: the Stream a is always an empty MVar + deriving Eq -- ^ @since 4.4.0.0 + +type Stream a = MVar (ChItem a) + +data ChItem a = ChItem a _UPK_(Stream a) + -- benchmarks show that unboxing the MVar here is worthwhile, because + -- although it leads to higher allocation, the channel data takes up + -- less space and is therefore quicker to GC. + +-- See the Concurrent Haskell paper for a diagram explaining +-- how the different channel operations proceed. + +-- @newChan@ sets up the read and write end of a channel by initialising +-- these two @MVar@s with an empty @MVar@. + +-- |Build and return a new instance of 'Chan'. +newChan :: IO (Chan a) +newChan = do + hole <- newEmptyMVar + readVar <- newMVar hole + writeVar <- newMVar hole + return (Chan readVar writeVar) + +-- To put an element on a channel, a new hole at the write end is created. +-- What was previously the empty @MVar@ at the back of the channel is then +-- filled in with a new stream element holding the entered value and the +-- new hole. + +-- |Write a value to a 'Chan'. +writeChan :: Chan a -> a -> IO () +writeChan (Chan _ writeVar) val = do + new_hole <- newEmptyMVar + mask_ $ do + old_hole <- takeMVar writeVar + putMVar old_hole (ChItem val new_hole) + putMVar writeVar new_hole + +-- The reason we don't simply do this: +-- +-- modifyMVar_ writeVar $ \old_hole -> do +-- putMVar old_hole (ChItem val new_hole) +-- return new_hole +-- +-- is because if an asynchronous exception is received after the 'putMVar' +-- completes and before modifyMVar_ installs the new value, it will set the +-- Chan's write end to a filled hole. + +-- |Read the next value from the 'Chan'. Blocks when the channel is empty. Since +-- the read end of a channel is an 'MVar', this operation inherits fairness +-- guarantees of 'MVar's (e.g. threads blocked in this operation are woken up in +-- FIFO order). +-- +-- Throws 'Control.Exception.BlockedIndefinitelyOnMVar' when the channel is +-- empty and no other thread holds a reference to the channel. +readChan :: Chan a -> IO a +readChan (Chan readVar _) = + modifyMVar readVar $ \read_end -> do + (ChItem val new_read_end) <- readMVar read_end + -- Use readMVar here, not takeMVar, + -- else dupChan doesn't work + return (new_read_end, val) + +-- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to +-- either channel from then on will be available from both. Hence this creates +-- a kind of broadcast channel, where data written by anyone is seen by +-- everyone else. +-- +-- (Note that a duplicated channel is not equal to its original. +-- So: @fmap (c /=) $ dupChan c@ returns @True@ for all @c@.) +dupChan :: Chan a -> IO (Chan a) +dupChan (Chan _ writeVar) = do + hole <- readMVar writeVar + newReadVar <- newMVar hole + return (Chan newReadVar writeVar) + +-- Operators for interfacing with functional streams. + +-- |Return a lazy list representing the contents of the supplied +-- 'Chan', much like 'GHC.Internal.System.IO.hGetContents'. +getChanContents :: Chan a -> IO [a] +getChanContents ch + = unsafeInterleaveIO (do + x <- readChan ch + xs <- getChanContents ch + return (x:xs) + ) + +-- |Write an entire list of items to a 'Chan'. +writeList2Chan :: Chan a -> [a] -> IO () +writeList2Chan ch ls = sequence_ (map (writeChan ch) ls) diff --git a/src/Control/Concurrent/MVar.hs b/src/Control/Concurrent/MVar.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/MVar.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Control.Concurrent.MVar +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (concurrency) +-- +-- An @'MVar' t@ is a mutable location that is either empty or contains a +-- value of type @t@. It has two fundamental operations: 'putMVar' +-- which fills an 'MVar' if it is empty and blocks otherwise, and +-- 'takeMVar' which empties an 'MVar' if it is full and blocks +-- otherwise. They can be used in multiple different ways: +-- +-- 1. As synchronized mutable variables, +-- +-- 2. As channels, with 'takeMVar' and 'putMVar' as receive and send, and +-- +-- 3. As a binary semaphore @'MVar' ()@, with 'takeMVar' and 'putMVar' as +-- wait and signal. +-- +-- They were introduced in the paper +-- ["Concurrent Haskell"](https://www.microsoft.com/en-us/research/wp-content/uploads/1996/01/concurrent-haskell.pdf) +-- by Simon Peyton Jones, Andrew Gordon and Sigbjorn Finne, though +-- some details of their implementation have since then changed (in +-- particular, a put on a full 'MVar' used to error, but now merely +-- blocks.) +-- +-- === Applicability +-- +-- 'MVar's offer more flexibility than 'Data.IORef.IORef's, but less flexibility +-- than 'GHC.Conc.STM'. They are appropriate for building synchronization +-- primitives and performing simple inter-thread communication; however +-- they are very simple and susceptible to race conditions, deadlocks or +-- uncaught exceptions. Do not use them if you need to perform larger +-- atomic operations such as reading from multiple variables: use 'GHC.Conc.STM' +-- instead. +-- +-- In particular, the "bigger" functions in this module ('swapMVar', +-- 'withMVar', 'modifyMVar_' and 'modifyMVar') are simply +-- the composition of a 'takeMVar' followed by a 'putMVar' with +-- exception safety. +-- These have atomicity guarantees only if all other threads +-- perform a 'takeMVar' before a 'putMVar' as well; otherwise, they may +-- block. +-- +-- === Fairness +-- +-- No thread can be blocked indefinitely on an 'MVar' unless another +-- thread holds that 'MVar' indefinitely. One usual implementation of +-- this fairness guarantee is that threads blocked on an 'MVar' are +-- served in a first-in-first-out fashion (this is what GHC does), +-- but this is not guaranteed in the semantics. +-- +-- === Gotchas +-- +-- Like many other Haskell data structures, 'MVar's are lazy. This +-- means that if you place an expensive unevaluated thunk inside an +-- 'MVar', it will be evaluated by the thread that consumes it, not the +-- thread that produced it. Be sure to 'evaluate' values to be placed +-- in an 'MVar' to the appropriate normal form, or utilize a strict +-- @MVar@ provided by the [strict-concurrency](https://hackage.haskell.org/package/strict-concurrency) package. +-- +-- === Ordering +-- +-- 'MVar' operations are always observed to take place in the order +-- they are written in the program, regardless of the memory model of +-- the underlying machine. This is in contrast to 'Data.IORef.IORef' operations +-- which may appear out-of-order to another thread in some cases. +-- +-- === Example +-- +-- Consider the following concurrent data structure, a skip channel. +-- This is a channel for an intermittent source of high bandwidth +-- information (for example, mouse movement events.) Writing to the +-- channel never blocks, and reading from the channel only returns the +-- most recent value, or blocks if there are no new values. Multiple +-- readers are supported with a @dupSkipChan@ operation. +-- +-- A skip channel is a pair of 'MVar's. The first 'MVar' contains the +-- current value, and a list of semaphores that need to be notified +-- when it changes. The second 'MVar' is a semaphore for this particular +-- reader: it is full if there is a value in the channel that this +-- reader has not read yet, and empty otherwise. +-- +-- @ +-- data SkipChan a = SkipChan (MVar (a, [MVar ()])) (MVar ()) +-- +-- newSkipChan :: IO (SkipChan a) +-- newSkipChan = do +-- sem <- newEmptyMVar +-- main <- newMVar (undefined, [sem]) +-- return (SkipChan main sem) +-- +-- putSkipChan :: SkipChan a -> a -> IO () +-- putSkipChan (SkipChan main _) v = do +-- (_, sems) <- takeMVar main +-- putMVar main (v, []) +-- mapM_ (\\sem -> putMVar sem ()) sems +-- +-- getSkipChan :: SkipChan a -> IO a +-- getSkipChan (SkipChan main sem) = do +-- takeMVar sem +-- (v, sems) <- takeMVar main +-- putMVar main (v, sem : sems) +-- return v +-- +-- dupSkipChan :: SkipChan a -> IO (SkipChan a) +-- dupSkipChan (SkipChan main _) = do +-- sem <- newEmptyMVar +-- (v, sems) <- takeMVar main +-- putMVar main (v, sem : sems) +-- return (SkipChan main sem) +-- @ +-- +-- This example was adapted from the original Concurrent Haskell paper. +-- For more examples of 'MVar's being used to build higher-level +-- synchronization primitives, see 'Control.Concurrent.Chan' and +-- 'Control.Concurrent.QSem'. +-- + +module Control.Concurrent.MVar + (-- * @MVar@s + MVar, + newEmptyMVar, + newMVar, + takeMVar, + putMVar, + readMVar, + swapMVar, + tryTakeMVar, + tryPutMVar, + isEmptyMVar, + withMVar, + withMVarMasked, + modifyMVar_, + modifyMVar, + modifyMVarMasked_, + modifyMVarMasked, + tryReadMVar, + mkWeakMVar, + addMVarFinalizer + ) where + +import GHC.Internal.Control.Concurrent.MVar diff --git a/src/Control/Concurrent/QSem.hs b/src/Control/Concurrent/QSem.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/QSem.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE BangPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.QSem +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (concurrency) +-- +-- Simple quantity semaphores. +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.QSem + ( -- * Simple Quantity Semaphores + QSem, -- abstract + newQSem, -- :: Int -> IO QSem + waitQSem, -- :: QSem -> IO () + signalQSem -- :: QSem -> IO () + ) where + +import Prelude +import GHC.Internal.Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar + , putMVar, newMVar, tryPutMVar) +import GHC.Internal.Control.Exception +import GHC.Internal.Data.Maybe + +-- | 'QSem' is a quantity semaphore in which the resource is acquired +-- and released in units of one. It provides guaranteed FIFO ordering +-- for satisfying blocked `waitQSem` calls. +-- +-- The pattern +-- +-- > bracket_ waitQSem signalQSem (...) +-- +-- is safe; it never loses a unit of the resource. +-- +newtype QSem = QSem (MVar (Int, [MVar ()], [MVar ()])) + +-- The semaphore state (i, xs, ys): +-- +-- i is the current resource value +-- +-- (xs,ys) is the queue of blocked threads, where the queue is +-- given by xs ++ reverse ys. We can enqueue new blocked threads +-- by consing onto ys, and dequeue by removing from the head of xs. +-- +-- A blocked thread is represented by an empty (MVar ()). To unblock +-- the thread, we put () into the MVar. +-- +-- A thread can dequeue itself by also putting () into the MVar, which +-- it must do if it receives an exception while blocked in waitQSem. +-- This means that when unblocking a thread in signalQSem we must +-- first check whether the MVar is already full; the MVar lock on the +-- semaphore itself resolves race conditions between signalQSem and a +-- thread attempting to dequeue itself. + +-- |Build a new 'QSem' with a supplied initial quantity. +-- The initial quantity must be at least 0. +newQSem :: Int -> IO QSem +newQSem initial + | initial < 0 = fail "newQSem: Initial quantity must be non-negative" + | otherwise = do + sem <- newMVar (initial, [], []) + return (QSem sem) + +-- |Wait for a unit to become available. +waitQSem :: QSem -> IO () +waitQSem (QSem m) = + mask_ $ do + (i,b1,b2) <- takeMVar m + if i == 0 + then do + b <- newEmptyMVar + putMVar m (i, b1, b:b2) + wait b + else do + let !z = i-1 + putMVar m (z, b1, b2) + return () + where + wait b = takeMVar b `onException` + (uninterruptibleMask_ $ do -- Note [signal uninterruptible] + (i,b1,b2) <- takeMVar m + r <- tryTakeMVar b + r' <- if isJust r + then signal (i,b1,b2) + else do putMVar b (); return (i,b1,b2) + putMVar m r') + +-- |Signal that a unit of the 'QSem' is available. +signalQSem :: QSem -> IO () +signalQSem (QSem m) = + uninterruptibleMask_ $ do -- Note [signal uninterruptible] + r <- takeMVar m + r' <- signal r + putMVar m r' + +-- Note [signal uninterruptible] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we have +-- +-- bracket waitQSem signalQSem (...) +-- +-- and an exception arrives at the signalQSem, then we must not lose +-- the resource. The signalQSem is masked by bracket, but taking +-- the MVar might block, and so it would be interruptible. Hence we +-- need an uninterruptibleMask here. +-- +-- This isn't ideal: during high contention, some threads won't be +-- interruptible. The QSemSTM implementation has better behaviour +-- here, but it performs much worse than this one in some +-- benchmarks. + +signal :: (Int,[MVar ()],[MVar ()]) -> IO (Int,[MVar ()],[MVar ()]) +signal (i,a1,a2) = + if i == 0 + then loop a1 a2 + else let !z = i+1 in return (z, a1, a2) + where + loop [] [] = return (1, [], []) + loop [] b2 = loop (reverse b2) [] + loop (b:bs) b2 = do + r <- tryPutMVar b () + if r then return (0, bs, b2) + else loop bs b2 diff --git a/src/Control/Concurrent/QSemN.hs b/src/Control/Concurrent/QSemN.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/QSemN.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.QSemN +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (concurrency) +-- +-- Quantity semaphores in which each thread may wait for an arbitrary +-- \"amount\". +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.QSemN + ( -- * General Quantity Semaphores + QSemN, -- abstract + newQSemN, -- :: Int -> IO QSemN + waitQSemN, -- :: QSemN -> Int -> IO () + signalQSemN -- :: QSemN -> Int -> IO () + ) where + +import Prelude +import GHC.Internal.Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar + , tryPutMVar, isEmptyMVar) +import GHC.Internal.Control.Exception +import GHC.Internal.Control.Monad (when) +import GHC.Internal.Data.IORef (IORef, newIORef, atomicModifyIORef) +import System.IO.Unsafe (unsafePerformIO) + +-- | 'QSemN' is a quantity semaphore in which the resource is acquired +-- and released in arbitrary amounts. It provides guaranteed FIFO ordering +-- for satisfying blocked `waitQSemN` calls. +-- +-- The pattern +-- +-- > bracket_ (waitQSemN n) (signalQSemN n) (...) +-- +-- is safe; it never loses any of the resource. +-- +data QSemN = QSemN !(IORef (Int, [(Int, MVar ())], [(Int, MVar ())])) + +-- The semaphore state (i, xs, ys): +-- +-- i is the current resource value +-- +-- (xs,ys) is the queue of blocked threads, where the queue is +-- given by xs ++ reverse ys. We can enqueue new blocked threads +-- by consing onto ys, and dequeue by removing from the head of xs. +-- +-- A blocked thread is represented by an empty (MVar ()). To unblock +-- the thread, we put () into the MVar. +-- +-- A thread can dequeue itself by also putting () into the MVar, which +-- it must do if it receives an exception while blocked in waitQSemN. +-- This means that when unblocking a thread in signalQSemN we must +-- first check whether the MVar is already full. + +-- |Build a new 'QSemN' with a supplied initial quantity. +-- The initial quantity must be at least 0. +newQSemN :: Int -> IO QSemN +newQSemN initial + | initial < 0 = fail "newQSemN: Initial quantity must be non-negative" + | otherwise = do + sem <- newIORef (initial, [], []) + return (QSemN sem) + +-- An unboxed version of Maybe (MVar a) +data MaybeMV a = JustMV !(MVar a) | NothingMV + +-- |Wait for the specified quantity to become available. +waitQSemN :: QSemN -> Int -> IO () +-- We need to mask here. Once we've enqueued our MVar, we need +-- to be sure to wait for it. Otherwise, we could lose our +-- allocated resource. +waitQSemN qs@(QSemN m) sz = mask_ $ do + -- unsafePerformIO and not unsafeDupablePerformIO. We must + -- be sure to wait on the same MVar that gets enqueued. + mmvar <- atomicModifyIORef m $ \ (i,b1,b2) -> unsafePerformIO $ do + let z = i-sz + if z < 0 + then do + b <- newEmptyMVar + return ((i, b1, (sz,b):b2), JustMV b) + else return ((z, b1, b2), NothingMV) + + -- Note: this case match actually allocates the MVar if necessary. + case mmvar of + NothingMV -> return () + JustMV b -> wait b + where + wait :: MVar () -> IO () + wait b = + takeMVar b `onException` do + already_filled <- not <$> tryPutMVar b () + when already_filled $ signalQSemN qs sz + +-- |Signal that a given quantity is now available from the 'QSemN'. +signalQSemN :: QSemN -> Int -> IO () +-- We don't need to mask here because we should *already* be masked +-- here (e.g., by bracket). Indeed, if we're not already masked, +-- it's too late to do so. +-- +-- What if the unsafePerformIO thunk is forced in another thread, +-- and receives an asynchronous exception? That shouldn't be a +-- problem: when we force it ourselves, presumably masked, we +-- will resume its execution. +signalQSemN (QSemN m) sz0 = do + -- unsafePerformIO and not unsafeDupablePerformIO. We must not + -- wake up more threads than we're supposed to. + unit <- atomicModifyIORef m $ \(i,a1,a2) -> + unsafePerformIO (loop (sz0 + i) a1 a2) + + -- Forcing this will actually wake the necessary threads. + evaluate unit + where + loop 0 bs b2 = return ((0, bs, b2), ()) + loop sz [] [] = return ((sz, [], []), ()) + loop sz [] b2 = loop sz (reverse b2) [] + loop sz ((j,b):bs) b2 + | j > sz = do + r <- isEmptyMVar b + if r then return ((sz, (j,b):bs, b2), ()) + else loop sz bs b2 + | otherwise = do + r <- tryPutMVar b () + if r then loop (sz-j) bs b2 + else loop sz bs b2 diff --git a/src/Control/Exception.hs b/src/Control/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Control/Exception.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- +-- Module : Control.Exception +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (extended exceptions) +-- +-- This module provides support for raising and catching both built-in +-- and user-defined exceptions. +-- +-- In addition to exceptions thrown by 'IO' operations, exceptions may +-- be thrown by pure code (imprecise exceptions) or by external events +-- (asynchronous exceptions), but may only be caught in the 'IO' monad. +-- For more details, see: +-- +-- * /A semantics for imprecise exceptions/, by Simon Peyton Jones, +-- Alastair Reid, Tony Hoare, Simon Marlow, Fergus Henderson, +-- in /PLDI'99/. +-- +-- * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton +-- Jones, Andy Moran and John Reppy, in /PLDI'01/. +-- +-- * /An Extensible Dynamically-Typed Hierarchy of Exceptions/, +-- by Simon Marlow, in /Haskell '06/. +-- + +module Control.Exception + (-- * The 'SomeException' type + SomeException(..), + -- ** The 'Exception' class + Exception(..), + addExceptionContext, + someExceptionContext, + annotateIO, + NoBacktrace(..), + ExceptionWithContext(..), + WhileHandling(..), + + -- * Concrete exception types + IOException, + ArithException(..), + ArrayException(..), + AssertionFailed(..), + NoMethodError(..), + PatternMatchFail(..), + RecConError(..), + RecSelError(..), + RecUpdError(..), + ErrorCall(..), + TypeError(..), + -- ** Asynchronous exceptions + SomeAsyncException(..), + AsyncException(..), + asyncExceptionToException, + asyncExceptionFromException, + NonTermination(..), + NestedAtomically(..), + BlockedIndefinitelyOnMVar(..), + BlockedIndefinitelyOnSTM(..), + AllocationLimitExceeded(..), + CompactionFailed(..), + Deadlock(..), + -- * Throwing exceptions + throw, + throwIO, + rethrowIO, + ioError, + throwTo, + -- * Catching Exceptions + -- $catching + -- ** Catching all exceptions + -- $catchall + -- ** The @catch@ functions + catch, + catchNoPropagate, + catches, + Handler(..), + catchJust, + -- ** The @handle@ functions + handle, + handleJust, + -- ** The @try@ functions + try, + tryWithContext, + tryJust, + -- ** The @evaluate@ function + evaluate, + -- ** The @mapException@ function + mapException, + -- * Asynchronous Exceptions + -- $async + -- ** Asynchronous exception control + -- | The following functions allow a thread to control delivery of + -- asynchronous exceptions during a critical region. + mask, + mask_, + uninterruptibleMask, + uninterruptibleMask_, + MaskingState(..), + getMaskingState, + interruptible, + allowInterrupt, + -- *** Applying @mask@ to an exception handler + -- $block_handler + -- *** Interruptible operations + -- $interruptible + -- * Assertions + assert, + -- * Utilities + bracket, + bracket_, + bracketOnError, + finally, + onException, + -- ** Printing + displayExceptionWithInfo + + ) where + +import GHC.Internal.Control.Exception +import GHC.Internal.Exception.Type + +{- $catching + +There are several functions for catching and examining +exceptions; all of them may only be used from within the +'IO' monad. + +Here's a rule of thumb for deciding which catch-style function to +use: + + * If you want to do some cleanup in the event that an exception + is raised, use 'finally', 'bracket' or 'onException'. + + * To recover after an exception and do something else, the best + choice is to use one of the 'try' family. + + * ... unless you are recovering from an asynchronous exception, in which + case use 'catch' or 'catchJust'. + +The difference between using 'try' and 'catch' for recovery is that in +'catch' the handler is inside an implicit 'mask' (see \"Asynchronous +Exceptions\") which is important when catching asynchronous +exceptions, but when catching other kinds of exception it is +unnecessary. Furthermore it is possible to accidentally stay inside +the implicit 'mask' by tail-calling rather than returning from the +handler, which is why we recommend using 'try' rather than 'catch' for +ordinary exception recovery. + +A typical use of 'tryJust' for recovery looks like this: + +> do r <- tryJust (guard . isDoesNotExistError) $ getEnv "HOME" +> case r of +> Left e -> ... +> Right home -> ... + +-} + +{- $async + + #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to +external influences, and can be raised at any point during execution. +'StackOverflow' and 'HeapOverflow' are two examples of +system-generated asynchronous exceptions. + +The primary source of asynchronous exceptions, however, is +'throwTo': + +> throwTo :: ThreadId -> Exception -> IO () + +'throwTo' (also 'Control.Concurrent.killThread') allows one +running thread to raise an arbitrary exception in another thread. The +exception is therefore asynchronous with respect to the target thread, +which could be doing anything at the time it receives the exception. +Great care should be taken with asynchronous exceptions; it is all too +easy to introduce race conditions by the over zealous use of +'throwTo'. +-} + +{- $block_handler +There\'s an implied 'mask' around every exception handler in a call +to one of the 'catch' family of functions. This is because that is +what you want most of the time - it eliminates a common race condition +in starting an exception handler, because there may be no exception +handler on the stack to handle another exception if one arrives +immediately. If asynchronous exceptions are masked on entering the +handler, though, we have time to install a new exception handler +before being interrupted. If this weren\'t the default, one would have +to write something like + +> mask $ \restore -> +> catch (restore (...)) +> (\e -> handler) + +If you need to unmask asynchronous exceptions again in the exception +handler, @restore@ can be used there too. + +Note that 'try' and friends /do not/ have a similar default, because +there is no exception handler in this case. Don't use 'try' for +recovering from an asynchronous exception. +-} + +{- $interruptible + + #interruptible# +Some operations are /interruptible/, which means that they can receive +asynchronous exceptions even in the scope of a 'mask'. Any function +which may itself block is defined as interruptible; this includes +'Control.Concurrent.MVar.takeMVar' +(but not 'Control.Concurrent.MVar.tryTakeMVar'), +and most operations which perform +some I\/O with the outside world. The reason for having +interruptible operations is so that we can write things like + +> mask $ \restore -> do +> a <- takeMVar m +> catch (restore (...)) +> (\e -> ...) + +if the 'Control.Concurrent.MVar.takeMVar' was not interruptible, +then this particular +combination could lead to deadlock, because the thread itself would be +blocked in a state where it can\'t receive any asynchronous exceptions. +With 'Control.Concurrent.MVar.takeMVar' interruptible, however, we can be +safe in the knowledge that the thread can receive exceptions right up +until the point when the 'Control.Concurrent.MVar.takeMVar' succeeds. +Similar arguments apply for other interruptible operations like +'System.IO.openFile'. + +It is useful to think of 'mask' not as a way to completely prevent +asynchronous exceptions, but as a way to switch from asynchronous mode +to polling mode. The main difficulty with asynchronous +exceptions is that they normally can occur anywhere, but within a +'mask' an asynchronous exception is only raised by operations that are +interruptible (or call other interruptible operations). In many cases +these operations may themselves raise exceptions, such as I\/O errors, +so the caller will usually be prepared to handle exceptions arising from the +operation anyway. To perform an explicit poll for asynchronous exceptions +inside 'mask', use 'allowInterrupt'. + +Sometimes it is too onerous to handle exceptions in the middle of a +critical piece of stateful code. There are three ways to handle this +kind of situation: + + * Use STM. Since a transaction is always either completely executed + or not at all, transactions are a good way to maintain invariants + over state in the presence of asynchronous (and indeed synchronous) + exceptions. + + * Use 'mask', and avoid interruptible operations. In order to do + this, we have to know which operations are interruptible. It is + impossible to know for any given library function whether it might + invoke an interruptible operation internally; so instead we give a + list of guaranteed-not-to-be-interruptible operations below. + + * Use 'uninterruptibleMask'. This is generally not recommended, + unless you can guarantee that any interruptible operations invoked + during the scope of 'uninterruptibleMask' can only ever block for + a short time. Otherwise, 'uninterruptibleMask' is a good way to + make your program deadlock and be unresponsive to user interrupts. + +The following operations are guaranteed not to be interruptible: + + * operations on 'Data.IORef.IORef' from "Data.IORef" + + * STM transactions that do not use 'Conc.retry' + + * everything from the @Foreign@ modules + + * everything from "Control.Exception" except for 'throwTo' + + * 'Control.Concurrent.MVar.tryTakeMVar', 'Control.Concurrent.MVar.tryPutMVar', + 'Control.Concurrent.MVar.isEmptyMVar' + + * 'Control.Concurrent.MVar.takeMVar' if the 'Control.Concurrent.MVar.MVar' is + definitely full, and conversely 'Control.Concurrent.MVar.putMVar' if the + 'Control.Concurrent.MVar.MVar' is definitely empty + + * 'Control.Concurrent.MVar.newEmptyMVar', 'Control.Concurrent.MVar.newMVar' + + * 'Control.Concurrent.forkIO', 'Control.Concurrent.myThreadId' + +-} + +{- $catchall + +It is possible to catch all exceptions, by using the type 'SomeException': + +> catch f (\e -> ... (e :: SomeException) ...) + +HOWEVER, this is normally not what you want to do! + +For example, suppose you want to read a file, but if it doesn't exist +then continue as if it contained \"\". You might be tempted to just +catch all exceptions and return \"\" in the handler. However, this has +all sorts of undesirable consequences. For example, if the user +presses control-C at just the right moment then the 'UserInterrupt' +exception will be caught, and the program will continue running under +the belief that the file contains \"\". Similarly, if another thread +tries to kill the thread reading the file then the 'ThreadKilled' +exception will be ignored. + +Instead, you should only catch exactly the exceptions that you really +want. In this case, this would likely be more specific than even +\"any IO exception\"; a permissions error would likely also want to be +handled differently. Instead, you would probably want something like: + +> e <- tryJust (guard . isDoesNotExistError) (readFile f) +> let str = either (const "") id e + +There are occasions when you really do need to catch any sort of +exception. However, in most cases this is just so you can do some +cleaning up; you aren't actually interested in the exception itself. +For example, if you open a file then you want to close it again, +whether processing the file executes normally or throws an exception. +However, in these cases you can use functions like 'bracket', 'finally' +and 'onException', which never actually pass you the exception, but +just call the cleanup functions at the appropriate points. + +But sometimes you really do need to catch any exception, and actually +see what the exception is. One example is at the very top-level of a +program, you may wish to catch any exception, print it to a logfile or +the screen, and then exit gracefully. For these cases, you can use +'catch' (or one of the other exception-catching functions) with the +'SomeException' type. +-} + diff --git a/src/Control/Exception/Annotation.hs b/src/Control/Exception/Annotation.hs new file mode 100644 --- /dev/null +++ b/src/Control/Exception/Annotation.hs @@ -0,0 +1,18 @@ +-- | +-- Module : Control.Exception.Annotation +-- Copyright : (c) The University of Glasgow, 1998-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Exception annotations. +-- +module Control.Exception.Annotation + ( SomeExceptionAnnotation(..) + , ExceptionAnnotation(..) + ) where + +import GHC.Internal.Exception.Context + diff --git a/src/Control/Exception/Backtrace.hs b/src/Control/Exception/Backtrace.hs new file mode 100644 --- /dev/null +++ b/src/Control/Exception/Backtrace.hs @@ -0,0 +1,59 @@ +-- | +-- Module : Control.Exception.Backtrace +-- Copyright : (c) The University of Glasgow 1994-2023 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- This module provides the 'Backtrace'\ s type, which provides a +-- common representation for backtrace information which can be, e.g., attached +-- to exceptions (via the 'Control.Exception.Context.ExceptionContext' facility). +-- These backtraces preserve useful context about the execution state of the program +-- using a variety of means; we call these means *backtrace mechanisms*. +-- +-- We currently support four backtrace mechanisms: +-- +-- - 'CostCentreBacktrace' captures the current cost-centre stack +-- using 'GHC.Stack.CCS.getCurrentCCS'. +-- - 'HasCallStackBacktrace' captures the 'HasCallStack' 'CallStack'. +-- - 'ExecutionBacktrace' captures the execution stack, unwound and resolved +-- to symbols via DWARF debug information. +-- - 'IPEBacktrace' captures the execution stack, resolved to names via info-table +-- provenance information. +-- +-- Each of these are useful in different situations. While 'CostCentreBacktrace's are +-- readily mapped back to the source program, they require that the program be instrumented +-- with cost-centres, incurring runtime cost. Similarly, 'HasCallStackBacktrace's require that +-- the program be manually annotated with 'HasCallStack' constraints. +-- +-- By contrast, 'IPEBacktrace's incur no runtime instrumentation but require that (at least +-- some subset of) the program be built with GHC\'s @-finfo-table-map@ flag. Moreover, because +-- info-table provenance information is derived after optimisation, it may be harder to relate +-- back to the structure of the source program. +-- +-- 'ExecutionBacktrace's are similar to 'IPEBacktrace's but use DWARF stack unwinding +-- and symbol resolution; this allows for useful backtraces even in the presence +-- of foreign calls, both into and out of Haskell. However, for robust stack unwinding +-- the entirety of the program (and its dependencies, both Haskell and native) must +-- be compiled with debugging information (e.g. using GHC\'s @-g@ flag). + + +-- Note [Backtrace mechanisms] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- See module docstring above. + + +module Control.Exception.Backtrace + ( -- * Backtrace mechanisms + BacktraceMechanism(..) + , getBacktraceMechanismState + , setBacktraceMechanismState + -- * Collecting backtraces + , Backtraces + , displayBacktraces + , collectBacktraces + ) where + +import GHC.Internal.Exception.Backtrace diff --git a/src/Control/Exception/Base.hs b/src/Control/Exception/Base.hs new file mode 100644 --- /dev/null +++ b/src/Control/Exception/Base.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Control.Exception.Base +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (extended exceptions) +-- +-- Extensible exceptions, except for multiple handlers. +-- + +module Control.Exception.Base + (-- * The Exception type + SomeException(..), + Exception(..), + IOException, + ArithException(..), + ArrayException(..), + AssertionFailed(..), + SomeAsyncException(..), + AsyncException(..), + asyncExceptionToException, + asyncExceptionFromException, + NonTermination(..), + NestedAtomically(..), + BlockedIndefinitelyOnMVar(..), + FixIOException(..), + BlockedIndefinitelyOnSTM(..), + AllocationLimitExceeded(..), + CompactionFailed(..), + Deadlock(..), + NoMethodError(..), + PatternMatchFail(..), + RecConError(..), + RecSelError(..), + RecUpdError(..), + ErrorCall(..), + TypeError(..), + NoMatchingContinuationPrompt(..), + -- * Throwing exceptions + throwIO, + throw, + ioError, + throwTo, + -- * Catching Exceptions + -- ** The @catch@ functions + catch, + catchJust, + -- ** The @handle@ functions + handle, + handleJust, + -- ** The @try@ functions + try, + tryJust, + onException, + -- ** The @evaluate@ function + evaluate, + -- ** The @mapException@ function + mapException, + -- * Asynchronous Exceptions + -- ** Asynchronous exception control + mask, + mask_, + uninterruptibleMask, + uninterruptibleMask_, + MaskingState(..), + getMaskingState, + -- * Assertions + assert, + -- * Utilities + bracket, + bracket_, + bracketOnError, + finally, + -- * Calls for GHC runtime + recSelError, + recConError, + impossibleError, + impossibleConstraintError, + nonExhaustiveGuardsError, + patError, + noMethodBindingError, + typeError, + nonTermination, + nestedAtomically, + noMatchingContinuationPrompt + ) where + +import GHC.Internal.Control.Exception.Base diff --git a/src/Control/Exception/Context.hs b/src/Control/Exception/Context.hs new file mode 100644 --- /dev/null +++ b/src/Control/Exception/Context.hs @@ -0,0 +1,22 @@ +-- | +-- Module : Control.Exception.Context +-- Copyright : (c) The University of Glasgow, 1998-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Exception context and annotations. +-- +module Control.Exception.Context + ( ExceptionContext(..) + , emptyExceptionContext + , addExceptionAnnotation + -- * Destructuring + , getExceptionAnnotations + , getAllExceptionAnnotations + , displayExceptionContext + ) where + +import GHC.Internal.Exception.Context diff --git a/src/Control/Monad.hs b/src/Control/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Control.Monad +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'Functor', 'Monad' and 'MonadPlus' classes, +-- with some useful operations on monads. + +module Control.Monad + (-- * Functor and monad classes + Functor(..), + Monad((>>=), (>>), return), + MonadFail(fail), + MonadPlus(mzero, mplus), + -- * Functions + -- ** Naming conventions + -- $naming + -- ** Basic @Monad@ functions + mapM, + mapM_, + forM, + forM_, + sequence, + sequence_, + (=<<), + (>=>), + (<=<), + forever, + void, + -- ** Generalisations of list functions + join, + msum, + mfilter, + filterM, + mapAndUnzipM, + zipWithM, + zipWithM_, + foldM, + foldM_, + replicateM, + replicateM_, + -- ** Conditional execution of monadic expressions + guard, + when, + unless, + -- ** Monadic lifting operators + liftM, + liftM2, + liftM3, + liftM4, + liftM5, + ap, + -- ** Strict monadic functions + (<$!>) + ) where + +import GHC.Internal.Control.Monad + +{- $naming + +The functions in this module use the following naming conventions: + +* A postfix \'@M@\' always stands for a function in the Kleisli category: + The monad type constructor @m@ is added to function results + (modulo currying) and nowhere else. So, for example, + +> filter :: (a -> Bool) -> [a] -> [a] +> filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a] + +* A postfix \'@_@\' changes the result type from @(m a)@ to @(m ())@. + Thus, for example: + +> sequence :: Monad m => [m a] -> m [a] +> sequence_ :: Monad m => [m a] -> m () + +* A prefix \'@m@\' generalizes an existing function to a monadic form. + Thus, for example: + +> filter :: (a -> Bool) -> [a] -> [a] +> mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a + +-} diff --git a/src/Control/Monad/Fail.hs b/src/Control/Monad/Fail.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Fail.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Control.Monad.Fail +-- Copyright : (C) 2015 David Luposchainsky, +-- (C) 2015 Herbert Valerio Riedel +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Transitional module providing the 'MonadFail' class and primitive +-- instances. +-- +-- This module can be imported for defining forward compatible +-- 'MonadFail' instances: +-- +-- @ +-- import qualified Control.Monad.Fail as Fail +-- +-- instance Monad Foo where +-- (>>=) = {- ...bind impl... -} +-- +-- -- Provide legacy 'fail' implementation for when +-- -- new-style MonadFail desugaring is not enabled. +-- fail = Fail.fail +-- +-- instance Fail.MonadFail Foo where +-- fail = {- ...fail implementation... -} +-- @ +-- +-- See +-- for more details. +-- +-- @since 4.9.0.0 +-- + +module Control.Monad.Fail + (MonadFail(fail)) where + +import GHC.Internal.Control.Monad.Fail diff --git a/src/Control/Monad/Fix.hs b/src/Control/Monad/Fix.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Fix.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Control.Monad.Fix +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Monadic fixpoints, used for desugaring of @{-# LANGUAGE RecursiveDo #-}@. +-- +-- 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), + fix + ) where + +import GHC.Internal.Control.Monad.Fix diff --git a/src/Control/Monad/IO/Class.hs b/src/Control/Monad/IO/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/IO/Class.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.IO.Class +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : stable +-- Portability : portable +-- +-- Class of monads based on @IO@. +----------------------------------------------------------------------------- + +module Control.Monad.IO.Class + ( MonadIO(..) ) + where + +import GHC.Internal.Control.Monad.IO.Class diff --git a/src/Control/Monad/Instances.hs b/src/Control/Monad/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Instances.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- +-- Module : Control.Monad.Instances +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- /This module is DEPRECATED and will be removed in the future!/ +-- +-- 'Functor' and 'Monad' instances for @(->) r@ and +-- 'Functor' instances for @(,) a@ and @'Either' a@. + +module Control.Monad.Instances + {-# DEPRECATED "This module now contains no instances and will be removed in the future" #-} -- deprecated in 7.8 + ( Functor(..), + Monad(..) + ) where + +import GHC.Internal.Base (Functor(..), Monad(..)) diff --git a/src/Control/Monad/ST.hs b/src/Control/Monad/ST.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/ST.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Control.Monad.ST +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This module provides support for /strict/ state threads, as +-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton +-- Jones /Lazy Functional State Threads/. +-- +-- References (variables) that can be used within the @ST@ monad are +-- provided by "Data.STRef", and arrays are provided by +-- [Data.Array.ST](https://hackage.haskell.org/package/array/docs/Data-Array-ST.html). + +module Control.Monad.ST + (-- * The 'ST' Monad + ST, + runST, + fixST, + -- * Converting 'ST' to 'IO' + RealWorld, + stToIO + ) where + +import GHC.Internal.Control.Monad.ST diff --git a/src/Control/Monad/ST/Lazy.hs b/src/Control/Monad/ST/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/ST/Lazy.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Control.Monad.ST.Lazy +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This module presents an identical interface to "Control.Monad.ST", +-- except that the monad delays evaluation of state operations until +-- a value depending on them is required. +-- + +module Control.Monad.ST.Lazy + (-- * The 'ST' monad + ST, + runST, + fixST, + -- * Converting between strict and lazy 'ST' + strictToLazyST, + lazyToStrictST, + -- * Converting 'ST' To 'IO' + RealWorld, + stToIO + ) where + +import GHC.Internal.Control.Monad.ST.Lazy diff --git a/src/Control/Monad/ST/Lazy/Safe.hs b/src/Control/Monad/ST/Lazy/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/ST/Lazy/Safe.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- +-- Module : Control.Monad.ST.Lazy.Safe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This module presents an identical interface to "Control.Monad.ST", +-- except that the monad delays evaluation of 'ST' operations until +-- a value depending on them is required. +-- +-- Safe API only. +-- + +module Control.Monad.ST.Lazy.Safe + {-# DEPRECATED "Safe is now the default, please use GHC.Internal.Control.Monad.ST.Lazy instead" #-} + (-- * The 'ST' monad + ST, + runST, + fixST, + -- * Converting between strict and lazy 'ST' + strictToLazyST, + lazyToStrictST, + -- * Converting 'ST' To 'IO' + RealWorld, + stToIO + ) where + +import GHC.Internal.Control.Monad.ST.Lazy.Imp diff --git a/src/Control/Monad/ST/Lazy/Unsafe.hs b/src/Control/Monad/ST/Lazy/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/ST/Lazy/Unsafe.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE Unsafe #-} + +-- | +-- +-- Module : Control.Monad.ST.Lazy.Unsafe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This module presents an identical interface to "Control.Monad.ST", +-- except that the monad delays evaluation of 'ST' operations until +-- a value depending on them is required. +-- +-- Unsafe API. +-- + +module Control.Monad.ST.Lazy.Unsafe + (-- * Unsafe operations + unsafeInterleaveST, + unsafeIOToST + ) where + +import GHC.Internal.Control.Monad.ST.Lazy.Imp diff --git a/src/Control/Monad/ST/Safe.hs b/src/Control/Monad/ST/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/ST/Safe.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- +-- Module : Control.Monad.ST.Safe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This module provides support for /strict/ state threads, as +-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton +-- Jones /Lazy Functional State Threads/. +-- +-- Safe API Only. +-- + +module Control.Monad.ST.Safe + {-# DEPRECATED "Safe is now the default, please use GHC.Internal.Control.Monad.ST instead" #-} + (-- * The 'ST' Monad + ST, + runST, + fixST, + -- * Converting 'ST' to 'IO' + RealWorld, + stToIO + ) where + +import GHC.Internal.Control.Monad.ST.Imp diff --git a/src/Control/Monad/ST/Strict.hs b/src/Control/Monad/ST/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/ST/Strict.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Control.Monad.ST.Strict +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires universal quantification for runST) +-- +-- The strict ST monad (re-export of "Control.Monad.ST") +-- + +module Control.Monad.ST.Strict + (module GHC.Internal.Control.Monad.ST) where + +import GHC.Internal.Control.Monad.ST diff --git a/src/Control/Monad/ST/Unsafe.hs b/src/Control/Monad/ST/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/ST/Unsafe.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE Unsafe #-} + +-- | +-- +-- Module : Control.Monad.ST.Unsafe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This module provides support for /strict/ state threads, as +-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton +-- Jones /Lazy Functional State Threads/. +-- +-- Unsafe API. +-- + +module Control.Monad.ST.Unsafe + (-- * Unsafe operations + unsafeInterleaveST, + unsafeDupableInterleaveST, + unsafeIOToST, + unsafeSTToIO + ) where + +import GHC.Internal.Control.Monad.ST.Imp diff --git a/src/Control/Monad/Zip.hs b/src/Control/Monad/Zip.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Zip.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Zip +-- Copyright : (c) Nils Schweinsberg 2011, +-- (c) George Giorgidze 2011 +-- (c) University Tuebingen 2011 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Monadic zipping (used for monad comprehensions) +-- +----------------------------------------------------------------------------- + +module Control.Monad.Zip ( MonadZip(..) ) where + +import GHC.Internal.Control.Monad.Zip(MonadZip(..)) diff --git a/src/Data/Array/Byte.hs b/src/Data/Array/Byte.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Byte.hs @@ -0,0 +1,388 @@ +-- | +-- Module : Data.Array.Byte +-- Copyright : (c) Roman Leshchinskiy 2009-2012 +-- License : BSD-style +-- +-- Maintainer : libraries@haskell.org +-- Portability : non-portable +-- +-- Derived from @primitive@ package. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Data.Array.Byte ( + ByteArray(..), + MutableByteArray(..), +) where + +import GHC.Internal.Data.Bits ((.&.), unsafeShiftR) +import GHC.Internal.Data.Data (mkNoRepType, Data(..)) +import GHC.Internal.Data.Typeable (Typeable) +import qualified GHC.Internal.Data.Foldable as F +import GHC.Internal.Data.Maybe (fromMaybe) +import Data.Semigroup +import GHC.Internal.Exts +import GHC.Num.Integer (Integer(..)) +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#'. +-- +-- Since 'ByteArray#' is an unlifted type and not a member of kind 'Data.Kind.Type', +-- things like @[ByteArray#]@ or @IO ByteArray#@ are ill-typed. To work around this +-- inconvenience this module provides a standard lifted wrapper, inhabiting 'Data.Kind.Type'. +-- Clients are expected to use 'ByteArray' in higher-level APIs, +-- 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# + +-- | Lifted wrapper for 'MutableByteArray#'. +-- +-- Since 'MutableByteArray#' is an unlifted type and not a member of kind 'Data.Kind.Type', +-- things like @[MutableByteArray#]@ or @IO MutableByteArray#@ are ill-typed. To work around this +-- inconvenience this module provides a standard lifted wrapper, inhabiting 'Data.Kind.Type'. +-- Clients are expected to use 'MutableByteArray' in higher-level APIs, +-- but wrap and unwrap 'MutableByteArray' internally as they please +-- and use functions from "GHC.Exts". +-- +-- @since 4.17.0.0 +data MutableByteArray s = MutableByteArray (MutableByteArray# s) + +-- | Create a new mutable byte array of the specified size in bytes. +-- +-- /Note:/ this function does not check if the input is non-negative. +newByteArray :: Int -> ST s (MutableByteArray s) +{-# INLINE newByteArray #-} +newByteArray (I# n#) = + ST (\s# -> case newByteArray# n# s# of + (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) + +-- | Convert a mutable byte array to an immutable one without copying. The +-- array should not be modified after the conversion. +unsafeFreezeByteArray :: MutableByteArray s -> ST s ByteArray +{-# INLINE unsafeFreezeByteArray #-} +unsafeFreezeByteArray (MutableByteArray arr#) = + ST (\s# -> case unsafeFreezeByteArray# arr# s# of + (# s'#, arr'# #) -> (# s'#, ByteArray arr'# #)) + +-- | Size of the byte array in bytes. +sizeofByteArray :: ByteArray -> Int +{-# INLINE sizeofByteArray #-} +sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#) + +-- | Read byte at specific index. +indexByteArray :: ByteArray -> Int -> Word8 +{-# INLINE indexByteArray #-} +indexByteArray (ByteArray arr#) (I# i#) = W8# (indexWord8Array# arr# i#) + +-- | Write byte at specific index. +writeByteArray :: MutableByteArray s -> Int -> Word8 -> ST s () +{-# INLINE writeByteArray #-} +writeByteArray (MutableByteArray arr#) (I# i#) (W8# x#) = + ST (\s# -> case writeWord8Array# arr# i# x# s# of + s'# -> (# s'#, () #)) + +-- | Explode 'ByteArray' into a list of bytes. +byteArrayToList :: ByteArray -> [Word8] +{-# INLINE byteArrayToList #-} +byteArrayToList arr = go 0 + where + go i + | i < maxI = indexByteArray arr i : go (i+1) + | otherwise = [] + maxI = sizeofByteArray arr + +-- | Create a 'ByteArray' from a list of a known length. If the length +-- of the list does not match the given length, this throws an exception. +byteArrayFromListN :: Int -> [Word8] -> ByteArray +byteArrayFromListN n ys + | n >= 0 = runST $ do + marr <- newByteArray n + let go !ix [] = if ix == n + then return () + else errorWithoutStackTrace $ "Data.Array.Byte.byteArrayFromListN: list length less than specified size" + go !ix (x : xs) = if ix < n + then do + writeByteArray marr ix x + go (ix + 1) xs + else errorWithoutStackTrace $ "Data.Array.Byte.byteArrayFromListN: list length greater than specified size" + go 0 ys + unsafeFreezeByteArray marr + | otherwise = errorWithoutStackTrace "Data.Array.Byte.ByteArrayFromListN: specified size is negative" + +-- | Copy a slice of an immutable byte array to a mutable byte array. +-- +-- /Note:/ this function does not do bounds or overlap checking. +unsafeCopyByteArray + :: MutableByteArray s -- ^ destination array + -> Int -- ^ offset into destination array + -> ByteArray -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of bytes to copy + -> ST s () +{-# INLINE unsafeCopyByteArray #-} +unsafeCopyByteArray (MutableByteArray dst#) (I# doff#) (ByteArray src#) (I# soff#) (I# sz#) = + ST (\s# -> case copyByteArray# src# soff# dst# doff# sz# s# of + s'# -> (# s'#, () #)) + +-- | Copy a slice from one mutable byte array to another +-- or to the same mutable byte array. +-- +-- /Note:/ this function does not do bounds or overlap checking. +unsafeCopyMutableByteArray + :: MutableByteArray s -- ^ destination array + -> Int -- ^ offset into destination array + -> MutableByteArray s -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of bytes to copy + -> ST s () +{-# INLINE unsafeCopyMutableByteArray #-} +unsafeCopyMutableByteArray (MutableByteArray dst#) (I# doff#) (MutableByteArray src#) (I# soff#) (I# sz#) = + ST (\s# -> case copyMutableByteArrayNonOverlapping# src# soff# dst# doff# sz# s# of + s'# -> (# s'#, () #)) + +-- | @since 4.17.0.0 +instance Data ByteArray where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Data.Array.Byte.ByteArray" + +-- | @since 4.17.0.0 +instance Typeable s => Data (MutableByteArray s) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Data.Array.Byte.MutableByteArray" + +-- | @since 4.17.0.0 +instance Show ByteArray where + showsPrec _ ba = + showString "[" . go 0 + where + showW8 :: Word8 -> String -> String + showW8 !w s = + '0' + : 'x' + : intToDigit (fromIntegral (unsafeShiftR w 4)) + : intToDigit (fromIntegral (w .&. 0x0F)) + : s + go i + | i < sizeofByteArray ba = comma . showW8 (indexByteArray ba i :: Word8) . go (i+1) + | otherwise = showChar ']' + 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 +{-# INLINE compareByteArraysFromBeginning #-} +compareByteArraysFromBeginning (ByteArray ba1#) (ByteArray ba2#) (I# n#) + = compare (I# (compareByteArrays# ba1# 0# ba2# 0# n#)) 0 + +-- | Do two byte arrays share the same pointer? +sameByteArray :: ByteArray# -> ByteArray# -> Bool +sameByteArray ba1 ba2 = + case sameByteArray# ba1 ba2 of r -> isTrue# r + +-- | @since 4.17.0.0 +instance Eq ByteArray where + ba1@(ByteArray ba1#) == ba2@(ByteArray ba2#) + | sameByteArray ba1# ba2# = True + | n1 /= n2 = False + | otherwise = compareByteArraysFromBeginning ba1 ba2 n1 == EQ + where + n1 = sizeofByteArray ba1 + n2 = sizeofByteArray ba2 + +-- | @since 4.17.0.0 +instance Eq (MutableByteArray s) where + (==) (MutableByteArray arr#) (MutableByteArray brr#) + = isTrue# (sameMutableByteArray# arr# brr#) + +-- | Non-lexicographic ordering. This compares the lengths of +-- the byte arrays first and uses a lexicographic ordering if +-- the lengths are equal. Subject to change between major versions. +-- +-- @since 4.17.0.0 +instance Ord ByteArray where + ba1@(ByteArray ba1#) `compare` ba2@(ByteArray ba2#) + | sameByteArray ba1# ba2# = EQ + | n1 /= n2 = n1 `compare` n2 + | otherwise = compareByteArraysFromBeginning ba1 ba2 n1 + where + n1 = sizeofByteArray ba1 + n2 = sizeofByteArray ba2 +-- The primop compareByteArrays# (invoked from 'compareByteArraysFromBeginning') +-- performs a check for pointer equality as well. However, it +-- is included here because it is likely better to check for pointer equality +-- before checking for length equality. Getting the length requires deferencing +-- the pointers, which could cause accesses to memory that is not in the cache. +-- By contrast, a pointer equality check is always extremely cheap. + +-- | Append two byte arrays. +appendByteArray :: ByteArray -> ByteArray -> ByteArray +appendByteArray ba1 ba2 = runST $ do + let n1 = sizeofByteArray ba1 + n2 = sizeofByteArray ba2 + totSz = fromMaybe (sizeOverflowError "appendByteArray") + (checkedIntAdd n1 n2) + marr <- newByteArray totSz + unsafeCopyByteArray marr 0 ba1 0 n1 + unsafeCopyByteArray marr n1 ba2 0 n2 + unsafeFreezeByteArray marr + +-- | Concatenate a list of 'ByteArray's. +concatByteArray :: [ByteArray] -> ByteArray +concatByteArray arrs = runST $ do + let addLen acc arr = fromMaybe (sizeOverflowError "concatByteArray") + (checkedIntAdd acc (sizeofByteArray arr)) + totLen = F.foldl' addLen 0 arrs + marr <- newByteArray totLen + pasteByteArrays marr 0 arrs + unsafeFreezeByteArray marr + +-- | Dump immutable 'ByteArray's into a mutable one, starting from a given offset. +pasteByteArrays :: MutableByteArray s -> Int -> [ByteArray] -> ST s () +pasteByteArrays !_ !_ [] = return () +pasteByteArrays !marr !ix (x : xs) = do + unsafeCopyByteArray marr ix x 0 (sizeofByteArray x) + pasteByteArrays marr (ix + sizeofByteArray x) xs + +-- | An array of zero length. +emptyByteArray :: ByteArray +emptyByteArray = runST (newByteArray 0 >>= unsafeFreezeByteArray) + +-- | Concatenates a given number of copies of an input ByteArray. +stimesPolymorphic :: Integral t => t -> ByteArray -> ByteArray +{-# INLINABLE stimesPolymorphic #-} +stimesPolymorphic nRaw !arr = case toInteger nRaw of + IS nInt# + | isTrue# (nInt# ># 0#) -> stimesPositiveInt (I# nInt#) arr + | isTrue# (nInt# >=# 0#) -> emptyByteArray + -- This check is redundant for unsigned types like Word. + -- Using >=# intead of ==# may make it easier for GHC to notice that. + | otherwise -> stimesNegativeErr + IP _ + | sizeofByteArray arr == 0 -> emptyByteArray + | otherwise -> stimesOverflowErr + IN _ -> stimesNegativeErr + +stimesNegativeErr :: ByteArray +stimesNegativeErr = + errorWithoutStackTrace "stimes @ByteArray: negative multiplier" + +stimesOverflowErr :: a +stimesOverflowErr = sizeOverflowError "stimes" + +stimesPositiveInt :: Int -> ByteArray -> ByteArray +{-# NOINLINE stimesPositiveInt #-} +-- NOINLINE to prevent its duplication in specialisations of stimesPolymorphic +stimesPositiveInt n arr = runST $ do + let inpSz = sizeofByteArray arr + tarSz = fromMaybe stimesOverflowErr (checkedIntMultiply n inpSz) + marr <- newByteArray tarSz + unsafeCopyByteArray marr 0 arr 0 inpSz + let + halfTarSz = (tarSz - 1) `div` 2 + go copied + | copied <= halfTarSz = do + unsafeCopyMutableByteArray marr copied marr 0 copied + go (copied + copied) + | otherwise = unsafeCopyMutableByteArray marr copied marr 0 (tarSz - copied) + go inpSz + unsafeFreezeByteArray marr + +-- | @since 4.17.0.0 +instance Semigroup ByteArray where + (<>) = appendByteArray + sconcat = mconcat . F.toList + {-# INLINE stimes #-} + stimes = stimesPolymorphic + +-- | @since 4.17.0.0 +instance Monoid ByteArray where + mempty = emptyByteArray + mconcat = concatByteArray + +-- | @since 4.17.0.0 +instance IsList ByteArray where + type Item ByteArray = Word8 + + toList = byteArrayToList + fromList xs = byteArrayFromListN (length xs) xs + fromListN = byteArrayFromListN + + +sizeOverflowError :: String -> a +sizeOverflowError fun + = errorWithoutStackTrace $ "Data.Array.Byte." ++ fun ++ ": size overflow" + + +-- TODO: Export these from a better home. + +-- | Adds two @Int@s, returning @Nothing@ if this results in an overflow +checkedIntAdd :: Int -> Int -> Maybe Int +checkedIntAdd (I# x#) (I# y#) = case addIntC# x# y# of + (# res, 0# #) -> Just (I# res) + _ -> Nothing + +-- | Multiplies two @Int@s, returning @Nothing@ if this results in an overflow +checkedIntMultiply :: Int -> Int -> Maybe Int +checkedIntMultiply (I# x#) (I# y#) = case timesInt2# x# y# of + (# 0#, _hi, lo #) -> Just (I# lo) + _ -> Nothing diff --git a/src/Data/Bifoldable.hs b/src/Data/Bifoldable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifoldable.hs @@ -0,0 +1,1054 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Bifoldable +-- Copyright : (C) 2011-2016 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- @since 4.10.0.0 +---------------------------------------------------------------------------- +module Data.Bifoldable + ( Bifoldable(..) + , bifoldr' + , bifoldr1 + , bifoldrM + , bifoldl' + , bifoldl1 + , bifoldlM + , bitraverse_ + , bifor_ + , bimapM_ + , biforM_ + , bimsum + , bisequenceA_ + , bisequence_ + , biasum + , biList + , binull + , bilength + , bielem + , bimaximum + , biminimum + , bisum + , biproduct + , biconcat + , biconcatMap + , biand + , bior + , biany + , biall + , bimaximumBy + , biminimumBy + , binotElem + , bifind + ) where + +import Control.Applicative +import GHC.Internal.Data.Functor.Utils (Max(..), Min(..), (#.)) +import GHC.Internal.Data.Maybe (fromMaybe) +import GHC.Internal.Data.Monoid +import GHC.Generics (K1(..)) +import Prelude + +-- $setup +-- >>> import Prelude +-- >>> import Data.Char +-- >>> import GHC.Internal.Data.Monoid (Product (..), Sum (..)) +-- >>> data BiList a b = BiList [a] [b] +-- >>> instance Bifoldable BiList where bifoldr f g z (BiList as bs) = foldr f (foldr g z bs) as + +-- | 'Bifoldable' identifies foldable structures with two different varieties +-- of elements (as opposed to 'Foldable', which has one variety of element). +-- Common examples are 'Either' and @(,)@: +-- +-- > instance Bifoldable Either where +-- > bifoldMap f _ (Left a) = f a +-- > bifoldMap _ g (Right b) = g b +-- > +-- > instance Bifoldable (,) where +-- > bifoldr f g z (a, b) = f a (g b z) +-- +-- Some examples below also use the following BiList to showcase empty +-- Bifoldable behaviors when relevant ('Either' and '(,)' containing always exactly +-- resp. 1 and 2 elements): +-- +-- > data BiList a b = BiList [a] [b] +-- > +-- > instance Bifoldable BiList where +-- > bifoldr f g z (BiList as bs) = foldr f (foldr g z bs) as +-- +-- A minimal 'Bifoldable' definition consists of either 'bifoldMap' or +-- 'bifoldr'. When defining more than this minimal set, one should ensure +-- that the following identities hold: +-- +-- @ +-- 'bifold' ≡ 'bifoldMap' 'id' 'id' +-- 'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty' +-- 'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' (Endo . f) (Endo . g) t) z +-- @ +-- +-- If the type is also an instance of 'Foldable', then +-- it must satisfy (up to laziness): +-- +-- @ +-- 'bifoldl' 'const' ≡ 'foldl' +-- 'bifoldr' ('flip' 'const') ≡ 'foldr' +-- 'bifoldMap' ('const' 'mempty') ≡ 'foldMap' +-- @ +-- +-- If the type is also a 'Data.Bifunctor.Bifunctor' instance, it should satisfy: +-- +-- @ +-- 'bifoldMap' f g ≡ 'bifold' . 'Data.Bifunctor.bimap' f g +-- @ +-- +-- which implies that +-- +-- @ +-- 'bifoldMap' f g . 'Data.Bifunctor.bimap' h i ≡ 'bifoldMap' (f . h) (g . i) +-- @ +-- +-- @since 4.10.0.0 +class Bifoldable p where + {-# MINIMAL bifoldr | bifoldMap #-} + + -- | Combines the elements of a structure using a monoid. + -- + -- @'bifold' ≡ 'bifoldMap' 'id' 'id'@ + -- + -- ==== __Examples__ + -- + -- Basic usage: + -- + -- >>> bifold (Right [1, 2, 3]) + -- [1,2,3] + -- + -- >>> bifold (Left [5, 6]) + -- [5,6] + -- + -- >>> bifold ([1, 2, 3], [4, 5]) + -- [1,2,3,4,5] + -- + -- >>> bifold (Product 6, Product 7) + -- Product {getProduct = 42} + -- + -- >>> bifold (Sum 6, Sum 7) + -- Sum {getSum = 13} + -- + -- @since 4.10.0.0 + bifold :: Monoid m => p m m -> m + bifold = bifoldMap id id + + -- | Combines the elements of a structure, given ways of mapping them to a + -- common monoid. + -- + -- @'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'@ + -- + -- ==== __Examples__ + -- + -- Basic usage: + -- + -- >>> bifoldMap (take 3) (fmap digitToInt) ([1..], "89") + -- [1,2,3,8,9] + -- + -- >>> bifoldMap (take 3) (fmap digitToInt) (Left [1..]) + -- [1,2,3] + -- + -- >>> bifoldMap (take 3) (fmap digitToInt) (Right "89") + -- [8,9] + -- + -- @since 4.10.0.0 + bifoldMap :: Monoid m => (a -> m) -> (b -> m) -> p a b -> m + bifoldMap f g = bifoldr (mappend . f) (mappend . g) mempty + + -- | Combines the elements of a structure in a right associative manner. + -- Given a hypothetical function @toEitherList :: p a b -> [Either a b]@ + -- yielding a list of all elements of a structure in order, the following + -- would hold: + -- + -- @'bifoldr' f g z ≡ 'foldr' ('either' f g) z . toEitherList@ + -- + -- ==== __Examples__ + -- + -- Basic usage: + -- + -- @ + -- > bifoldr (+) (*) 3 (5, 7) + -- 26 -- 5 + (7 * 3) + -- + -- > bifoldr (+) (*) 3 (7, 5) + -- 22 -- 7 + (5 * 3) + -- + -- > bifoldr (+) (*) 3 (Right 5) + -- 15 -- 5 * 3 + -- + -- > bifoldr (+) (*) 3 (Left 5) + -- 8 -- 5 + 3 + -- @ + -- + -- @since 4.10.0.0 + bifoldr :: (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c + bifoldr f g z t = appEndo (bifoldMap (Endo #. f) (Endo #. g) t) z + + -- | Combines the elements of a structure in a left associative manner. Given + -- a hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a + -- list of all elements of a structure in order, the following would hold: + -- + -- @'bifoldl' f g z + -- ≡ 'foldl' (\acc -> 'either' (f acc) (g acc)) z . toEitherList@ + -- + -- Note that if you want an efficient left-fold, you probably want to use + -- 'bifoldl'' instead of 'bifoldl'. The reason is that the latter does not + -- force the "inner" results, resulting in a thunk chain which then must be + -- evaluated from the outside-in. + -- + -- ==== __Examples__ + -- + -- Basic usage: + -- + -- @ + -- > bifoldl (+) (*) 3 (5, 7) + -- 56 -- (5 + 3) * 7 + -- + -- > bifoldl (+) (*) 3 (7, 5) + -- 50 -- (7 + 3) * 5 + -- + -- > bifoldl (+) (*) 3 (Right 5) + -- 15 -- 5 * 3 + -- + -- > bifoldl (+) (*) 3 (Left 5) + -- 8 -- 5 + 3 + -- @ + -- + -- @since 4.10.0.0 + bifoldl :: (c -> a -> c) -> (c -> b -> c) -> c -> p a b -> c + bifoldl f g z t = appEndo (getDual (bifoldMap (Dual . Endo . flip f) + (Dual . Endo . flip g) t)) z + +-- | Class laws for tuples hold only up to laziness. The +-- Bifoldable methods are lazier than their Foldable counterparts. +-- For example the law @'bifoldr' ('flip' 'const') ≡ 'foldr'@ does +-- not hold for tuples if laziness is exploited: +-- +-- >>> bifoldr (flip const) (:) [] (undefined :: (Int, Word)) `seq` () +-- () +-- >>> foldr (:) [] (errorWithoutStackTrace "error!" :: (Int, Word)) `seq` () +-- *** Exception: error! +-- +-- @since 4.10.0.0 +instance Bifoldable (,) where + bifoldMap f g ~(a, b) = f a `mappend` g b + +-- | @since 4.10.0.0 +instance Bifoldable Const where + bifoldMap f _ (Const a) = f a + +-- | @since 4.10.0.0 +instance Bifoldable (K1 i) where + bifoldMap f _ (K1 c) = f c + +-- | @since 4.10.0.0 +instance Bifoldable ((,,) x) where + bifoldMap f g ~(_,a,b) = f a `mappend` g b + +-- | @since 4.10.0.0 +instance Bifoldable ((,,,) x y) where + bifoldMap f g ~(_,_,a,b) = f a `mappend` g b + +-- | @since 4.10.0.0 +instance Bifoldable ((,,,,) x y z) where + bifoldMap f g ~(_,_,_,a,b) = f a `mappend` g b + +-- | @since 4.10.0.0 +instance Bifoldable ((,,,,,) x y z w) where + bifoldMap f g ~(_,_,_,_,a,b) = f a `mappend` g b + +-- | @since 4.10.0.0 +instance Bifoldable ((,,,,,,) x y z w v) where + bifoldMap f g ~(_,_,_,_,_,a,b) = f a `mappend` g b + +-- | @since 4.10.0.0 +instance Bifoldable Either where + bifoldMap f _ (Left a) = f a + bifoldMap _ g (Right b) = g b + +-- | As 'bifoldr', but strict in the result of the reduction functions at each +-- step. +-- +-- @since 4.10.0.0 +bifoldr' :: Bifoldable t => (a -> c -> c) -> (b -> c -> c) -> c -> t a b -> c +bifoldr' f g z0 xs = bifoldl f' g' id xs z0 where + f' k x z = k $! f x z + g' k x z = k $! g x z + +-- | A variant of 'bifoldr' that has no base case, +-- and thus may only be applied to non-empty structures. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bifoldr1 (+) (5, 7) +-- 12 +-- +-- >>> bifoldr1 (+) (Right 7) +-- 7 +-- +-- >>> bifoldr1 (+) (Left 5) +-- 5 +-- +-- @ +-- > bifoldr1 (+) (BiList [1, 2] [3, 4]) +-- 10 -- 1 + (2 + (3 + 4)) +-- @ +-- +-- >>> bifoldr1 (+) (BiList [1, 2] []) +-- 3 +-- +-- On empty structures, this function throws an exception: +-- +-- >>> bifoldr1 (+) (BiList [] []) +-- *** Exception: bifoldr1: empty structure +-- ... +-- +-- @since 4.10.0.0 +bifoldr1 :: Bifoldable t => (a -> a -> a) -> t a a -> a +bifoldr1 f xs = fromMaybe (error "bifoldr1: empty structure") + (bifoldr mbf mbf Nothing xs) + where + mbf x m = Just (case m of + Nothing -> x + Just y -> f x y) + +-- | Right associative monadic bifold over a structure. +-- +-- @since 4.10.0.0 +bifoldrM :: (Bifoldable t, Monad m) + => (a -> c -> m c) -> (b -> c -> m c) -> c -> t a b -> m c +bifoldrM f g z0 xs = bifoldl f' g' return xs z0 where + f' k x z = f x z >>= k + g' k x z = g x z >>= k + +-- | As 'bifoldl', but strict in the result of the reduction functions at each +-- step. +-- +-- This ensures that each step of the bifold is forced to weak head normal form +-- before being applied, avoiding the collection of thunks that would otherwise +-- occur. This is often what you want to strictly reduce a finite structure to +-- a single, monolithic result (e.g., 'bilength'). +-- +-- @since 4.10.0.0 +bifoldl':: Bifoldable t => (a -> b -> a) -> (a -> c -> a) -> a -> t b c -> a +bifoldl' f g z0 xs = bifoldr f' g' id xs z0 where + f' x k z = k $! f z x + g' x k z = k $! g z x + +-- | A variant of 'bifoldl' that has no base case, +-- and thus may only be applied to non-empty structures. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bifoldl1 (+) (5, 7) +-- 12 +-- +-- >>> bifoldl1 (+) (Right 7) +-- 7 +-- +-- >>> bifoldl1 (+) (Left 5) +-- 5 +-- +-- @ +-- > bifoldl1 (+) (BiList [1, 2] [3, 4]) +-- 10 -- ((1 + 2) + 3) + 4 +-- @ +-- +-- >>> bifoldl1 (+) (BiList [1, 2] []) +-- 3 +-- +-- On empty structures, this function throws an exception: +-- +-- >>> bifoldl1 (+) (BiList [] []) +-- *** Exception: bifoldl1: empty structure +-- ... +-- +-- @since 4.10.0.0 +bifoldl1 :: Bifoldable t => (a -> a -> a) -> t a a -> a +bifoldl1 f xs = fromMaybe (error "bifoldl1: empty structure") + (bifoldl mbf mbf Nothing xs) + where + mbf m y = Just (case m of + Nothing -> y + Just x -> f x y) + +-- | Left associative monadic bifold over a structure. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bifoldlM (\a b -> print b >> pure a) (\a c -> print (show c) >> pure a) 42 ("Hello", True) +-- "Hello" +-- "True" +-- 42 +-- +-- >>> bifoldlM (\a b -> print b >> pure a) (\a c -> print (show c) >> pure a) 42 (Right True) +-- "True" +-- 42 +-- +-- >>> bifoldlM (\a b -> print b >> pure a) (\a c -> print (show c) >> pure a) 42 (Left "Hello") +-- "Hello" +-- 42 +-- +-- @since 4.10.0.0 +bifoldlM :: (Bifoldable t, Monad m) + => (a -> b -> m a) -> (a -> c -> m a) -> a -> t b c -> m a +bifoldlM f g z0 xs = bifoldr f' g' return xs z0 where + f' x k z = f z x >>= k + g' x k z = g z x >>= k + +-- | Map each element of a structure using one of two actions, evaluate these +-- actions from left to right, and ignore the results. For a version that +-- doesn't ignore the results, see 'Data.Bitraversable.bitraverse'. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bitraverse_ print (print . show) ("Hello", True) +-- "Hello" +-- "True" +-- +-- >>> bitraverse_ print (print . show) (Right True) +-- "True" +-- +-- >>> bitraverse_ print (print . show) (Left "Hello") +-- "Hello" +-- +-- @since 4.10.0.0 +bitraverse_ :: (Bifoldable t, Applicative f) + => (a -> f c) -> (b -> f d) -> t a b -> f () +bitraverse_ f g = bifoldr ((*>) . f) ((*>) . g) (pure ()) + +-- | As 'bitraverse_', but with the structure as the primary argument. For a +-- version that doesn't ignore the results, see 'Data.Bitraversable.bifor'. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bifor_ ("Hello", True) print (print . show) +-- "Hello" +-- "True" +-- +-- >>> bifor_ (Right True) print (print . show) +-- "True" +-- +-- >>> bifor_ (Left "Hello") print (print . show) +-- "Hello" +-- +-- @since 4.10.0.0 +bifor_ :: (Bifoldable t, Applicative f) + => t a b -> (a -> f c) -> (b -> f d) -> f () +bifor_ t f g = bitraverse_ f g t + +-- | Alias for 'bitraverse_'. +-- +-- @since 4.10.0.0 +bimapM_ :: (Bifoldable t, Applicative f) + => (a -> f c) -> (b -> f d) -> t a b -> f () +bimapM_ = bitraverse_ + +-- | Alias for 'bifor_'. +-- +-- @since 4.10.0.0 +biforM_ :: (Bifoldable t, Applicative f) + => t a b -> (a -> f c) -> (b -> f d) -> f () +biforM_ = bifor_ + +-- | Alias for 'bisequence_'. +-- +-- @since 4.10.0.0 +bisequenceA_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f () +bisequenceA_ = bisequence_ + +-- | Evaluate each action in the structure from left to right, and ignore the +-- results. For a version that doesn't ignore the results, see +-- 'Data.Bitraversable.bisequence'. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bisequence_ (print "Hello", print "World") +-- "Hello" +-- "World" +-- +-- >>> bisequence_ (Left (print "Hello")) +-- "Hello" +-- +-- >>> bisequence_ (Right (print "World")) +-- "World" +-- +-- @since 4.10.0.0 +bisequence_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f () +bisequence_ = bifoldr (*>) (*>) (pure ()) + +-- | The sum of a collection of actions, generalizing 'biconcat'. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> biasum (Nothing, Nothing) +-- Nothing +-- +-- >>> biasum (Nothing, Just 42) +-- Just 42 +-- +-- >>> biasum (Just 18, Nothing) +-- Just 18 +-- +-- >>> biasum (Just 18, Just 42) +-- Just 18 +-- +-- @since 4.10.0.0 +biasum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a +biasum = bifoldr (<|>) (<|>) empty + +-- | Alias for 'biasum'. +-- +-- @since 4.10.0.0 +bimsum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a +bimsum = biasum + +-- | Collects the list of elements of a structure, from left to right. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> biList (18, 42) +-- [18,42] +-- +-- >>> biList (Left 18) +-- [18] +-- +-- @since 4.10.0.0 +biList :: Bifoldable t => t a a -> [a] +biList = bifoldr (:) (:) [] + +-- | Test whether the structure is empty. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> binull (18, 42) +-- False +-- +-- >>> binull (Right 42) +-- False +-- +-- >>> binull (BiList [] []) +-- True +-- +-- @since 4.10.0.0 +binull :: Bifoldable t => t a b -> Bool +binull = bifoldr (\_ _ -> False) (\_ _ -> False) True + +-- | Returns the size/length of a finite structure as an 'Int'. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bilength (True, 42) +-- 2 +-- +-- >>> bilength (Right 42) +-- 1 +-- +-- >>> bilength (BiList [1,2,3] [4,5]) +-- 5 +-- +-- >>> bilength (BiList [] []) +-- 0 +-- +-- On infinite structures, this function hangs: +-- +-- @ +-- > bilength (BiList [1..] []) +-- * Hangs forever * +-- @ +-- +-- @since 4.10.0.0 +bilength :: Bifoldable t => t a b -> Int +bilength = bifoldl' (\c _ -> c+1) (\c _ -> c+1) 0 + +-- | Does the element occur in the structure? +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bielem 42 (17, 42) +-- True +-- +-- >>> bielem 42 (17, 43) +-- False +-- +-- >>> bielem 42 (Left 42) +-- True +-- +-- >>> bielem 42 (Right 13) +-- False +-- +-- >>> bielem 42 (BiList [1..5] [1..100]) +-- True +-- +-- >>> bielem 42 (BiList [1..5] [1..41]) +-- False +-- +-- @since 4.10.0.0 +bielem :: (Bifoldable t, Eq a) => a -> t a a -> Bool +bielem x = biany (== x) (== x) + +-- | Reduces a structure of lists to the concatenation of those lists. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> biconcat ([1, 2, 3], [4, 5]) +-- [1,2,3,4,5] +-- +-- >>> biconcat (Left [1, 2, 3]) +-- [1,2,3] +-- +-- >>> biconcat (BiList [[1, 2, 3, 4, 5], [6, 7, 8]] [[9]]) +-- [1,2,3,4,5,6,7,8,9] +-- +-- @since 4.10.0.0 +biconcat :: Bifoldable t => t [a] [a] -> [a] +biconcat = bifold + +-- | 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__ +-- +-- Basic usage: +-- +-- >>> bimaximum (42, 17) +-- 42 +-- +-- >>> bimaximum (Right 42) +-- 42 +-- +-- >>> bimaximum (BiList [13, 29, 4] [18, 1, 7]) +-- 29 +-- +-- >>> bimaximum (BiList [13, 29, 4] []) +-- 29 +-- +-- On empty structures, this function throws an exception: +-- +-- >>> bimaximum (BiList [] []) +-- *** Exception: bimaximum: empty structure +-- ... +-- +-- @since 4.10.0.0 +bimaximum :: forall t a. (Bifoldable t, Ord a) => t a a -> a +bimaximum = fromMaybe (error "bimaximum: empty structure") . + getMax . bifoldMap mj mj + where mj = Max #. (Just :: a -> Maybe a) + +-- | 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__ +-- +-- Basic usage: +-- +-- >>> biminimum (42, 17) +-- 17 +-- +-- >>> biminimum (Right 42) +-- 42 +-- +-- >>> biminimum (BiList [13, 29, 4] [18, 1, 7]) +-- 1 +-- +-- >>> biminimum (BiList [13, 29, 4] []) +-- 4 +-- +-- On empty structures, this function throws an exception: +-- +-- >>> biminimum (BiList [] []) +-- *** Exception: biminimum: empty structure +-- ... +-- +-- @since 4.10.0.0 +biminimum :: forall t a. (Bifoldable t, Ord a) => t a a -> a +biminimum = fromMaybe (error "biminimum: empty structure") . + getMin . bifoldMap mj mj + where mj = Min #. (Just :: a -> Maybe a) + +-- | The 'bisum' function computes the sum of the numbers of a structure. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bisum (42, 17) +-- 59 +-- +-- >>> bisum (Right 42) +-- 42 +-- +-- >>> bisum (BiList [13, 29, 4] [18, 1, 7]) +-- 72 +-- +-- >>> bisum (BiList [13, 29, 4] []) +-- 46 +-- +-- >>> bisum (BiList [] []) +-- 0 +-- +-- @since 4.10.0.0 +bisum :: (Bifoldable t, Num a) => t a a -> a +bisum = getSum #. bifoldMap Sum Sum + +-- | The 'biproduct' function computes the product of the numbers of a +-- structure. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> biproduct (42, 17) +-- 714 +-- +-- >>> biproduct (Right 42) +-- 42 +-- +-- >>> biproduct (BiList [13, 29, 4] [18, 1, 7]) +-- 190008 +-- +-- >>> biproduct (BiList [13, 29, 4] []) +-- 1508 +-- +-- >>> biproduct (BiList [] []) +-- 1 +-- +-- @since 4.10.0.0 +biproduct :: (Bifoldable t, Num a) => t a a -> a +biproduct = getProduct #. bifoldMap Product Product + +-- | Given a means of mapping the elements of a structure to lists, computes the +-- concatenation of all such lists in order. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> biconcatMap (take 3) (fmap digitToInt) ([1..], "89") +-- [1,2,3,8,9] +-- +-- >>> biconcatMap (take 3) (fmap digitToInt) (Left [1..]) +-- [1,2,3] +-- +-- >>> biconcatMap (take 3) (fmap digitToInt) (Right "89") +-- [8,9] +-- +-- @since 4.10.0.0 +biconcatMap :: Bifoldable t => (a -> [c]) -> (b -> [c]) -> t a b -> [c] +biconcatMap = bifoldMap + +-- | 'biand' returns the conjunction of a container of Bools. For the +-- result to be 'True', the container must be finite; 'False', however, +-- results from a 'False' value finitely far from the left end. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> biand (True, False) +-- False +-- +-- >>> biand (True, True) +-- True +-- +-- >>> biand (Left True) +-- True +-- +-- Empty structures yield 'True': +-- +-- >>> biand (BiList [] []) +-- True +-- +-- A 'False' value finitely far from the left end yields 'False' (short circuit): +-- +-- >>> biand (BiList [True, True, False, True] (repeat True)) +-- False +-- +-- A 'False' value infinitely far from the left end hangs: +-- +-- @ +-- > biand (BiList (repeat True) [False]) +-- * Hangs forever * +-- @ +-- +-- An infinitely 'True' value hangs: +-- +-- @ +-- > biand (BiList (repeat True) []) +-- * Hangs forever * +-- @ +-- +-- @since 4.10.0.0 +biand :: Bifoldable t => t Bool Bool -> Bool +biand = getAll #. bifoldMap All All + +-- | 'bior' returns the disjunction of a container of Bools. For the +-- result to be 'False', the container must be finite; 'True', however, +-- results from a 'True' value finitely far from the left end. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bior (True, False) +-- True +-- +-- >>> bior (False, False) +-- False +-- +-- >>> bior (Left True) +-- True +-- +-- Empty structures yield 'False': +-- +-- >>> bior (BiList [] []) +-- False +-- +-- A 'True' value finitely far from the left end yields 'True' (short circuit): +-- +-- >>> bior (BiList [False, False, True, False] (repeat False)) +-- True +-- +-- A 'True' value infinitely far from the left end hangs: +-- +-- @ +-- > bior (BiList (repeat False) [True]) +-- * Hangs forever * +-- @ +-- +-- An infinitely 'False' value hangs: +-- +-- @ +-- > bior (BiList (repeat False) []) +-- * Hangs forever * +-- @ +-- +-- @since 4.10.0.0 +bior :: Bifoldable t => t Bool Bool -> Bool +bior = getAny #. bifoldMap Any Any + +-- | Determines whether any element of the structure satisfies its appropriate +-- predicate argument. Empty structures yield 'False'. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> biany even isDigit (27, 't') +-- False +-- +-- >>> biany even isDigit (27, '8') +-- True +-- +-- >>> biany even isDigit (26, 't') +-- True +-- +-- >>> biany even isDigit (Left 27) +-- False +-- +-- >>> biany even isDigit (Left 26) +-- True +-- +-- >>> biany even isDigit (BiList [27, 53] ['t', '8']) +-- True +-- +-- Empty structures yield 'False': +-- +-- >>> biany even isDigit (BiList [] []) +-- False +-- +-- @since 4.10.0.0 +biany :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool +biany p q = getAny #. bifoldMap (Any . p) (Any . q) + +-- | Determines whether all elements of the structure satisfy their appropriate +-- predicate argument. Empty structures yield 'True'. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> biall even isDigit (27, 't') +-- False +-- +-- >>> biall even isDigit (26, '8') +-- True +-- +-- >>> biall even isDigit (Left 27) +-- False +-- +-- >>> biall even isDigit (Left 26) +-- True +-- +-- >>> biall even isDigit (BiList [26, 52] ['3', '8']) +-- True +-- +-- Empty structures yield 'True': +-- +-- >>> biall even isDigit (BiList [] []) +-- True +-- +-- @since 4.10.0.0 +biall :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool +biall p q = getAll #. bifoldMap (All . p) (All . q) + +-- | The largest element of a non-empty structure with respect to the +-- given comparison function. Structure order is used as a tie-breaker: if +-- there are multiple largest elements, the rightmost of them is chosen. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bimaximumBy compare (42, 17) +-- 42 +-- +-- >>> bimaximumBy compare (Left 17) +-- 17 +-- +-- >>> bimaximumBy compare (BiList [42, 17, 23] [-5, 18]) +-- 42 +-- +-- On empty structures, this function throws an exception: +-- +-- >>> bimaximumBy compare (BiList [] []) +-- *** Exception: bifoldr1: empty structure +-- ... +-- +-- @since 4.10.0.0 +bimaximumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a +bimaximumBy cmp = bifoldr1 max' + where max' x y = case cmp x y of + GT -> x + _ -> y + +-- | The least element of a non-empty structure with respect to the +-- given comparison function. Structure order is used as a tie-breaker: if +-- there are multiple least elements, the leftmost of them is chosen. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> biminimumBy compare (42, 17) +-- 17 +-- +-- >>> biminimumBy compare (Left 17) +-- 17 +-- +-- >>> biminimumBy compare (BiList [42, 17, 23] [-5, 18]) +-- -5 +-- +-- On empty structures, this function throws an exception: +-- +-- >>> biminimumBy compare (BiList [] []) +-- *** Exception: bifoldr1: empty structure +-- ... +-- +-- @since 4.10.0.0 +biminimumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a +biminimumBy cmp = bifoldr1 min' + where min' x y = case cmp x y of + GT -> y + _ -> x + +-- | 'binotElem' is the negation of 'bielem'. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> binotElem 42 (17, 42) +-- False +-- +-- >>> binotElem 42 (17, 43) +-- True +-- +-- >>> binotElem 42 (Left 42) +-- False +-- +-- >>> binotElem 42 (Right 13) +-- True +-- +-- >>> binotElem 42 (BiList [1..5] [1..100]) +-- False +-- +-- >>> binotElem 42 (BiList [1..5] [1..41]) +-- True +-- +-- @since 4.10.0.0 +binotElem :: (Bifoldable t, Eq a) => a -> t a a-> Bool +binotElem x = not . bielem x + +-- | The 'bifind' function takes a predicate and a structure and returns +-- the leftmost element of the structure matching the predicate, or +-- 'Nothing' if there is no such element. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bifind even (27, 53) +-- Nothing +-- +-- >>> bifind even (27, 52) +-- Just 52 +-- +-- >>> bifind even (26, 52) +-- Just 26 +-- +-- Empty structures always yield 'Nothing': +-- +-- >>> bifind even (BiList [] []) +-- Nothing +-- +-- @since 4.10.0.0 +bifind :: Bifoldable t => (a -> Bool) -> t a a -> Maybe a +bifind p = getFirst . bifoldMap finder finder + where finder x = First (if p x then Just x else Nothing) diff --git a/src/Data/Bifoldable1.hs b/src/Data/Bifoldable1.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifoldable1.hs @@ -0,0 +1,49 @@ +-- | +-- Copyright: Edward Kmett, Oleg Grenrus +-- License: BSD-3-Clause +-- + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Safe #-} + +module Data.Bifoldable1 where + +import Control.Applicative (Const (..)) +import Data.Bifoldable (Bifoldable (..)) +import Data.Semigroup (Arg (..), Semigroup (..)) +import Prelude (Either (..), id) + +class Bifoldable t => Bifoldable1 t where + bifold1 :: Semigroup m => t m m -> m + bifold1 = bifoldMap1 id id + {-# INLINE bifold1 #-} + + bifoldMap1 :: Semigroup m => (a -> m) -> (b -> m) -> t a b -> m + +instance Bifoldable1 Arg where + bifoldMap1 f g (Arg a b) = f a <> g b + +instance Bifoldable1 Either where + bifoldMap1 f _ (Left a) = f a + bifoldMap1 _ g (Right b) = g b + {-# INLINE bifoldMap1 #-} + +instance Bifoldable1 (,) where + bifoldMap1 f g (a, b) = f a <> g b + {-# INLINE bifoldMap1 #-} + +instance Bifoldable1 ((,,) x) where + bifoldMap1 f g (_,a,b) = f a <> g b + {-# INLINE bifoldMap1 #-} + +instance Bifoldable1 ((,,,) x y) where + bifoldMap1 f g (_,_,a,b) = f a <> g b + {-# INLINE bifoldMap1 #-} + +instance Bifoldable1 ((,,,,) x y z) where + bifoldMap1 f g (_,_,_,a,b) = f a <> g b + {-# INLINE bifoldMap1 #-} + +instance Bifoldable1 Const where + bifoldMap1 f _ (Const a) = f a + {-# INLINE bifoldMap1 #-} diff --git a/src/Data/Bifunctor.hs b/src/Data/Bifunctor.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifunctor.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Bifunctor +-- Copyright : (C) 2008-2014 Edward Kmett, +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- @since 4.8.0.0 +---------------------------------------------------------------------------- +module Data.Bifunctor + ( Bifunctor(..) + ) where + +import Control.Applicative ( Const(..) ) +import GHC.Generics ( K1(..) ) +import Prelude + +-- $setup +-- >>> import Prelude +-- >>> import Data.Char (toUpper) + +-- | A bifunctor is a type constructor that takes +-- two type arguments and is a functor in /both/ arguments. That +-- is, unlike with 'Functor', a type constructor such as 'Either' +-- does not need to be partially applied for a 'Bifunctor' +-- instance, and the methods in this class permit mapping +-- functions over the 'Left' value or the 'Right' value, +-- or both at the same time. +-- +-- Formally, the class 'Bifunctor' represents a bifunctor +-- from @Hask@ -> @Hask@. +-- +-- Intuitively it is a bifunctor where both the first and second +-- arguments are covariant. +-- +-- The class definition of a 'Bifunctor' @p@ uses the +-- [QuantifiedConstraints](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/quantified_constraints.html) +-- language extension to quantify over the first type +-- argument @a@ in its context. The context requires that @p a@ +-- must be a 'Functor' for all @a@. In other words a partially +-- applied 'Bifunctor' must be a 'Functor'. This makes 'Functor' a +-- superclass of 'Bifunctor' such that a function with a +-- 'Bifunctor' constraint may use 'fmap' in its implementation. +-- 'Functor' has been a quantified superclass of +-- 'Bifunctor' since base-4.18.0.0. +-- +-- You can define a 'Bifunctor' by either defining 'bimap' or by +-- defining both 'first' and 'second'. The 'second' method must +-- agree with 'fmap': +-- +-- @'second' ≡ 'fmap'@ +-- +-- From this it follows that: +-- +-- @'second' 'id' ≡ 'id'@ +-- +-- If you supply 'bimap', you should ensure that: +-- +-- @'bimap' 'id' 'id' ≡ 'id'@ +-- +-- If you supply 'first' and 'second', ensure: +-- +-- @ +-- 'first' 'id' ≡ 'id' +-- 'second' 'id' ≡ 'id' +-- @ +-- +-- If you supply both, you should also ensure: +-- +-- @'bimap' f g ≡ 'first' f '.' 'second' g@ +-- +-- These ensure by parametricity: +-- +-- @ +-- 'bimap' (f '.' g) (h '.' i) ≡ 'bimap' f h '.' 'bimap' g i +-- 'first' (f '.' g) ≡ 'first' f '.' 'first' g +-- 'second' (f '.' g) ≡ 'second' f '.' 'second' g +-- @ +-- +-- @since 4.8.0.0 +class (forall a. Functor (p a)) => Bifunctor p where + {-# MINIMAL bimap | first, second #-} + + -- | Map over both arguments at the same time. + -- + -- @'bimap' f g ≡ 'first' f '.' 'second' g@ + -- + -- ==== __Examples__ + -- >>> bimap toUpper (+1) ('j', 3) + -- ('J',4) + -- + -- >>> bimap toUpper (+1) (Left 'j') + -- Left 'J' + -- + -- >>> bimap toUpper (+1) (Right 3) + -- Right 4 + bimap :: (a -> b) -> (c -> d) -> p a c -> p b d + bimap f g = first f . second g + + + -- | Map covariantly over the first argument. + -- + -- @'first' f ≡ 'bimap' f 'id'@ + -- + -- ==== __Examples__ + -- >>> first toUpper ('j', 3) + -- ('J',3) + -- + -- >>> first toUpper (Left 'j') + -- Left 'J' + first :: (a -> b) -> p a c -> p b c + first f = bimap f id + + + -- | Map covariantly over the second argument. + -- + -- @'second' ≡ 'bimap' 'id'@ + -- + -- ==== __Examples__ + -- >>> second (+1) ('j', 3) + -- ('j',4) + -- + -- >>> second (+1) (Right 3) + -- Right 4 + second :: (b -> c) -> p a b -> p a c + second = bimap id + + +-- | Class laws for tuples hold only up to laziness. Both +-- 'first' 'id' and 'second' 'id' are lazier than 'id' (and 'fmap' 'id'): +-- +-- >>> first id (undefined :: (Int, Word)) `seq` () +-- () +-- >>> second id (undefined :: (Int, Word)) `seq` () +-- () +-- >>> id (errorWithoutStackTrace "error!" :: (Int, Word)) `seq` () +-- *** Exception: error! +-- +-- @since 4.8.0.0 +instance Bifunctor (,) where + bimap f g ~(a, b) = (f a, g b) + +-- | @since 4.8.0.0 +instance Bifunctor ((,,) x1) where + bimap f g ~(x1, a, b) = (x1, f a, g b) + +-- | @since 4.8.0.0 +instance Bifunctor ((,,,) x1 x2) where + bimap f g ~(x1, x2, a, b) = (x1, x2, f a, g b) + +-- | @since 4.8.0.0 +instance Bifunctor ((,,,,) x1 x2 x3) where + bimap f g ~(x1, x2, x3, a, b) = (x1, x2, x3, f a, g b) + +-- | @since 4.8.0.0 +instance Bifunctor ((,,,,,) x1 x2 x3 x4) where + bimap f g ~(x1, x2, x3, x4, a, b) = (x1, x2, x3, x4, f a, g b) + +-- | @since 4.8.0.0 +instance Bifunctor ((,,,,,,) x1 x2 x3 x4 x5) where + bimap f g ~(x1, x2, x3, x4, x5, a, b) = (x1, x2, x3, x4, x5, f a, g b) + + +-- | @since 4.8.0.0 +instance Bifunctor Either where + bimap f _ (Left a) = Left (f a) + bimap _ g (Right b) = Right (g b) + +-- | @since 4.8.0.0 +instance Bifunctor Const where + bimap f _ (Const a) = Const (f a) + +-- | @since 4.9.0.0 +instance Bifunctor (K1 i) where + bimap f _ (K1 c) = K1 (f c) diff --git a/src/Data/Bitraversable.hs b/src/Data/Bitraversable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitraversable.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Bitraversable +-- Copyright : (C) 2011-2016 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- @since 4.10.0.0 +---------------------------------------------------------------------------- +module Data.Bitraversable + ( Bitraversable(..) + , bisequenceA + , bisequence + , bimapM + , firstA + , secondA + , bifor + , biforM + , bimapAccumL + , bimapAccumR + , bimapDefault + , bifoldMapDefault + ) where + +import Control.Applicative +import Data.Bifunctor +import Data.Bifoldable +import GHC.Internal.Data.Coerce +import GHC.Internal.Data.Functor.Identity (Identity(..)) +import GHC.Internal.Data.Functor.Utils (StateL(..), StateR(..)) +import GHC.Generics (K1(..)) +import Prelude + +-- $setup +-- >>> import Prelude +-- >>> import GHC.Internal.Data.Maybe +-- >>> import GHC.Internal.Data.List (find) + +-- | 'Bitraversable' identifies bifunctorial data structures whose elements can +-- be traversed in order, performing 'Applicative' or 'Monad' actions at each +-- element, and collecting a result structure with the same shape. +-- +-- As opposed to 'Traversable' data structures, which have one variety of +-- element on which an action can be performed, 'Bitraversable' data structures +-- have two such varieties of elements. +-- +-- A definition of 'bitraverse' must satisfy the following laws: +-- +-- [Naturality] +-- @'bitraverse' (t . f) (t . g) ≡ t . 'bitraverse' f g@ +-- for every applicative transformation @t@ +-- +-- [Identity] +-- @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@ +-- +-- [Composition] +-- @'Data.Functor.Compose.Compose' . +-- 'fmap' ('bitraverse' g1 g2) . +-- 'bitraverse' f1 f2 +-- ≡ 'bitraverse' ('Data.Functor.Compose.Compose' . 'fmap' g1 . f1) +-- ('Data.Functor.Compose.Compose' . 'fmap' g2 . f2)@ +-- +-- where an /applicative transformation/ is a function +-- +-- @t :: ('Applicative' f, 'Applicative' g) => f a -> g a@ +-- +-- preserving the 'Applicative' operations: +-- +-- @ +-- t ('pure' x) ≡ 'pure' x +-- t (f '<*>' x) ≡ t f '<*>' t x +-- @ +-- +-- and the identity functor 'Identity' and composition functors +-- 'Data.Functor.Compose.Compose' are from "Data.Functor.Identity" and +-- "Data.Functor.Compose". +-- +-- Some simple examples are 'Either' and @(,)@: +-- +-- > instance Bitraversable Either where +-- > bitraverse f _ (Left x) = Left <$> f x +-- > bitraverse _ g (Right y) = Right <$> g y +-- > +-- > instance Bitraversable (,) where +-- > bitraverse f g (x, y) = (,) <$> f x <*> g y +-- +-- 'Bitraversable' relates to its superclasses in the following ways: +-- +-- @ +-- 'bimap' f g ≡ 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g) +-- 'bifoldMap' f g ≡ 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g) +-- @ +-- +-- These are available as 'bimapDefault' and 'bifoldMapDefault' respectively. +-- +-- If the type is also an instance of 'Traversable', then +-- it must satisfy (up to laziness): +-- +-- @ +-- 'traverse' ≡ 'bitraverse' 'pure' +-- @ +-- +-- @since 4.10.0.0 +class (Bifunctor t, Bifoldable t) => Bitraversable t where + -- | Evaluates the relevant functions at each element in the structure, + -- running the action, and builds a new structure with the same shape, using + -- the results produced from sequencing the actions. + -- + -- @'bitraverse' f g ≡ 'bisequenceA' . 'bimap' f g@ + -- + -- For a version that ignores the results, see 'bitraverse_'. + -- + -- ==== __Examples__ + -- + -- Basic usage: + -- + -- >>> bitraverse listToMaybe (find odd) (Left []) + -- Nothing + -- + -- >>> bitraverse listToMaybe (find odd) (Left [1, 2, 3]) + -- Just (Left 1) + -- + -- >>> bitraverse listToMaybe (find odd) (Right [4, 5]) + -- Just (Right 5) + -- + -- >>> bitraverse listToMaybe (find odd) ([1, 2, 3], [4, 5]) + -- Just (1,5) + -- + -- >>> bitraverse listToMaybe (find odd) ([], [4, 5]) + -- Nothing + -- + -- @since 4.10.0.0 + bitraverse :: Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d) + +-- | Alias for 'bisequence'. +-- +-- @since 4.10.0.0 +bisequenceA :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b) +bisequenceA = bisequence + +-- | Alias for 'bitraverse'. +-- +-- @since 4.10.0.0 +bimapM :: (Bitraversable t, Applicative f) + => (a -> f c) -> (b -> f d) -> t a b -> f (t c d) +bimapM = bitraverse + +-- | Sequences all the actions in a structure, building a new structure with +-- the same shape using the results of the actions. For a version that ignores +-- the results, see 'bisequence_'. +-- +-- @'bisequence' ≡ 'bitraverse' 'id' 'id'@ +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bisequence (Just 4, Nothing) +-- Nothing +-- +-- >>> bisequence (Just 4, Just 5) +-- Just (4,5) +-- +-- >>> bisequence ([1, 2, 3], [4, 5]) +-- [(1,4),(1,5),(2,4),(2,5),(3,4),(3,5)] +-- +-- @since 4.10.0.0 +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 +-- not hold for tuples if laziness is exploited: +-- +-- >>> (bitraverse pure pure undefined :: IO (Int, Word)) `seq` () +-- () +-- >>> (traverse pure (errorWithoutStackTrace "error!") :: IO (Int, Word)) `seq` () +-- *** Exception: error! +-- +-- @since 4.10.0.0 +instance Bitraversable (,) where + bitraverse f g ~(a, b) = liftA2 (,) (f a) (g b) + +-- | @since 4.10.0.0 +instance Bitraversable ((,,) x) where + bitraverse f g ~(x, a, b) = liftA2 ((,,) x) (f a) (g b) + +-- | @since 4.10.0.0 +instance Bitraversable ((,,,) x y) where + bitraverse f g ~(x, y, a, b) = liftA2 ((,,,) x y) (f a) (g b) + +-- | @since 4.10.0.0 +instance Bitraversable ((,,,,) x y z) where + bitraverse f g ~(x, y, z, a, b) = liftA2 ((,,,,) x y z) (f a) (g b) + +-- | @since 4.10.0.0 +instance Bitraversable ((,,,,,) x y z w) where + bitraverse f g ~(x, y, z, w, a, b) = liftA2 ((,,,,,) x y z w) (f a) (g b) + +-- | @since 4.10.0.0 +instance Bitraversable ((,,,,,,) x y z w v) where + bitraverse f g ~(x, y, z, w, v, a, b) = + liftA2 ((,,,,,,) x y z w v) (f a) (g b) + +-- | @since 4.10.0.0 +instance Bitraversable Either where + bitraverse f _ (Left a) = Left <$> f a + bitraverse _ g (Right b) = Right <$> g b + +-- | @since 4.10.0.0 +instance Bitraversable Const where + bitraverse f _ (Const a) = Const <$> f a + +-- | @since 4.10.0.0 +instance Bitraversable (K1 i) where + bitraverse f _ (K1 c) = K1 <$> f c + +-- | 'bifor' is 'bitraverse' with the structure as the first argument. For a +-- version that ignores the results, see 'bifor_'. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bifor (Left []) listToMaybe (find even) +-- Nothing +-- +-- >>> bifor (Left [1, 2, 3]) listToMaybe (find even) +-- Just (Left 1) +-- +-- >>> bifor (Right [4, 5]) listToMaybe (find even) +-- Just (Right 4) +-- +-- >>> bifor ([1, 2, 3], [4, 5]) listToMaybe (find even) +-- Just (1,4) +-- +-- >>> bifor ([], [4, 5]) listToMaybe (find even) +-- Nothing +-- +-- @since 4.10.0.0 +bifor :: (Bitraversable t, Applicative f) + => t a b -> (a -> f c) -> (b -> f d) -> f (t c d) +bifor t f g = bitraverse f g t + +-- | Alias for 'bifor'. +-- +-- @since 4.10.0.0 +biforM :: (Bitraversable t, Applicative f) + => t a b -> (a -> f c) -> (b -> f d) -> f (t c d) +biforM = bifor + +-- | The 'bimapAccumL' function behaves like a combination of 'bimap' and +-- 'bifoldl'; it traverses a structure from left to right, threading a state +-- of type @a@ and using the given actions to compute new elements for the +-- structure. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bimapAccumL (\acc bool -> (acc + 1, show bool)) (\acc string -> (acc * 2, reverse string)) 3 (True, "foo") +-- (8,("True","oof")) +-- +-- @since 4.10.0.0 +bimapAccumL :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e)) + -> a -> t b d -> (a, t c e) +bimapAccumL f g s t + = runStateL (bitraverse (StateL . flip f) (StateL . flip g) t) s + +-- | The 'bimapAccumR' function behaves like a combination of 'bimap' and +-- 'bifoldr'; it traverses a structure from right to left, threading a state +-- of type @a@ and using the given actions to compute new elements for the +-- structure. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bimapAccumR (\acc bool -> (acc + 1, show bool)) (\acc string -> (acc * 2, reverse string)) 3 (True, "foo") +-- (7,("True","oof")) +-- +-- @since 4.10.0.0 +bimapAccumR :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e)) + -> a -> t b d -> (a, t c e) +bimapAccumR f g s t + = runStateR (bitraverse (StateR . flip f) (StateR . flip g) t) s + +-- | A default definition of 'bimap' in terms of the 'Bitraversable' +-- operations. +-- +-- @'bimapDefault' f g ≡ +-- 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)@ +-- +-- @since 4.10.0.0 +bimapDefault :: forall t a b c d . Bitraversable t + => (a -> b) -> (c -> d) -> t a c -> t b d +-- See Note [Function coercion] in Data.Functor.Utils. +bimapDefault = coerce + (bitraverse :: (a -> Identity b) + -> (c -> Identity d) -> t a c -> Identity (t b d)) +{-# INLINE bimapDefault #-} + +-- | A default definition of 'bifoldMap' in terms of the 'Bitraversable' +-- operations. +-- +-- @'bifoldMapDefault' f g ≡ +-- 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)@ +-- +-- @since 4.10.0.0 +bifoldMapDefault :: forall t m a b . (Bitraversable t, Monoid m) + => (a -> m) -> (b -> m) -> t a b -> m +-- See Note [Function coercion] in Data.Functor.Utils. +bifoldMapDefault = coerce + (bitraverse :: (a -> Const m ()) + -> (b -> Const m ()) -> t a b -> Const m (t () ())) +{-# INLINE bifoldMapDefault #-} diff --git a/src/Data/Bits.hs b/src/Data/Bits.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bits.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Bits +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- This module defines bitwise operations for signed and unsigned +-- integers. Instances of the class 'Bits' for the 'Int' and +-- 'Integer' types are available from this module, and instances for +-- explicitly sized integral types are available from the +-- "Data.Int" and "Data.Word" modules. +-- + +module Data.Bits + (-- * Type classes + Bits((.&.), (.|.), xor, complement, shift, rotate, zeroBits, bit, setBit, clearBit, complementBit, testBit, bitSizeMaybe, bitSize, isSigned, shiftL, shiftR, unsafeShiftL, unsafeShiftR, rotateL, rotateR, popCount), + FiniteBits(finiteBitSize, countLeadingZeros, countTrailingZeros), + -- * Extra functions + bitDefault, + testBitDefault, + popCountDefault, + toIntegralSized, + oneBits, + (.^.), + (.>>.), + (.<<.), + (!>>.), + (!<<.), + -- * Newtypes + And(..), + Ior(..), + Xor(..), + Iff(..) + ) where + +import GHC.Internal.Data.Bits diff --git a/src/Data/Bool.hs b/src/Data/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bool.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Bool +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- The 'Bool' type and related functions. +-- + +module Data.Bool + (-- * Booleans + Bool(..), + -- ** Operations + (&&), + (||), + not, + otherwise, + bool + ) where + +import GHC.Internal.Data.Bool 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/Char.hs b/src/Data/Char.hs new file mode 100644 --- /dev/null +++ b/src/Data/Char.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Char +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- The Char type and associated operations. +-- +----------------------------------------------------------------------------- + +module Data.Char + ( + Char + + -- * Character classification + -- | Unicode characters are divided into letters, numbers, marks, + -- punctuation, symbols, separators (including spaces) and others + -- (including control characters). + , isControl, isSpace + , isLower, isLowerCase, isUpper, isUpperCase, isAlpha, isAlphaNum, isPrint + , isDigit, isOctDigit, isHexDigit + , isLetter, isMark, isNumber, isPunctuation, isSymbol, isSeparator + + -- ** Subranges + , isAscii, isLatin1 + , isAsciiUpper, isAsciiLower + + -- ** Unicode general categories + , GeneralCategory(..), generalCategory + + -- * Case conversion + , toUpper, toLower, toTitle + + -- * Single digit characters + , digitToInt + , intToDigit + + -- * Numeric representations + , ord + , chr + + -- * String representations + , showLitChar + , lexLitChar + , readLitChar + ) where + +import GHC.Internal.Base +import GHC.Internal.Char +import GHC.Internal.Real (fromIntegral) +import GHC.Internal.Show +import GHC.Internal.Read (readLitChar, lexLitChar) +import GHC.Internal.Unicode +import GHC.Internal.Num + +-- $setup +-- Allow the use of Prelude in doctests. +-- >>> import Prelude + +-- | Convert a single digit 'Char' to the corresponding 'Int'. This +-- function fails unless its argument satisfies 'isHexDigit', but +-- recognises both upper- and lower-case hexadecimal digits (that +-- is, @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@). +-- +-- ==== __Examples__ +-- +-- Characters @\'0\'@ through @\'9\'@ are converted properly to +-- @0..9@: +-- +-- >>> map digitToInt ['0'..'9'] +-- [0,1,2,3,4,5,6,7,8,9] +-- +-- Both upper- and lower-case @\'A\'@ through @\'F\'@ are converted +-- as well, to @10..15@. +-- +-- >>> map digitToInt ['a'..'f'] +-- [10,11,12,13,14,15] +-- >>> map digitToInt ['A'..'F'] +-- [10,11,12,13,14,15] +-- +-- Anything else throws an exception: +-- +-- >>> digitToInt 'G' +-- *** Exception: Char.digitToInt: not a digit 'G' +-- >>> digitToInt '♥' +-- *** Exception: Char.digitToInt: not a digit '\9829' +-- +digitToInt :: Char -> Int +digitToInt c + | (fromIntegral dec::Word) <= 9 = dec + | (fromIntegral hexl::Word) <= 5 = hexl + 10 + | (fromIntegral hexu::Word) <= 5 = hexu + 10 + | otherwise = errorWithoutStackTrace ("Char.digitToInt: not a digit " ++ show c) -- sigh + where + dec = ord c - ord '0' + hexl = ord c - ord 'a' + hexu = ord c - ord 'A' + +-- derived character classifiers + +-- | Selects alphabetic Unicode characters (lower-case, upper-case and +-- title-case letters, plus letters of caseless scripts and +-- modifiers letters). This function is equivalent to +-- 'Data.Char.isAlpha'. +-- +-- This function returns 'True' if its argument has one of the +-- following 'GeneralCategory's, or 'False' otherwise: +-- +-- * 'UppercaseLetter' +-- * 'LowercaseLetter' +-- * 'TitlecaseLetter' +-- * 'ModifierLetter' +-- * 'OtherLetter' +-- +-- These classes are defined in the +-- , +-- part of the Unicode standard. The same document defines what is +-- and is not a \"Letter\". +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> isLetter 'a' +-- True +-- >>> isLetter 'A' +-- True +-- >>> isLetter 'λ' +-- True +-- >>> isLetter '0' +-- False +-- >>> isLetter '%' +-- False +-- >>> isLetter '♥' +-- False +-- >>> isLetter '\31' +-- False +-- +-- Ensure that 'isLetter' and 'isAlpha' are equivalent. +-- +-- >>> let chars = [(chr 0)..] +-- >>> let letters = map isLetter chars +-- >>> let alphas = map isAlpha chars +-- >>> letters == alphas +-- True +-- +isLetter :: Char -> Bool +isLetter c = case generalCategory c of + UppercaseLetter -> True + LowercaseLetter -> True + TitlecaseLetter -> True + ModifierLetter -> True + OtherLetter -> True + _ -> False + +-- | Selects Unicode mark characters, for example accents and the +-- like, which combine with preceding characters. +-- +-- This function returns 'True' if its argument has one of the +-- following 'GeneralCategory's, or 'False' otherwise: +-- +-- * 'NonSpacingMark' +-- * 'SpacingCombiningMark' +-- * 'EnclosingMark' +-- +-- These classes are defined in the +-- , +-- part of the Unicode standard. The same document defines what is +-- and is not a \"Mark\". +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> isMark 'a' +-- False +-- >>> isMark '0' +-- False +-- +-- Combining marks such as accent characters usually need to follow +-- another character before they become printable: +-- +-- >>> map isMark "ò" +-- [False,True] +-- +-- Puns are not necessarily supported: +-- +-- >>> isMark '✓' +-- False +-- +isMark :: Char -> Bool +isMark c = case generalCategory c of + NonSpacingMark -> True + SpacingCombiningMark -> True + EnclosingMark -> True + _ -> False + +-- | Selects Unicode numeric characters, including digits from various +-- scripts, Roman numerals, et cetera. +-- +-- This function returns 'True' if its argument has one of the +-- following 'GeneralCategory's, or 'False' otherwise: +-- +-- * 'DecimalNumber' +-- * 'LetterNumber' +-- * 'OtherNumber' +-- +-- These classes are defined in the +-- , +-- part of the Unicode standard. The same document defines what is +-- and is not a \"Number\". +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> isNumber 'a' +-- False +-- >>> isNumber '%' +-- False +-- >>> isNumber '3' +-- True +-- +-- ASCII @\'0\'@ through @\'9\'@ are all numbers: +-- +-- >>> and $ map isNumber ['0'..'9'] +-- True +-- +-- Unicode Roman numerals are \"numbers\" as well: +-- +-- >>> isNumber 'Ⅸ' +-- True +-- +isNumber :: Char -> Bool +isNumber c = case generalCategory c of + DecimalNumber -> True + LetterNumber -> True + OtherNumber -> True + _ -> False + +-- | Selects Unicode space and separator characters. +-- +-- This function returns 'True' if its argument has one of the +-- following 'GeneralCategory's, or 'False' otherwise: +-- +-- * 'Space' +-- * 'LineSeparator' +-- * 'ParagraphSeparator' +-- +-- These classes are defined in the +-- , +-- part of the Unicode standard. The same document defines what is +-- and is not a \"Separator\". +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> isSeparator 'a' +-- False +-- >>> isSeparator '6' +-- False +-- >>> isSeparator ' ' +-- True +-- +-- Warning: newlines and tab characters are not considered +-- separators. +-- +-- >>> isSeparator '\n' +-- False +-- >>> isSeparator '\t' +-- False +-- +-- But some more exotic characters are (like HTML's @ @): +-- +-- >>> isSeparator '\160' +-- True +-- +isSeparator :: Char -> Bool +isSeparator c = case generalCategory c of + Space -> True + LineSeparator -> True + ParagraphSeparator -> True + _ -> False + diff --git a/src/Data/Coerce.hs b/src/Data/Coerce.hs new file mode 100644 --- /dev/null +++ b/src/Data/Coerce.hs @@ -0,0 +1,24 @@ +-- | +-- +-- Module : Data.Coerce +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Safe coercions between data types. +-- +-- More in-depth information can be found on the +-- +-- +-- @since 4.7.0.0 + +module Data.Coerce + (-- * Safe coercions + coerce, + Coercible + ) where + +import GHC.Internal.Data.Coerce diff --git a/src/Data/Complex.hs b/src/Data/Complex.hs new file mode 100644 --- /dev/null +++ b/src/Data/Complex.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Complex +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Complex numbers. +-- +----------------------------------------------------------------------------- + +module Data.Complex + ( + -- * Rectangular form + Complex((:+)) + + , realPart + , imagPart + -- * Polar form + , mkPolar + , cis + , polar + , magnitude + , phase + -- * Conjugate + , conjugate + + ) where + +import Prelude hiding (Applicative(..)) +import GHC.Internal.Base (Applicative (..)) +import GHC.Generics (Generic, Generic1) +import GHC.Internal.Float (Floating(..)) +import GHC.Internal.Data.Data (Data) +import Foreign (Storable, castPtr, peek, poke, pokeElemOff, peekElemOff, sizeOf, + alignment) +import GHC.Internal.Control.Monad.Fix (MonadFix(..)) +import Control.Monad.Zip (MonadZip(..)) + +infix 6 :+ + +-- $setup +-- >>> import Prelude + +-- ----------------------------------------------------------------------------- +-- The Complex type + +-- | A data type representing complex numbers. +-- +-- You can read about complex numbers [on wikipedia](https://en.wikipedia.org/wiki/Complex_number). +-- +-- In haskell, complex numbers are represented as @a :+ b@ which can be thought of +-- as representing \(a + bi\). For a complex number @z@, @'abs' z@ is a number with the 'magnitude' of @z@, +-- but oriented in the positive real direction, whereas @'signum' z@ +-- has the 'phase' of @z@, but unit 'magnitude'. +-- Apart from the loss of precision due to IEEE754 floating point numbers, +-- 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 'Eq' instance has similar +-- problems to `Float`'s. +-- +-- As can be seen in the examples, the 'Foldable' +-- and 'Traversable' instances traverse the real part first. +-- +-- ==== __Examples__ +-- +-- >>> (5.0 :+ 2.5) + 6.5 +-- 11.5 :+ 2.5 +-- +-- >>> abs (1.0 :+ 1.0) - sqrt 2.0 +-- 0.0 :+ 0.0 +-- +-- >>> abs (signum (4.0 :+ 3.0)) +-- 1.0 :+ 0.0 +-- +-- >>> foldr (:) [] (1 :+ 2) +-- [1,2] +-- +-- >>> mapM print (1 :+ 2) +-- 1 +-- 2 +-- () :+ () +data Complex a + = !a :+ !a -- ^ forms a complex number from its real and imaginary + -- rectangular components. + deriving ( Eq -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Data -- ^ @since 2.01 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Foldable -- ^ @since 4.9.0.0 + , Traversable -- ^ @since 4.9.0.0 + ) + + +-- ----------------------------------------------------------------------------- +-- Functions over Complex + +-- | Extracts the real part of a complex number. +-- +-- ==== __Examples__ +-- +-- >>> realPart (5.0 :+ 3.0) +-- 5.0 +-- +-- >>> realPart ((5.0 :+ 3.0) * (2.0 :+ 3.0)) +-- 1.0 +realPart :: Complex a -> a +realPart (x :+ _) = x + +-- | Extracts the imaginary part of a complex number. +-- +-- ==== __Examples__ +-- +-- >>> imagPart (5.0 :+ 3.0) +-- 3.0 +-- +-- >>> imagPart ((5.0 :+ 3.0) * (2.0 :+ 3.0)) +-- 21.0 +imagPart :: Complex a -> a +imagPart (_ :+ y) = y + +-- | The 'conjugate' of a complex number. +-- +-- prop> conjugate (conjugate x) = x +-- +-- ==== __Examples__ +-- +-- >>> conjugate (3.0 :+ 3.0) +-- 3.0 :+ (-3.0) +-- +-- >>> conjugate ((3.0 :+ 3.0) * (2.0 :+ 2.0)) +-- 0.0 :+ (-12.0) +{-# SPECIALISE conjugate :: Complex Double -> Complex Double #-} +conjugate :: Num a => Complex a -> Complex a +conjugate (x:+y) = x :+ (-y) + +-- | Form a complex number from 'polar' components of 'magnitude' and 'phase'. +-- +-- ==== __Examples__ +-- +-- >>> mkPolar 1 (pi / 4) +-- 0.7071067811865476 :+ 0.7071067811865475 +-- +-- >>> mkPolar 1 0 +-- 1.0 :+ 0.0 +{-# SPECIALISE mkPolar :: Double -> Double -> Complex Double #-} +mkPolar :: Floating a => a -> a -> Complex a +mkPolar r theta = r * cos theta :+ r * sin theta + +-- | @'cis' t@ is a complex value with 'magnitude' @1@ +-- and 'phase' @t@ (modulo @2*'pi'@). +-- +-- @ +-- 'cis' = 'mkPolar' 1 +-- @ +-- +-- ==== __Examples__ +-- +-- >>> cis 0 +-- 1.0 :+ 0.0 +-- +-- The following examples are not perfectly zero due to [IEEE 754](https://en.wikipedia.org/wiki/IEEE_754) +-- +-- >>> cis pi +-- (-1.0) :+ 1.2246467991473532e-16 +-- +-- >>> cis (4 * pi) - cis (2 * pi) +-- 0.0 :+ (-2.4492935982947064e-16) +{-# SPECIALISE cis :: Double -> Complex Double #-} +cis :: Floating a => a -> Complex a +cis theta = cos theta :+ sin theta + +-- | The function 'polar' takes a complex number and +-- returns a ('magnitude', 'phase') pair in canonical form: +-- the 'magnitude' is non-negative, and the 'phase' in the range @(-'pi', 'pi']@; +-- if the 'magnitude' is zero, then so is the 'phase'. +-- +-- @'polar' z = ('magnitude' z, 'phase' z)@ +-- +-- ==== __Examples__ +-- +-- >>> polar (1.0 :+ 1.0) +-- (1.4142135623730951,0.7853981633974483) +-- +-- >>> polar ((-1.0) :+ 0.0) +-- (1.0,3.141592653589793) +-- +-- >>> polar (0.0 :+ 0.0) +-- (0.0,0.0) +{-# SPECIALISE polar :: Complex Double -> (Double,Double) #-} +polar :: (RealFloat a) => Complex a -> (a,a) +polar z = (magnitude z, phase z) + +-- | The non-negative 'magnitude' of a complex number. +-- +-- ==== __Examples__ +-- +-- >>> magnitude (1.0 :+ 1.0) +-- 1.4142135623730951 +-- +-- >>> magnitude (1.0 + 0.0) +-- 1.0 +-- +-- >>> magnitude (0.0 :+ (-5.0)) +-- 5.0 +{-# SPECIALISE magnitude :: Complex Double -> Double #-} +magnitude :: (RealFloat a) => Complex a -> a +magnitude (x:+y) = scaleFloat k + (sqrt (sqr (scaleFloat mk x) + sqr (scaleFloat mk y))) + where k = max (exponent x) (exponent y) + mk = - k + sqr z = z * z + +-- | The 'phase' of a complex number, in the range @(-'pi', 'pi']@. +-- If the 'magnitude' is zero, then so is the 'phase'. +-- +-- ==== __Examples__ +-- +-- >>> phase (0.5 :+ 0.5) / pi +-- 0.25 +-- +-- >>> phase (0 :+ 4) / pi +-- 0.5 +{-# SPECIALISE phase :: Complex Double -> Double #-} +phase :: (RealFloat a) => Complex a -> a +phase (0 :+ 0) = 0 -- SLPJ July 97 from John Peterson +phase (x:+y) = atan2 y x + + +-- ----------------------------------------------------------------------------- +-- Instances of Complex + +-- | @since 2.01 +instance (RealFloat a) => Num (Complex a) where + {-# SPECIALISE instance Num (Complex Float) #-} + {-# SPECIALISE instance Num (Complex Double) #-} + (x:+y) + (x':+y') = (x+x') :+ (y+y') + (x:+y) - (x':+y') = (x-x') :+ (y-y') + (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') + negate (x:+y) = negate x :+ negate y + abs z = magnitude z :+ 0 + signum (0:+0) = 0 + signum z@(x:+y) = x/r :+ y/r where r = magnitude z + fromInteger n = fromInteger n :+ 0 + +-- | @since 2.01 +instance (RealFloat a) => Fractional (Complex a) where + {-# SPECIALISE instance Fractional (Complex Float) #-} + {-# SPECIALISE instance Fractional (Complex Double) #-} + (x:+y) / (x':+y') = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d + where x'' = scaleFloat k x' + y'' = scaleFloat k y' + k = - max (exponent x') (exponent y') + d = x'*x'' + y'*y'' + + fromRational a = fromRational a :+ 0 + +-- | @since 2.01 +instance (RealFloat a) => Floating (Complex a) where + {-# SPECIALISE instance Floating (Complex Float) #-} + {-# SPECIALISE instance Floating (Complex Double) #-} + pi = pi :+ 0 + exp (x:+y) = expx * cos y :+ expx * sin y + where expx = exp x + log z = log (magnitude z) :+ phase z + + x ** y = case (x,y) of + (_ , (0:+0)) -> 1 :+ 0 + ((0:+0), (exp_re:+_)) -> case compare exp_re 0 of + GT -> 0 :+ 0 + LT -> inf :+ 0 + EQ -> nan :+ nan + ((re:+im), (exp_re:+_)) + | (isInfinite re || isInfinite im) -> case compare exp_re 0 of + GT -> inf :+ 0 + LT -> 0 :+ 0 + EQ -> nan :+ nan + | otherwise -> exp (log x * y) + where + inf = 1/0 + nan = 0/0 + + sqrt (0:+0) = 0 + sqrt z@(x:+y) = u :+ (if y < 0 then -v else v) + where (u,v) = if x < 0 then (v',u') else (u',v') + v' = abs y / (u'*2) + u' = sqrt ((magnitude z + abs x) / 2) + + sin (x:+y) = sin x * cosh y :+ cos x * sinh y + cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y) + tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy)) + where sinx = sin x + cosx = cos x + sinhy = sinh y + coshy = cosh y + + sinh (x:+y) = cos y * sinh x :+ sin y * cosh x + cosh (x:+y) = cos y * cosh x :+ sin y * sinh x + tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx) + where siny = sin y + cosy = cos y + sinhx = sinh x + coshx = cosh x + + asin z@(x:+y) = y':+(-x') + where (x':+y') = log (((-y):+x) + sqrt (1 - z*z)) + acos z = y'':+(-x'') + where (x'':+y'') = log (z + ((-y'):+x')) + (x':+y') = sqrt (1 - z*z) + atan z@(x:+y) = y':+(-x') + where (x':+y') = log (((1-y):+x) / sqrt (1+z*z)) + + asinh z = log (z + sqrt (1+z*z)) + -- Take care to allow (-1)::Complex, fixing #8532 + acosh z = log (z + (sqrt $ z+1) * (sqrt $ z-1)) + atanh z = 0.5 * log ((1.0+z) / (1.0-z)) + + log1p x@(a :+ b) + | abs a < 0.5 && abs b < 0.5 + , u <- 2*a + a*a + b*b = log1p (u/(1 + sqrt(u+1))) :+ atan2 (1 + a) b + | otherwise = log (1 + x) + {-# INLINE log1p #-} + + expm1 x@(a :+ b) + | a*a + b*b < 1 + , u <- expm1 a + , v <- sin (b/2) + , w <- -2*v*v = (u*w + u + w) :+ (u+1)*sin b + | otherwise = exp x - 1 + {-# INLINE expm1 #-} + +-- | @since 4.8.0.0 +instance Storable a => Storable (Complex a) where + sizeOf a = 2 * sizeOf (realPart a) + alignment a = alignment (realPart a) + peek p = do + q <- return $ castPtr p + r <- peek q + i <- peekElemOff q 1 + return (r :+ i) + poke p (r :+ i) = do + q <-return $ (castPtr p) + poke q r + pokeElemOff q 1 i + +-- | @since 4.9.0.0 +instance Applicative Complex where + pure a = a :+ a + f :+ g <*> a :+ b = f a :+ g b + liftA2 f (x :+ y) (a :+ b) = f x a :+ f y b + +-- | @since 4.9.0.0 +instance Monad Complex where + a :+ b >>= f = realPart (f a) :+ imagPart (f b) + +-- | @since 4.15.0.0 +instance MonadZip Complex where + mzipWith = liftA2 + +-- | @since 4.15.0.0 +instance MonadFix Complex where + mfix f = (let a :+ _ = f a in a) :+ (let _ :+ a = f a in a) + +-- ----------------------------------------------------------------------------- +-- Rules on Complex + +{-# RULES + +"realToFrac/a->Complex Double" + realToFrac = \x -> realToFrac x :+ (0 :: Double) + +"realToFrac/a->Complex Float" + realToFrac = \x -> realToFrac x :+ (0 :: Float) + + #-} diff --git a/src/Data/Data.hs b/src/Data/Data.hs new file mode 100644 --- /dev/null +++ b/src/Data/Data.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : Data.Data +-- Copyright : (c) The University of Glasgow, CWI 2001--2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (local universal quantification) +-- +-- This module provides the 'Data' class with its primitives for +-- generic programming, along with instances for many datatypes. It +-- corresponds to a merge between the previous "Data.Generics.Basics" +-- and almost all of "Data.Generics.Instances". The instances that are +-- not present in this module were moved to the +-- @Data.Generics.Instances@ module in the @syb@ package. +-- +-- \"Scrap your boilerplate\" --- Generic programming in Haskell. See +-- . +-- + +module Data.Data ( + + -- * Module Data.Typeable re-exported for convenience + module Data.Typeable, + + -- * The Data class for processing constructor applications + Data( + gfoldl, + gunfold, + toConstr, + dataTypeOf, + dataCast1, -- mediate types and unary type constructors + dataCast2, -- mediate types and binary type constructors + -- Generic maps defined in terms of gfoldl + gmapT, + gmapQ, + gmapQl, + gmapQr, + gmapQi, + gmapM, + gmapMp, + gmapMo + ), + + -- * Datatype representations + DataType, -- abstract + -- ** Constructors + mkDataType, + mkIntType, + mkFloatType, + mkCharType, + mkNoRepType, + -- ** Observers + dataTypeName, + DataRep(..), + dataTypeRep, + -- ** Convenience functions + repConstr, + isAlgType, + dataTypeConstrs, + indexConstr, + maxConstrIndex, + isNorepType, + + -- * Data constructor representations + Constr, -- abstract + ConIndex, -- alias for Int, start at 1 + Fixity(..), + -- ** Constructors + mkConstr, + mkConstrTag, + mkIntegralConstr, + mkRealConstr, + mkCharConstr, + -- ** Observers + constrType, + ConstrRep(..), + constrRep, + constrFields, + constrFixity, + -- ** Convenience function: algebraic data types + constrIndex, + -- ** From strings to constructors and vice versa: all data types + showConstr, + readConstr, + + -- * Convenience functions: take type constructors apart + tyconUQname, + tyconModule, + + -- * Generic operations defined in terms of 'gunfold' + fromConstr, + fromConstrB, + fromConstrM + + ) where + +import GHC.Internal.Data.Data +import Data.Typeable diff --git a/src/Data/Dynamic.hs b/src/Data/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Dynamic.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Dynamic +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- The Dynamic interface provides basic support for dynamic types. +-- +-- Operations for injecting values of arbitrary type into +-- a dynamically typed value, Dynamic, are provided, together +-- with operations for converting dynamic values into a concrete +-- (monomorphic) type. +-- + +module Data.Dynamic + (-- * The @Dynamic@ type + Dynamic(..), + -- * Converting to and from @Dynamic@ + toDyn, + fromDyn, + fromDynamic, + -- * Applying functions of dynamic type + dynApply, + dynApp, + dynTypeRep, + -- * Convenience re-exports + Typeable + ) where + +import GHC.Internal.Data.Dynamic diff --git a/src/Data/Either.hs b/src/Data/Either.hs new file mode 100644 --- /dev/null +++ b/src/Data/Either.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Either +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- The Either type, and associated operations. +-- + +module Data.Either + (Either(..), + either, + lefts, + rights, + isLeft, + isRight, + fromLeft, + fromRight, + partitionEithers + ) where + +import GHC.Internal.Data.Either diff --git a/src/Data/Enum.hs b/src/Data/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Data/Enum.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Enum +-- Copyright : (c) The University of Glasgow, 1992-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : stable +-- Portability : non-portable (GHC extensions) +-- +-- The 'Enum' class. +-- +-- @since 4.20.0.0 +-- +----------------------------------------------------------------------------- + +module Data.Enum + ( Enum(..) + , {-# DEPRECATED "Bounded should be imported from Data.Bounded" #-} + Bounded(..) + , enumerate + ) where + +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/Eq.hs b/src/Data/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Eq.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Eq +-- Copyright : (c) The University of Glasgow 2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Equality +-- + +module Data.Eq + (Eq(..) + ) where + +import GHC.Internal.Data.Eq diff --git a/src/Data/Fixed.hs b/src/Data/Fixed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Fixed.hs @@ -0,0 +1,458 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Fixed +-- Copyright : (c) Ashley Yakeley 2005, 2006, 2009 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Ashley Yakeley +-- Stability : stable +-- Portability : portable +-- +-- This module defines a 'Fixed' type for working with fixed-point arithmetic. +-- Fixed-point arithmetic represents fractional numbers with a fixed number of +-- digits for their fractional part. This is different to the behaviour of the floating-point +-- number types 'Float' and 'Double', because the number of digits of the +-- fractional part of 'Float' and 'Double' numbers depends on the size of the number. +-- Fixed point arithmetic is frequently used in financial mathematics, where they +-- are used for representing decimal currencies. +-- +-- The type 'Fixed' is used for fixed-point fractional numbers, which are internally +-- represented as an 'Integer'. The type 'Fixed' takes one parameter, which should implement +-- the typeclass 'HasResolution', to specify the number of digits of the fractional part. +-- This module provides instances of the `HasResolution` typeclass for arbitrary typelevel +-- natural numbers, and for some canonical important fixed-point representations. +-- +-- This module also contains generalisations of 'div', 'mod', and 'divMod' to +-- work with any 'Real' instance. +-- +-- Automatic conversion between different 'Fixed' can be performed through +-- 'realToFrac', bear in mind that converting to a fixed with a smaller +-- resolution will truncate the number, losing information. +-- +-- >>> realToFrac (0.123456 :: Pico) :: Milli +-- 0.123 +-- +----------------------------------------------------------------------------- + +module Data.Fixed +( -- * The Fixed Type + Fixed(..), HasResolution(..), + showFixed, + -- * Resolution \/ Scaling Factors + -- | The resolution or scaling factor determines the number of digits in the fractional part. + -- + -- +------------+----------------------+--------------------------+--------------------------+ + -- | Resolution | Scaling Factor | Synonym for \"Fixed EX\" | show (12345 :: Fixed EX) | + -- +============+======================+==========================+==========================+ + -- | E0 | 1\/1 | Uni | 12345.0 | + -- +------------+----------------------+--------------------------+--------------------------+ + -- | E1 | 1\/10 | Deci | 1234.5 | + -- +------------+----------------------+--------------------------+--------------------------+ + -- | E2 | 1\/100 | Centi | 123.45 | + -- +------------+----------------------+--------------------------+--------------------------+ + -- | E3 | 1\/1 000 | Milli | 12.345 | + -- +------------+----------------------+--------------------------+--------------------------+ + -- | E6 | 1\/1 000 000 | Micro | 0.012345 | + -- +------------+----------------------+--------------------------+--------------------------+ + -- | E9 | 1\/1 000 000 000 | Nano | 0.000012345 | + -- +------------+----------------------+--------------------------+--------------------------+ + -- | E12 | 1\/1 000 000 000 000 | Pico | 0.000000012345 | + -- +------------+----------------------+--------------------------+--------------------------+ + -- + + -- ** 1\/1 + E0,Uni, + -- ** 1\/10 + E1,Deci, + -- ** 1\/100 + E2,Centi, + -- ** 1\/1 000 + E3,Milli, + -- ** 1\/1 000 000 + E6,Micro, + -- ** 1\/1 000 000 000 + E9,Nano, + -- ** 1\/1 000 000 000 000 + E12,Pico, + -- * Generalized Functions on Real's + div', + mod', + divMod' +) where + +import GHC.Internal.Data.Data +import GHC.Internal.TypeLits (KnownNat, natVal) +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' +div' :: (Real a,Integral b) => a -> a -> b +div' n d = floor ((toRational n) / (toRational d)) + +-- | Generalisation of 'divMod' to any instance of 'Real' +divMod' :: (Real a,Integral b) => a -> a -> (b,a) +divMod' n d = (f,n - (fromIntegral f) * d) where + f = div' n d + +-- | Generalisation of 'mod' to any instance of 'Real' +mod' :: (Real a) => a -> a -> a +mod' n d = n - (fromInteger f) * d where + f = div' n d + +-- | The type of fixed-point fractional numbers. +-- The type parameter specifies the number of digits of the fractional part and should be an instance of the 'HasResolution' typeclass. +-- +-- === __Examples__ +-- +-- @ +-- MkFixed 12345 :: Fixed E3 +-- @ +newtype Fixed (a :: k) = MkFixed Integer + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + ) + +-- We do this because the automatically derived Data instance requires (Data a) context. +-- Our manual instance has the more general (Typeable a) context. +tyFixed :: DataType +tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed] + +conMkFixed :: Constr +conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix + +-- | @since 4.1.0.0 +instance (Typeable k,Typeable a) => Data (Fixed (a :: k)) where + gfoldl k z (MkFixed a) = k (z MkFixed) a + 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 + -- | Provide the resolution for a fixed-point fractional number. + resolution :: p a -> Integer + +-- | For example, @Fixed 1000@ will give you a 'Fixed' with a resolution of 1000. +instance KnownNat n => HasResolution n where + resolution _ = natVal (Proxy :: Proxy n) + +withType :: (Proxy a -> f a) -> f a +withType foo = foo Proxy + +withResolution :: (HasResolution a) => (Integer -> f a) -> f a +withResolution foo = withType (foo . resolution) + +-- | @since 2.01 +-- +-- Recall that, for numeric types, 'succ' and 'pred' typically add and subtract +-- @1@, respectively. This is not true in the case of 'Fixed', whose successor +-- and predecessor functions intuitively return the "next" and "previous" values +-- in the enumeration. The results of these functions thus depend on the +-- resolution of the 'Fixed' value. For example, when enumerating values of +-- resolution @10^-3@ of @type Milli = Fixed E3@, +-- +-- >>> succ (0.000 :: Milli) +-- 0.001 +-- +-- and likewise +-- +-- >>> pred (0.000 :: Milli) +-- -0.001 +-- +-- In other words, 'succ' and 'pred' increment and decrement a fixed-precision +-- value by the least amount such that the value's resolution is unchanged. +-- For example, @10^-12@ is the smallest (positive) amount that can be added to +-- a value of @type Pico = Fixed E12@ without changing its resolution, and so +-- +-- >>> succ (0.000000000000 :: Pico) +-- 0.000000000001 +-- +-- and similarly +-- +-- >>> pred (0.000000000000 :: Pico) +-- -0.000000000001 +-- +-- +-- This is worth bearing in mind when defining 'Fixed' arithmetic sequences. In +-- particular, you may be forgiven for thinking the sequence +-- +-- @ +-- [1..10] :: [Pico] +-- @ +-- +-- +-- evaluates to @[1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Pico]@. +-- +-- However, this is not true. On the contrary, similarly to the above +-- implementations of 'succ' and 'pred', @enumFromTo :: Pico -> Pico -> [Pico]@ +-- has a "step size" of @10^-12@. Hence, the list @[1..10] :: [Pico]@ has +-- the form +-- +-- @ +-- [1.000000000000, 1.00000000001, 1.00000000002, ..., 10.000000000000] +-- @ +-- +-- +-- and contains @9 * 10^12 + 1@ values. +instance Enum (Fixed a) where + succ (MkFixed a) = MkFixed (succ a) + pred (MkFixed a) = MkFixed (pred a) + toEnum = MkFixed . toEnum + fromEnum (MkFixed a) = fromEnum a + enumFrom (MkFixed a) = fmap MkFixed (enumFrom a) + enumFromThen (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromThen a b) + enumFromTo (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromTo a b) + enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c) + +-- | @since 2.01 +-- +-- Multiplication is not associative or distributive: +-- +-- >>> (0.2 * 0.6 :: Deci) * 0.9 == 0.2 * (0.6 * 0.9) +-- False +-- +-- >>> (0.1 + 0.1 :: Deci) * 0.5 == 0.1 * 0.5 + 0.1 * 0.5 +-- False +instance (HasResolution a) => Num (Fixed a) where + (MkFixed a) + (MkFixed b) = MkFixed (a + b) + (MkFixed a) - (MkFixed b) = MkFixed (a - b) + fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (resolution fa)) + negate (MkFixed a) = MkFixed (negate a) + abs (MkFixed a) = MkFixed (abs a) + signum (MkFixed a) = fromInteger (signum a) + fromInteger i = withResolution (\res -> MkFixed (i * res)) + +-- | @since 2.01 +instance (HasResolution a) => Real (Fixed a) where + toRational fa@(MkFixed a) = (toRational a) / (toRational (resolution fa)) + +-- | @since 2.01 +instance (HasResolution a) => Fractional (Fixed a) where + fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (resolution fa)) b) + recip fa@(MkFixed a) = MkFixed (div (res * res) a) where + res = resolution fa + fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res)))) + +-- | @since 2.01 +instance (HasResolution a) => RealFrac (Fixed a) where + properFraction a = (i,a - (fromIntegral i)) where + i = truncate a + truncate f = truncate (toRational f) + round f = round (toRational f) + ceiling f = ceiling (toRational f) + floor f = floor (toRational f) + +chopZeros :: Integer -> String +chopZeros 0 = "" +chopZeros a | mod a 10 == 0 = chopZeros (div a 10) +chopZeros a = show a + +-- only works for positive a +showIntegerZeros :: Bool -> Int -> Integer -> String +showIntegerZeros True _ 0 = "" +showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where + s = show a + s' = if chopTrailingZeros then chopZeros a else s + +withDot :: String -> String +withDot "" = "" +withDot s = '.':s + +-- | First arg is whether to chop off trailing zeros +-- +-- === __Examples__ +-- +-- >>> showFixed True (MkFixed 10000 :: Fixed E3) +-- "10" +-- +-- >>> showFixed False (MkFixed 10000 :: Fixed E3) +-- "10.000" +-- +showFixed :: (HasResolution a) => Bool -> Fixed a -> String +showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa)) +showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where + res = resolution fa + (i,d) = divMod a res + -- enough digits to be unambiguous + digits = ceiling (logBase 10 (fromInteger res) :: Double) + maxnum = 10 ^ digits + -- read floors, so show must ceil for `read . show = id` to hold. See #9240 + fracNum = divCeil (d * maxnum) res + divCeil x y = (x + y - 1) `div` y + +-- | @since 2.01 +instance (HasResolution a) => Show (Fixed a) where + showsPrec p n = showParen (p > 6 && n < 0) $ showString $ showFixed False n + +-- | @since 4.3.0.0 +instance (HasResolution a) => Read (Fixed a) where + readPrec = readNumber convertFixed + readListPrec = readListPrecDefault + readList = readListDefault + +convertFixed :: forall a . HasResolution a => Lexeme -> ReadPrec (Fixed a) +convertFixed (Number n) + | Just (i, f) <- numberToFixed e n = + return (fromInteger i + (fromInteger f / (10 ^ e))) + where r = resolution (Proxy :: Proxy a) + -- round 'e' up to help make the 'read . show == id' property + -- possible also for cases where 'resolution' is not a + -- power-of-10, such as e.g. when 'resolution = 128' + e = ceiling (logBase 10 (fromInteger r) :: Double) +convertFixed _ = pfail + +-- | Resolution of 1, this works the same as Integer. +data E0 + +-- | @since 4.1.0.0 +instance HasResolution E0 where + resolution _ = 1 + +-- | Resolution of 1, this works the same as Integer. +-- +-- === __Examples__ +-- +-- >>> show (MkFixed 12345 :: Fixed E0) +-- "12345.0" +-- +-- >>> show (MkFixed 12345 :: Uni) +-- "12345.0" +-- +type Uni = Fixed E0 + +-- | Resolution of 10^-1 = .1 +data E1 + +-- | @since 4.1.0.0 +instance HasResolution E1 where + resolution _ = 10 + +-- | Resolution of 10^-1 = .1 +-- +-- === __Examples__ +-- +-- >>> show (MkFixed 12345 :: Fixed E1) +-- "1234.5" +-- +-- >>> show (MkFixed 12345 :: Deci) +-- "1234.5" +-- +type Deci = Fixed E1 + +-- | Resolution of 10^-2 = .01, useful for many monetary currencies +data E2 + +-- | @since 4.1.0.0 +instance HasResolution E2 where + resolution _ = 100 + +-- | Resolution of 10^-2 = .01, useful for many monetary currencies +-- +-- === __Examples__ +-- +-- >>> show (MkFixed 12345 :: Fixed E2) +-- "123.45" +-- +-- >>> show (MkFixed 12345 :: Centi) +-- "123.45" +-- +type Centi = Fixed E2 + +-- | Resolution of 10^-3 = .001 +data E3 + +-- | @since 4.1.0.0 +instance HasResolution E3 where + resolution _ = 1000 + +-- | Resolution of 10^-3 = .001 +-- +-- === __Examples__ +-- +-- >>> show (MkFixed 12345 :: Fixed E3) +-- "12.345" +-- +-- >>> show (MkFixed 12345 :: Milli) +-- "12.345" +-- +type Milli = Fixed E3 + +-- | Resolution of 10^-6 = .000001 +data E6 + +-- | @since 2.01 +instance HasResolution E6 where + resolution _ = 1000000 + +-- | Resolution of 10^-6 = .000001 +-- +-- === __Examples__ +-- +-- >>> show (MkFixed 12345 :: Fixed E6) +-- "0.012345" +-- +-- >>> show (MkFixed 12345 :: Micro) +-- "0.012345" +-- +type Micro = Fixed E6 + +-- | Resolution of 10^-9 = .000000001 +data E9 + +-- | @since 4.1.0.0 +instance HasResolution E9 where + resolution _ = 1000000000 + +-- | Resolution of 10^-9 = .000000001 +-- +-- === __Examples__ +-- +-- >>> show (MkFixed 12345 :: Fixed E9) +-- "0.000012345" +-- +-- >>> show (MkFixed 12345 :: Nano) +-- "0.000012345" +-- +type Nano = Fixed E9 + +-- | Resolution of 10^-12 = .000000000001 +data E12 + +-- | @since 2.01 +instance HasResolution E12 where + resolution _ = 1000000000000 + +-- | Resolution of 10^-12 = .000000000001 +-- +-- === __Examples__ +-- +-- >>> show (MkFixed 12345 :: Fixed E12) +-- "0.000000012345" +-- +-- >>> show (MkFixed 12345 :: Pico) +-- "0.000000012345" +-- +type Pico = Fixed E12 diff --git a/src/Data/Foldable.hs b/src/Data/Foldable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foldable.hs @@ -0,0 +1,1119 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : Data.Foldable +-- Copyright : Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Class of data structures that can be folded to a summary value. +-- + +module Data.Foldable ( + Foldable(..), + -- * Special biased folds + foldrM, + foldlM, + -- * Folding actions + -- ** Applicative actions + traverse_, + for_, + sequenceA_, + asum, + -- ** Monadic actions + mapM_, + forM_, + sequence_, + msum, + -- * Specialized folds + concat, + concatMap, + and, + or, + any, + all, + maximumBy, + minimumBy, + -- * Searches + notElem, + find + + -- * Overview + -- $overview + + -- ** Expectation of efficient left-to-right iteration + -- $chirality + + -- ** Recursive and corecursive reduction + -- $reduction + + -- *** Strict recursive folds + -- $strict + + -- **** List of strict functions + -- $strictlist + + -- *** Lazy corecursive folds + -- $lazy + + -- **** List of lazy functions + -- $lazylist + + -- *** Short-circuit folds + -- $shortcircuit + + -- **** List of short-circuit functions + -- $shortlist + + -- *** Hybrid folds + -- $hybrid + + -- ** Generative Recursion + -- $generative + + -- ** Avoiding multi-pass folds + -- $multipass + + -- * Defining instances + -- $instances + + -- *** Being strict by being lazy + -- $strictlazy + + -- * Laws + -- $laws + + -- * Notes + -- $notes + + -- ** Generally linear-time `elem` + -- $linear + + -- * See also + -- $also + ) where + +import GHC.Internal.Data.Foldable + +-- $setup +-- >>> import Prelude +-- >>> import qualified Data.List as List + +-- $overview +-- +-- #overview# +-- The Foldable class generalises some common "Data.List" functions to +-- structures that can be reduced to a summary value one element at a time. +-- +-- == Left and right folds +-- +-- #leftright# +-- The contribution of each element to the final result is combined with an +-- accumulator via a suitable /operator/. The operator may be explicitly +-- provided by the caller as with `foldr` or may be implicit as in `length`. +-- In the case of `foldMap`, the caller provides a function mapping each +-- element into a suitable 'Monoid', which makes it possible to merge the +-- per-element contributions via that monoid's `mappend` function. +-- +-- A key distinction is between left-associative and right-associative +-- folds: +-- +-- * In left-associative folds the accumulator is a partial fold over the +-- elements that __precede__ the current element, and is passed to the +-- operator as its first (left) argument. The outermost application of the +-- operator merges the contribution of the last element of the structure with +-- the contributions of all its predecessors. +-- +-- * In right-associative folds the accumulator is a partial fold over the +-- elements that __follow__ the current element, and is passed to the +-- operator as its second (right) argument. The outermost application of +-- the operator merges the contribution of the first element of the structure +-- with the contributions of all its successors. +-- +-- These two types of folds are typified by the left-associative strict +-- 'foldl'' and the right-associative lazy `foldr`. +-- +-- @ +-- 'foldl'' :: Foldable t => (b -> a -> b) -> b -> t a -> b +-- `foldr` :: Foldable t => (a -> b -> b) -> b -> t a -> b +-- @ +-- +-- Example usage: +-- +-- >>> foldl' (+) 0 [1..100] +-- 5050 +-- >>> foldr (&&) True (List.repeat False) +-- False +-- +-- The first argument of both is an explicit /operator/ that merges the +-- contribution of an element of the structure with a partial fold over, +-- respectively, either the preceding or following elements of the structure. +-- +-- The second argument of both is an initial accumulator value @z@ of type +-- @b@. This is the result of the fold when the structure is empty. +-- When the structure is non-empty, this is the accumulator value merged with +-- the first element in left-associative folds, or with the last element in +-- right-associative folds. +-- +-- The third and final argument is a @Foldable@ structure containing elements +-- @(a, b, c, …)@. +-- +-- * __'foldl''__ takes an operator argument of the form: +-- +-- @ +-- f :: b -- accumulated fold of the initial elements +-- -> a -- current element +-- -> b -- updated fold, inclusive of current element +-- @ +-- +-- If the structure's last element is @y@, the result of the fold is: +-- +-- @ +-- g y . … . g c . g b . g a $ z +-- where g element !acc = f acc element +-- @ +-- +-- Since 'foldl'' is strict in the accumulator, this is always +-- a [strict](#strict) reduction with no opportunity for early return or +-- intermediate results. The structure must be finite, since no result is +-- returned until the last element is processed. The advantage of +-- strictness is space efficiency: the final result can be computed without +-- storing a potentially deep stack of lazy intermediate results. +-- +-- * __`foldr`__ takes an operator argument of the form: +-- +-- @ +-- f :: a -- current element +-- -> b -- accumulated fold of the remaining elements +-- -> b -- updated fold, inclusive of current element +-- @ +-- +-- the result of the fold is: +-- +-- @f a . f b . f c . … $ z@ +-- +-- If each call of @f@ on the current element @e@, (referenced as @(f e)@ +-- below) returns a structure in which its second argument is captured in a +-- lazily-evaluated component, then the fold of the remaining elements is +-- available to the caller of `foldr` as a pending computation (thunk) that +-- is computed only when that component is evaluated. +-- +-- Alternatively, if any of the @(f e)@ ignore their second argument, the +-- fold stops there, with the remaining elements unused. As a result, +-- `foldr` is well suited to define both [corecursive](#corec) +-- and [short-circuit](#short) reductions. +-- +-- When the operator is always strict in its second argument, 'foldl'' is +-- generally a better choice than `foldr`. When `foldr` is called with a +-- strict operator, evaluation cannot begin until the last element is +-- reached, by which point a deep stack of pending function applications +-- may have been built up in memory. +-- + +-- $chirality +-- +-- #chirality# +-- Foldable structures are generally expected to be efficiently iterable from +-- left to right. Right-to-left iteration may be substantially more costly, or +-- even impossible (as with, for example, infinite lists). The text in the +-- sections that follow that suggests performance differences between +-- left-associative and right-associative folds assumes /left-handed/ +-- structures in which left-to-right iteration is cheaper than right-to-left +-- iteration. +-- +-- In finite structures for which right-to-left sequencing no less efficient +-- than left-to-right sequencing, there is no inherent performance distinction +-- between left-associative and right-associative folds. If the structure's +-- @Foldable@ instance takes advantage of this symmetry to also make strict +-- right folds space-efficient and lazy left folds corecursive, one need only +-- take care to choose either a strict or lazy method for the task at hand. +-- +-- Foldable instances for symmetric structures should strive to provide equally +-- performant left-associative and right-associative interfaces. The main +-- limitations are: +-- +-- * The lazy 'fold', 'foldMap' and 'toList' methods have no right-associative +-- counterparts. +-- * The strict 'foldMap'' method has no left-associative counterpart. +-- +-- Thus, for some foldable structures 'foldr'' is just as efficient as 'foldl'' +-- for strict reduction, and 'foldl' may be just as appropriate for corecursive +-- folds as 'foldr'. +-- +-- Finally, in some less common structures (e.g. /snoc/ lists) right to left +-- iterations are cheaper than left to right. Such structures are poor +-- candidates for a @Foldable@ instance, and are perhaps best handled via their +-- type-specific interfaces. If nevertheless a @Foldable@ instance is +-- provided, the material in the sections that follow applies to these also, by +-- replacing each method with one with the opposite associativity (when +-- available) and switching the order of arguments in the fold's /operator/. +-- +-- You may need to pay careful attention to strictness of the fold's /operator/ +-- when its strictness is different between its first and second argument. +-- For example, while @('+')@ is expected to be commutative and strict in both +-- arguments, the list concatenation operator @('++')@ is not commutative and +-- is only strict in the initial constructor of its first argument. The fold: +-- +-- > myconcat xs = foldr (\a b -> a ++ b) [] xs +-- +-- is substantially cheaper (linear in the length of the consumed portion of +-- the final list, thus e.g. constant time/space for just the first element) +-- than: +-- +-- > revconcat xs = foldr (\a b -> b ++ a) [] xs +-- +-- In which the total cost scales up with both the number of lists combined and +-- the number of elements ultimately consumed. A more efficient way to combine +-- lists in reverse order, is to use: +-- +-- > revconcat = foldr (++) [] . reverse + +-------------- + +-- $reduction +-- +-- As observed in the [above description](#leftright) of left and right folds, +-- there are three general ways in which a structure can be reduced to a +-- summary value: +-- +-- * __Recursive__ reduction, which is strict in all the elements of the +-- structure. This produces a single final result only after processing the +-- entire input structure, and so the input must be finite. +-- +-- * __Corecursion__, which yields intermediate results as it encounters +-- additional input elements. Lazy processing of the remaining elements +-- makes the intermediate results available even before the rest of the +-- input is processed. The input may be unbounded, and the caller can +-- stop processing intermediate results early. +-- +-- * __Short-circuit__ reduction, which examines some initial sequence of the +-- input elements, but stops once a termination condition is met, returning a +-- final result based only on the elements considered up to that point. The +-- remaining elements are not considered. The input should generally be +-- finite, because the termination condition might otherwise never be met. +-- +-- Whether a fold is recursive, corecursive or short-circuiting can depend on +-- both the method chosen to perform the fold and on the operator passed to +-- that method (which may be implicit, as with the `mappend` method of a monoid +-- instance). +-- +-- There are also hybrid cases, where the method and/or operator are not well +-- suited to the task at hand, resulting in a fold that fails to yield +-- incremental results until the entire input is processed, or fails to +-- strictly evaluate results as it goes, deferring all the work to the +-- evaluation of a large final thunk. Such cases should be avoided, either by +-- selecting a more appropriate @Foldable@ method, or by tailoring the operator +-- to the chosen method. +-- +-- The distinction between these types of folds is critical, both in deciding +-- which @Foldable@ method to use to perform the reduction efficiently, and in +-- writing @Foldable@ instances for new structures. Below is a more detailed +-- overview of each type. + +-------------- + +-- $strict +-- #strict# +-- +-- Common examples of strict recursive reduction are the various /aggregate/ +-- functions, like 'sum', 'product', 'length', as well as more complex +-- summaries such as frequency counts. These functions return only a single +-- value after processing the entire input structure. In such cases, lazy +-- processing of the tail of the input structure is generally not only +-- unnecessary, but also inefficient. Thus, these and similar folds should be +-- implemented in terms of strict left-associative @Foldable@ methods (typically +-- 'foldl'') to perform an efficient reduction in constant space. +-- +-- Conversely, an implementation of @Foldable@ for a new structure should +-- ensure that 'foldl'' actually performs a strict left-associative reduction. +-- +-- The 'foldMap'' method is a special case of 'foldl'', in which the initial +-- accumulator is `mempty` and the operator is @mappend . f@, where @f@ maps +-- each input element into the 'Monoid' in question. Therefore, 'foldMap'' is +-- an appropriate choice under essentially the same conditions as 'foldl'', and +-- its implementation for a given @Foldable@ structure should also be a strict +-- left-associative reduction. +-- +-- While the examples below are not necessarily the most optimal definitions of +-- the intended functions, they are all cases in which 'foldMap'' is far more +-- appropriate (as well as more efficient) than the lazy `foldMap`. +-- +-- > length = getSum . foldMap' (const (Sum 1)) +-- > sum = getSum . foldMap' Sum +-- > product = getProduct . foldMap' Product +-- +-- [ The actual default definitions employ coercions to optimise out +-- 'getSum' and 'getProduct'. ] + +-------------- + +-- $strictlist +-- +-- The full list of strict recursive functions in this module is: +-- +-- * Provided the operator is strict in its left argument: +-- +-- @'foldl'' :: Foldable t => (b -> a -> b) -> b -> t a -> b@ +-- +-- * Provided `mappend` is strict in its left argument: +-- +-- @'foldMap'' :: (Foldable t, Monoid m) => (a -> m) -> t a -> m@ +-- +-- * Provided the instance is correctly defined: +-- +-- @ +-- `length` :: Foldable t => t a -> Int +-- `sum` :: (Foldable t, Num a) => t a -> a +-- `product` :: (Foldable t, Num a) => t a -> a +-- `maximum` :: (Foldable t, Ord a) => t a -> a +-- `minimum` :: (Foldable t, Ord a) => t a -> a +-- `maximumBy` :: Foldable t => (a -> a -> Ordering) -> t a -> a +-- `minimumBy` :: Foldable t => (a -> a -> Ordering) -> t a -> a +-- @ + +-------------- + +-- $lazy +-- +-- #corec# +-- Common examples of lazy corecursive reduction are functions that map and +-- flatten a structure to a lazy stream of result values, i.e. an iterator +-- over the transformed input elements. In such cases, it is important to +-- choose a @Foldable@ method that is lazy in the tail of the structure, such +-- as `foldr` (or `foldMap`, if the result @Monoid@ has a lazy `mappend` as +-- with e.g. ByteString Builders). +-- +-- Conversely, an implementation of `foldr` for a structure that can +-- accommodate a large (and possibly unbounded) number of elements is expected +-- to be lazy in the tail of the input, allowing operators that are lazy in the +-- accumulator to yield intermediate results incrementally. Such folds are +-- right-associative, with the tail of the stream returned as a lazily +-- evaluated component of the result (an element of a tuple or some other +-- non-strict constructor, e.g. the @(:)@ constructor for lists). +-- +-- The @toList@ function below lazily transforms a @Foldable@ structure to a +-- List. Note that this transformation may be lossy, e.g. for a keyed +-- container (@Map@, @HashMap@, …) the output stream holds only the +-- values, not the keys. Lossless transformations to\/from lists of @(key, +-- value)@ pairs are typically available in the modules for the specific +-- container types. +-- +-- > toList = foldr (:) [] +-- +-- A more complex example is concatenation of a list of lists expressed as a +-- nested right fold (bypassing @('++')@). We can check that the definition is +-- indeed lazy by folding an infinite list of lists, and taking an initial +-- segment. +-- +-- >>> myconcat = foldr (\x z -> foldr (:) z x) [] +-- >>> 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 +-- list comprehension: +-- +-- > myconcat xss = [x | xs <- xss, x <- xs] + +-------------- + +-- $lazylist +-- +-- The full list of lazy corecursive functions in this module is: +-- +-- * Provided the reduction function is lazy in its second argument, +-- (otherwise best to use a strict recursive reduction): +-- +-- @ +-- `foldr` :: Foldable t => (a -> b -> b) -> b -> t a -> b +-- `foldr1` :: Foldable t => (a -> a -> a) -> t a -> a +-- @ +-- +-- * Provided the 'Monoid' `mappend` is lazy in its second argument +-- (otherwise best to use a strict recursive reduction): +-- +-- @ +-- `fold` :: Foldable t => Monoid m => t m -> m +-- `foldMap` :: Foldable t => Monoid m => (a -> m) -> t a -> m +-- @ +-- +-- * Provided the instance is correctly defined: +-- +-- @ +-- `toList` :: Foldable t => t a -> [a] +-- `concat` :: Foldable t => t [a] -> [a] +-- `concatMap` :: Foldable t => (a -> [b]) -> t a -> [b] +-- @ + +-------------- + +-- $shortcircuit +-- +-- #short# +-- Examples of short-circuit reduction include various boolean predicates that +-- test whether some or all the elements of a structure satisfy a given +-- condition. Because these don't necessarily consume the entire list, they +-- typically employ `foldr` with an operator that is conditionally strict in +-- its second argument. Once the termination condition is met the second +-- argument (tail of the input structure) is ignored. No result is returned +-- until that happens. +-- +-- The key distinguishing feature of these folds is /conditional/ strictness +-- in the second argument, it is sometimes evaluated and sometimes not. +-- +-- The simplest (degenerate case) of these is 'null', which determines whether +-- a structure is empty or not. This only needs to look at the first element, +-- and only to the extent of whether it exists or not, and not its value. In +-- this case termination is guaranteed, and infinite input structures are fine. +-- Its default definition is of course in terms of the lazy 'foldr': +-- +-- > null = foldr (\_ _ -> False) True +-- +-- A more general example is `any`, which applies a predicate to each input +-- element in turn until it finds the first one for which the predicate is +-- true, at which point it returns success. If, in an infinite input stream +-- the predicate is false for all the elements, `any` will not terminate, +-- but since it runs in constant space, it typically won't run out of memory, +-- it'll just loop forever. + +-------------- + +-- $shortlist +-- +-- The full list of short-circuit folds in this module is: +-- +-- * Boolean predicate folds. +-- These functions examine elements strictly until a condition is met, +-- but then return a result ignoring the rest (lazy in the tail). These +-- may loop forever given an unbounded input where no elements satisfy the +-- termination condition. +-- +-- @ +-- `null` :: Foldable t => t a -> Bool +-- `elem` :: Foldable t => Eq a => a -> t a -> Bool +-- `notElem` :: (Foldable t, Eq a) => a -> t a -> Bool +-- `and` :: Foldable t => t Bool -> Bool +-- `or` :: Foldable t => t Bool -> Bool +-- `find` :: Foldable t => (a -> Bool) -> t a -> Maybe a +-- `any` :: Foldable t => (a -> Bool) -> t a -> Bool +-- `all` :: Foldable t => (a -> Bool) -> t a -> Bool +-- @ +-- +-- * Many instances of @('<|>')@ (e.g. the 'Maybe' instance) are conditionally +-- lazy, and use or don't use their second argument depending on the value +-- of the first. These are used with the folds below, which terminate as +-- early as possible, but otherwise generally keep going. Some instances +-- (e.g. for List) are always strict, but the result is lazy in the tail +-- of the output, so that `asum` for a list of lists is in fact corecursive. +-- These folds are defined in terms of `foldr`. +-- +-- @ +-- `asum` :: (Foldable t, Alternative f) => t (f a) -> f a +-- `msum` :: (Foldable t, MonadPlus m) => t (m a) -> m a +-- @ +-- +-- * Likewise, the @('*>')@ operator in some `Applicative` functors, and @('>>')@ +-- in some monads are conditionally lazy and can /short-circuit/ a chain of +-- computations. The below folds will terminate as early as possible, but +-- even infinite loops can be productive here, when evaluated solely for +-- their stream of IO side-effects. See "Data.Traversable#effectful" +-- for discussion of related functions. +-- +-- @ +-- `traverse_` :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () +-- `for_` :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f () +-- `sequenceA_` :: (Foldable t, Applicative f) => t (f a) -> f () +-- `mapM_` :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () +-- `forM_` :: (Foldable t, Monad m) => t a -> (a -> m b) -> m () +-- `sequence_` :: (Foldable t, Monad m) => t (m a) -> m () +-- @ +-- +-- * Finally, there's one more special case, `foldlM`: +-- +-- @`foldlM` :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b@ +-- +-- The sequencing of monadic effects proceeds from left to right. If at +-- some step the bind operator @('>>=')@ short-circuits (as with, e.g., +-- 'mzero' with a 'MonadPlus', or an exception with a 'MonadThrow', etc.), +-- 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..] +-- 0 +-- 1 +-- 2 +-- 3 +-- Nothing +-- +-- Contrast this with `foldrM`, which sequences monadic effects from right +-- 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..] +-- ...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] +-- 5 +-- 4 +-- 3 +-- Nothing + +-------------- + +-- $hybrid +-- +-- The below folds, are neither strict reductions that produce a final answer +-- in constant space, nor lazy corecursions, and so have limited applicability. +-- They do have specialised uses, but are best avoided when in doubt. +-- +-- @ +-- 'foldr'' :: Foldable t => (a -> b -> b) -> b -> t a -> b +-- 'foldl' :: Foldable t => (b -> a -> b) -> b -> t a -> b +-- 'foldl1' :: Foldable t => (a -> a -> a) -> t a -> a +-- 'foldrM' :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b +-- @ +-- +-- The lazy left-folds (used corecursively) and 'foldrM' (used to sequence +-- actions right-to-left) can be performant in structures whose @Foldable@ +-- instances take advantage of efficient right-to-left iteration to compute +-- lazy left folds outside-in from the rightmost element. +-- +-- The strict 'foldr'' is the least likely to be useful, structures that +-- support efficient sequencing /only/ right-to-left are not common. + +-------------- + +-- $instances +-- +-- #instances# +-- For many structures reasonably efficient @Foldable@ instances can be derived +-- automatically, by enabling the @DeriveFoldable@ GHC extension. When this +-- works, it is generally not necessary to define a custom instance by hand. +-- Though in some cases one may be able to get slightly faster hand-tuned code, +-- care is required to avoid producing slower code, or code that is not +-- sufficiently lazy, strict or /lawful/. +-- +-- The hand-crafted instances can get away with only defining one of 'foldr' or +-- 'foldMap'. All the other methods have default definitions in terms of one +-- of these. The default definitions have the expected strictness and the +-- expected asymptotic runtime and space costs, modulo small constant factors. +-- If you choose to hand-tune, benchmarking is advised to see whether you're +-- doing better than the default derived implementations, plus careful tests to +-- ensure that the custom methods are correct. +-- +-- 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) +-- +-- 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 +-- :} +-- +-- The 'Node' case is a right fold of the left subtree whose initial +-- value is a right fold of the rest of the tree. +-- +-- For example, when @f@ is @(':')@, all three cases return an immediate value, +-- respectively @z@ or a /cons cell/ holding @x@ or @l@, with the remainder the +-- structure, if any, encapsulated in a lazy thunk. This meets the expected +-- efficient [corecursive](#corec) behaviour of 'foldr'. +-- +-- Alternatively, one could define @foldMap@: +-- +-- > instance Foldable Tree where +-- > foldMap f Empty = mempty +-- > foldMap f (Leaf x) = f x +-- > foldMap f (Node l k r) = foldMap f l <> f k <> foldMap f r +-- +-- And indeed some efficiency may be gained by directly defining both, +-- avoiding some indirection in the default definitions that express +-- one in terms of the other. If you implement just one, likely 'foldr' +-- is the better choice. +-- +-- A binary tree typically (when balanced, or randomly biased) provides equally +-- efficient access to its left and right subtrees. This makes it possible to +-- define a `foldl` optimised for [corecursive](#corec) folds with operators +-- that are lazy in their first (left) argument. +-- +-- > 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 +-- > -- +-- > foldMap f Empty = mempty +-- > foldMap f (Leaf x) = f x +-- > foldMap f (Node l k r) = foldMap f l <> f k <> foldMap f r +-- > -- +-- > foldl f z Empty = z +-- > foldl f z (Leaf x) = f z x +-- > foldl f z (Node l k r) = foldl f (f (foldl f z l) k) r +-- +-- Now left-to-right and right-to-left iteration over the structure +-- elements are equally efficient (note the mirror-order output when +-- using `foldl`): +-- +-- >>> foldr (\e acc -> e : acc) [] (Node (Leaf 1) 2 (Leaf 3)) +-- [1,2,3] +-- >>> foldl (\acc e -> e : acc) [] (Node (Leaf 1) 2 (Leaf 3)) +-- [3,2,1] +-- +-- We can carry this further, and define more non-default methods... +-- +-- The structure definition actually admits trees that are unbounded on either +-- or both sides. The only fold that can plausibly terminate for a tree +-- unbounded on both left and right is `null`, when defined as shown below. +-- The default definition in terms of `foldr` diverges if the tree is unbounded +-- on the left. Here we define a variant that avoids travelling down the tree +-- to find the leftmost element and just examines the root node. +-- +-- > null Empty = True +-- > null _ = False +-- +-- This is a sound choice also for finite trees. +-- +-- In practice, unbounded trees are quite uncommon, and can barely be said to +-- be @Foldable@. They would typically employ breadth first traversal, and +-- would support only corecursive and short-circuit folds (diverge under strict +-- reduction). +-- +-- Returning to simpler instances, defined just in terms of `foldr`, it is +-- somewhat surprising that a fairly efficient /default/ implementation of the +-- strict 'foldl'' is defined in terms of lazy `foldr` when only the latter is +-- explicitly provided by the instance. It may be instructive to take a look +-- at how this works. + +-------------- + +-- $strictlazy +-- +-- #strictlazy# +-- +-- Sometimes, it is useful for the result of applying 'foldr' to be a +-- /function/. This is done by mapping the structure elements to functions +-- with the same argument and result types. The per-element functions are then +-- composed to give the final result. +-- +-- For example, we can /flip/ the strict left fold 'foldl'' by writing: +-- +-- > foldl' f z xs = flippedFoldl' f xs z +-- +-- with the function 'flippedFoldl'' defined as below, with 'seq' used to +-- ensure the strictness in the accumulator: +-- +-- > flippedFoldl' f [] z = z +-- > flippedFoldl' f (x : xs) z = z `seq` flippedFoldl' f xs (f z x) +-- +-- Rewriting to use lambdas, this is: +-- +-- > flippedFoldl' f [] = \ b -> b +-- > flippedFoldl' f (x : xs) = \ b -> b `seq` r (f b x) +-- > where r = flippedFoldl' f xs +-- +-- The above has the form of a right fold, enabling a rewrite to: +-- +-- > flippedFoldl' f = \ xs -> foldr f' id xs +-- > where f' x r = \ b -> b `seq` r (f b x) +-- +-- We can now unflip this to get 'foldl'': +-- +-- > foldl' f z = \ xs -> foldr f' id xs z +-- > -- \ xs -> flippedFoldl' f xs z +-- > where f' x r = \ b -> b `seq` r (f b x) +-- +-- The function __@foldr f' id xs@__ applied to @z@ is built corecursively, and +-- its terms are applied to an eagerly evaluated accumulator before further +-- terms are applied to the result. As required, this runs in constant space, +-- and can be optimised to an efficient loop. +-- +-- (The actual definition of 'foldl'' labels the lambdas in the definition of +-- __@f'@__ above as /oneShot/, which enables further optimisations). + +-------------- + +-- $generative +-- +-- #generative# +-- So far, we have not discussed /generative recursion/. Unlike recursive +-- reduction or corecursion, instead of processing a sequence of elements +-- already in memory, generative recursion involves producing a possibly +-- unbounded sequence of values from an initial seed value. The canonical +-- example of this is 'Data.List.unfoldr' for Lists, with variants available +-- for Vectors and various other structures. +-- +-- A key issue with lists, when used generatively as /iterators/, rather than as +-- poor-man's containers (see [[1\]](#uselistsnot)), is that such iterators +-- tend to consume memory when used more than once. A single traversal of a +-- list-as-iterator will run in constant space, but as soon as the list is +-- retained for reuse, its entire element sequence is stored in memory, and the +-- second traversal reads the copy, rather than regenerates the elements. It +-- is sometimes better to recompute the elements rather than memoise the list. +-- +-- Memoisation happens because the built-in Haskell list __@[]@__ is +-- represented as __data__, either empty or a /cons-cell/ holding the first +-- element and the tail of the list. The @Foldable@ class enables a variant +-- representation of iterators as /functions/, which take an operator and a +-- starting accumulator and output a summary result. +-- +-- The [@fmlist@](https://hackage.haskell.org/package/fmlist) package takes +-- this approach, by representing a list via its `foldMap` action. +-- +-- Below we implement an analogous data structure using a representation +-- based on `foldr`. This is an example of /Church encoding/ +-- (named after Alonzo Church, inventor of the lambda calculus). +-- +-- > {-# LANGUAGE RankNTypes #-} +-- > newtype FRList a = FR { unFR :: forall b. (a -> b -> b) -> b -> b } +-- +-- The __@unFR@__ field of this type is essentially its `foldr` method +-- with the list as its first rather than last argument. Thus we +-- immediately get a @Foldable@ instance (and a 'toList' function +-- mapping an __@FRList@__ to a regular list). +-- +-- > instance Foldable FRList where +-- > foldr f z l = unFR l f z +-- > -- With older versions of @base@, also define sum, product, ... +-- > -- to ensure use of the strict 'foldl''. +-- > -- sum = foldl' (+) 0 +-- > -- ... +-- +-- We can convert a regular list to an __@FRList@__ with: +-- +-- > fromList :: [a] -> FRList a +-- > fromList as = FRList $ \ f z -> foldr f z as +-- +-- However, reuse of an __@FRList@__ obtained in this way will typically +-- memoise the underlying element sequence. Instead, we can define +-- __@FRList@__ terms directly: +-- +-- > -- | Immediately return the initial accumulator +-- > nil :: FRList a +-- > nil = FRList $ \ _ z -> z +-- > {-# INLINE nil #-} +-- +-- > -- | Fold the tail to use as an accumulator with the new initial element +-- > cons :: a -> FRList a -> FRList a +-- > cons a l = FRList $ \ f z -> f a (unFR l f z) +-- > {-# INLINE cons #-} +-- +-- More crucially, we can also directly define the key building block for +-- generative recursion: +-- +-- > -- | Generative recursion, dual to `foldr`. +-- > unfoldr :: (s -> Maybe (a, s)) -> s -> FRList a +-- > unfoldr g s0 = FR generate +-- > where generate f z = loop s0 +-- > where loop s | Just (a, t) <- g s = f a (loop t) +-- > | otherwise = z +-- > {-# INLINE unfoldr #-} +-- +-- Which can, for example, be specialised to number ranges: +-- +-- > -- | Generate a range of consecutive integral values. +-- > range :: (Ord a, Integral a) => a -> a -> FRList a +-- > range lo hi = +-- > unfoldr (\s -> if s > hi then Nothing else Just (s, s+1)) lo +-- > {-# INLINE range #-} +-- +-- The program below, when compiled with optimisation: +-- +-- > main :: IO () +-- > main = do +-- > let r :: FRList Int +-- > r = range 1 10000000 +-- > in print (sum r, length r) +-- +-- produces the expected output with no noticeable garbage-collection, despite +-- reuse of the __@FRList@__ term __@r@__. +-- +-- > (50000005000000,10000000) +-- > 52,120 bytes allocated in the heap +-- > 3,320 bytes copied during GC +-- > 44,376 bytes maximum residency (1 sample(s)) +-- > 25,256 bytes maximum slop +-- > 3 MiB total memory in use (0 MB lost due to fragmentation) +-- +-- The Weak Head Normal Form of an __@FRList@__ is a lambda abstraction not a +-- data value, and reuse does not lead to memoisation. Reuse of the iterator +-- above is somewhat contrived, when computing multiple folds over a common +-- list, you should generally traverse a list only [once](#multipass). The +-- goal is to demonstrate that the separate computations of the 'sum' and +-- 'length' run efficiently in constant space, despite reuse. This would not +-- be the case with the list @[1..10000000]@. +-- +-- This is, however, an artificially simple reduction. More typically, there +-- are likely to be some allocations in the inner loop, but the temporary +-- storage used will be garbage-collected as needed, and overall memory +-- utilisation will remain modest and will not scale with the size of the list. +-- +-- If we go back to built-in lists (i.e. __@[]@__), but avoid reuse by +-- performing reduction in a single pass, as below: +-- +-- > data PairS a b = P !a !b -- We define a strict pair datatype +-- > +-- > main :: IO () +-- > main = do +-- > let l :: [Int] +-- > l = [1..10000000] +-- > in print $ average l +-- > where +-- > sumlen :: PairS Int Int -> Int -> PairS Int Int +-- > sumlen (P s l) a = P (s + a) (l + 1) +-- > +-- > average is = +-- > let (P s l) = foldl' sumlen (P 0 0) is +-- > in (fromIntegral s :: Double) / fromIntegral l +-- +-- the result is again obtained in constant space: +-- +-- > 5000000.5 +-- > 102,176 bytes allocated in the heap +-- > 3,320 bytes copied during GC +-- > 44,376 bytes maximum residency (1 sample(s)) +-- > 25,256 bytes maximum slop +-- > 3 MiB total memory in use (0 MB lost due to fragmentation) +-- +-- (and, in fact, faster than with __@FRList@__ by a small factor). +-- +-- The __@[]@__ list structure works as an efficient iterator when used +-- just once. When space-leaks via list reuse are not a concern, and/or +-- memoisation is actually desirable, the regular list implementation is +-- likely to be faster. This is not a suggestion to replace all your uses of +-- __@[]@__ with a generative alternative. +-- +-- The __@FRList@__ type could be further extended with instances of 'Functor', +-- 'Applicative', 'Monad', 'Alternative', etc., and could then provide a +-- fully-featured list type, optimised for reuse without space-leaks. If, +-- however, all that's required is space-efficient, re-use friendly iteration, +-- less is perhaps more, and just @Foldable@ may be sufficient. + +-------------- + +-- $multipass +-- +-- #multipass# +-- In applications where you want to compute a composite function of a +-- structure, which requires more than one aggregate as an input, it is +-- generally best to compute all the aggregates in a single pass, rather +-- than to traverse the same structure repeatedly. +-- +-- The [@foldl@](http://hackage.haskell.org/package/foldl) package implements a +-- robust general framework for dealing with this situation. If you choose to +-- to do it yourself, with a bit of care, the simplest cases are not difficult +-- to handle directly. You just need to accumulate the individual aggregates +-- as __strict__ components of a single data type, and then apply a final +-- transformation to it to extract the composite result. For example, +-- computing an average requires computing both the 'sum' and the 'length' of a +-- (non-empty) structure and dividing the sum by the length: +-- +-- > import Data.Foldable (foldl') +-- > +-- > data PairS a b = P !a !b -- We define a strict pair datatype +-- > +-- > -- | Compute sum and length in a single pass, then reduce to the average. +-- > average :: (Foldable f, Fractional a) => f a -> a +-- > average xs = +-- > let sumlen (P s l) a = P (s + a) (l + 1 :: Int) +-- > (P s l) = foldl' sumlen (P 0 0) xs +-- > in s / fromIntegral l +-- +-- The above example is somewhat contrived, some structures keep track of their +-- length internally, and can return it in /O(1)/ time, so this particular +-- recipe for averages is not always the most efficient. In general, composite +-- aggregate functions of large structures benefit from single-pass reduction. +-- This is especially the case when reuse of a list and memoisation of its +-- elements is thereby avoided. + +-------------- + +-- $laws +-- #laws# +-- +-- The type constructor 'Endo' from "Data.Monoid", associates with each type +-- __@b@__ the __@newtype@__-encapsulated type of functions mapping __@b@__ to +-- itself. Functions from a type to itself are called /endomorphisms/, hence +-- the name /Endo/. The type __@Endo b@__ is a 'Monoid' under function +-- composition: +-- +-- > newtype Endo b = Endo { appEndo :: b -> b } +-- > instance Semigroup Endo b where +-- > Endo f <> Endo g = Endo (f . g) +-- > instance Monoid Endo b where +-- > mempty = Endo id +-- +-- For every 'Monoid' m, we also have a 'Dual' monoid __@Dual m@__ which +-- combines elements in the opposite order: +-- +-- > newtype Dual m = Dual { getDual :: m } +-- > instance Semigroup m => Semigroup Dual m where +-- > Dual a <> Dual b = Dual (b <> a) +-- > instance Monoid m => Monoid Dual m where +-- > mempty = Dual mempty +-- +-- With the above preliminaries out of the way, 'Foldable' instances are +-- expected to satisfy the following laws: +-- +-- The 'foldr' method must be equivalent in value and strictness to replacing +-- each element __@a@__ of a 'Foldable' structure with __@Endo (f a)@__, +-- composing these via 'foldMap' and applying the result to the base case +-- __@z@__: +-- +-- > foldr f z t = appEndo (foldMap (Endo . f) t ) z +-- +-- Likewise, the 'foldl' method must be equivalent in value and strictness +-- to composing the functions __@flip f a@__ in reverse order and applying +-- the result to the base case: +-- +-- > foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z +-- +-- When the elements of the structure are taken from a 'Monoid', the +-- definition of 'fold' must agree with __@foldMap id@__: +-- +-- > fold = foldMap id +-- +-- The 'length' method must agree with a 'foldMap' mapping each element to +-- __@Sum 1@__ (The 'Sum' type abstracts numbers as a monoid under addition). +-- +-- > length = getSum . foldMap (Sum . const 1) +-- +-- @sum@, @product@, @maximum@, and @minimum@ should all be essentially +-- equivalent to @foldMap@ forms, such as +-- +-- > sum = getSum . foldMap' Sum +-- > product = getProduct . foldMap' Product +-- +-- but are generally more efficient when defined more directly as: +-- +-- > sum = foldl' (+) 0 +-- > product = foldl' (*) 1 +-- +-- If the 'Foldable' structure has a 'Functor' instance, then for every +-- function __@f@__ mapping the elements into a 'Monoid', it should satisfy: +-- +-- > foldMap f = fold . fmap f +-- +-- which implies that +-- +-- > foldMap f . fmap g = foldMap (f . g) +-- + +-------------- + +-- $notes +-- +-- #notes# +-- Since 'Foldable' does not have 'Functor' as a superclass, it is possible to +-- define 'Foldable' instances for structures that constrain their element +-- types. Therefore, __@Set@__ can be 'Foldable', even though sets keep their +-- elements in ascending order. This requires the elements to be comparable, +-- which precludes defining a 'Functor' instance for @Set@. +-- +-- The 'Foldable' class makes it possible to use idioms familiar from the @List@ +-- type with container structures that are better suited to the task at hand. +-- This supports use of more appropriate 'Foldable' data types, such as @Seq@, +-- @Set@, @NonEmpty@, etc., without requiring new idioms (see +-- [[1\]](#uselistsnot) for when not to use lists). +-- +-- The more general methods of the 'Foldable' class are now exported by the +-- "Prelude" in place of the original List-specific methods (see the +-- [FTP Proposal](https://wiki.haskell.org/Foldable_Traversable_In_Prelude)). +-- The List-specific variants are for now still available in "GHC.OldList", but +-- that module is intended only as a transitional aid, and may be removed in +-- the future. +-- +-- Surprises can arise from the @Foldable@ instance of the 2-tuple @(a,)@ which +-- now behaves as a 1-element @Foldable@ container in its second slot. In +-- contexts where a specific monomorphic type is expected, and you want to be +-- able to rely on type errors to guide refactoring, it may make sense to +-- define and use less-polymorphic variants of some of the @Foldable@ methods. +-- +-- Below are two examples showing a definition of a reusable less-polymorphic +-- 'sum' and a one-off in-line specialisation of 'length': +-- +-- > {-# LANGUAGE TypeApplications #-} +-- > +-- > mySum :: Num a => [a] -> a +-- > mySum = sum +-- > +-- > type SlowVector a = [a] +-- > slowLength :: SlowVector -> Int +-- > slowLength v = length @[] v +-- +-- In both cases, if the data type to which the function is applied changes +-- to something other than a list, the call-site will no longer compile until +-- appropriate changes are made. + +-- $linear +-- +-- It is perhaps worth noting that since the __`elem`__ function in the +-- 'Foldable' class carries only an __`Eq`__ constraint on the element type, +-- search for the presence or absence of an element in the structure generally +-- takes /O(n)/ time, even for ordered structures like __@Set@__ that are +-- potentially capable of performing the search faster. (The @member@ function +-- of the @Set@ module carries an `Ord` constraint, and can perform the search +-- in /O(log n)/ time). +-- +-- An alternative to Foldable's __`elem`__ method is required in order to +-- abstract potentially faster than linear search over general container +-- structures. This can be achieved by defining an additional type class (e.g. +-- @HasMember@ below). Instances of such a type class (that are also +-- `Foldable') can employ the `elem` linear search as a last resort, when +-- faster search is not supported. +-- +-- > {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +-- > +-- > import qualified Data.Set as Set +-- > +-- > class Eq a => HasMember t a where +-- > member :: a -> t a -> Bool +-- > +-- > instance Eq a => HasMember [] a where +-- > member = elem +-- > [...] +-- > instance Ord a => HasMember Set.Set a where +-- > member = Set.member +-- +-- The above suggests that 'elem' may be a misfit in the 'Foldable' class. +-- Alternative design ideas are solicited on GHC's bug tracker via issue +-- [\#20421](https://gitlab.haskell.org/ghc/ghc/-/issues/20421). +-- +-- Note that some structure-specific optimisations may of course be possible +-- directly in the corresponding @Foldable@ instance, e.g. with @Set@ the size +-- of the set is known in advance, without iterating to count the elements, and +-- its `length` instance takes advantage of this to return the size directly. + +-------------- + +-- $also +-- +-- * [1] #uselistsnot# \"When You Should Use Lists in Haskell (Mostly, You Should Not)\", +-- by Johannes Waldmann, +-- in arxiv.org, Programming Languages (cs.PL), at +-- . +-- +-- * [2] \"The Essence of the Iterator Pattern\", +-- by Jeremy Gibbons and Bruno Oliveira, +-- in /Mathematically-Structured Functional Programming/, 2006, online at +-- . +-- +-- * [3] \"A tutorial on the universality and expressiveness of fold\", +-- by Graham Hutton, J\. Functional Programming 9 (4): 355–372, July 1999, +-- online at . diff --git a/src/Data/Foldable1.hs b/src/Data/Foldable1.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foldable1.hs @@ -0,0 +1,620 @@ +-- | +-- Copyright: Edward Kmett, Oleg Grenrus +-- License: BSD-3-Clause +-- +-- A class of non-empty data structures that can be folded to a summary value. +-- +-- @since 4.18.0.0 + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Foldable1 ( + Foldable1(..), + foldr1, foldr1', + foldl1, foldl1', + intercalate1, + foldrM1, + foldlM1, + foldrMapM1, + foldlMapM1, + maximumBy, + minimumBy, + ) where + +import GHC.Internal.Data.Foldable (Foldable, foldlM, foldr) +import GHC.Internal.Data.List (foldl, foldl') +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup + (Dual (..), First (..), Last (..), Max (..), Min (..), Product (..), + Semigroup (..), Sum (..)) +import GHC.Tuple (Solo (..)) +import Prelude + (Maybe (..), Monad (..), Ord, Ordering (..), id, seq, ($!), ($), (.), + (=<<), flip, const, error) + +import qualified Data.List.NonEmpty as NE + +import Data.Complex (Complex (..)) +import GHC.Generics + (M1 (..), Par1 (..), Rec1 (..), V1, (:*:) (..), (:+:) (..), (:.:) (..)) + +import GHC.Internal.Data.Ord (Down (..)) + +import qualified GHC.Internal.Data.Monoid as Mon + +-- Instances +import Data.Functor.Compose (Compose (..)) +import GHC.Internal.Data.Functor.Identity (Identity (..)) + +import qualified Data.Functor.Product as Functor +import qualified Data.Functor.Sum as Functor + +-- coerce +import GHC.Internal.Data.Coerce (Coercible, coerce) + +-- $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 +------------------------------------------------------------------------------- + +-- | Non-empty data structures that can be folded. +-- +-- @since 4.18.0.0 +class Foldable t => Foldable1 t where + {-# MINIMAL foldMap1 | foldrMap1 #-} + + -- At some point during design it was possible to define this class using + -- only 'toNonEmpty'. But it seems a bad idea in general. + -- + -- So currently we require either foldMap1 or foldrMap1 + -- + -- * foldMap1 defined using foldrMap1 + -- * foldrMap1 defined using foldMap1 + -- + -- One can always define an instance using the following pattern: + -- + -- toNonEmpty = ... + -- foldMap f = foldMap f . toNonEmpty + -- foldrMap1 f g = foldrMap1 f g . toNonEmpty + + -- | Given a structure with elements whose type is a 'Semigroup', combine + -- them via the semigroup's @('<>')@ operator. This fold is + -- right-associative and lazy in the accumulator. When you need a strict + -- left-associative fold, use 'foldMap1'' instead, with 'id' as the map. + -- + -- @since 4.18.0.0 + fold1 :: Semigroup m => t m -> m + fold1 = foldMap1 id + + -- | Map each element of the structure to a semigroup, and combine the + -- results with @('<>')@. This fold is right-associative and lazy in the + -- accumulator. For strict left-associative folds consider 'foldMap1'' + -- instead. + -- + -- >>> foldMap1 (:[]) (1 :| [2, 3, 4]) + -- [1,2,3,4] + -- + -- @since 4.18.0.0 + foldMap1 :: Semigroup m => (a -> m) -> t a -> m + foldMap1 f = foldrMap1 f (\a m -> f a <> m) + + -- | A left-associative variant of 'foldMap1' that is strict in the + -- accumulator. Use this for strict reduction when partial results are + -- merged via @('<>')@. + -- + -- >>> foldMap1' Sum (1 :| [2, 3, 4]) + -- Sum {getSum = 10} + -- + -- @since 4.18.0.0 + foldMap1' :: Semigroup m => (a -> m) -> t a -> m + foldMap1' f = foldlMap1' f (\m a -> m <> f a) + + -- | 'NonEmpty' list of elements of a structure, from left to right. + -- + -- >>> toNonEmpty (Identity 2) + -- 2 :| [] + -- + -- @since 4.18.0.0 + toNonEmpty :: t a -> NonEmpty a + toNonEmpty = runNonEmptyDList . foldMap1 singleton + + -- | 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 + -- + -- @since 4.18.0.0 + maximum :: Ord a => t a -> a + maximum = getMax #. foldMap1' Max + + -- | 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 + -- + -- @since 4.18.0.0 + minimum :: Ord a => t a -> a + minimum = getMin #. foldMap1' Min + + -- | The first element of a non-empty structure. + -- + -- >>> head (1 :| [2, 3, 4]) + -- 1 + -- + -- @since 4.18.0.0 + head :: t a -> a + head = getFirst #. foldMap1 First + + -- | The last element of a non-empty structure. + -- + -- >>> last (1 :| [2, 3, 4]) + -- 4 + -- + -- @since 4.18.0.0 + last :: t a -> a + last = getLast #. foldMap1 Last + + -- | Right-associative fold of a structure, lazy in the accumulator. + -- + -- In case of 'NonEmpty' lists, 'foldrMap1', when given a function @f@, a + -- binary operator @g@, and a list, reduces the list using @g@ from right to + -- left applying @f@ to the rightmost element: + -- + -- > foldrMap1 f g (x1 :| [x2, ..., xn1, xn]) == x1 `g` (x2 `g` ... (xn1 `g` (f xn))...) + -- + -- Note that since the head of the resulting expression is produced by + -- an application of @g@ to the first element of the list, if @g@ is lazy + -- in its right argument, 'foldrMap1' can produce a terminating expression + -- from an unbounded list. + -- + -- For a general 'Foldable1' structure this should be semantically identical + -- to: + -- + -- @foldrMap1 f g = foldrMap1 f g . 'toNonEmpty'@ + -- + -- @since 4.18.0.0 + foldrMap1 :: (a -> b) -> (a -> b -> b) -> t a -> b + foldrMap1 f g xs = + appFromMaybe (foldMap1 (FromMaybe #. h) xs) Nothing + where + h a Nothing = f a + h a (Just b) = g a b + + -- | Left-associative fold of a structure but with strict application of the + -- operator. + -- + -- This ensures that each step of the fold is forced to Weak Head Normal + -- Form before being applied, avoiding the collection of thunks that would + -- otherwise occur. This is often what you want to strictly reduce a + -- finite structure to a single strict result. + -- + -- For a general 'Foldable1' structure this should be semantically identical + -- to: + -- + -- @foldlMap1' f z = foldlMap1' f z . 'toNonEmpty'@ + -- + -- @since 4.18.0.0 + foldlMap1' :: (a -> b) -> (b -> a -> b) -> t a -> b + foldlMap1' f g xs = + foldrMap1 f' g' xs SNothing + where + -- f' :: a -> SMaybe b -> b + f' a SNothing = f a + f' a (SJust b) = g b a + + -- g' :: a -> (SMaybe b -> b) -> SMaybe b -> b + g' a x SNothing = x $! SJust (f a) + g' a x (SJust b) = x $! SJust (g b a) + + -- | Left-associative fold of a structure, lazy in the accumulator. This is + -- rarely what you want, but can work well for structures with efficient + -- right-to-left sequencing and an operator that is lazy in its left + -- argument. + -- + -- In case of 'NonEmpty' lists, 'foldlMap1', when given a function @f@, a + -- binary operator @g@, and a list, reduces the list using @g@ from left to + -- right applying @f@ to the leftmost element: + -- + -- > foldlMap1 f g (x1 :| [x2, ..., xn]) == (...(((f x1) `g` x2) `g`...) `g` xn + -- + -- Note that to produce the outermost application of the operator the entire + -- input list must be traversed. This means that 'foldlMap1' will diverge if + -- given an infinite list. + -- + -- If you want an efficient strict left-fold, you probably want to use + -- 'foldlMap1'' instead of 'foldlMap1'. The reason for this is that the + -- latter does not force the /inner/ results (e.g. @(f x1) \`g\` x2@ in the + -- above example) before applying them to the operator (e.g. to + -- @(\`g\` x3)@). This results in a thunk chain \(O(n)\) elements long, + -- which then must be evaluated from the outside-in. + -- + -- For a general 'Foldable1' structure this should be semantically identical + -- to: + -- + -- @foldlMap1 f g = foldlMap1 f g . 'toNonEmpty'@ + -- + -- @since 4.18.0.0 + foldlMap1 :: (a -> b) -> (b -> a -> b) -> t a -> b + foldlMap1 f g xs = + appFromMaybe (getDual (foldMap1 ((Dual . FromMaybe) #. h) xs)) Nothing + where + h a Nothing = f a + h a (Just b) = g b a + + -- | 'foldrMap1'' is a variant of 'foldrMap1' that performs strict reduction + -- from right to left, i.e. starting with the right-most element. The input + -- structure /must/ be finite, otherwise 'foldrMap1'' runs out of space + -- (/diverges/). + -- + -- If you want a strict right fold in constant space, you need a structure + -- that supports faster than \(O(n)\) access to the right-most element. + -- + -- This method does not run in constant space for structures such as + -- 'NonEmpty' lists that don't support efficient right-to-left iteration and + -- so require \(O(n)\) space to perform right-to-left reduction. Use of this + -- method with such a structure is a hint that the chosen structure may be a + -- poor fit for the task at hand. If the order in which the elements are + -- combined is not important, use 'foldlMap1'' instead. + -- + -- @since 4.18.0.0 + foldrMap1' :: (a -> b) -> (a -> b -> b) -> t a -> b + foldrMap1' f g xs = + foldlMap1 f' g' xs SNothing + where + f' a SNothing = f a + f' a (SJust b) = g a b + + g' bb a SNothing = bb $! SJust (f a) + g' bb a (SJust b) = bb $! SJust (g a b) + +------------------------------------------------------------------------------- +-- Combinators +------------------------------------------------------------------------------- + +-- | A variant of 'foldrMap1' where the rightmost element maps to itself. +-- +-- @since 4.18.0.0 +foldr1 :: Foldable1 t => (a -> a -> a) -> t a -> a +foldr1 = foldrMap1 id +{-# INLINE foldr1 #-} + +-- | A variant of 'foldrMap1'' where the rightmost element maps to itself. +-- +-- @since 4.18.0.0 +foldr1' :: Foldable1 t => (a -> a -> a) -> t a -> a +foldr1' = foldrMap1' id +{-# INLINE foldr1' #-} + +-- | A variant of 'foldlMap1' where the leftmost element maps to itself. +-- +-- @since 4.18.0.0 +foldl1 :: Foldable1 t => (a -> a -> a) -> t a -> a +foldl1 = foldlMap1 id +{-# INLINE foldl1 #-} + +-- | A variant of 'foldlMap1'' where the leftmost element maps to itself. +-- +-- @since 4.18.0.0 +foldl1' :: Foldable1 t => (a -> a -> a) -> t a -> a +foldl1' = foldlMap1' id +{-# INLINE foldl1' #-} + +-- | Insert an @m@ between each pair of @t m@. +-- +-- >>> intercalate1 ", " $ "hello" :| ["how", "are", "you"] +-- "hello, how, are, you" +-- +-- >>> intercalate1 ", " $ "hello" :| [] +-- "hello" +-- +-- >>> intercalate1 mempty $ "I" :| ["Am", "Fine", "You?"] +-- "IAmFineYou?" +-- +-- @since 4.18.0.0 +intercalate1 :: (Foldable1 t, Semigroup m) => m -> t m -> m +intercalate1 = flip intercalateMap1 id + +intercalateMap1 :: (Foldable1 t, Semigroup m) => m -> (a -> m) -> t a -> m +intercalateMap1 j f = flip joinee j . foldMap1 (JoinWith . const . f) + +-- | Monadic fold over the elements of a non-empty structure, +-- associating to the right, i.e. from right to left. +-- +-- @since 4.18.0.0 +foldrM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a +foldrM1 = foldrMapM1 return + +-- | Map variant of 'foldrM1'. +-- +-- @since 4.18.0.0 +foldrMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (a -> b -> m b) -> t a -> m b +foldrMapM1 g f = go . toNonEmpty + where + go (e:|es) = + case es of + [] -> g e + x:xs -> f e =<< go (x:|xs) + +-- | Monadic fold over the elements of a non-empty structure, +-- associating to the left, i.e. from left to right. +-- +-- @since 4.18.0.0 +foldlM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a +foldlM1 = foldlMapM1 return + +-- | Map variant of 'foldlM1'. +-- +-- @since 4.18.0.0 +foldlMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (b -> a -> m b) -> t a -> m b +foldlMapM1 g f t = g x >>= \y -> foldlM f y xs + where x:|xs = toNonEmpty t + +-- | The largest element of a non-empty structure with respect to the +-- 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 +maximumBy cmp = foldl1' max' + where max' x y = case cmp x y of + GT -> x + _ -> y + +-- | The least element of a non-empty structure with respect to the +-- 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 +minimumBy cmp = foldl1' min' + where min' x y = case cmp x y of + GT -> y + _ -> x + +------------------------------------------------------------------------------- +-- Auxiliary types +------------------------------------------------------------------------------- + +-- | Used for default toNonEmpty implementation. +newtype NonEmptyDList a = NEDL { unNEDL :: [a] -> NonEmpty a } + +instance Semigroup (NonEmptyDList a) where + xs <> ys = NEDL (unNEDL xs . NE.toList . unNEDL ys) + {-# INLINE (<>) #-} + +-- | Create dlist with a single element +singleton :: a -> NonEmptyDList a +singleton = NEDL #. (:|) + +-- | Convert a dlist to a non-empty list +runNonEmptyDList :: NonEmptyDList a -> NonEmpty a +runNonEmptyDList = ($ []) . unNEDL +{-# INLINE runNonEmptyDList #-} + +-- | Used for foldrMap1 and foldlMap1 definitions +newtype FromMaybe b = FromMaybe { appFromMaybe :: Maybe b -> b } + +instance Semigroup (FromMaybe b) where + FromMaybe f <> FromMaybe g = FromMaybe (f . Just . g) + +-- | Strict maybe, used to implement default foldlMap1' etc. +data SMaybe a = SNothing | SJust !a + +-- | Used to implement intercalate1/Map +newtype JoinWith a = JoinWith {joinee :: (a -> a)} + +instance Semigroup a => Semigroup (JoinWith a) where + JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j + +------------------------------------------------------------------------------- +-- Instances for misc base types +------------------------------------------------------------------------------- + +-- | @since 4.18.0.0 +instance Foldable1 NonEmpty where + foldMap1 f (x :| xs) = go (f x) xs where + go y [] = y + go y (z : zs) = y <> go (f z) zs + + foldMap1' f (x :| xs) = foldl' (\m y -> m <> f y) (f x) xs + + toNonEmpty = id + + foldrMap1 g f (x :| xs) = go x xs where + go y [] = g y + go y (z : zs) = f y (go z zs) + + foldlMap1 g f (x :| xs) = foldl f (g x) xs + foldlMap1' g f (x :| xs) = let gx = g x in gx `seq` foldl' f gx xs + + head = NE.head + last = NE.last + +-- | @since 4.18.0.0 +instance Foldable1 Down where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 Complex where + foldMap1 f (x :+ y) = f x <> f y + + toNonEmpty (x :+ y) = x :| y : [] + +------------------------------------------------------------------------------- +-- Instances for tuples +------------------------------------------------------------------------------- + +-- 3+ tuples are not Foldable/Traversable + +-- | @since 4.18.0.0 +instance Foldable1 Solo where + foldMap1 f (MkSolo y) = f y + toNonEmpty (MkSolo x) = x :| [] + minimum (MkSolo x) = x + maximum (MkSolo x) = x + head (MkSolo x) = x + last (MkSolo x) = x + +-- | @since 4.18.0.0 +instance Foldable1 ((,) a) where + foldMap1 f (_, y) = f y + toNonEmpty (_, x) = x :| [] + minimum (_, x) = x + maximum (_, x) = x + head (_, x) = x + last (_, x) = x + +------------------------------------------------------------------------------- +-- Monoid / Semigroup instances +------------------------------------------------------------------------------- + +-- | @since 4.18.0.0 +instance Foldable1 Dual where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 Sum where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 Product where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 Min where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 Max where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 First where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 Last where + foldMap1 = coerce + +-- | @since 4.18.0.0 +deriving instance (Foldable1 f) => Foldable1 (Mon.Alt f) + +-- | @since 4.18.0.0 +deriving instance (Foldable1 f) => Foldable1 (Mon.Ap f) + +------------------------------------------------------------------------------- +-- GHC.Generics instances +------------------------------------------------------------------------------- + +-- | @since 4.18.0.0 +instance Foldable1 V1 where + foldMap1 _ x = x `seq` error "foldMap1 @V1" + +-- | @since 4.18.0.0 +instance Foldable1 Par1 where + foldMap1 = coerce + +-- | @since 4.18.0.0 +deriving instance Foldable1 f => Foldable1 (Rec1 f) + +-- | @since 4.18.0.0 +deriving instance Foldable1 f => Foldable1 (M1 i c f) + +-- | @since 4.18.0.0 +instance (Foldable1 f, Foldable1 g) => Foldable1 (f :+: g) where + foldMap1 f (L1 x) = foldMap1 f x + foldMap1 f (R1 y) = foldMap1 f y + +-- | @since 4.18.0.0 +instance (Foldable1 f, Foldable1 g) => Foldable1 (f :*: g) where + foldMap1 f (x :*: y) = foldMap1 f x <> foldMap1 f y + +-- | @since 4.18.0.0 +instance (Foldable1 f, Foldable1 g) => Foldable1 (f :.: g) where + foldMap1 f = foldMap1 (foldMap1 f) . unComp1 + +------------------------------------------------------------------------------- +-- Extra instances +------------------------------------------------------------------------------- + +-- | @since 4.18.0.0 +instance Foldable1 Identity where + foldMap1 = coerce + + foldrMap1 g _ = coerce g + foldrMap1' g _ = coerce g + foldlMap1 g _ = coerce g + foldlMap1' g _ = coerce g + + toNonEmpty (Identity x) = x :| [] + + last = coerce + head = coerce + minimum = coerce + maximum = coerce + +-- | It would be enough for either half of a product to be 'Foldable1'. +-- Other could be 'Foldable'. +instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Product f g) where + foldMap1 f (Functor.Pair x y) = foldMap1 f x <> foldMap1 f y + foldrMap1 g f (Functor.Pair x y) = foldr f (foldrMap1 g f y) x + + head (Functor.Pair x _) = head x + last (Functor.Pair _ y) = last y + +-- | @since 4.18.0.0 +instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Sum f g) where + foldMap1 f (Functor.InL x) = foldMap1 f x + foldMap1 f (Functor.InR y) = foldMap1 f y + + foldrMap1 g f (Functor.InL x) = foldrMap1 g f x + foldrMap1 g f (Functor.InR y) = foldrMap1 g f y + + toNonEmpty (Functor.InL x) = toNonEmpty x + toNonEmpty (Functor.InR y) = toNonEmpty y + + head (Functor.InL x) = head x + head (Functor.InR y) = head y + last (Functor.InL x) = last x + last (Functor.InR y) = last y + + minimum (Functor.InL x) = minimum x + minimum (Functor.InR y) = minimum y + maximum (Functor.InL x) = maximum x + maximum (Functor.InR y) = maximum y + +-- | @since 4.18.0.0 +instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where + foldMap1 f = foldMap1 (foldMap1 f) . getCompose + + foldrMap1 f g = foldrMap1 (foldrMap1 f g) (\xs x -> foldr g x xs) . getCompose + + head = head . head . getCompose + last = last . last . getCompose + +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c +(#.) _f = coerce diff --git a/src/Data/Function.hs b/src/Data/Function.hs new file mode 100644 --- /dev/null +++ b/src/Data/Function.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Function +-- Copyright : Nils Anders Danielsson 2006 +-- , Alexander Berntsen 2014 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Simple combinators working solely on and with functions. +-- + +module Data.Function + (-- * "Prelude" re-exports + id, + const, + (.), + flip, + ($), + -- * Other combinators + (&), + fix, + on, + applyWhen + ) where + +import GHC.Internal.Data.Function diff --git a/src/Data/Functor.hs b/src/Data/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Functor +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- +-- 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@. +module Data.Functor + (Functor(..), + ($>), + (<$>), + (<&>), + unzip, + void + ) where + +import GHC.Internal.Data.Functor diff --git a/src/Data/Functor/Classes.hs b/src/Data/Functor/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Classes.hs @@ -0,0 +1,1446 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE QuantifiedConstraints #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Classes +-- Copyright : (c) Ross Paterson 2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to +-- unary and binary type constructors. +-- +-- These classes are needed to express the constraints on arguments of +-- transformers in portable Haskell. Thus for a new transformer @T@, +-- one might write instances like +-- +-- > instance (Eq1 f) => Eq1 (T f) where ... +-- > instance (Ord1 f) => Ord1 (T f) where ... +-- > instance (Read1 f) => Read1 (T f) where ... +-- > instance (Show1 f) => Show1 (T f) where ... +-- +-- If these instances can be defined, defining instances of the base +-- classes is mechanical: +-- +-- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1 +-- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1 +-- > instance (Read1 f, Read a) => Read (T f a) where +-- > readPrec = readPrec1 +-- > readListPrec = readListPrecDefault +-- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1 +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Functor.Classes ( + -- * Liftings of Prelude classes + -- ** For unary constructors + Eq1(..), eq1, + Ord1(..), compare1, + Read1(..), readsPrec1, readPrec1, + liftReadListDefault, liftReadListPrecDefault, + Show1(..), showsPrec1, + -- ** For binary constructors + Eq2(..), eq2, + Ord2(..), compare2, + Read2(..), readsPrec2, readPrec2, + liftReadList2Default, liftReadListPrec2Default, + Show2(..), showsPrec2, + -- * Helper functions + -- $example + readsData, readData, + readsUnaryWith, readUnaryWith, + readsBinaryWith, readBinaryWith, + showsUnaryWith, + showsBinaryWith, + -- ** Obsolete helpers + readsUnary, + readsUnary1, + readsBinary1, + showsUnary, + showsUnary1, + showsBinary1, + ) where + +import Control.Applicative (Alternative((<|>)), Const(Const)) + +import GHC.Internal.Data.Functor.Identity (Identity(Identity)) +import GHC.Internal.Data.Proxy (Proxy(Proxy)) +import Data.List.NonEmpty (NonEmpty(..)) +import GHC.Internal.Data.Ord (Down(Down)) +import Data.Complex (Complex((:+))) + +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, readField) +import GHC.Internal.Show (appPrec) + +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 + +-- $setup +-- >>> import Prelude +-- >>> import Data.Complex (Complex (..)) +-- >>> import GHC.Internal.Text.ParserCombinators.ReadPrec + +-- | Lifting of the 'Eq' class to unary type constructors. +-- +-- Any instance should be subject to the following law that canonicity +-- is preserved: +-- +-- @liftEq (==)@ = @(==)@ +-- +-- This class therefore represents the generalization of 'Eq' by +-- decomposing its main method into a canonical lifting on a canonical +-- inner method, so that the lifting can be reused for other arguments +-- than the canonical one. +-- +-- @since 4.9.0.0 +class (forall a. Eq a => Eq (f a)) => Eq1 f where + -- | Lift an equality test through the type constructor. + -- + -- The function will usually be applied to an equality function, + -- but the more general type ensures that the implementation uses + -- it to compare elements of the first container with elements of + -- the second. + -- + -- @since 4.9.0.0 + liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool + default liftEq + :: (f ~ f' c, Eq2 f', Eq c) + => (a -> b -> Bool) -> f a -> f b -> Bool + liftEq = liftEq2 (==) + +-- | Lift the standard @('==')@ function through the type constructor. +-- +-- @since 4.9.0.0 +eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool +eq1 = liftEq (==) + +-- | Lifting of the 'Ord' class to unary type constructors. +-- +-- Any instance should be subject to the following law that canonicity +-- is preserved: +-- +-- @liftCompare compare@ = 'compare' +-- +-- This class therefore represents the generalization of 'Ord' by +-- decomposing its main method into a canonical lifting on a canonical +-- inner method, so that the lifting can be reused for other arguments +-- than the canonical one. +-- +-- @since 4.9.0.0 +class (Eq1 f, forall a. Ord a => Ord (f a)) => Ord1 f where + -- | Lift a 'compare' function through the type constructor. + -- + -- The function will usually be applied to a comparison function, + -- but the more general type ensures that the implementation uses + -- it to compare elements of the first container with elements of + -- the second. + -- + -- @since 4.9.0.0 + liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering + default liftCompare + :: (f ~ f' c, Ord2 f', Ord c) + => (a -> b -> Ordering) -> f a -> f b -> Ordering + liftCompare = liftCompare2 compare + +-- | Lift the standard 'compare' function through the type constructor. +-- +-- @since 4.9.0.0 +compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering +compare1 = liftCompare compare + +-- | Lifting of the 'Read' class to unary type constructors. +-- +-- Any instance should be subject to the following laws that canonicity +-- is preserved: +-- +-- @liftReadsPrec readsPrec readList@ = 'readsPrec' +-- +-- @liftReadList readsPrec readList@ = 'readList' +-- +-- @liftReadPrec readPrec readListPrec@ = 'readPrec' +-- +-- @liftReadListPrec readPrec readListPrec@ = 'readListPrec' +-- +-- This class therefore represents the generalization of 'Read' by +-- decomposing it's methods into a canonical lifting on a canonical +-- inner method, so that the lifting can be reused for other arguments +-- than the canonical one. +-- +-- Both 'liftReadsPrec' and 'liftReadPrec' exist to match the interface +-- provided in the 'Read' type class, but it is recommended to implement +-- 'Read1' instances using 'liftReadPrec' as opposed to 'liftReadsPrec', since +-- the former is more efficient than the latter. For example: +-- +-- @ +-- instance 'Read1' T where +-- 'liftReadPrec' = ... +-- 'liftReadListPrec' = 'liftReadListPrecDefault' +-- @ +-- +-- For more information, refer to the documentation for the 'Read' class. +-- +-- @since 4.9.0.0 +class (forall a. Read a => Read (f a)) => Read1 f where + {-# MINIMAL liftReadsPrec | liftReadPrec #-} + + -- | 'readsPrec' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument type. + -- + -- @since 4.9.0.0 + liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) + liftReadsPrec rp rl = readPrec_to_S $ + liftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl)) + + -- | 'readList' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument type. + -- The default implementation using standard list syntax is correct + -- for most types. + -- + -- @since 4.9.0.0 + liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a] + liftReadList rp rl = readPrec_to_S + (list $ liftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl))) 0 + + -- | 'readPrec' function for an application of the type constructor + -- based on 'readPrec' and 'readListPrec' functions for the argument type. + -- + -- @since 4.10.0.0 + liftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (f a) + liftReadPrec rp rl = readS_to_Prec $ + liftReadsPrec (readPrec_to_S rp) (readPrec_to_S rl 0) + + -- | 'readListPrec' function for an application of the type constructor + -- based on 'readPrec' and 'readListPrec' functions for the argument type. + -- + -- The default definition uses 'liftReadList'. Instances that define + -- 'liftReadPrec' should also define 'liftReadListPrec' as + -- 'liftReadListPrecDefault'. + -- + -- @since 4.10.0.0 + liftReadListPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec [f a] + liftReadListPrec rp rl = readS_to_Prec $ \_ -> + liftReadList (readPrec_to_S rp) (readPrec_to_S rl 0) + +-- | Lift the standard 'readsPrec' and 'readList' functions through the +-- type constructor. +-- +-- @since 4.9.0.0 +readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a) +readsPrec1 = liftReadsPrec readsPrec readList + +-- | Lift the standard 'readPrec' and 'readListPrec' functions through the +-- type constructor. +-- +-- @since 4.10.0.0 +readPrec1 :: (Read1 f, Read a) => ReadPrec (f a) +readPrec1 = liftReadPrec readPrec readListPrec + +-- | A possible replacement definition for the 'liftReadList' method. +-- This is only needed for 'Read1' instances where 'liftReadListPrec' isn't +-- defined as 'liftReadListPrecDefault'. +-- +-- @since 4.10.0.0 +liftReadListDefault :: Read1 f => (Int -> ReadS a) -> ReadS [a] -> ReadS [f a] +liftReadListDefault rp rl = readPrec_to_S + (liftReadListPrec (readS_to_Prec rp) (readS_to_Prec (const rl))) 0 + +-- | A possible replacement definition for the 'liftReadListPrec' method, +-- defined using 'liftReadPrec'. +-- +-- @since 4.10.0.0 +liftReadListPrecDefault :: Read1 f => ReadPrec a -> ReadPrec [a] + -> ReadPrec [f a] +liftReadListPrecDefault rp rl = list (liftReadPrec rp rl) + +-- | Lifting of the 'Show' class to unary type constructors. +-- +-- Any instance should be subject to the following laws that canonicity +-- is preserved: +-- +-- @liftShowsPrec showsPrec showList@ = 'showsPrec' +-- +-- @liftShowList showsPrec showList@ = 'showList' +-- +-- This class therefore represents the generalization of 'Show' by +-- decomposing it's methods into a canonical lifting on a canonical +-- inner method, so that the lifting can be reused for other arguments +-- than the canonical one. +-- +-- @since 4.9.0.0 +class (forall a. Show a => Show (f a)) => Show1 f where + -- | 'showsPrec' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument type. + -- + -- @since 4.9.0.0 + liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + Int -> f a -> ShowS + default liftShowsPrec + :: (f ~ f' b, Show2 f', Show b) + => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS + liftShowsPrec = liftShowsPrec2 showsPrec showList + + -- | 'showList' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument type. + -- The default implementation using standard list syntax is correct + -- for most types. + -- + -- @since 4.9.0.0 + liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + [f a] -> ShowS + liftShowList sp sl = showListWith (liftShowsPrec sp sl 0) + +-- | Lift the standard 'showsPrec' and 'showList' functions through the +-- type constructor. +-- +-- @since 4.9.0.0 +showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS +showsPrec1 = liftShowsPrec showsPrec showList + +-- | Lifting of the 'Eq' class to binary type constructors. +-- +-- @since 4.9.0.0 +class (forall a. Eq a => Eq1 (f a)) => Eq2 f where + -- | Lift equality tests through the type constructor. + -- + -- The function will usually be applied to equality functions, + -- but the more general type ensures that the implementation uses + -- them to compare elements of the first container with elements of + -- the second. + -- + -- @since 4.9.0.0 + liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool + +-- | Lift the standard @('==')@ function through the type constructor. +-- +-- @since 4.9.0.0 +eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool +eq2 = liftEq2 (==) (==) + +-- | Lifting of the 'Ord' class to binary type constructors. +-- +-- @since 4.9.0.0 +class (Eq2 f, forall a. Ord a => Ord1 (f a)) => Ord2 f where + -- | Lift 'compare' functions through the type constructor. + -- + -- The function will usually be applied to comparison functions, + -- but the more general type ensures that the implementation uses + -- them to compare elements of the first container with elements of + -- the second. + -- + -- @since 4.9.0.0 + liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) -> + f a c -> f b d -> Ordering + +-- | Lift the standard 'compare' function through the type constructor. +-- +-- @since 4.9.0.0 +compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering +compare2 = liftCompare2 compare compare + +-- | Lifting of the 'Read' class to binary type constructors. +-- +-- Both 'liftReadsPrec2' and 'liftReadPrec2' exist to match the interface +-- provided in the 'Read' type class, but it is recommended to implement +-- 'Read2' instances using 'liftReadPrec2' as opposed to 'liftReadsPrec2', +-- since the former is more efficient than the latter. For example: +-- +-- @ +-- instance 'Read2' T where +-- 'liftReadPrec2' = ... +-- 'liftReadListPrec2' = 'liftReadListPrec2Default' +-- @ +-- +-- For more information, refer to the documentation for the 'Read' class. +-- +-- @since 4.9.0.0 +class (forall a. Read a => Read1 (f a)) => Read2 f where + {-# MINIMAL liftReadsPrec2 | liftReadPrec2 #-} + + -- | 'readsPrec' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument types. + -- + -- @since 4.9.0.0 + liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] -> + (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b) + liftReadsPrec2 rp1 rl1 rp2 rl2 = readPrec_to_S $ + liftReadPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1)) + (readS_to_Prec rp2) (readS_to_Prec (const rl2)) + + -- | 'readList' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument types. + -- The default implementation using standard list syntax is correct + -- for most types. + -- + -- @since 4.9.0.0 + liftReadList2 :: (Int -> ReadS a) -> ReadS [a] -> + (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b] + liftReadList2 rp1 rl1 rp2 rl2 = readPrec_to_S + (list $ liftReadPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1)) + (readS_to_Prec rp2) (readS_to_Prec (const rl2))) 0 + + -- | 'readPrec' function for an application of the type constructor + -- based on 'readPrec' and 'readListPrec' functions for the argument types. + -- + -- @since 4.10.0.0 + liftReadPrec2 :: ReadPrec a -> ReadPrec [a] -> + ReadPrec b -> ReadPrec [b] -> ReadPrec (f a b) + liftReadPrec2 rp1 rl1 rp2 rl2 = readS_to_Prec $ + liftReadsPrec2 (readPrec_to_S rp1) (readPrec_to_S rl1 0) + (readPrec_to_S rp2) (readPrec_to_S rl2 0) + + -- | 'readListPrec' function for an application of the type constructor + -- based on 'readPrec' and 'readListPrec' functions for the argument types. + -- + -- The default definition uses 'liftReadList2'. Instances that define + -- 'liftReadPrec2' should also define 'liftReadListPrec2' as + -- 'liftReadListPrec2Default'. + -- + -- @since 4.10.0.0 + liftReadListPrec2 :: ReadPrec a -> ReadPrec [a] -> + ReadPrec b -> ReadPrec [b] -> ReadPrec [f a b] + liftReadListPrec2 rp1 rl1 rp2 rl2 = readS_to_Prec $ \_ -> + liftReadList2 (readPrec_to_S rp1) (readPrec_to_S rl1 0) + (readPrec_to_S rp2) (readPrec_to_S rl2 0) + +-- | Lift the standard 'readsPrec' function through the type constructor. +-- +-- @since 4.9.0.0 +readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b) +readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList + +-- | Lift the standard 'readPrec' function through the type constructor. +-- +-- @since 4.10.0.0 +readPrec2 :: (Read2 f, Read a, Read b) => ReadPrec (f a b) +readPrec2 = liftReadPrec2 readPrec readListPrec readPrec readListPrec + +-- | A possible replacement definition for the 'liftReadList2' method. +-- This is only needed for 'Read2' instances where 'liftReadListPrec2' isn't +-- defined as 'liftReadListPrec2Default'. +-- +-- @since 4.10.0.0 +liftReadList2Default :: Read2 f => (Int -> ReadS a) -> ReadS [a] -> + (Int -> ReadS b) -> ReadS [b] ->ReadS [f a b] +liftReadList2Default rp1 rl1 rp2 rl2 = readPrec_to_S + (liftReadListPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1)) + (readS_to_Prec rp2) (readS_to_Prec (const rl2))) 0 + +-- | A possible replacement definition for the 'liftReadListPrec2' method, +-- defined using 'liftReadPrec2'. +-- +-- @since 4.10.0.0 +liftReadListPrec2Default :: Read2 f => ReadPrec a -> ReadPrec [a] -> + ReadPrec b -> ReadPrec [b] -> ReadPrec [f a b] +liftReadListPrec2Default rp1 rl1 rp2 rl2 = list (liftReadPrec2 rp1 rl1 rp2 rl2) + +-- | Lifting of the 'Show' class to binary type constructors. +-- +-- @since 4.9.0.0 +class (forall a. Show a => Show1 (f a)) => Show2 f where + -- | 'showsPrec' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument types. + -- + -- @since 4.9.0.0 + liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS + + -- | 'showList' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument types. + -- The default implementation using standard list syntax is correct + -- for most types. + -- + -- @since 4.9.0.0 + liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS + liftShowList2 sp1 sl1 sp2 sl2 = + showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0) + +-- | Lift the standard 'showsPrec' function through the type constructor. +-- +-- @since 4.9.0.0 +showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS +showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList + +-- Instances for Prelude type constructors + +-- | @since 4.9.0.0 +instance Eq1 Maybe where + liftEq _ Nothing Nothing = True + liftEq _ Nothing (Just _) = False + liftEq _ (Just _) Nothing = False + liftEq eq (Just x) (Just y) = eq x y + +-- | @since 4.9.0.0 +instance Ord1 Maybe where + liftCompare _ Nothing Nothing = EQ + liftCompare _ Nothing (Just _) = LT + liftCompare _ (Just _) Nothing = GT + liftCompare comp (Just x) (Just y) = comp x y + +-- | @since 4.9.0.0 +instance Read1 Maybe where + liftReadPrec rp _ = + parens (expectP (Ident "Nothing") *> pure Nothing) + <|> + readData (readUnaryWith rp "Just" Just) + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since 4.9.0.0 +instance Show1 Maybe where + liftShowsPrec _ _ _ Nothing = showString "Nothing" + liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x + +-- | @since 4.9.0.0 +instance Eq1 [] where + liftEq _ [] [] = True + liftEq _ [] (_:_) = False + liftEq _ (_:_) [] = False + liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys + +-- | @since 4.9.0.0 +instance Ord1 [] where + liftCompare _ [] [] = EQ + liftCompare _ [] (_:_) = LT + liftCompare _ (_:_) [] = GT + liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys + +-- | @since 4.9.0.0 +instance Read1 [] where + liftReadPrec _ rl = rl + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since 4.9.0.0 +instance Show1 [] where + liftShowsPrec _ sl _ = sl + +-- | @since 4.10.0.0 +instance Eq1 NonEmpty where + liftEq eq (a :| as) (b :| bs) = eq a b && liftEq eq as bs + +-- | @since 4.10.0.0 +instance Ord1 NonEmpty where + liftCompare cmp (a :| as) (b :| bs) = cmp a b `mappend` liftCompare cmp as bs + +-- | @since 4.10.0.0 +instance Read1 NonEmpty where + liftReadsPrec rdP rdL p s = readParen (p > 5) (\s' -> do + (a, s'') <- rdP 6 s' + (":|", s''') <- lex s'' + (as, s'''') <- rdL s''' + return (a :| as, s'''')) s + +-- | @since 4.10.0.0 +instance Show1 NonEmpty where + liftShowsPrec shwP shwL p (a :| as) = showParen (p > 5) $ + shwP 6 a . showString " :| " . shwL as + + +-- | @since 4.9.0.0 +instance Eq2 (,) where + liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2 + +-- | @since 4.9.0.0 +instance Ord2 (,) where + liftCompare2 comp1 comp2 (x1, y1) (x2, y2) = + comp1 x1 x2 `mappend` comp2 y1 y2 + +-- | @since 4.9.0.0 +instance Read2 (,) where + liftReadPrec2 rp1 _ rp2 _ = parens $ paren $ do + x <- rp1 + expectP (Punc ",") + y <- rp2 + return (x,y) + + liftReadListPrec2 = liftReadListPrec2Default + liftReadList2 = liftReadList2Default + +-- | @since 4.9.0.0 +instance Show2 (,) where + liftShowsPrec2 sp1 _ sp2 _ _ (x, y) = + showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')' + +-- | @since 4.15 +instance Eq1 Solo where + liftEq eq (MkSolo a) (MkSolo b) = a `eq` b + +-- | @since 4.9.0.0 +instance (Eq a) => Eq1 ((,) a) where + liftEq = liftEq2 (==) + +-- | @since 4.15 +instance Ord1 Solo where + liftCompare cmp (MkSolo a) (MkSolo b) = cmp a b + +-- | @since 4.9.0.0 +instance (Ord a) => Ord1 ((,) a) where + liftCompare = liftCompare2 compare + +-- | @since 4.15 +instance Read1 Solo where + liftReadPrec rp _ = readData (readUnaryWith rp "MkSolo" MkSolo) + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since 4.9.0.0 +instance (Read a) => Read1 ((,) a) where + liftReadPrec = liftReadPrec2 readPrec readListPrec + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since 4.15 +instance Show1 Solo where + liftShowsPrec sp _ d (MkSolo x) = showsUnaryWith sp "MkSolo" d x + +-- | @since 4.9.0.0 +instance (Show a) => Show1 ((,) a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + + +-- | @since 4.16.0.0 +-- +-- >>> eq2 ('x', True, "str") ('x', True, "str") +-- True +-- +instance Eq a => Eq2 ((,,) a) where + liftEq2 e1 e2 (u1, x1, y1) (v1, x2, y2) = + u1 == v1 && + e1 x1 x2 && e2 y1 y2 + +-- | @since 4.16.0.0 +-- +-- >>> compare2 ('x', True, "aaa") ('x', True, "zzz") +-- LT +instance Ord a => Ord2 ((,,) a) where + liftCompare2 comp1 comp2 (u1, x1, y1) (v1, x2, y2) = + compare u1 v1 `mappend` + comp1 x1 x2 `mappend` comp2 y1 y2 + +-- | @since 4.16.0.0 +-- +-- >>> readPrec_to_S readPrec2 0 "('x', True, 2)" :: [((Char, Bool, Int), String)] +-- [(('x',True,2),"")] +-- +instance Read a => Read2 ((,,) a) where + liftReadPrec2 rp1 _ rp2 _ = parens $ paren $ do + x1 <- readPrec + expectP (Punc ",") + y1 <- rp1 + expectP (Punc ",") + y2 <- rp2 + return (x1,y1,y2) + + liftReadListPrec2 = liftReadListPrec2Default + liftReadList2 = liftReadList2Default + +-- | @since 4.16.0.0 +-- +-- >>> showsPrec2 0 ('x', True, 2 :: Int) "" +-- "('x',True,2)" +-- +instance Show a => Show2 ((,,) a) where + liftShowsPrec2 sp1 _ sp2 _ _ (x1,y1,y2) + = showChar '(' . showsPrec 0 x1 + . showChar ',' . sp1 0 y1 + . showChar ',' . sp2 0 y2 + . showChar ')' + +-- | @since 4.16.0.0 +instance (Eq a, Eq b) => Eq1 ((,,) a b) where + liftEq = liftEq2 (==) + +-- | @since 4.16.0.0 +instance (Ord a, Ord b) => Ord1 ((,,) a b) where + liftCompare = liftCompare2 compare + +-- | @since 4.16.0.0 +instance (Read a, Read b) => Read1 ((,,) a b) where + liftReadPrec = liftReadPrec2 readPrec readListPrec + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since 4.16.0.0 +instance (Show a, Show b) => Show1 ((,,) a b) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + + +-- | @since 4.16.0.0 +-- +-- >>> eq2 ('x', True, "str", 2) ('x', True, "str", 2 :: Int) +-- True +-- +instance (Eq a, Eq b) => Eq2 ((,,,) a b) where + liftEq2 e1 e2 (u1, u2, x1, y1) (v1, v2, x2, y2) = + u1 == v1 && + u2 == v2 && + e1 x1 x2 && e2 y1 y2 + +-- | @since 4.16.0.0 +-- +-- >>> compare2 ('x', True, "str", 2) ('x', True, "str", 3 :: Int) +-- LT +-- +instance (Ord a, Ord b) => Ord2 ((,,,) a b) where + liftCompare2 comp1 comp2 (u1, u2, x1, y1) (v1, v2, x2, y2) = + compare u1 v1 `mappend` + compare u2 v2 `mappend` + comp1 x1 x2 `mappend` comp2 y1 y2 + +-- | @since 4.16.0.0 +-- +-- >>> readPrec_to_S readPrec2 0 "('x', True, 2, 4.5)" :: [((Char, Bool, Int, Double), String)] +-- [(('x',True,2,4.5),"")] +-- +instance (Read a, Read b) => Read2 ((,,,) a b) where + liftReadPrec2 rp1 _ rp2 _ = parens $ paren $ do + x1 <- readPrec + expectP (Punc ",") + x2 <- readPrec + expectP (Punc ",") + y1 <- rp1 + expectP (Punc ",") + y2 <- rp2 + return (x1,x2,y1,y2) + + liftReadListPrec2 = liftReadListPrec2Default + liftReadList2 = liftReadList2Default + +-- | @since 4.16.0.0 +-- +-- >>> showsPrec2 0 ('x', True, 2 :: Int, 4.5 :: Double) "" +-- "('x',True,2,4.5)" +-- +instance (Show a, Show b) => Show2 ((,,,) a b) where + liftShowsPrec2 sp1 _ sp2 _ _ (x1,x2,y1,y2) + = showChar '(' . showsPrec 0 x1 + . showChar ',' . showsPrec 0 x2 + . showChar ',' . sp1 0 y1 + . showChar ',' . sp2 0 y2 + . showChar ')' + +-- | @since 4.16.0.0 +instance (Eq a, Eq b, Eq c) => Eq1 ((,,,) a b c) where + liftEq = liftEq2 (==) + +-- | @since 4.16.0.0 +instance (Ord a, Ord b, Ord c) => Ord1 ((,,,) a b c) where + liftCompare = liftCompare2 compare + +-- | @since 4.16.0.0 +instance (Read a, Read b, Read c) => Read1 ((,,,) a b c) where + liftReadPrec = liftReadPrec2 readPrec readListPrec + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since 4.16.0.0 +instance (Show a, Show b, Show c) => Show1 ((,,,) a b c) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +-- | @since 4.17.0.0 +instance (Generic1 f, Eq1 (Rep1 f)) => Eq1 (Generically1 f) where + liftEq :: (a1 -> a2 -> Bool) -> (Generically1 f a1 -> Generically1 f a2 -> Bool) + liftEq (===) (Generically1 as1) (Generically1 as2) = liftEq (===) (from1 as1) (from1 as2) + +-- | @since 4.17.0.0 +instance (Generic1 f, Ord1 (Rep1 f)) => Ord1 (Generically1 f) where + liftCompare :: (a1 -> a2 -> Ordering) -> (Generically1 f a1 -> Generically1 f a2 -> Ordering) + liftCompare cmp (Generically1 as1) (Generically1 as2) = liftCompare cmp (from1 as1) (from1 as2) + +-- | @since 4.9.0.0 +instance Eq2 Either where + liftEq2 e1 _ (Left x) (Left y) = e1 x y + liftEq2 _ _ (Left _) (Right _) = False + liftEq2 _ _ (Right _) (Left _) = False + liftEq2 _ e2 (Right x) (Right y) = e2 x y + +-- | @since 4.9.0.0 +instance Ord2 Either where + liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y + liftCompare2 _ _ (Left _) (Right _) = LT + liftCompare2 _ _ (Right _) (Left _) = GT + liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y + +-- | @since 4.9.0.0 +instance Read2 Either where + liftReadPrec2 rp1 _ rp2 _ = readData $ + readUnaryWith rp1 "Left" Left <|> + readUnaryWith rp2 "Right" Right + + liftReadListPrec2 = liftReadListPrec2Default + liftReadList2 = liftReadList2Default + +-- | @since 4.9.0.0 +instance Show2 Either where + liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x + liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x + +-- | @since 4.9.0.0 +instance (Eq a) => Eq1 (Either a) where + liftEq = liftEq2 (==) + +-- | @since 4.9.0.0 +instance (Ord a) => Ord1 (Either a) where + liftCompare = liftCompare2 compare + +-- | @since 4.9.0.0 +instance (Read a) => Read1 (Either a) where + liftReadPrec = liftReadPrec2 readPrec readListPrec + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since 4.9.0.0 +instance (Show a) => Show1 (Either a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +-- Instances for other functors defined in the base package + +-- | @since 4.9.0.0 +instance Eq1 Identity where + liftEq eq (Identity x) (Identity y) = eq x y + +-- | @since 4.9.0.0 +instance Ord1 Identity where + liftCompare comp (Identity x) (Identity y) = comp x y + +-- | @since 4.9.0.0 +instance Read1 Identity where + liftReadPrec rp _ = readData $ + readUnaryWith rp "Identity" Identity + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since 4.9.0.0 +instance Show1 Identity where + liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x + +-- | @since 4.9.0.0 +instance Eq2 Const where + liftEq2 eq _ (Const x) (Const y) = eq x y + +-- | @since 4.9.0.0 +instance Ord2 Const where + liftCompare2 comp _ (Const x) (Const y) = comp x y + +-- | @since 4.9.0.0 +instance Read2 Const where + liftReadPrec2 rp _ _ _ = readData $ + readUnaryWith rp "Const" Const + + liftReadListPrec2 = liftReadListPrec2Default + liftReadList2 = liftReadList2Default + +-- | @since 4.9.0.0 +instance Show2 Const where + liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x + +-- | @since 4.9.0.0 +instance (Eq a) => Eq1 (Const a) where + liftEq = liftEq2 (==) +-- | @since 4.9.0.0 +instance (Ord a) => Ord1 (Const a) where + liftCompare = liftCompare2 compare +-- | @since 4.9.0.0 +instance (Read a) => Read1 (Const a) where + liftReadPrec = liftReadPrec2 readPrec readListPrec + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault +-- | @since 4.9.0.0 +instance (Show a) => Show1 (Const a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +-- Proxy unfortunately imports this module, hence these instances are placed +-- here, +-- | @since 4.9.0.0 +instance Eq1 Proxy where + liftEq _ _ _ = True + +-- | @since 4.9.0.0 +instance Ord1 Proxy where + liftCompare _ _ _ = EQ + +-- | @since 4.9.0.0 +instance Show1 Proxy where + liftShowsPrec _ _ _ _ = showString "Proxy" + +-- | @since 4.9.0.0 +instance Read1 Proxy where + liftReadPrec _ _ = parens (expectP (Ident "Proxy") *> pure Proxy) + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since 4.12.0.0 +instance Eq1 Down where + liftEq eq (Down x) (Down y) = eq x y + +-- | @since 4.12.0.0 +instance Ord1 Down where + liftCompare comp (Down x) (Down y) = case comp x y of + LT -> GT + EQ -> EQ + GT -> LT + +-- | @since 4.12.0.0 +instance Read1 Down where + liftReadsPrec rp _ = readsData $ + readsUnaryWith rp "Down" Down + +-- | @since 4.12.0.0 +instance Show1 Down where + liftShowsPrec sp _ d (Down x) = showsUnaryWith sp "Down" d x + +-- | @since 4.16.0.0 +-- +-- >>> eq1 (1 :+ 2) (1 :+ 2) +-- True +-- +-- >>> eq1 (1 :+ 2) (1 :+ 3) +-- False +-- +instance Eq1 Complex where + liftEq eq (x :+ y) (u :+ v) = eq x u && eq y v + +-- | @since 4.16.0.0 +-- +-- >>> readPrec_to_S readPrec1 0 "(2 % 3) :+ (3 % 4)" :: [(Complex Rational, String)] +-- [(2 % 3 :+ 3 % 4,"")] +-- +instance Read1 Complex where + liftReadPrec rp _ = parens $ prec complexPrec $ do + x <- step rp + expectP (Symbol ":+") + y <- step rp + return (x :+ y) + where + complexPrec = 6 + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since 4.16.0.0 +-- +-- >>> showsPrec1 0 (2 :+ 3) "" +-- "2 :+ 3" +-- +instance Show1 Complex where + liftShowsPrec sp _ d (x :+ y) = showParen (d > complexPrec) $ + sp (complexPrec+1) x . showString " :+ " . sp (complexPrec+1) y + where + complexPrec = 6 + +-- Building blocks + +-- | @'readsData' p d@ is a parser for datatypes where each alternative +-- begins with a data constructor. It parses the constructor and +-- passes it to @p@. Parsers for various constructors can be constructed +-- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with +-- @mappend@ from the @Monoid@ class. +-- +-- @since 4.9.0.0 +readsData :: (String -> ReadS a) -> Int -> ReadS a +readsData reader d = + readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s] + +-- | @'readData' p@ is a parser for datatypes where each alternative +-- begins with a data constructor. It parses the constructor and +-- passes it to @p@. Parsers for various constructors can be constructed +-- with 'readUnaryWith' and 'readBinaryWith', and combined with +-- '(<|>)' from the 'Alternative' class. +-- +-- @since 4.10.0.0 +readData :: ReadPrec a -> ReadPrec a +readData reader = parens $ prec 10 reader + +-- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor +-- and then parses its argument using @rp@. +-- +-- @since 4.9.0.0 +readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t +readsUnaryWith rp name cons kw s = + [(cons x,t) | kw == name, (x,t) <- rp 11 s] + +-- | @'readUnaryWith' rp n c'@ matches the name of a unary data constructor +-- and then parses its argument using @rp@. +-- +-- @since 4.10.0.0 +readUnaryWith :: ReadPrec a -> String -> (a -> t) -> ReadPrec t +readUnaryWith rp name cons = do + expectP $ Ident name + x <- step rp + return $ cons x + +-- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary +-- data constructor and then parses its arguments using @rp1@ and @rp2@ +-- respectively. +-- +-- @since 4.9.0.0 +readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) -> + String -> (a -> b -> t) -> String -> ReadS t +readsBinaryWith rp1 rp2 name cons kw s = + [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t] + +-- | @'readBinaryWith' rp1 rp2 n c'@ matches the name of a binary +-- data constructor and then parses its arguments using @rp1@ and @rp2@ +-- respectively. +-- +-- @since 4.10.0.0 +readBinaryWith :: ReadPrec a -> ReadPrec b -> + String -> (a -> b -> t) -> ReadPrec t +readBinaryWith rp1 rp2 name cons = do + expectP $ Ident name + x <- step rp1 + y <- step rp2 + return $ cons x y + +-- | @'showsUnaryWith' sp n d x@ produces the string representation of a +-- unary data constructor with name @n@ and argument @x@, in precedence +-- context @d@. +-- +-- @since 4.9.0.0 +showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS +showsUnaryWith sp name d x = showParen (d > 10) $ + showString name . showChar ' ' . sp 11 x + +-- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string +-- representation of a binary data constructor with name @n@ and arguments +-- @x@ and @y@, in precedence context @d@. +-- +-- @since 4.9.0.0 +showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> + String -> Int -> a -> b -> ShowS +showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $ + showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y + +-- Obsolete building blocks + +-- | @'readsUnary' n c n'@ matches the name of a unary data constructor +-- and then parses its argument using 'readsPrec'. +-- +-- @since 4.9.0.0 +{-# DEPRECATED readsUnary "Use 'readsUnaryWith' to define 'liftReadsPrec'" #-} +readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t +readsUnary name cons kw s = + [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s] + +-- | @'readsUnary1' n c n'@ matches the name of a unary data constructor +-- and then parses its argument using 'readsPrec1'. +-- +-- @since 4.9.0.0 +{-# DEPRECATED readsUnary1 "Use 'readsUnaryWith' to define 'liftReadsPrec'" #-} +readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t +readsUnary1 name cons kw s = + [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s] + +-- | @'readsBinary1' n c n'@ matches the name of a binary data constructor +-- and then parses its arguments using 'readsPrec1'. +-- +-- @since 4.9.0.0 +{-# DEPRECATED readsBinary1 + "Use 'readsBinaryWith' to define 'liftReadsPrec'" #-} +readsBinary1 :: (Read1 f, Read1 g, Read a) => + String -> (f a -> g a -> t) -> String -> ReadS t +readsBinary1 name cons kw s = + [(cons x y,u) | kw == name, + (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t] + +-- | @'showsUnary' n d x@ produces the string representation of a unary data +-- constructor with name @n@ and argument @x@, in precedence context @d@. +-- +-- @since 4.9.0.0 +{-# DEPRECATED showsUnary "Use 'showsUnaryWith' to define 'liftShowsPrec'" #-} +showsUnary :: (Show a) => String -> Int -> a -> ShowS +showsUnary name d x = showParen (d > 10) $ + showString name . showChar ' ' . showsPrec 11 x + +-- | @'showsUnary1' n d x@ produces the string representation of a unary data +-- constructor with name @n@ and argument @x@, in precedence context @d@. +-- +-- @since 4.9.0.0 +{-# DEPRECATED showsUnary1 "Use 'showsUnaryWith' to define 'liftShowsPrec'" #-} +showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS +showsUnary1 name d x = showParen (d > 10) $ + showString name . showChar ' ' . showsPrec1 11 x + +-- | @'showsBinary1' n d x y@ produces the string representation of a binary +-- data constructor with name @n@ and arguments @x@ and @y@, in precedence +-- context @d@. +-- +-- @since 4.9.0.0 +{-# DEPRECATED showsBinary1 + "Use 'showsBinaryWith' to define 'liftShowsPrec'" #-} +showsBinary1 :: (Show1 f, Show1 g, Show a) => + String -> Int -> f a -> g a -> ShowS +showsBinary1 name d x y = showParen (d > 10) $ + showString name . showChar ' ' . showsPrec1 11 x . + showChar ' ' . showsPrec1 11 y + +{- $example +These functions can be used to assemble 'Read' and 'Show' instances for +new algebraic types. For example, given the definition + +> data T f a = Zero a | One (f a) | Two a (f a) + +a standard 'Read1' instance may be defined as + +> instance (Read1 f) => Read1 (T f) where +> liftReadPrec rp rl = readData $ +> readUnaryWith rp "Zero" Zero <|> +> readUnaryWith (liftReadPrec rp rl) "One" One <|> +> readBinaryWith rp (liftReadPrec rp rl) "Two" Two +> liftReadListPrec = liftReadListPrecDefault + +and the corresponding 'Show1' instance as + +> instance (Show1 f) => Show1 (T f) where +> liftShowsPrec sp _ d (Zero x) = +> showsUnaryWith sp "Zero" d x +> liftShowsPrec sp sl d (One x) = +> showsUnaryWith (liftShowsPrec sp sl) "One" d x +> liftShowsPrec sp sl d (Two x y) = +> 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 new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Compose.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Compose +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Composition of functors. +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Functor.Compose ( + Compose(..), + ) where + +import Data.Functor.Classes + +import Control.Applicative +import GHC.Internal.Data.Coerce (coerce) +import GHC.Internal.Data.Data (Data) +import GHC.Internal.Data.Foldable (Foldable(..)) +import GHC.Internal.Data.Monoid (Sum(..), All(..), Any(..), Product(..)) +import GHC.Internal.Data.Type.Equality (TestEquality(..), (:~:)(..)) +import GHC.Generics (Generic, Generic1) +import GHC.Internal.Text.Read (Read(..), ReadPrec, readListDefault, readListPrecDefault) +import Prelude + +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. +-- +-- ==== __Examples__ +-- +-- >>> fmap (subtract 1) (Compose (Just [1, 2, 3])) +-- Compose (Just [0,1,2]) +-- +-- >>> Compose (Just [1, 2, 3]) <> Compose Nothing +-- Compose (Just [1,2,3]) +-- +-- >>> Compose (Just [(++ "World"), (++ "Haskell")]) <*> Compose (Just ["Hello, "]) +-- Compose (Just ["Hello, World","Hello, Haskell"]) +newtype Compose f g a = Compose { getCompose :: f (g a) } + deriving ( Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + , Semigroup -- ^ @since 4.16.0.0 + , Monoid -- ^ @since 4.16.0.0 + ) + +-- Instances of Prelude classes + +-- | @since 4.18.0.0 +deriving instance Eq (f (g a)) => Eq (Compose f g a) +-- | @since 4.18.0.0 +deriving instance Ord (f (g a)) => Ord (Compose f g a) +-- | @since 4.18.0.0 +instance Read (f (g a)) => Read (Compose f g a) where + readPrec = liftReadPrecCompose readPrec + + readListPrec = readListPrecDefault + readList = readListDefault +-- | @since 4.18.0.0 +instance Show (f (g a)) => Show (Compose f g a) where + showsPrec = liftShowsPrecCompose showsPrec + +-- Instances of lifted Prelude classes + +-- | @since 4.9.0.0 +instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where + liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y + +-- | @since 4.9.0.0 +instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where + liftCompare comp (Compose x) (Compose y) = + liftCompare (liftCompare comp) x y + +-- | @since 4.9.0.0 +instance (Read1 f, Read1 g) => Read1 (Compose f g) where + liftReadPrec rp rl = + liftReadPrecCompose (liftReadPrec rp' rl') + where + rp' = liftReadPrec rp rl + rl' = liftReadListPrec rp rl + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since 4.9.0.0 +instance (Show1 f, Show1 g) => Show1 (Compose f g) where + liftShowsPrec sp sl = + liftShowsPrecCompose (liftShowsPrec sp' sl') + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +-- The workhorse for Compose's Read and Read1 instances. +liftReadPrecCompose :: ReadPrec (f (g a)) -> ReadPrec (Compose f g a) +liftReadPrecCompose rp = readData $ readUnaryWith rp "Compose" Compose + +-- The workhorse for Compose's Show and Show1 instances. +liftShowsPrecCompose :: (Int -> f (g a) -> ShowS) -> Int -> Compose f g a -> ShowS +liftShowsPrecCompose sp d (Compose x) = showsUnaryWith sp "Compose" d x + +-- Functor instances + +-- | @since 4.9.0.0 +instance (Functor f, Functor g) => Functor (Compose f g) where + fmap f (Compose x) = Compose (fmap (fmap f) x) + a <$ (Compose x) = Compose (fmap (a <$) x) + +-- | @since 4.9.0.0 +instance (Foldable f, Foldable g) => Foldable (Compose f g) where + fold (Compose t) = foldMap fold t + foldMap f (Compose t) = foldMap (foldMap f) t + foldMap' f (Compose t) = foldMap' (foldMap' f) t + foldr f b (Compose fga) = foldr (\ga acc -> foldr f acc ga) b fga + foldr' f b (Compose fga) = foldr' (\ga acc -> foldr' f acc ga) b fga + foldl f b (Compose fga) = foldl (\acc ga -> foldl f acc ga) b fga + foldl' f b (Compose fga) = foldl' (\acc ga -> foldl' f acc ga) b fga + + null (Compose t) = null t || getAll (foldMap (All . null) t) + length (Compose t) = getSum (foldMap' (Sum . length) t) + elem x (Compose t) = getAny (foldMap (Any . elem x) t) + + minimum (Compose fga) = minimum $ map minimum $ filter (not . null) $ toList fga + maximum (Compose fga) = maximum $ map maximum $ filter (not . null) $ toList fga + + sum (Compose t) = getSum (foldMap' (Sum . sum) t) + product (Compose t) = getProduct (foldMap' (Product . product) t) + +-- | @since 4.9.0.0 +instance (Traversable f, Traversable g) => Traversable (Compose f g) where + traverse f (Compose t) = Compose <$> traverse (traverse f) t + +-- | @since 4.9.0.0 +instance (Applicative f, Applicative g) => Applicative (Compose f g) where + pure x = Compose (pure (pure x)) + Compose f <*> Compose x = Compose (liftA2 (<*>) f x) + liftA2 f (Compose x) (Compose y) = + Compose (liftA2 (liftA2 f) x y) + +-- | @since 4.9.0.0 +instance (Alternative f, Applicative g) => Alternative (Compose f g) where + empty = Compose empty + (<|>) = coerce ((<|>) :: f (g a) -> f (g a) -> f (g a)) + :: forall a . Compose f g a -> Compose f g a -> Compose f g a + some = coerce (fmap sequenceA . some :: f (g a) -> f (g [a])) + :: forall a . Compose f g a -> Compose f g [a] + many = coerce (fmap sequenceA . many :: f (g a) -> f (g [a])) + :: forall a . Compose f g a -> Compose f g [a] + +-- | The deduction (via generativity) that if @g x :~: g y@ then @x :~: y@. +-- +-- @since 4.14.0.0 +instance (TestEquality f) => TestEquality (Compose f g) where + testEquality (Compose x) (Compose y) = + case testEquality x y of -- :: Maybe (g x :~: g y) + Just Refl -> Just Refl -- :: Maybe (x :~: y) + Nothing -> Nothing + +-- | @since 4.19.0.0 +deriving instance Enum (f (g a)) => Enum (Compose f g a) +-- | @since 4.19.0.0 +deriving instance Bounded (f (g a)) => Bounded (Compose f g a) +-- | @since 4.19.0.0 +deriving instance Num (f (g a)) => Num (Compose f g a) +-- | @since 4.19.0.0 +deriving instance Real (f (g a)) => Real (Compose f g a) +-- | @since 4.19.0.0 +deriving instance Integral (f (g a)) => Integral (Compose f g a) +-- | @since 4.20.0.0 +deriving instance Fractional (f (g a)) => Fractional (Compose f g a) +-- | @since 4.20.0.0 +deriving instance RealFrac (f (g a)) => RealFrac (Compose f g a) +-- | @since 4.20.0.0 +deriving instance Floating (f (g a)) => Floating (Compose f g a) +-- | @since 4.20.0.0 +deriving instance RealFloat (f (g a)) => RealFloat (Compose f g a) diff --git a/src/Data/Functor/Const.hs b/src/Data/Functor/Const.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Const.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Functor.Const +-- Copyright : Conor McBride and Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable + +module Data.Functor.Const + (Const(..) + ) where + +import GHC.Internal.Data.Functor.Const diff --git a/src/Data/Functor/Contravariant.hs b/src/Data/Functor/Contravariant.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Contravariant.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Contravariant +-- Copyright : (C) 2007-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@, +-- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor' +-- the definition of 'Contravariant' for a given ADT is unambiguous. +-- +-- @since 4.12.0.0 +---------------------------------------------------------------------------- + +module Data.Functor.Contravariant ( + -- * Contravariant Functors + Contravariant(..) + , phantom + + -- * Operators + , (>$<), (>$$<), ($<) + + -- * Predicates + , Predicate(..) + + -- * Comparisons + , Comparison(..) + , defaultComparison + + -- * Equivalence Relations + , Equivalence(..) + , defaultEquivalence + , comparisonEquivalence + + -- * Dual arrows + , Op(..) + ) where + +import Control.Applicative +import GHC.Internal.Control.Category +import GHC.Internal.Data.Function (on) + +import Data.Functor.Product +import Data.Functor.Sum +import Data.Functor.Compose + +import GHC.Internal.Data.Monoid (Alt(..), All(..)) +import GHC.Internal.Data.Proxy +import GHC.Generics + +import Prelude hiding ((.), id) + +-- | The class of contravariant functors. +-- +-- Whereas in Haskell, one can think of a 'Functor' as containing or producing +-- values, a contravariant functor is a functor that can be thought of as +-- /consuming/ values. +-- +-- As an example, consider the type of predicate functions @a -> Bool@. One +-- such predicate might be @negative x = x < 0@, which +-- classifies integers as to whether they are negative. However, given this +-- predicate, we can re-use it in other situations, providing we have a way to +-- map values /to/ integers. For instance, we can use the @negative@ predicate +-- on a person's bank balance to work out if they are currently overdrawn: +-- +-- @ +-- newtype Predicate a = Predicate { getPredicate :: a -> Bool } +-- +-- instance Contravariant Predicate where +-- contramap :: (a' -> a) -> (Predicate a -> Predicate a') +-- contramap f (Predicate p) = Predicate (p . f) +-- | `- First, map the input... +-- `----- then apply the predicate. +-- +-- overdrawn :: Predicate Person +-- overdrawn = contramap personBankBalance negative +-- @ +-- +-- Any instance should be subject to the following laws: +-- +-- [Identity] @'contramap' 'id' = 'id'@ +-- [Composition] @'contramap' (g . f) = 'contramap' f . 'contramap' g@ +-- +-- Note, that the second law follows from the free theorem of the type of +-- 'contramap' and the first law, so you need only check that the former +-- condition holds. + +class Contravariant f where + contramap :: (a' -> a) -> (f a -> f a') + + -- | Replace all locations in the output with the same value. + -- The default definition is @'contramap' . 'const'@, but this may be + -- overridden with a more efficient version. + (>$) :: b -> f b -> f a + (>$) = contramap . const + +-- | If @f@ is both 'Functor' and 'Contravariant' then by the time you factor +-- in the laws of each of those classes, it can't actually use its argument in +-- any meaningful capacity. +-- +-- This method is surprisingly useful. Where both instances exist and are +-- lawful we have the following laws: +-- +-- @ +-- 'fmap' f ≡ 'phantom' +-- 'contramap' f ≡ 'phantom' +-- @ +phantom :: (Functor f, Contravariant f) => f a -> f b +phantom x = () <$ x $< () + +infixl 4 >$, $<, >$<, >$$< + +-- | This is '>$' with its arguments flipped. +($<) :: Contravariant f => f b -> b -> f a +($<) = flip (>$) + +-- | This is an infix alias for 'contramap'. +(>$<) :: Contravariant f => (a -> b) -> (f b -> f a) +(>$<) = contramap + +-- | This is an infix version of 'contramap' with the arguments flipped. +(>$$<) :: Contravariant f => f b -> (a -> b) -> f a +(>$$<) = flip contramap + +deriving newtype instance Contravariant f => Contravariant (Alt f) +deriving newtype instance Contravariant f => Contravariant (Rec1 f) +deriving newtype instance Contravariant f => Contravariant (M1 i c f) + +instance Contravariant V1 where + contramap :: (a' -> a) -> (V1 a -> V1 a') + contramap _ x = case x of + +instance Contravariant U1 where + contramap :: (a' -> a) -> (U1 a -> U1 a') + contramap _ _ = U1 + +instance Contravariant (K1 i c) where + contramap :: (a' -> a) -> (K1 i c a -> K1 i c a') + contramap _ (K1 c) = K1 c + +instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where + contramap :: (a' -> a) -> ((f :*: g) a -> (f :*: g) a') + contramap f (xs :*: ys) = contramap f xs :*: contramap f ys + +instance (Functor f, Contravariant g) => Contravariant (f :.: g) where + contramap :: (a' -> a) -> ((f :.: g) a -> (f :.: g) a') + contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg) + +instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where + contramap :: (a' -> a) -> ((f :+: g) a -> (f :+: g) a') + contramap f (L1 xs) = L1 (contramap f xs) + contramap f (R1 ys) = R1 (contramap f ys) + +instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where + contramap :: (a' -> a) -> (Sum f g a -> Sum f g a') + contramap f (InL xs) = InL (contramap f xs) + contramap f (InR ys) = InR (contramap f ys) + +instance (Contravariant f, Contravariant g) + => Contravariant (Product f g) where + contramap :: (a' -> a) -> (Product f g a -> Product f g a') + contramap f (Pair a b) = Pair (contramap f a) (contramap f b) + +instance Contravariant (Const a) where + contramap :: (b' -> b) -> (Const a b -> Const a b') + contramap _ (Const a) = Const a + +instance (Functor f, Contravariant g) => Contravariant (Compose f g) where + contramap :: (a' -> a) -> (Compose f g a -> Compose f g a') + contramap f (Compose fga) = Compose (fmap (contramap f) fga) + +instance Contravariant Proxy where + contramap :: (a' -> a) -> (Proxy a -> Proxy a') + contramap _ _ = Proxy + +newtype Predicate a = Predicate { getPredicate :: a -> Bool } + deriving + ( -- | @('<>')@ on predicates uses logical conjunction @('&&')@ on + -- the results. Without newtypes this equals @'liftA2' (&&)@. + -- + -- @ + -- (<>) :: Predicate a -> Predicate a -> Predicate a + -- Predicate pred <> Predicate pred' = Predicate \a -> + -- pred a && pred' a + -- @ + Semigroup + , -- | @'mempty'@ on predicates always returns @True@. Without + -- newtypes this equals @'pure' True@. + -- + -- @ + -- mempty :: Predicate a + -- mempty = \_ -> True + -- @ + Monoid + ) + via a -> All + + deriving + ( -- | A 'Predicate' is a 'Contravariant' 'Functor', because + -- 'contramap' can apply its function argument to the input of + -- the predicate. + -- + -- Without newtypes @'contramap' f@ equals precomposing with @f@ + -- (= @(. f)@). + -- + -- @ + -- contramap :: (a' -> a) -> (Predicate a -> Predicate a') + -- contramap f (Predicate g) = Predicate (g . f) + -- @ + Contravariant + ) + via Op Bool + +-- | Defines a total ordering on a type as per 'compare'. +-- +-- This condition is not checked by the types. You must ensure that the +-- supplied values are valid total orderings yourself. +newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering } + deriving + newtype + ( -- | @('<>')@ on comparisons combines results with @('<>') + -- \@Ordering@. Without newtypes this equals @'liftA2' ('liftA2' + -- ('<>'))@. + -- + -- @ + -- (<>) :: Comparison a -> Comparison a -> Comparison a + -- Comparison cmp <> Comparison cmp' = Comparison \a a' -> + -- cmp a a' <> cmp a a' + -- @ + Semigroup + , -- | @'mempty'@ on comparisons always returns @EQ@. Without + -- newtypes this equals @'pure' ('pure' EQ)@. + -- + -- @ + -- mempty :: Comparison a + -- mempty = Comparison \_ _ -> EQ + -- @ + Monoid + ) + +-- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can +-- apply its function argument to each input of the comparison function. +instance Contravariant Comparison where + contramap :: (a' -> a) -> (Comparison a -> Comparison a') + contramap f (Comparison g) = Comparison (on g f) + +-- | Compare using 'compare'. +defaultComparison :: Ord a => Comparison a +defaultComparison = Comparison compare + +-- | This data type represents an equivalence relation. +-- +-- Equivalence relations are expected to satisfy three laws: +-- +-- [Reflexivity]: @'getEquivalence' f a a = True@ +-- [Symmetry]: @'getEquivalence' f a b = 'getEquivalence' f b a@ +-- [Transitivity]: +-- If @'getEquivalence' f a b@ and @'getEquivalence' f b c@ are both 'True' +-- then so is @'getEquivalence' f a c@. +-- +-- The types alone do not enforce these laws, so you'll have to check them +-- yourself. +newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool } + deriving + ( -- | @('<>')@ on equivalences uses logical conjunction @('&&')@ + -- on the results. Without newtypes this equals @'liftA2' + -- ('liftA2' (&&))@. + -- + -- @ + -- (<>) :: Equivalence a -> Equivalence a -> Equivalence a + -- Equivalence equiv <> Equivalence equiv' = Equivalence \a b -> + -- equiv a b && equiv' a b + -- @ + Semigroup + , -- | @'mempty'@ on equivalences always returns @True@. Without + -- newtypes this equals @'pure' ('pure' True)@. + -- + -- @ + -- mempty :: Equivalence a + -- mempty = Equivalence \_ _ -> True + -- @ + Monoid + ) + via a -> a -> All + +-- | Equivalence relations are 'Contravariant', because you can +-- apply the contramapped function to each input to the equivalence +-- relation. +instance Contravariant Equivalence where + contramap :: (a' -> a) -> (Equivalence a -> Equivalence a') + contramap f (Equivalence g) = Equivalence (on g f) + +-- | Check for equivalence with '=='. +-- +-- Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@. +defaultEquivalence :: Eq a => Equivalence a +defaultEquivalence = Equivalence (==) + +comparisonEquivalence :: Comparison a -> Equivalence a +comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ + +-- | Dual function arrows. +newtype Op a b = Op { getOp :: b -> a } + deriving + newtype + ( -- | @('<>') \@(Op a b)@ without newtypes is @('<>') \@(b->a)@ = + -- @liftA2 ('<>')@. This lifts the 'Semigroup' operation + -- @('<>')@ over the output of @a@. + -- + -- @ + -- (<>) :: Op a b -> Op a b -> Op a b + -- Op f <> Op g = Op \a -> f a <> g a + -- @ + Semigroup + , -- | @'mempty' \@(Op a b)@ without newtypes is @mempty \@(b->a)@ + -- = @\_ -> mempty@. + -- + -- @ + -- mempty :: Op a b + -- mempty = Op \_ -> mempty + -- @ + Monoid + ) + +instance Category Op where + id :: Op a a + id = Op id + + (.) :: Op b c -> Op a b -> Op a c + Op f . Op g = Op (g . f) + +instance Contravariant (Op a) where + contramap :: (b' -> b) -> (Op a b -> Op a b') + contramap f g = Op (getOp g . f) + +instance Num a => Num (Op a b) where + Op f + Op g = Op $ \a -> f a + g a + Op f * Op g = Op $ \a -> f a * g a + Op f - Op g = Op $ \a -> f a - g a + abs (Op f) = Op $ abs . f + signum (Op f) = Op $ signum . f + fromInteger = Op . const . fromInteger + +instance Fractional a => Fractional (Op a b) where + Op f / Op g = Op $ \a -> f a / g a + recip (Op f) = Op $ recip . f + fromRational = Op . const . fromRational + +instance Floating a => Floating (Op a b) where + pi = Op $ const pi + exp (Op f) = Op $ exp . f + sqrt (Op f) = Op $ sqrt . f + log (Op f) = Op $ log . f + sin (Op f) = Op $ sin . f + tan (Op f) = Op $ tan . f + cos (Op f) = Op $ cos . f + asin (Op f) = Op $ asin . f + atan (Op f) = Op $ atan . f + acos (Op f) = Op $ acos . f + sinh (Op f) = Op $ sinh . f + tanh (Op f) = Op $ tanh . f + cosh (Op f) = Op $ cosh . f + asinh (Op f) = Op $ asinh . f + atanh (Op f) = Op $ atanh . f + acosh (Op f) = Op $ acosh . f + Op f ** Op g = Op $ \a -> f a ** g a + logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a) diff --git a/src/Data/Functor/Identity.hs b/src/Data/Functor/Identity.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Identity.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Functor.Identity +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : stable +-- Portability : portable +-- +-- The identity functor and monad. +-- +-- This trivial type constructor serves two purposes: +-- +-- * It can be used with functions parameterized by functor or monad classes. +-- +-- * It can be used as a base monad to which a series of monad +-- transformers may be applied to construct a composite monad. +-- Most monad transformer modules include the special case of +-- applying the transformer to 'Identity'. For example, @State s@ +-- is an abbreviation for @StateT s 'Identity'@. +-- +-- @since 4.8.0.0 + +module Data.Functor.Identity + (Identity(..) + ) where + +import GHC.Internal.Data.Functor.Identity diff --git a/src/Data/Functor/Product.hs b/src/Data/Functor/Product.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Product.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Product +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Products, lifted to functors. +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Functor.Product ( + Product(..), + ) where + +import Control.Applicative +import GHC.Internal.Control.Monad (MonadPlus(..)) +import GHC.Internal.Control.Monad.Fix (MonadFix(..)) +import Control.Monad.Zip (MonadZip(mzipWith)) +import GHC.Internal.Data.Data (Data) +import Data.Functor.Classes +import GHC.Generics (Generic, Generic1) +import Prelude + +-- $setup +-- >>> import Prelude + +-- | Lifted product of functors. +-- +-- ==== __Examples__ +-- +-- >>> fmap (+1) (Pair [1, 2, 3] (Just 0)) +-- Pair [2,3,4] (Just 1) +-- +-- >>> Pair "Hello, " (Left 'x') <> Pair "World" (Right 'y') +-- Pair "Hello, World" (Right 'y') +data Product f g a = Pair (f a) (g a) + deriving ( Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) + +-- | @since 4.18.0.0 +deriving instance (Eq (f a), Eq (g a)) => Eq (Product f g a) +-- | @since 4.18.0.0 +deriving instance (Ord (f a), Ord (g a)) => Ord (Product f g a) +-- | @since 4.18.0.0 +deriving instance (Read (f a), Read (g a)) => Read (Product f g a) +-- | @since 4.18.0.0 +deriving instance (Show (f a), Show (g a)) => Show (Product f g a) + +-- | @since 4.9.0.0 +instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where + liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2 + +-- | @since 4.9.0.0 +instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where + liftCompare comp (Pair x1 y1) (Pair x2 y2) = + liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2 + +-- | @since 4.9.0.0 +instance (Read1 f, Read1 g) => Read1 (Product f g) where + liftReadPrec rp rl = readData $ + readBinaryWith (liftReadPrec rp rl) (liftReadPrec rp rl) "Pair" Pair + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since 4.9.0.0 +instance (Show1 f, Show1 g) => Show1 (Product f g) where + liftShowsPrec sp sl d (Pair x y) = + showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y + +-- | @since 4.9.0.0 +instance (Functor f, Functor g) => Functor (Product f g) where + fmap f (Pair x y) = Pair (fmap f x) (fmap f y) + a <$ (Pair x y) = Pair (a <$ x) (a <$ y) + +-- | @since 4.9.0.0 +instance (Foldable f, Foldable g) => Foldable (Product f g) where + foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y + +-- | @since 4.9.0.0 +instance (Traversable f, Traversable g) => Traversable (Product f g) where + traverse f (Pair x y) = liftA2 Pair (traverse f x) (traverse f y) + +-- | @since 4.9.0.0 +instance (Applicative f, Applicative g) => Applicative (Product f g) where + pure x = Pair (pure x) (pure x) + Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y) + liftA2 f (Pair a b) (Pair x y) = Pair (liftA2 f a x) (liftA2 f b y) + +-- | @since 4.9.0.0 +instance (Alternative f, Alternative g) => Alternative (Product f g) where + empty = Pair empty empty + Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2) + +-- | @since 4.9.0.0 +instance (Monad f, Monad g) => Monad (Product f g) where + Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f) + where + fstP (Pair a _) = a + sndP (Pair _ b) = b + +-- | @since 4.9.0.0 +instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where + mzero = Pair mzero mzero + Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2) + +-- | @since 4.9.0.0 +instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where + mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f)) + where + fstP (Pair a _) = a + sndP (Pair _ b) = b + +-- | @since 4.9.0.0 +instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where + mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2) + +-- | @since 4.16.0.0 +instance (Semigroup (f a), Semigroup (g a)) => Semigroup (Product f g a) where + Pair x1 y1 <> Pair x2 y2 = Pair (x1 <> x2) (y1 <> y2) + +-- | @since 4.16.0.0 +instance (Monoid (f a), Monoid (g a)) => Monoid (Product f g a) where + mempty = Pair mempty mempty diff --git a/src/Data/Functor/Sum.hs b/src/Data/Functor/Sum.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Sum.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Sum +-- Copyright : (c) Ross Paterson 2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Sums, lifted to functors. +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Functor.Sum ( + Sum(..), + ) where + +import Control.Applicative ((<|>)) +import GHC.Internal.Data.Data (Data) +import Data.Functor.Classes +import GHC.Generics (Generic, Generic1) +import Prelude + +-- $setup +-- >>> import Prelude + +-- | Lifted sum of functors. +-- +-- ==== __Examples__ +-- +-- >>> fmap (+1) (InL (Just 1)) :: Sum Maybe [] Int +-- InL (Just 2) +-- +-- >>> fmap (+1) (InR [1, 2, 3]) :: Sum Maybe [] Int +-- InR [2,3,4] +data Sum f g a = InL (f a) | InR (g a) + deriving ( Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) + +-- | @since 4.18.0.0 +deriving instance (Eq (f a), Eq (g a)) => Eq (Sum f g a) +-- | @since 4.18.0.0 +deriving instance (Ord (f a), Ord (g a)) => Ord (Sum f g a) +-- | @since 4.18.0.0 +deriving instance (Read (f a), Read (g a)) => Read (Sum f g a) +-- | @since 4.18.0.0 +deriving instance (Show (f a), Show (g a)) => Show (Sum f g a) + +-- | @since 4.9.0.0 +instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where + liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2 + liftEq _ (InL _) (InR _) = False + liftEq _ (InR _) (InL _) = False + liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2 + +-- | @since 4.9.0.0 +instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where + liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2 + liftCompare _ (InL _) (InR _) = LT + liftCompare _ (InR _) (InL _) = GT + liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2 + +-- | @since 4.9.0.0 +instance (Read1 f, Read1 g) => Read1 (Sum f g) where + liftReadPrec rp rl = readData $ + readUnaryWith (liftReadPrec rp rl) "InL" InL <|> + readUnaryWith (liftReadPrec rp rl) "InR" InR + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault + +-- | @since 4.9.0.0 +instance (Show1 f, Show1 g) => Show1 (Sum f g) where + liftShowsPrec sp sl d (InL x) = + showsUnaryWith (liftShowsPrec sp sl) "InL" d x + liftShowsPrec sp sl d (InR y) = + showsUnaryWith (liftShowsPrec sp sl) "InR" d y + +-- | @since 4.9.0.0 +instance (Functor f, Functor g) => Functor (Sum f g) where + fmap f (InL x) = InL (fmap f x) + fmap f (InR y) = InR (fmap f y) + + a <$ (InL x) = InL (a <$ x) + a <$ (InR y) = InR (a <$ y) + +-- | @since 4.9.0.0 +instance (Foldable f, Foldable g) => Foldable (Sum f g) where + foldMap f (InL x) = foldMap f x + foldMap f (InR y) = foldMap f y + +-- | @since 4.9.0.0 +instance (Traversable f, Traversable g) => Traversable (Sum f g) where + traverse f (InL x) = InL <$> traverse f x + traverse f (InR y) = InR <$> traverse f y diff --git a/src/Data/IORef.hs b/src/Data/IORef.hs new file mode 100644 --- /dev/null +++ b/src/Data/IORef.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.IORef +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Mutable references in the IO monad. +-- + +module Data.IORef + (-- * IORefs + IORef, + newIORef, + readIORef, + writeIORef, + modifyIORef, + modifyIORef', + atomicModifyIORef, + atomicModifyIORef', + atomicWriteIORef, + mkWeakIORef, + -- ** Memory Model + -- $memmodel + ) where + +import GHC.Internal.Data.IORef + +{- $memmodel + #memmodel# + + Most modern CPU achitectures (e.g. x86/64, ARM) have a memory model which allows + threads to reorder reads with earlier writes to different locations, + e.g. see , + 8.2.3.4 Loads May Be Reordered with Earlier Stores to Different Locations. + + Because of that, in a concurrent program, 'IORef' operations may appear out-of-order + to another thread. In the following example: + + > import GHC.Internal.Data.IORef + > import GHC.Internal.Control.Monad (unless) + > import Control.Concurrent (forkIO, threadDelay) + > + > maybePrint :: IORef Bool -> IORef Bool -> IO () + > maybePrint myRef yourRef = do + > writeIORef myRef True + > yourVal <- readIORef yourRef + > unless yourVal $ putStrLn "critical section" + > + > main :: IO () + > main = do + > r1 <- newIORef False + > r2 <- newIORef False + > forkIO $ maybePrint r1 r2 + > forkIO $ maybePrint r2 r1 + > threadDelay 1000000 + + it is possible that the string @"critical section"@ is printed + twice, even though there is no interleaving of the operations of the + two threads that allows that outcome. The memory model of x86/64 + allows 'readIORef' to happen before the earlier 'writeIORef'. + + The ARM memory order model is typically even weaker than x86/64, allowing + any reordering of reads and writes as long as they are independent + from the point of view of the current thread. + + The implementation is required to ensure that reordering of memory + operations cannot cause type-correct code to go wrong. In + particular, when inspecting the value read from an 'IORef', the + memory writes that created that value must have occurred from the + point of view of the current thread. + + 'atomicWriteIORef', 'atomicModifyIORef' and 'atomicModifyIORef'' act + as a barrier to reordering. Multiple calls to these functions + occur in strict program order, never taking place ahead of any + earlier (in program order) 'IORef' operations, or after any later + 'IORef' operations. + +-} diff --git a/src/Data/Int.hs b/src/Data/Int.hs new file mode 100644 --- /dev/null +++ b/src/Data/Int.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Int +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Signed integer types +-- + +module Data.Int + (-- * Signed integer types + Int, + Int8, + Int16, + Int32, + Int64, + -- * Notes + -- $notes + ) where + +import GHC.Internal.Int + +{- $notes + +* All arithmetic is performed modulo 2^n, where @n@ is the number of + bits in the type. + +* For coercing between any two integer types, use 'Prelude.fromIntegral', + which is specialized for all the common cases so should be fast + enough. Coercing word types (see "Data.Word") to and from integer + types preserves representation, not sign. + +* The rules that hold for 'Prelude.Enum' instances over a + bounded type such as 'Int' (see the section of the + Haskell report dealing with arithmetic sequences) also hold for the + 'Prelude.Enum' instances over the various + 'Int' types defined here. + +* Right and left shifts by amounts greater than or equal to the width + of the type result in either zero or -1, depending on the sign of + the value being shifted. This is contrary to the behaviour in C, + which is undefined; a common interpretation is to truncate the shift + count to the width of the type, for example @1 \<\< 32 + == 1@ in some C implementations. +-} + diff --git a/src/Data/Ix.hs b/src/Data/Ix.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ix.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Ix +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- The 'Ix' class is used to map a contiguous subrange of values in +-- type onto integers. It is used primarily for array indexing +-- (see the array package). 'Ix' uses row-major order. +-- + +module Data.Ix + (-- * The 'Ix' class + Ix(range, index, inRange, rangeSize), + -- * Deriving Instances of 'Ix' + -- | Derived instance declarations for the class 'Ix' are only possible + -- for enumerations (i.e. datatypes having only nullary constructors) + -- and single-constructor datatypes, including arbitrarily large tuples, + -- whose constituent types are instances of 'Ix'. + -- + -- * For an enumeration, the nullary constructors are assumed to be + -- numbered left-to-right with the indices being 0 to n-1 inclusive. This + -- is the same numbering defined by the 'Enum' class. For example, given + -- the datatype: + -- + -- > data Colour = Red | Orange | Yellow | Green | Blue | Indigo | Violet + -- + -- we would have: + -- + -- > range (Yellow,Blue) == [Yellow,Green,Blue] + -- > index (Yellow,Blue) Green == 1 + -- > inRange (Yellow,Blue) Red == False + -- + -- * For single-constructor datatypes, the derived instance declarations + -- are as shown for tuples in chapter 19, section 2 of the Haskell 2010 report: + -- . + ) where + +import GHC.Internal.Data.Ix diff --git a/src/Data/Kind.hs b/src/Data/Kind.hs new file mode 100644 --- /dev/null +++ b/src/Data/Kind.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- +-- Module : Data.Kind +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : not portable +-- +-- Basic kinds +-- +-- @since 4.9.0.0 + +module Data.Kind + (Type, + Constraint, + FUN + ) where + +import GHC.Prim (FUN) +import GHC.Types (Type, Constraint) diff --git a/src/Data/List.hs b/src/Data/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/List.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.List +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Operations on lists. +-- + +module Data.List + (List, + -- * Basic functions + (++), + head, + last, + tail, + init, + uncons, + unsnoc, + singleton, + null, + length, + compareLength, + -- * List transformations + map, + reverse, + intersperse, + intercalate, + transpose, + subsequences, + permutations, + -- * Reducing lists (folds) + foldl, + foldl', + foldl1, + foldl1', + foldr, + foldr1, + -- ** Special folds + concat, + concatMap, + and, + or, + any, + all, + sum, + product, + maximum, + minimum, + -- * Building lists + -- ** Scans + scanl, + scanl', + scanl1, + scanr, + scanr1, + -- ** Accumulating maps + mapAccumL, + mapAccumR, + -- ** Infinite lists + iterate, + iterate', + repeat, + replicate, + cycle, + -- ** Unfolding + unfoldr, + -- * Sublists + -- ** Extracting sublists + take, + drop, + splitAt, + takeWhile, + dropWhile, + dropWhileEnd, + span, + break, + stripPrefix, + group, + inits, + inits1, + tails, + tails1, + -- ** Predicates + isPrefixOf, + isSuffixOf, + isInfixOf, + isSubsequenceOf, + -- * Searching lists + -- ** Searching by equality + elem, + notElem, + lookup, + -- ** Searching with a predicate + find, + filter, + partition, + -- * Indexing lists + -- | These functions treat a list @xs@ as an indexed collection, + -- with indices ranging from 0 to @'length' xs - 1@. + (!?), + (!!), + elemIndex, + elemIndices, + findIndex, + findIndices, + -- * Zipping and unzipping lists + zip, + zip3, + zip4, + zip5, + zip6, + zip7, + zipWith, + zipWith3, + zipWith4, + zipWith5, + zipWith6, + zipWith7, + unzip, + unzip3, + unzip4, + unzip5, + unzip6, + unzip7, + -- * Special lists + -- ** Functions on strings + lines, + words, + unlines, + unwords, + -- ** \"Set\" operations + nub, + delete, + (\\), + union, + intersect, + -- ** Ordered lists + sort, + sortOn, + insert, + -- * Generalized functions + -- ** The \"@By@\" operations + -- | By convention, overloaded functions have a non-overloaded + -- counterpart whose name is suffixed with \`@By@\'. + -- + -- It is often convenient to use these functions together with + -- 'Data.Function.on', for instance @'sortBy' ('Prelude.compare' + -- ``Data.Function.on`` 'Prelude.fst')@. + + -- *** User-supplied equality (replacing an @Eq@ context) + -- | The predicate is assumed to define an equivalence. + nubBy, + deleteBy, + deleteFirstsBy, + unionBy, + intersectBy, + groupBy, + -- *** User-supplied comparison (replacing an @Ord@ context) + -- | The function is assumed to define a total ordering. + sortBy, + insertBy, + maximumBy, + minimumBy, + -- ** The \"@generic@\" operations + -- | The prefix \`@generic@\' indicates an overloaded function that + -- is a generalized version of a "Prelude" function. + genericLength, + genericTake, + genericDrop, + genericSplitAt, + genericIndex, + 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 new file mode 100644 --- /dev/null +++ b/src/Data/List/NonEmpty.hs @@ -0,0 +1,616 @@ +{-# LANGUAGE Trustworthy #-} -- can't use Safe due to IsList instance +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.List.NonEmpty +-- Copyright : (C) 2011-2015 Edward Kmett, +-- (C) 2010 Tony Morris, Oliver Taylor, Eelis van der Weegen +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A 'NonEmpty' list is one which always has at least one element, but +-- is otherwise identical to the traditional list type in complexity +-- and in terms of API. You will almost certainly want to import this +-- module @qualified@. +-- +-- @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(..) + + -- * Non-empty stream transformations + , map -- :: (a -> b) -> NonEmpty a -> NonEmpty b + , intersperse -- :: a -> NonEmpty a -> NonEmpty a + , scanl -- :: Foldable f => (b -> a -> b) -> b -> f a -> NonEmpty b + , scanr -- :: Foldable f => (a -> b -> b) -> b -> f a -> NonEmpty b + , scanl1 -- :: (a -> a -> a) -> NonEmpty a -> NonEmpty a + , scanr1 -- :: (a -> a -> a) -> NonEmpty a -> NonEmpty a + , transpose -- :: NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a) + , sortBy -- :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a + , 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 + , init -- :: NonEmpty a -> [a] + , singleton -- :: a -> NonEmpty a + , (<|), cons -- :: a -> NonEmpty a -> NonEmpty a + , uncons -- :: NonEmpty a -> (a, Maybe (NonEmpty a)) + , unfoldr -- :: (a -> (b, Maybe a)) -> a -> NonEmpty b + , sort -- :: Ord a => NonEmpty a -> NonEmpty a + , sortOn -- :: Ord b => (a -> b) -> NonEmpty a -> NonEmpty a + , reverse -- :: NonEmpty a -> NonEmpty a + , inits -- :: Foldable f => f a -> NonEmpty [a] + , inits1 -- :: NonEmpty a -> NonEmpty (NonEmpty a) + , tails -- :: Foldable f => f a -> NonEmpty [a] + , tails1 -- :: NonEmpty a -> NonEmpty (NonEmpty a) + , append -- :: NonEmpty a -> NonEmpty a -> NonEmpty a + , appendList -- :: NonEmpty a -> [a] -> NonEmpty a + , prependList -- :: [a] -> NonEmpty a -> NonEmpty a + -- * Building streams + , iterate -- :: (a -> a) -> a -> NonEmpty a + , repeat -- :: a -> NonEmpty a + , cycle -- :: NonEmpty a -> NonEmpty a + , unfold -- :: (a -> (b, Maybe a)) -> a -> NonEmpty b + , insert -- :: (Foldable f, Ord a) => a -> f a -> NonEmpty a + , some1 -- :: Alternative f => f a -> f (NonEmpty a) + -- * Extracting sublists + , take -- :: Int -> NonEmpty a -> [a] + , drop -- :: Int -> NonEmpty a -> [a] + , splitAt -- :: Int -> NonEmpty a -> ([a], [a]) + , takeWhile -- :: (a -> Bool) -> NonEmpty a -> [a] + , dropWhile -- :: (a -> Bool) -> NonEmpty a -> [a] + , span -- :: (a -> Bool) -> NonEmpty a -> ([a], [a]) + , break -- :: (a -> Bool) -> NonEmpty a -> ([a], [a]) + , filter -- :: (a -> Bool) -> NonEmpty a -> [a] + , partition -- :: (a -> Bool) -> NonEmpty a -> ([a],[a]) + , group -- :: (Foldable f, Eq a) => f a -> [NonEmpty a] + , groupBy -- :: Foldable f => (a -> a -> Bool) -> f a -> [NonEmpty a] + , groupWith -- :: (Foldable f, Eq b) => (a -> b) -> f a -> [NonEmpty a] + , groupAllWith -- :: Ord b => (a -> b) -> [a] -> [NonEmpty a] + , group1 -- :: Eq a => NonEmpty a -> NonEmpty (NonEmpty a) + , groupBy1 -- :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a) + , groupWith1 -- :: Eq b => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a) + , groupAllWith1 -- :: Ord b => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a) + , permutations -- :: [a] -> NonEmpty [a] + , permutations1 -- :: NonEmpty a -> NonEmpty (NonEmpty a) + -- * Sublist predicates + , isPrefixOf -- :: Eq a => [a] -> NonEmpty a -> Bool + -- * \"Set\" operations + , nub -- :: Eq a => NonEmpty a -> NonEmpty a + , nubBy -- :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a + -- * Indexing streams + , (!!) -- :: NonEmpty a -> Int -> a + -- * Zipping and unzipping streams + , zip -- :: NonEmpty a -> NonEmpty b -> NonEmpty (a,b) + , zipWith -- :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c + , unzip -- :: Functor f => f (a,b) -> (f a, f b) + -- * Converting to and from a list + , fromList -- :: [a] -> NonEmpty a + , toList -- :: NonEmpty a -> [a] + , nonEmpty -- :: [a] -> Maybe (NonEmpty a) + , xor -- :: NonEmpty Bool -> Bool + ) where + + +import Prelude hiding (break, cycle, drop, dropWhile, + filter, foldl, foldr, head, init, iterate, + last, length, map, repeat, reverse, + scanl, scanl1, scanr, scanr1, span, + splitAt, tail, take, takeWhile, + unzip, zip, zipWith, (!!), Applicative(..)) +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 GHC.Internal.Data.Ord (comparing) +import GHC.Internal.Stack.Types (HasCallStack) +import GHC.Internal.Data.List.NonEmpty (NonEmpty (..), map, zip, zipWith) + +infixr 5 <| + +-- $setup +-- >>> 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 + where xor' True y = not y + xor' False y = y + +-- | 'unfold' produces a new stream by repeatedly applying the unfolding +-- function to the seed value to produce an element of type @b@ and a new +-- seed value. When the unfolding function returns 'Nothing' instead of +-- a new seed value, the stream ends. +unfold :: (a -> (b, Maybe a)) -> a -> NonEmpty b +unfold f a = case f a of + (b, Nothing) -> b :| [] + (b, Just c) -> b <| unfold f c +{-# DEPRECATED unfold "Use unfoldr" #-} +-- Deprecated in 8.2.1, remove in 8.4 + +-- | 'nonEmpty' efficiently turns a normal list into a 'NonEmpty' stream, +-- producing 'Nothing' if the input is empty. +nonEmpty :: [a] -> Maybe (NonEmpty a) +nonEmpty [] = Nothing +nonEmpty (a:as) = Just (a :| as) + +-- | '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) + +-- | The 'unfoldr' function is analogous to "Data.List"'s +-- 'GHC.Internal.Data.List.unfoldr' operation. +unfoldr :: (a -> (b, Maybe a)) -> a -> NonEmpty b +unfoldr f a = case f a of + (b, mc) -> b :| maybe [] go mc + where + go c = case f c of + (d, me) -> d : maybe [] go me + +-- | Extract the first element of the stream. +head :: NonEmpty a -> a +head (a :| _) = a + +-- | Extract the possibly-empty tail of the stream. +tail :: NonEmpty a -> [a] +tail (_ :| as) = as + +-- | Extract the last element of the stream. +last :: NonEmpty a -> a +last (a :| []) = a +last (_ :| (a : as)) = last (a :| as) + +-- | Extract everything except the last element of the stream. +init :: NonEmpty a -> [a] +init (_ :| []) = [] +init (a1 :| (a2 : as)) = a1 : init (a2 :| as) + +-- | Construct a 'NonEmpty' list from a single element. +-- +-- @since 4.15 +singleton :: a -> NonEmpty a +singleton a = a :| [] + +-- | Prepend an element to the stream. +(<|) :: a -> NonEmpty a -> NonEmpty a +a <| bs = a :| toList bs + +-- | Synonym for '<|'. +cons :: a -> NonEmpty a -> NonEmpty a +cons = (<|) + +-- | Sort a stream. +sort :: Ord a => NonEmpty a -> NonEmpty a +sort = lift List.sort + +-- | Sort a 'NonEmpty' on a user-supplied projection of its elements. +-- See 'List.sortOn' for more detailed information. +-- +-- ==== __Examples__ +-- +-- >>> sortOn fst $ (2, "world") :| [(4, "!"), (1, "Hello")] +-- (1,"Hello") :| [(2,"world"),(4,"!")] +-- +-- >>> sortOn List.length ("jim" :| ["creed", "pam", "michael", "dwight", "kevin"]) +-- "jim" :| ["pam","creed","kevin","dwight","michael"] +-- +-- ==== __Performance notes__ +-- +-- This function minimises the projections performed, by materialising +-- the projections in an intermediate list. +-- +-- For trivial projections, you should prefer using 'sortBy' with +-- 'comparing', for example: +-- +-- >>> sortBy (comparing fst) $ (3, 1) :| [(2, 2), (1, 3)] +-- (1,3) :| [(2,2),(3,1)] +-- +-- Or, for the exact same API as 'sortOn', you can use `sortBy . comparing`: +-- +-- >>> (sortBy . comparing) fst $ (3, 1) :| [(2, 2), (1, 3)] +-- (1,3) :| [(2,2),(3,1)] +-- +-- 'sortWith' is an alias for `sortBy . comparing`. +-- +-- @since 4.20.0.0 +sortOn :: Ord b => (a -> b) -> NonEmpty a -> NonEmpty a +sortOn f = lift (List.sortOn f) + +-- | Converts a normal list to a 'NonEmpty' stream. +-- +-- Raises an error if given an empty list. +fromList :: HasCallStack => [a] -> NonEmpty a +fromList (a:as) = a :| as +fromList [] = error "NonEmpty.fromList: empty list" + +-- | Convert a stream to a normal list efficiently. +toList :: NonEmpty a -> [a] +toList (a :| as) = a : as + +-- | Lift list operations to work on a 'NonEmpty' stream. +-- +-- /Beware/: If the provided function returns an empty list, +-- this will raise an error. +lift :: Foldable f => ([a] -> [b]) -> f a -> NonEmpty b +lift f = fromList . f . Foldable.toList + +-- | 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 +-- element. +-- +-- > inits [1,2,3] == [] :| [[1], [1,2], [1,2,3]] +-- > inits [1] == [] :| [[1]] +-- > inits [] == [] :| [] +inits :: Foldable f => f a -> NonEmpty [a] +inits = fromList . List.inits . Foldable.toList + +-- | The 'inits1' function takes a 'NonEmpty' stream @xs@ and returns all the +-- 'NonEmpty' finite prefixes of @xs@, starting with the shortest. +-- +-- > inits1 (1 :| [2,3]) == (1 :| []) :| [1 :| [2], 1 :| [2,3]] +-- > inits1 (1 :| []) == (1 :| []) :| [] +-- +-- @since 4.18 +inits1 :: NonEmpty a -> NonEmpty (NonEmpty a) +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' +-- because the result always contains the empty list as the last element. +-- +-- > tails [1,2,3] == [1,2,3] :| [[2,3], [3], []] +-- > tails [1] == [1] :| [[]] +-- > tails [] == [] :| [] +tails :: Foldable f => f a -> NonEmpty [a] +tails = fromList . List.tails . Foldable.toList + +-- | The 'tails1' function takes a 'NonEmpty' stream @xs@ and returns all the +-- non-empty suffixes of @xs@, starting with the longest. +-- +-- > tails1 (1 :| [2,3]) == (1 :| [2,3]) :| [2 :| [3], 3 :| []] +-- > tails1 (1 :| []) == (1 :| []) :| [] +-- +-- @since 4.18 +tails1 :: NonEmpty a -> NonEmpty (NonEmpty a) +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 +-- list is sorted beforehand, the result will also be sorted. +insert :: (Foldable f, Ord a) => a -> f a -> NonEmpty a +insert a = fromList . List.insert a . Foldable.toList + +-- | @'some1' x@ sequences @x@ one or more times. +some1 :: Alternative f => f a -> f (NonEmpty a) +some1 x = liftA2 (:|) x (many x) + +-- | 'scanl' is similar to 'foldl', but returns a stream of successive +-- reduced values from the left: +-- +-- > scanl f z [x1, x2, ...] == z :| [z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > last (scanl f z xs) == foldl f z xs. +scanl :: Foldable f => (b -> a -> b) -> b -> f a -> NonEmpty b +scanl f z = fromList . List.scanl f z . Foldable.toList + +-- | 'scanr' is the right-to-left dual of 'scanl'. +-- Note that +-- +-- > head (scanr f z xs) == foldr f z xs. +scanr :: Foldable f => (a -> b -> b) -> b -> f a -> NonEmpty b +scanr f z = fromList . List.scanr f z . Foldable.toList + +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument: +-- +-- > 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) + +-- | '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)) + +-- | '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 + [] -> [] + _ -> a : List.intersperse a bs + +-- | @'iterate' f x@ produces the infinite sequence +-- of repeated applications of @f@ to @x@. +-- +-- > iterate f x = x :| [f x, f (f x), ..] +iterate :: (a -> a) -> a -> NonEmpty a +iterate f a = a :| List.iterate f (f a) + +-- | @'cycle' xs@ returns the infinite repetition of @xs@: +-- +-- > cycle (1 :| [2,3]) = 1 :| [2,3,1,2,3,...] +cycle :: NonEmpty a -> NonEmpty a +cycle = fromList . List.cycle . toList + +-- | 'reverse' a finite NonEmpty stream. +reverse :: NonEmpty a -> NonEmpty a +reverse = lift List.reverse + +-- | @'repeat' x@ returns a constant stream, where all elements are +-- equal to @x@. +repeat :: a -> NonEmpty a +repeat a = a :| List.repeat a + +-- | @'take' n xs@ returns the first @n@ elements of @xs@. +take :: Int -> NonEmpty a -> [a] +take n = List.take n . toList + +-- | @'drop' n xs@ drops the first @n@ elements off the front of +-- the sequence @xs@. +drop :: Int -> NonEmpty a -> [a] +drop n = List.drop n . toList + +-- | @'splitAt' n xs@ returns a pair consisting of the prefix of @xs@ +-- of length @n@ and the remaining stream immediately following this prefix. +-- +-- > 'splitAt' n xs == ('take' n xs, 'drop' n xs) +-- > xs == ys ++ zs where (ys, zs) = 'splitAt' n xs +splitAt :: Int -> NonEmpty a -> ([a],[a]) +splitAt n = List.splitAt n . toList + +-- | @'takeWhile' p xs@ returns the longest prefix of the stream +-- @xs@ for which the predicate @p@ holds. +takeWhile :: (a -> Bool) -> NonEmpty a -> [a] +takeWhile p = List.takeWhile p . toList + +-- | @'dropWhile' p xs@ returns the suffix remaining after +-- @'takeWhile' p xs@. +dropWhile :: (a -> Bool) -> NonEmpty a -> [a] +dropWhile p = List.dropWhile p . toList + +-- | @'span' p xs@ returns the longest prefix of @xs@ that satisfies +-- @p@, together with the remainder of the stream. +-- +-- > 'span' p xs == ('takeWhile' p xs, 'dropWhile' p xs) +-- > xs == ys ++ zs where (ys, zs) = 'span' p xs +span :: (a -> Bool) -> NonEmpty a -> ([a], [a]) +span p = List.span p . toList + +-- | The @'break' p@ function is equivalent to @'span' (not . p)@. +break :: (a -> Bool) -> NonEmpty a -> ([a], [a]) +break p = span (not . p) + +-- | @'filter' p xs@ removes any elements from @xs@ that do not satisfy @p@. +filter :: (a -> Bool) -> NonEmpty a -> [a] +filter p = List.filter p . toList + +-- | The 'partition' function takes a predicate @p@ and a stream +-- @xs@, and returns a pair of lists. The first list corresponds to the +-- elements of @xs@ for which @p@ holds; the second corresponds to the +-- elements of @xs@ for which @p@ does not hold. +-- +-- > 'partition' p xs = ('filter' p xs, 'filter' (not . p) xs) +partition :: (a -> Bool) -> NonEmpty a -> ([a], [a]) +partition p = List.partition p . toList + +-- | The 'group' function takes a stream and returns a list of +-- streams such that flattening the resulting list is equal to the +-- argument. Moreover, each stream in the resulting list +-- contains only equal elements, and consecutive equal elements +-- of the input end up in the same stream of the output list. +-- For example, in list notation: +-- +-- >>> group "Mississippi" +-- ['M' :| "",'i' :| "",'s' :| "s",'i' :| "",'s' :| "s",'i' :| "",'p' :| "p",'i' :| ""] +group :: (Foldable f, Eq a) => f a -> [NonEmpty a] +group = groupBy (==) + +-- | 'groupBy' operates like 'group', but uses the provided equality +-- predicate instead of `==`. +groupBy :: Foldable f => (a -> a -> Bool) -> f a -> [NonEmpty a] +groupBy eq0 = go eq0 . Foldable.toList + where + go _ [] = [] + go eq (x : xs) = (x :| ys) : groupBy eq zs + where (ys, zs) = List.span (eq x) xs + +-- | 'groupWith' operates like 'group', but uses the provided projection when +-- comparing for equality +groupWith :: (Foldable f, Eq b) => (a -> b) -> f a -> [NonEmpty a] +groupWith f = groupBy ((==) `on` f) + +-- | 'groupAllWith' operates like 'groupWith', but sorts the list +-- first so that each equivalence class has, at most, one list in the +-- output +groupAllWith :: (Ord b) => (a -> b) -> [a] -> [NonEmpty a] +groupAllWith f = groupWith f . List.sortBy (compare `on` f) + +-- | 'group1' operates like 'group', but uses the knowledge that its +-- input is non-empty to produce guaranteed non-empty output. +group1 :: Eq a => NonEmpty a -> NonEmpty (NonEmpty a) +group1 = groupBy1 (==) + +-- | 'groupBy1' is to 'group1' as 'groupBy' is to 'group'. +groupBy1 :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a) +groupBy1 eq (x :| xs) = (x :| ys) :| groupBy eq zs + where (ys, zs) = List.span (eq x) xs + +-- | 'groupWith1' is to 'group1' as 'groupWith' is to 'group' +groupWith1 :: (Eq b) => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a) +groupWith1 f = groupBy1 ((==) `on` f) + +-- | 'groupAllWith1' is to 'groupWith1' as 'groupAllWith' is to 'groupWith' +groupAllWith1 :: (Ord b) => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a) +groupAllWith1 f = groupWith1 f . sortWith f + +-- | The 'permutations' function returns the list of all permutations of the argument. +-- +-- @since 4.20.0.0 +permutations :: [a] -> NonEmpty [a] +permutations xs0 = xs0 :| perms xs0 [] + where + perms [] _ = [] + perms (t:ts) is = foldr interleave (perms ts (t:is)) (permutations is) + where interleave xs r = let (_,zs) = interleave' id xs r in zs + interleave' _ [] r = (ts, r) + interleave' f (y:ys) r = let (us,zs) = interleave' (f . (y:)) ys r + in (y:us, f (t:y:us) : zs) +-- The implementation of 'permutations' is adopted from 'GHC.Internal.Data.List.permutations', +-- see there for discussion and explanations. + +-- | 'permutations1' operates like 'permutations', but uses the knowledge that its input is +-- non-empty to produce output where every element is non-empty. +-- +-- > permutations1 = fmap fromList . permutations . toList +-- +-- @since 4.20.0.0 +permutations1 :: NonEmpty a -> NonEmpty (NonEmpty a) +permutations1 xs = fromList <$> permutations (toList xs) + +-- | The 'isPrefixOf' function returns 'True' if the first argument is +-- a prefix of the second. +isPrefixOf :: Eq a => [a] -> NonEmpty a -> Bool +isPrefixOf [] _ = True +isPrefixOf (y:ys) (x :| xs) = (y == x) && List.isPrefixOf ys xs + +-- | @xs !! n@ returns the element of the stream @xs@ at index +-- @n@. Note that the head of the stream has index 0. +-- +-- /Beware/: a negative or out-of-bounds index will cause an error. +(!!) :: HasCallStack => NonEmpty a -> Int -> a +(!!) (x :| xs) n + | n == 0 = x + | n > 0 = xs List.!! (n - 1) + | otherwise = error "NonEmpty.!! negative index" +infixl 9 !! + +-- | The 'unzip' function is the inverse of the 'zip' function. +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. +-- (The name 'nub' means \'essence\'.) +-- It is a special case of 'nubBy', which allows the programmer to +-- supply their own inequality test. +nub :: Eq a => NonEmpty a -> NonEmpty a +nub = nubBy (==) + +-- | The 'nubBy' function behaves just like 'nub', except it uses a +-- user-supplied equality predicate instead of the overloaded '==' +-- function. +nubBy :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a +nubBy eq (a :| as) = a :| List.nubBy eq (List.filter (\b -> not (eq a b)) as) + +-- | 'transpose' for 'NonEmpty', behaves the same as 'GHC.Internal.Data.List.transpose' +-- The rows/columns need not be the same length, in which case +-- > transpose . transpose /= id +transpose :: NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a) +transpose = fmap fromList + . fromList . List.transpose . toList + . fmap toList + +-- | 'sortBy' for 'NonEmpty', behaves the same as 'GHC.Internal.Data.List.sortBy' +sortBy :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a +sortBy f = lift (List.sortBy f) + +-- | 'sortWith' for 'NonEmpty', behaves the same as: +-- +-- > sortBy . comparing +sortWith :: Ord o => (a -> o) -> NonEmpty a -> NonEmpty a +sortWith = sortBy . comparing + +-- | A monomorphic version of '<>' for 'NonEmpty'. +-- +-- >>> append (1 :| []) (2 :| [3]) +-- 1 :| [2,3] +-- +-- @since 4.16 +append :: NonEmpty a -> NonEmpty a -> NonEmpty a +append = (<>) + +-- | Attach a list at the end of a 'NonEmpty'. +-- +-- >>> appendList (1 :| [2,3]) [] +-- 1 :| [2,3] +-- +-- >>> appendList (1 :| [2,3]) [4,5] +-- 1 :| [2,3,4,5] +-- +-- @since 4.16 +appendList :: NonEmpty a -> [a] -> NonEmpty a +appendList (x :| xs) ys = x :| xs <> ys + +-- | Attach a list at the beginning of a 'NonEmpty'. +-- +-- >>> prependList [] (1 :| [2,3]) +-- 1 :| [2,3] +-- +-- >>> prependList [negate 1, 0] (1 :| [2, 3]) +-- -1 :| [0,1,2,3] +-- +-- @since 4.16 +prependList :: [a] -> NonEmpty a -> NonEmpty a +prependList ls ne = case ls of + [] -> ne + (x : xs) -> x :| xs <> toList ne diff --git a/src/Data/Maybe.hs b/src/Data/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Maybe.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Maybe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- The Maybe type, and associated operations. +-- + +module Data.Maybe + (Maybe(Nothing, Just), + maybe, + isJust, + isNothing, + fromJust, + fromMaybe, + listToMaybe, + maybeToList, + catMaybes, + mapMaybe + ) where + +import GHC.Internal.Data.Maybe diff --git a/src/Data/Monoid.hs b/src/Data/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Data/Monoid.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Monoid +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- A type @a@ is a 'Monoid' if it provides an associative function ('<>') +-- that lets you combine any two values of type @a@ into one, and a neutral +-- element (`mempty`) such that +-- +-- > a <> mempty == mempty <> a == a +-- +-- A 'Monoid' is a 'Semigroup' with the added requirement of a neutral element. +-- Thus any 'Monoid' is a 'Semigroup', but not the other way around. +-- +-- ==== __Examples__ +-- +-- 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 +-- Sum {getSum = 10} +-- +-- We can combine multiple values in a list into a single value using the `mconcat` function. +-- Note that we have to specify the type here since 'Int' is a monoid under several different +-- operations: +-- +-- >>> mconcat [1,2,3,4] :: Sum Int +-- Sum {getSum = 10} +-- >>> mconcat [] :: Sum Int +-- Sum {getSum = 0} +-- +-- Another valid monoid instance of 'Int' is 'Product' It is defined by multiplication +-- and `1` as neutral element: +-- +-- >>> Product 1 <> Product 2 <> Product 3 <> Product 4 :: Product Int +-- Product {getProduct = 24} +-- >>> mconcat [1,2,3,4] :: Product Int +-- Product {getProduct = 24} +-- >>> mconcat [] :: Product Int +-- Product {getProduct = 1} +-- +-- + +module Data.Monoid + (-- * 'Monoid' typeclass + Monoid(..), + (<>), + Dual(..), + Endo(..), + -- * 'Bool' wrappers + All(..), + Any(..), + -- * 'Num' wrappers + Sum(..), + Product(..), + -- * 'Maybe' wrappers + -- $MaybeExamples + First(..), + Last(..), + -- * 'Alternative' wrapper + Alt(..), + -- * 'Applicative' wrapper + Ap(..) + ) where + +import GHC.Internal.Data.Monoid + diff --git a/src/Data/Ord.hs b/src/Data/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ord.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Ord +-- Copyright : (c) The University of Glasgow 2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Orderings +-- + +module Data.Ord + (Ord(..), + Ordering(..), + Down(..), + comparing, + clamp + ) where + +import GHC.Internal.Data.Ord diff --git a/src/Data/Proxy.hs b/src/Data/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/Data/Proxy.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Proxy +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Definition of a Proxy type (poly-kinded in GHC) +-- +-- @since 4.7.0.0 + +module Data.Proxy + (Proxy(..), + asProxyTypeOf, + KProxy(..) + ) where + +import GHC.Internal.Data.Proxy diff --git a/src/Data/Ratio.hs b/src/Data/Ratio.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ratio.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Ratio +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Standard functions on rational numbers +-- +----------------------------------------------------------------------------- + +module Data.Ratio + ( Ratio + , Rational + , (%) + , numerator + , denominator + , approxRational + + ) where + +import GHC.Internal.Real -- The basic defns for Ratio +import Prelude + +-- ----------------------------------------------------------------------------- +-- approxRational + +-- | 'approxRational', applied to two real fractional numbers @x@ and @epsilon@, +-- returns the simplest rational number within @epsilon@ of @x@. +-- A rational number @y@ is said to be /simpler/ than another @y'@ if +-- +-- * @'abs' ('numerator' y) <= 'abs' ('numerator' y')@, and +-- +-- * @'denominator' y <= 'denominator' y'@. +-- +-- Any real interval contains a unique simplest rational; +-- in particular, note that @0\/1@ is the simplest rational of all. + +-- Implementation details: Here, for simplicity, we assume a closed rational +-- interval. If such an interval includes at least one whole number, then +-- the simplest rational is the absolutely least whole number. Otherwise, +-- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d +-- and abs r' < d', and the simplest rational is q%1 + the reciprocal of +-- the simplest rational between d'%r' and d%r. + +approxRational :: (RealFrac a) => a -> a -> Rational +approxRational rat eps = + -- We convert rat and eps to rational *before* subtracting/adding since + -- otherwise we may overflow. This was the cause of #14425. + simplest (toRational rat - toRational eps) (toRational rat + toRational eps) + where + simplest x y + | y < x = simplest y x + | x == y = xr + | x > 0 = simplest' n d n' d' + | y < 0 = - simplest' (-n') d' (-n) d + | otherwise = 0 :% 1 + where xr = toRational x + n = numerator xr + d = denominator xr + nd' = toRational y + n' = numerator nd' + d' = denominator nd' + + simplest' n d n' d' -- assumes 0 < n%d < n'%d' + | r == 0 = q :% 1 + | q /= q' = (q+1) :% 1 + | otherwise = (q*n''+d'') :% n'' + where (q,r) = quotRem n d + (q',r') = quotRem n' d' + nd'' = simplest' d' r' d r + n'' = numerator nd'' + d'' = denominator nd'' + diff --git a/src/Data/STRef.hs b/src/Data/STRef.hs new file mode 100644 --- /dev/null +++ b/src/Data/STRef.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.STRef +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (uses Control.Monad.ST) +-- +-- Mutable references in the (strict) ST monad. +-- + +module Data.STRef + (-- * STRefs + STRef, + newSTRef, + readSTRef, + writeSTRef, + modifySTRef, + modifySTRef' + ) where + +import GHC.Internal.Data.STRef diff --git a/src/Data/STRef/Lazy.hs b/src/Data/STRef/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Data/STRef/Lazy.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.STRef.Lazy +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (uses Control.Monad.ST.Lazy) +-- +-- Mutable references in the lazy ST monad. +-- +----------------------------------------------------------------------------- + +module Data.STRef.Lazy ( + -- * STRefs + ST.STRef, -- abstract + newSTRef, + readSTRef, + writeSTRef, + modifySTRef + ) where + +import Prelude +import GHC.Internal.Control.Monad.ST.Lazy +import qualified GHC.Internal.Data.STRef as ST + +newSTRef :: a -> ST s (ST.STRef s a) +readSTRef :: ST.STRef s a -> ST s a +writeSTRef :: ST.STRef s a -> a -> ST s () +modifySTRef :: ST.STRef s a -> (a -> a) -> ST s () + +newSTRef = strictToLazyST . ST.newSTRef +readSTRef = strictToLazyST . ST.readSTRef +writeSTRef r a = strictToLazyST (ST.writeSTRef r a) +modifySTRef r f = strictToLazyST (ST.modifySTRef r f) + diff --git a/src/Data/STRef/Strict.hs b/src/Data/STRef/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Data/STRef/Strict.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.STRef.Strict +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (uses Control.Monad.ST.Strict) +-- +-- Mutable references in the (strict) ST monad (re-export of "Data.STRef") +-- + +module Data.STRef.Strict (module Data.STRef) where + +import Data.STRef diff --git a/src/Data/Semigroup.hs b/src/Data/Semigroup.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup.hs @@ -0,0 +1,663 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Semigroup +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A type @a@ is a 'Semigroup' if it provides an associative function ('<>') +-- that lets you combine any two values of type @a@ into one. Where being +-- associative means that the following must always hold: +-- +-- prop> (a <> b) <> c == a <> (b <> c) +-- +-- ==== __Examples__ +-- +-- The 'Min' 'Semigroup' instance for 'Int' is defined to always pick the smaller +-- number: +-- +-- >>> Min 1 <> Min 2 <> Min 3 <> Min 4 :: Min Int +-- Min {getMin = 1} +-- +-- If we need to combine multiple values we can use the 'sconcat' function +-- to do so. We need to ensure however that we have at least one value to +-- operate on, since otherwise our result would be undefined. It is for this +-- reason that 'sconcat' uses "Data.List.NonEmpty.NonEmpty" - a list that +-- can never be empty: +-- +-- >>> (1 :| []) +-- 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. +-- +-- 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 +-- respectively: +-- +-- >>> sconcat (1 :| [2, 3, 4]) :: Min Int +-- Min {getMin = 1} +-- +-- >>> sconcat (1 :| [2, 3, 4]) :: Max Int +-- Max {getMax = 4} +-- +-- String concatenation is another example of a 'Semigroup' instance: +-- +-- >>> "foo" <> "bar" +-- "foobar" +-- +-- A 'Semigroup' is a generalization of a 'Monoid'. Yet unlike the 'Semigroup', the 'Monoid' +-- requires the presence of a neutral element ('mempty') in addition to the associative +-- operator. The requirement for a neutral element prevents many types from being a full Monoid, +-- like "Data.List.NonEmpty.NonEmpty". +-- +-- Note that the use of @(\<\>)@ in this module conflicts with an operator with the same +-- name that is being exported by "Data.Monoid". However, this package +-- re-exports (most of) the contents of Data.Monoid, so to use semigroups +-- and monoids in the same package just +-- +-- > import Data.Semigroup +-- +-- @since 4.9.0.0 +---------------------------------------------------------------------------- +module Data.Semigroup ( + Semigroup(..) + , stimesMonoid + , stimesIdempotent + , stimesIdempotentMonoid + , mtimesDefault + -- * Semigroups + , Min(..) + , Max(..) + , First(..) + , Last(..) + , WrappedMonoid(..) + -- * Re-exported monoids + , Dual(..) + , Endo(..) + , All(..) + , Any(..) + , Sum(..) + , Product(..) + -- * Difference lists of a semigroup + , diff + , cycle1 + -- * ArgMin, ArgMax + , Arg(..) + , ArgMin + , ArgMax + ) where + +import GHC.Internal.Base hiding (Any, NonEmpty(..)) +import GHC.Internal.Enum +import GHC.Internal.Show +import GHC.Internal.Read +import GHC.Internal.Num +import GHC.Internal.Real +import GHC.Internal.Data.Functor ((<$>)) +import Data.Bifoldable +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 +import GHC.Internal.Data.Data +import GHC.Generics +import qualified GHC.Internal.List as List + +-- $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. +-- +-- ==== __Examples__ +-- +-- >>> take 10 $ cycle1 [1, 2, 3] +-- [1,2,3,1,2,3,1,2,3,1] +-- +-- >>> cycle1 (Right 1) +-- Right 1 +-- +-- >>> cycle1 (Left 1) +-- * Hangs forever * +cycle1 :: Semigroup m => m -> m +cycle1 xs = xs' where xs' = xs <> xs' + +-- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'. +-- +-- ==== __Examples__ +-- +-- >>> let hello = diff "Hello, " +-- +-- >>> appEndo hello "World!" +-- "Hello, World!" +-- +-- >>> appEndo (hello <> mempty) "World!" +-- "Hello, World!" +-- +-- >>> appEndo (mempty <> hello) "World!" +-- "Hello, World!" +-- +-- >>> let world = diff "World" +-- >>> let excl = diff "!" +-- +-- >>> appEndo (hello <> (world <> excl)) mempty +-- "Hello, World!" +-- +-- >>> appEndo ((hello <> world) <> excl) mempty +-- "Hello, World!" +diff :: Semigroup m => m -> Endo m +diff = Endo . (<>) + +-- | The 'Min' 'Monoid' and 'Semigroup' always choose the smaller element as +-- by the 'Ord' instance and 'min' of the contained type. +-- +-- ==== __Examples__ +-- +-- >>> Min 42 <> Min 3 +-- Min {getMin = 3} +-- +-- >>> sconcat $ Min 1 :| [ Min n | n <- [2 .. 100]] +-- Min {getMin = 1} +newtype Min a = Min { getMin :: a } + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) + +-- | @since 4.9.0.0 +instance Enum a => Enum (Min a) where + succ (Min a) = Min (succ a) + pred (Min a) = Min (pred a) + toEnum = Min . toEnum + fromEnum = fromEnum . getMin + enumFrom (Min a) = Min `fmap` enumFrom a + enumFromThen (Min a) (Min b) = Min `fmap` enumFromThen a b + enumFromTo (Min a) (Min b) = Min `fmap` enumFromTo a b + enumFromThenTo (Min a) (Min b) (Min c) = Min `fmap` enumFromThenTo a b c + + +-- | @since 4.9.0.0 +instance Ord a => Semigroup (Min a) where + (<>) = coerce (min :: a -> a -> a) + stimes = stimesIdempotent + +-- | @since 4.9.0.0 +instance (Ord a, Bounded a) => Monoid (Min a) where + mempty = maxBound + -- By default, we would get a lazy right fold. This forces the use of a strict + -- left fold instead. + mconcat = List.foldl' (<>) mempty + {-# INLINE mconcat #-} + +-- | @since 4.9.0.0 +instance Functor Min where + fmap f (Min x) = Min (f x) + +-- | @since 4.9.0.0 +instance Foldable Min where + foldMap f (Min a) = f a + +-- | @since 4.9.0.0 +instance Traversable Min where + traverse f (Min a) = Min `fmap` f a + +-- | @since 4.9.0.0 +instance Applicative Min where + pure = Min + a <* _ = a + _ *> a = a + (<*>) = coerce + liftA2 = coerce + +-- | @since 4.9.0.0 +instance Monad Min where + (>>) = (*>) + Min a >>= f = f a + +-- | @since 4.9.0.0 +instance MonadFix Min where + mfix f = fix (f . getMin) + +-- | @since 4.9.0.0 +instance Num a => Num (Min a) where + (Min a) + (Min b) = Min (a + b) + (Min a) * (Min b) = Min (a * b) + (Min a) - (Min b) = Min (a - b) + negate (Min a) = Min (negate a) + abs (Min a) = Min (abs a) + signum (Min a) = Min (signum a) + fromInteger = Min . fromInteger + +-- | The 'Max' 'Monoid' and 'Semigroup' always choose the bigger element as +-- by the 'Ord' instance and 'max' of the contained type. +-- +-- ==== __Examples__ +-- +-- >>> Max 42 <> Max 3 +-- Max {getMax = 42} +-- +-- >>> sconcat $ Max 1 :| [ Max n | n <- [2 .. 100]] +-- Max {getMax = 100} +newtype Max a = Max { getMax :: a } + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) + +-- | @since 4.9.0.0 +instance Enum a => Enum (Max a) where + succ (Max a) = Max (succ a) + pred (Max a) = Max (pred a) + toEnum = Max . toEnum + fromEnum = fromEnum . getMax + enumFrom (Max a) = Max `fmap` enumFrom a + enumFromThen (Max a) (Max b) = Max `fmap` enumFromThen a b + enumFromTo (Max a) (Max b) = Max `fmap` enumFromTo a b + enumFromThenTo (Max a) (Max b) (Max c) = Max `fmap` enumFromThenTo a b c + +-- | @since 4.9.0.0 +instance Ord a => Semigroup (Max a) where + (<>) = coerce (max :: a -> a -> a) + stimes = stimesIdempotent + +-- | @since 4.9.0.0 +instance (Ord a, Bounded a) => Monoid (Max a) where + mempty = minBound + -- By default, we would get a lazy right fold. This forces the use of a strict + -- left fold instead. + mconcat = List.foldl' (<>) mempty + {-# INLINE mconcat #-} + +-- | @since 4.9.0.0 +instance Functor Max where + fmap f (Max x) = Max (f x) + +-- | @since 4.9.0.0 +instance Foldable Max where + foldMap f (Max a) = f a + +-- | @since 4.9.0.0 +instance Traversable Max where + traverse f (Max a) = Max `fmap` f a + +-- | @since 4.9.0.0 +instance Applicative Max where + pure = Max + a <* _ = a + _ *> a = a + (<*>) = coerce + liftA2 = coerce + +-- | @since 4.9.0.0 +instance Monad Max where + (>>) = (*>) + Max a >>= f = f a + +-- | @since 4.9.0.0 +instance MonadFix Max where + mfix f = fix (f . getMax) + +-- | @since 4.9.0.0 +instance Num a => Num (Max a) where + (Max a) + (Max b) = Max (a + b) + (Max a) * (Max b) = Max (a * b) + (Max a) - (Max b) = Max (a - b) + negate (Max a) = Max (negate a) + abs (Max a) = Max (abs a) + signum (Max a) = Max (signum a) + 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. 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__ +-- +-- >>> minimum [ Arg (x * x) x | x <- [-10 .. 10] ] +-- Arg 0 0 +-- +-- >>> maximum [ Arg (-0.2*x^2 + 1.5*x + 1) x | x <- [-10 .. 10] ] +-- Arg 3.8 4.0 +-- +-- >>> minimum [ Arg (-0.2*x^2 + 1.5*x + 1) x | x <- [-10 .. 10] ] +-- Arg (-34.0) (-10.0) +data Arg a b = Arg + a + -- ^ The argument used for comparisons in 'Eq' and 'Ord'. + b + -- ^ The "value" exposed via the 'Functor', 'Foldable' etc. instances. + deriving + ( Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) + +-- | +-- ==== __Examples__ +-- +-- >>> Min (Arg 0 ()) <> Min (Arg 1 ()) +-- Min {getMin = Arg 0 ()} +-- +-- >>> minimum [ Arg (length name) name | name <- ["violencia", "lea", "pixie"]] +-- Arg 3 "lea" +type ArgMin a b = Min (Arg a b) + +-- | +-- ==== __Examples__ +-- +-- >>> Max (Arg 0 ()) <> Max (Arg 1 ()) +-- Max {getMax = Arg 1 ()} +-- +-- >>> maximum [ Arg (length name) name | name <- ["violencia", "lea", "pixie"]] +-- Arg 9 "violencia" +type ArgMax a b = Max (Arg a b) + +-- | @since 4.9.0.0 +instance Functor (Arg a) where + fmap f (Arg x a) = Arg x (f a) + +-- | @since 4.9.0.0 +instance Foldable (Arg a) where + foldMap f (Arg _ a) = f a + +-- | @since 4.9.0.0 +instance Traversable (Arg a) where + traverse f (Arg x a) = Arg x `fmap` f a + +-- | +-- 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 + +-- | +-- 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 _) + | a <= b = x + | otherwise = y + max x@(Arg a _) y@(Arg b _) + | a >= b = x + | otherwise = y + +-- | @since 4.9.0.0 +instance Bifunctor Arg where + bimap f g (Arg a b) = Arg (f a) (g b) + +-- | @since 4.10.0.0 +instance Bitraversable Arg where + bitraverse f g (Arg a b) = Arg <$> f a <*> g b + +-- | @since 4.10.0.0 +instance Bifoldable Arg where + bifoldMap f g (Arg a b) = f a <> g b + +-- | +-- Beware that @Data.Semigroup.@'First' is different from +-- @Data.Monoid.@'Data.Monoid.First'. The former simply returns the first value, +-- so @Data.Semigroup.First Nothing <> x = Data.Semigroup.First Nothing@. +-- The latter returns the first non-'Nothing', +-- thus @Data.Monoid.First Nothing <> x = x@. +-- +-- ==== __Examples__ +-- +-- >>> First 0 <> First 10 +-- First {getFirst = 0} +-- +-- >>> sconcat $ First 1 :| [ First n | n <- [2 ..] ] +-- First {getFirst = 1} +newtype First a = First { getFirst :: a } + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) + +-- | @since 4.9.0.0 +instance Enum a => Enum (First a) where + succ (First a) = First (succ a) + pred (First a) = First (pred a) + toEnum = First . toEnum + fromEnum = fromEnum . getFirst + enumFrom (First a) = First `fmap` enumFrom a + enumFromThen (First a) (First b) = First `fmap` enumFromThen a b + enumFromTo (First a) (First b) = First `fmap` enumFromTo a b + enumFromThenTo (First a) (First b) (First c) = First `fmap` enumFromThenTo a b c + +-- | @since 4.9.0.0 +instance Semigroup (First a) where + a <> _ = a + stimes = stimesIdempotent + sconcat (x :| _) = x + +-- | @since 4.9.0.0 +instance Functor First where + fmap f (First x) = First (f x) + +-- | @since 4.9.0.0 +instance Foldable First where + foldMap f (First a) = f a + +-- | @since 4.9.0.0 +instance Traversable First where + traverse f (First a) = First `fmap` f a + +-- | @since 4.9.0.0 +instance Applicative First where + pure x = First x + a <* _ = a + _ *> a = a + (<*>) = coerce + liftA2 = coerce + +-- | @since 4.9.0.0 +instance Monad First where + (>>) = (*>) + First a >>= f = f a + +-- | @since 4.9.0.0 +instance MonadFix First where + mfix f = fix (f . getFirst) + +-- | +-- Beware that @Data.Semigroup.@'Last' is different from +-- @Data.Monoid.@'Data.Monoid.Last'. The former simply returns the last value, +-- so @x <> Data.Semigroup.Last Nothing = Data.Semigroup.Last Nothing@. +-- The latter returns the last non-'Nothing', +-- thus @x <> Data.Monoid.Last Nothing = x@. +-- +-- ==== __Examples__ +-- +-- >>> Last 0 <> Last 10 +-- Last {getLast = 10} +-- +-- >>> sconcat $ Last 1 :| [ Last n | n <- [2..]] +-- * Hangs forever * +newtype Last a = Last { getLast :: a } + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) + +-- | @since 4.9.0.0 +instance Enum a => Enum (Last a) where + succ (Last a) = Last (succ a) + pred (Last a) = Last (pred a) + toEnum = Last . toEnum + fromEnum = fromEnum . getLast + enumFrom (Last a) = Last `fmap` enumFrom a + enumFromThen (Last a) (Last b) = Last `fmap` enumFromThen a b + enumFromTo (Last a) (Last b) = Last `fmap` enumFromTo a b + enumFromThenTo (Last a) (Last b) (Last c) = Last `fmap` enumFromThenTo a b c + +-- | @since 4.9.0.0 +instance Semigroup (Last a) where + _ <> b = b + stimes = stimesIdempotent + +-- | @since 4.9.0.0 +instance Functor Last where + fmap f (Last x) = Last (f x) + a <$ _ = Last a + +-- | @since 4.9.0.0 +instance Foldable Last where + foldMap f (Last a) = f a + +-- | @since 4.9.0.0 +instance Traversable Last where + traverse f (Last a) = Last `fmap` f a + +-- | @since 4.9.0.0 +instance Applicative Last where + pure = Last + a <* _ = a + _ *> a = a + (<*>) = coerce + liftA2 = coerce + +-- | @since 4.9.0.0 +instance Monad Last where + (>>) = (*>) + Last a >>= f = f a + +-- | @since 4.9.0.0 +instance MonadFix Last where + mfix f = fix (f . getLast) + +-- | Provide a Semigroup for an arbitrary Monoid. +-- +-- __NOTE__: This is not needed anymore since 'Semigroup' became a superclass of +-- 'Monoid' in /base-4.11/ and this newtype be deprecated at some point in the future. +newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m } + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) + +-- | @since 4.9.0.0 +instance Monoid m => Semigroup (WrappedMonoid m) where + (<>) = coerce (mappend :: m -> m -> m) + +-- | @since 4.9.0.0 +instance Monoid m => Monoid (WrappedMonoid m) where + mempty = WrapMonoid mempty + -- This ensures that we use whatever mconcat is defined for the wrapped + -- Monoid. + mconcat = coerce (mconcat :: [m] -> m) + +-- | @since 4.9.0.0 +instance Enum a => Enum (WrappedMonoid a) where + succ (WrapMonoid a) = WrapMonoid (succ a) + pred (WrapMonoid a) = WrapMonoid (pred a) + toEnum = WrapMonoid . toEnum + fromEnum = fromEnum . unwrapMonoid + enumFrom (WrapMonoid a) = WrapMonoid `fmap` enumFrom a + enumFromThen (WrapMonoid a) (WrapMonoid b) = WrapMonoid `fmap` enumFromThen a b + enumFromTo (WrapMonoid a) (WrapMonoid b) = WrapMonoid `fmap` enumFromTo a b + enumFromThenTo (WrapMonoid a) (WrapMonoid b) (WrapMonoid c) = + WrapMonoid `fmap` enumFromThenTo a b c + +-- | Repeat a value @n@ times. +-- +-- > mtimesDefault n a = a <> a <> ... <> a -- using <> (n-1) times +-- +-- In many cases, @'stimes' 0 a@ for a `Monoid` will produce `mempty`. +-- However, there are situations when it cannot do so. In particular, +-- the following situation is fairly common: +-- +-- @ +-- data T a = ... +-- +-- class Constraint1 a +-- class Constraint1 a => Constraint2 a +-- @ +-- +-- @ +-- instance Constraint1 a => 'Semigroup' (T a) +-- instance Constraint2 a => 'Monoid' (T a) +-- @ +-- +-- Since @Constraint1@ is insufficient to implement 'mempty', +-- 'stimes' for @T a@ cannot do so. +-- +-- When working with such a type, or when working polymorphically with +-- 'Semigroup' instances, @mtimesDefault@ should be used when the +-- multiplier might be zero. It is implemented using 'stimes' when +-- the multiplier is nonzero and 'mempty' when it is zero. +-- +-- ==== __Examples__ +-- +-- >>> mtimesDefault 0 "bark" +-- "" +-- +-- >>> mtimesDefault 3 "meow" +-- "meowmeowmeow" +mtimesDefault :: (Integral b, Monoid a) => b -> a -> a +mtimesDefault n x + | n == 0 = mempty + | otherwise = stimes n x diff --git a/src/Data/String.hs b/src/Data/String.hs new file mode 100644 --- /dev/null +++ b/src/Data/String.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.String +-- Copyright : (c) The University of Glasgow 2007 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- The @String@ type and associated operations. +-- + +module Data.String + (String, + IsString(..), + -- * Functions on strings + lines, + words, + unlines, + unwords + ) where + +import GHC.Internal.Data.String diff --git a/src/Data/Traversable.hs b/src/Data/Traversable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Traversable.hs @@ -0,0 +1,1112 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : Data.Traversable +-- Copyright : Conor McBride and Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Class of data structures that can be traversed from left to right, +-- performing an action on each element. Instances are expected to satisfy +-- the listed [laws](#laws). + +module Data.Traversable ( + -- * The 'Traversable' class + Traversable(..), + -- * Utility functions + for, + forM, + forAccumM, + mapAccumL, + mapAccumR, + mapAccumM, + -- * General definitions for superclass methods + fmapDefault, + foldMapDefault, + + -- * Overview + -- $overview + + -- ** The 'traverse' and 'mapM' methods + -- $traverse + + -- *** Their 'Foldable', just the effects, analogues. + -- $effectful + + -- *** Result multiplicity + -- $multiplicity + + -- ** The 'sequenceA' and 'sequence' methods + -- $sequence + + -- *** Care with default method implementations + -- $seqdefault + + -- *** Monadic short circuits + -- $seqshort + + -- ** Example binary tree instance + -- $tree_instance + + -- *** Pre-order and post-order tree traversal + -- $tree_order + + -- ** Making construction intuitive + -- + -- $construction + + -- * Advanced traversals + -- $advanced + + -- *** Coercion + -- $coercion + + -- ** Identity: the 'fmapDefault' function + -- $identity + + -- ** State: the 'mapAccumL', 'mapAccumR' functions + -- $stateful + + -- ** Const: the 'foldMapDefault' function + -- $phantom + + -- ** ZipList: transposing lists of lists + -- $ziplist + + -- * Laws + -- + -- $laws + + -- * See also + -- $also + ) where + +import GHC.Internal.Data.Traversable + +-- $setup +-- >>> import Prelude +-- >>> import Data.Maybe +-- >>> import Data.Either +-- >>> import qualified Data.List as List +-- >>> :set -XExplicitForAll + +-- $overview +-- +-- #overview# +-- Traversable structures support element-wise sequencing of 'Applicative' +-- effects (thus also 'Monad' effects) to construct new structures of +-- __the same shape__ as the input. +-- +-- To illustrate what is meant by /same shape/, if the input structure is +-- __@[a]@__, each output structure is a list __@[b]@__ of the same length as +-- the input. If the input is a __@Tree a@__, each output __@Tree b@__ has the +-- same graph of intermediate nodes and leaves. Similarly, if the input is a +-- 2-tuple __@(x, a)@__, each output is a 2-tuple __@(x, b)@__, and so forth. +-- +-- It is in fact possible to decompose a traversable structure __@t a@__ into +-- its shape (a.k.a. /spine/) of type __@t ()@__ and its element list +-- __@[a]@__. The original structure can be faithfully reconstructed from its +-- spine and element list. +-- +-- The implementation of a @Traversable@ instance for a given structure follows +-- naturally from its type; see the [Construction](#construction) section for +-- details. +-- Instances must satisfy the laws listed in the [Laws section](#laws). +-- The diverse uses of @Traversable@ structures result from the many possible +-- choices of Applicative effects. +-- See the [Advanced Traversals](#advanced) section for some examples. +-- +-- Every @Traversable@ structure is both a 'Functor' and 'Foldable' because it +-- is possible to implement the requisite instances in terms of 'traverse' by +-- using 'fmapDefault' for 'fmap' and 'foldMapDefault' for 'foldMap'. Direct +-- fine-tuned implementations of these superclass methods can in some cases be +-- more efficient. + +------------------ + +-- $traverse +-- For an 'Applicative' functor __@f@__ and a @Traversable@ functor __@t@__, +-- the type signatures of 'traverse' and 'fmap' are rather similar: +-- +-- > fmap :: (a -> f b) -> t a -> t (f b) +-- > traverse :: (a -> f b) -> t a -> f (t b) +-- +-- The key difference is that 'fmap' produces a structure whose elements (of +-- type __@f b@__) are individual effects, while 'traverse' produces an +-- aggregate effect yielding structures of type __@t b@__. +-- +-- For example, when __@f@__ is the __@IO@__ monad, and __@t@__ is __@List@__, +-- 'fmap' yields a list of IO actions, whereas 'traverse' constructs an IO +-- action that evaluates to a list of the return values of the individual +-- actions performed left-to-right. +-- +-- > traverse :: (a -> IO b) -> [a] -> IO [b] +-- +-- The 'mapM' function is a specialisation of 'traverse' to the case when +-- __@f@__ is a 'Monad'. For monads, 'mapM' is more idiomatic than 'traverse'. +-- The two are otherwise generally identical (though 'mapM' may be specifically +-- optimised for monads, and could be more efficient than using the more +-- general 'traverse'). +-- +-- > traverse :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b) +-- > mapM :: (Monad m, Traversable t) => (a -> m b) -> t a -> m (t b) +-- +-- When the traversable term is a simple variable or expression, and the +-- monadic action to run is a non-trivial do block, it can be more natural to +-- write the action last. This idiom is supported by 'for', 'forM', and +-- 'forAccumM' which are the flipped versions of 'traverse', 'mapM', and +-- 'mapAccumM' respectively. + +------------------ + +-- $multiplicity +-- +-- #multiplicity# +-- When 'traverse' or 'mapM' is applied to an empty structure __@ts@__ (one for +-- which __@'null' ts@__ is 'True') the return value is __@pure ts@__ +-- regardless of the provided function __@g :: a -> f b@__. It is not possible +-- to apply the function when no values of type __@a@__ are available, but its +-- type determines the relevant instance of 'pure'. +-- +-- prop> null ts ==> traverse g ts == pure ts +-- +-- Otherwise, when __@ts@__ is non-empty and at least one value of type __@b@__ +-- results from each __@f a@__, the structures __@t b@__ have /the same shape/ +-- (list length, graph of tree nodes, ...) as the input structure __@t a@__, +-- but the slots previously occupied by elements of type __@a@__ now hold +-- elements of type __@b@__. +-- +-- A single traversal may produce one, zero or many such structures. The zero +-- case happens when one of the effects __@f a@__ sequenced as part of the +-- traversal yields no replacement values. Otherwise, the many case happens +-- when one of sequenced effects yields multiple values. +-- +-- The 'traverse' function does not perform selective filtering of slots in the +-- output structure as with e.g. 'Data.Maybe.mapMaybe'. +-- +-- >>> let incOdd n = if odd n then Just $ n + 1 else Nothing +-- >>> mapMaybe incOdd [1, 2, 3] +-- [2,4] +-- >>> traverse incOdd [1, 3, 5] +-- Just [2,4,6] +-- >>> traverse incOdd [1, 2, 3] +-- Nothing +-- +-- In the above examples, with 'Maybe' as the 'Applicative' __@f@__, we see +-- that the number of __@t b@__ structures produced by 'traverse' may differ +-- from one: it is zero when the result short-circuits to __@Nothing@__. The +-- same can happen when __@f@__ is __@List@__ and the result is __@[]@__, or +-- __@f@__ is __@Either e@__ and the result is __@Left (x :: e)@__, or perhaps +-- the 'Control.Applicative.empty' value of some +-- 'Control.Applicative.Alternative' functor. +-- +-- When __@f@__ is e.g. __@List@__, and the map __@g :: a -> [b]@__ returns +-- more than one value for some inputs __@a@__ (and at least one for all +-- __@a@__), the result of __@mapM g ts@__ will contain multiple structures of +-- the same shape as __@ts@__: +-- +-- prop> List.length (mapM g ts) == List.product (fmap (List.length . g) ts) +-- +-- For example: +-- +-- >>> List.length $ mapM (\n -> [1..n]) [1..6] +-- 720 +-- >>> List.product $ List.length . (\n -> [1..n]) <$> [1..6] +-- 720 +-- +-- In other words, a traversal with a function __@g :: a -> [b]@__, over an +-- input structure __@t a@__, yields a list __@[t b]@__, whose length is the +-- product of the lengths of the lists that @g@ returns for each element of the +-- input structure! The individual elements __@a@__ of the structure are +-- replaced by each element of __@g a@__ in turn: +-- +-- >>> mapM (\n -> [1..n]) $ Just 3 +-- [Just 1,Just 2,Just 3] +-- >>> mapM (\n -> [1..n]) [1..3] +-- [[1,1,1],[1,1,2],[1,1,3],[1,2,1],[1,2,2],[1,2,3]] +-- +-- If any element of the structure __@t a@__ is mapped by @g@ to an empty list, +-- then the entire aggregate result is empty, because no value is available to +-- fill one of the slots of the output structure: +-- +-- >>> mapM (\n -> [1..n]) $ [0..6] -- [1..0] is empty +-- [] + +------------------ + +-- $effectful +-- #effectful# +-- +-- The 'traverse' and 'mapM' methods have analogues in the "Data.Foldable" +-- module. These are 'traverse_' and 'mapM_', and their flipped variants +-- 'for_' and 'forM_', respectively. The result type is __@f ()@__, they don't +-- return an updated structure, and can be used to sequence effects over all +-- the elements of a @Traversable@ (any 'Foldable') structure just for their +-- side-effects. +-- +-- If the @Traversable@ structure is empty, the result is __@pure ()@__. When +-- effects short-circuit, the __@f ()@__ result may, for example, be 'Nothing' +-- if __@f@__ is 'Maybe', or __@'Left' e@__ when it is __@'Either' e@__. +-- +-- It is perhaps worth noting that 'Maybe' is not only a potential +-- 'Applicative' functor for the return value of the first argument of +-- 'traverse', but is also itself a 'Traversable' structure with either zero or +-- one element. A convenient idiom for conditionally executing an action just +-- for its effects on a 'Just' value, and doing nothing otherwise is: +-- +-- > -- action :: Monad m => a -> m () +-- > -- mvalue :: Maybe a +-- > mapM_ action mvalue -- :: m () +-- +-- which is more concise than: +-- +-- > maybe (return ()) action mvalue +-- +-- The 'mapM_' idiom works verbatim if the type of __@mvalue@__ is later +-- refactored from __@Maybe a@__ to __@Either e a@__ (assuming it remains OK to +-- silently do nothing in the 'Left' case). + +------------------ + +-- $sequence +-- +-- #sequence# +-- The 'sequenceA' and 'sequence' methods are useful when what you have is a +-- container of pending applicative or monadic effects, and you want to combine +-- them into a single effect that produces zero or more containers with the +-- computed values. +-- +-- > sequenceA :: (Applicative f, Traversable t) => t (f a) -> f (t a) +-- > sequence :: (Monad m, Traversable t) => t (m a) -> m (t a) +-- > sequenceA = traverse id -- default definition +-- > sequence = sequenceA -- default definition +-- +-- When the monad __@m@__ is 'System.IO.IO', applying 'sequence' to a list of +-- IO actions, performs each in turn, returning a list of the results: +-- +-- > sequence [putStr "Hello ", putStrLn "World!"] +-- > = (\a b -> [a,b]) <$> putStr "Hello " <*> putStrLn "World!" +-- > = do u1 <- putStr "Hello " +-- > u2 <- putStrLn "World!" +-- > return [u1, u2] -- In this case [(), ()] +-- +-- For 'sequenceA', the /non-deterministic/ behaviour of @List@ is most easily +-- seen in the case of a list of lists (of elements of some common fixed type). +-- The result is a cross-product of all the sublists: +-- +-- >>> sequenceA [[0, 1, 2], [30, 40], [500]] +-- [[0,30,500],[0,40,500],[1,30,500],[1,40,500],[2,30,500],[2,40,500]] +-- +-- Because the input list has three (sublist) elements, the result is a list of +-- triples (/same shape/). + +------------------ + +-- $seqshort +-- +-- #seqshort# +-- When the monad __@m@__ is 'Either' or 'Maybe' (more generally any +-- 'Control.Monad.MonadPlus'), the effect in question is to short-circuit the +-- result on encountering 'Left' or 'Nothing' (more generally +-- 'Control.Monad.mzero'). +-- +-- >>> sequence [Just 1,Just 2,Just 3] +-- Just [1,2,3] +-- >>> sequence [Just 1,Nothing,Just 3] +-- Nothing +-- >>> sequence [Right 1,Right 2,Right 3] +-- Right [1,2,3] +-- >>> sequence [Right 1,Left "sorry",Right 3] +-- Left "sorry" +-- +-- The result of 'sequence' is all-or-nothing, either structures of exactly the +-- same shape as the input or none at all. The 'sequence' function does not +-- perform selective filtering as with e.g. 'Data.Maybe.catMaybes' or +-- 'Data.Either.rights': +-- +-- >>> catMaybes [Just 1,Nothing,Just 3] +-- [1,3] +-- >>> rights [Right 1,Left "sorry",Right 3] +-- [1,3] + +------------------ + +-- $seqdefault +-- +-- #seqdefault# +-- The 'traverse' method has a default implementation in terms of 'sequenceA': +-- +-- > traverse g = sequenceA . fmap g +-- +-- but relying on this default implementation is not recommended, it requires +-- that the structure is already independently a 'Functor'. The definition of +-- 'sequenceA' in terms of __@traverse id@__ is much simpler than 'traverse' +-- expressed via a composition of 'sequenceA' and 'fmap'. Instances should +-- generally implement 'traverse' explicitly. It may in some cases also make +-- sense to implement a specialised 'mapM'. +-- +-- Because 'fmapDefault' is defined in terms of 'traverse' (whose default +-- definition in terms of 'sequenceA' uses 'fmap'), you must not use +-- 'fmapDefault' to define the @Functor@ instance if the @Traversable@ instance +-- directly defines only 'sequenceA'. + +------------------ + +-- $tree_instance +-- +-- #tree# +-- The definition of a 'Traversable' instance for a binary tree is rather +-- similar to the corresponding instance of 'Functor', given the data type: +-- +-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) +-- +-- a canonical @Functor@ instance would be +-- +-- > instance Functor Tree where +-- > fmap g Empty = Empty +-- > fmap g (Leaf x) = Leaf (g x) +-- > fmap g (Node l k r) = Node (fmap g l) (g k) (fmap g r) +-- +-- a canonical @Traversable@ instance would be +-- +-- > instance Traversable Tree where +-- > traverse g Empty = pure Empty +-- > traverse g (Leaf x) = Leaf <$> g x +-- > traverse g (Node l k r) = Node <$> traverse g l <*> g k <*> traverse g r +-- +-- This definition works for any __@g :: a -> f b@__, with __@f@__ an +-- Applicative functor, as the laws for @('<*>')@ imply the requisite +-- associativity. +-- +-- We can add an explicit non-default 'mapM' if desired: +-- +-- > mapM g Empty = return Empty +-- > mapM g (Leaf x) = Leaf <$> g x +-- > mapM g (Node l k r) = do +-- > ml <- mapM g l +-- > mk <- g k +-- > mr <- mapM g r +-- > return $ Node ml mk mr +-- +-- See [Construction](#construction) below for a more detailed exploration of +-- the general case, but as mentioned in [Overview](#overview) above, instance +-- definitions are typically rather simple, all the interesting behaviour is a +-- result of an interesting choice of 'Applicative' functor for a traversal. + +-- $tree_order +-- +-- It is perhaps worth noting that the traversal defined above gives an +-- /in-order/ sequencing of the elements. If instead you want either +-- /pre-order/ (parent first, then child nodes) or post-order (child nodes +-- first, then parent) sequencing, you can define the instance accordingly: +-- +-- > inOrderNode :: Tree a -> a -> Tree a -> Tree a +-- > inOrderNode l x r = Node l x r +-- > +-- > preOrderNode :: a -> Tree a -> Tree a -> Tree a +-- > preOrderNode x l r = Node l x r +-- > +-- > postOrderNode :: Tree a -> Tree a -> a -> Tree a +-- > postOrderNode l r x = Node l x r +-- > +-- > -- Traversable instance with in-order traversal +-- > instance Traversable Tree where +-- > traverse g t = case t of +-- > Empty -> pure Empty +-- > Leaf x -> Leaf <$> g x +-- > Node l x r -> inOrderNode <$> traverse g l <*> g x <*> traverse g r +-- > +-- > -- Traversable instance with pre-order traversal +-- > instance Traversable Tree where +-- > traverse g t = case t of +-- > Empty -> pure Empty +-- > Leaf x -> Leaf <$> g x +-- > Node l x r -> preOrderNode <$> g x <*> traverse g l <*> traverse g r +-- > +-- > -- Traversable instance with post-order traversal +-- > instance Traversable Tree where +-- > traverse g t = case t of +-- > Empty -> pure Empty +-- > Leaf x -> Leaf <$> g x +-- > Node l x r -> postOrderNode <$> traverse g l <*> traverse g r <*> g x +-- +-- Since the same underlying Tree structure is used in all three cases, it is +-- possible to use @newtype@ wrappers to make all three available at the same +-- time! The user need only wrap the root of the tree in the appropriate +-- @newtype@ for the desired traversal order. Tne associated instance +-- definitions are shown below (see [coercion](#coercion) if unfamiliar with +-- the use of 'coerce' in the sample code): +-- +-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +-- > +-- > -- Default in-order traversal +-- > +-- > import Data.Coerce (coerce) +-- > import Data.Traversable +-- > +-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) +-- > instance Functor Tree where fmap = fmapDefault +-- > instance Foldable Tree where foldMap = foldMapDefault +-- > +-- > instance Traversable Tree where +-- > traverse _ Empty = pure Empty +-- > traverse g (Leaf a) = Leaf <$> g a +-- > traverse g (Node l a r) = Node <$> traverse g l <*> g a <*> traverse g r +-- > +-- > -- Optional pre-order traversal +-- > +-- > newtype PreOrderTree a = PreOrderTree (Tree a) +-- > instance Functor PreOrderTree where fmap = fmapDefault +-- > instance Foldable PreOrderTree where foldMap = foldMapDefault +-- > +-- > instance Traversable PreOrderTree where +-- > traverse _ (PreOrderTree Empty) = pure $ preOrderEmpty +-- > traverse g (PreOrderTree (Leaf x)) = preOrderLeaf <$> g x +-- > traverse g (PreOrderTree (Node l x r)) = preOrderNode +-- > <$> g x +-- > <*> traverse g (coerce l) +-- > <*> traverse g (coerce r) +-- > +-- > preOrderEmpty :: forall a. PreOrderTree a +-- > preOrderEmpty = coerce (Empty @a) +-- > preOrderLeaf :: forall a. a -> PreOrderTree a +-- > preOrderLeaf = coerce (Leaf @a) +-- > preOrderNode :: a -> PreOrderTree a -> PreOrderTree a -> PreOrderTree a +-- > preOrderNode x l r = coerce (Node (coerce l) x (coerce r)) +-- > +-- > -- Optional post-order traversal +-- > +-- > newtype PostOrderTree a = PostOrderTree (Tree a) +-- > instance Functor PostOrderTree where fmap = fmapDefault +-- > instance Foldable PostOrderTree where foldMap = foldMapDefault +-- > +-- > instance Traversable PostOrderTree where +-- > traverse _ (PostOrderTree Empty) = pure postOrderEmpty +-- > traverse g (PostOrderTree (Leaf x)) = postOrderLeaf <$> g x +-- > traverse g (PostOrderTree (Node l x r)) = postOrderNode +-- > <$> traverse g (coerce l) +-- > <*> traverse g (coerce r) +-- > <*> g x +-- > +-- > postOrderEmpty :: forall a. PostOrderTree a +-- > postOrderEmpty = coerce (Empty @a) +-- > postOrderLeaf :: forall a. a -> PostOrderTree a +-- > postOrderLeaf = coerce (Leaf @a) +-- > postOrderNode :: PostOrderTree a -> PostOrderTree a -> a -> PostOrderTree a +-- > postOrderNode l r x = coerce (Node (coerce l) x (coerce r)) +-- +-- With the above, given a sample tree: +-- +-- > inOrder :: Tree Int +-- > inOrder = Node (Node (Leaf 10) 3 (Leaf 20)) 5 (Leaf 42) +-- +-- we have: +-- +-- > import Data.Foldable (toList) +-- > print $ toList inOrder +-- > [10,3,20,5,42] +-- > +-- > print $ toList (coerce inOrder :: PreOrderTree Int) +-- > [5,3,10,20,42] +-- > +-- > print $ toList (coerce inOrder :: PostOrderTree Int) +-- > [10,20,3,42,5] +-- +-- You would typically define instances for additional common type classes, +-- such as 'Eq', 'Ord', 'Show', etc. + +------------------ + +-- $construction +-- +-- #construction# +-- In order to be able to reason about how a given type of 'Applicative' +-- effects will be sequenced through a general 'Traversable' structure by its +-- 'traversable' and related methods, it is helpful to look more closely +-- at how a general 'traverse' method is implemented. We'll look at how +-- general traversals are constructed primarily with a view to being able +-- to predict their behaviour as a user, even if you're not defining your +-- own 'Traversable' instances. +-- +-- Traversable structures __@t a@__ are assembled incrementally from their +-- constituent parts, perhaps by prepending or appending individual elements of +-- type __@a@__, or, more generally, by recursively combining smaller composite +-- traversable building blocks that contain multiple such elements. +-- +-- As in the [tree example](#tree) above, the components being combined are +-- typically pieced together by a suitable /constructor/, i.e. a function +-- taking two or more arguments that returns a composite value. +-- +-- The 'traverse' method enriches simple incremental construction with +-- threading of 'Applicative' effects of some function __@g :: a -> f b@__. +-- +-- The basic building blocks we'll use to model the construction of 'traverse' +-- are a hypothetical set of elementary functions, some of which may have +-- direct analogues in specific @Traversable@ structures. For example, the +-- __@(':')@__ constructor is an analogue for lists of @prepend@ or the more +-- general @combine@. +-- +-- > empty :: t a -- build an empty container +-- > singleton :: a -> t a -- build a one-element container +-- > prepend :: a -> t a -> t a -- extend by prepending a new initial element +-- > append :: t a -> a -> t a -- extend by appending a new final element +-- > combine :: a1 -> a2 -> ... -> an -> t a -- combine multiple inputs +-- +-- * An empty structure has no elements of type __@a@__, so there's nothing +-- to which __@g@__ can be applied, but since we need an output of type +-- __@f (t b)@__, we just use the 'pure' instance of __@f@__ to wrap an +-- empty of type __@t b@__: +-- +-- > traverse _ (empty :: t a) = pure (empty :: t b) +-- +-- With the List monad, /empty/ is __@[]@__, while with 'Maybe' it is +-- 'Nothing'. With __@Either e a@__ we have an /empty/ case for each +-- value of __@e@__: +-- +-- > traverse _ (Left e :: Either e a) = pure $ (Left e :: Either e b) +-- +-- * A singleton structure has just one element of type __@a@__, and +-- 'traverse' can take that __@a@__, apply __@g :: a -> f b@__ getting an +-- __@f b@__, then __@fmap singleton@__ over that, getting an __@f (t b)@__ +-- as required: +-- +-- > traverse g (singleton a) = fmap singleton $ g a +-- +-- Note that if __@f@__ is __@List@__ and __@g@__ returns multiple values +-- the result will be a list of multiple __@t b@__ singletons! +-- +-- Since 'Maybe' and 'Either' are either empty or singletons, we have +-- +-- > traverse _ Nothing = pure Nothing +-- > traverse g (Just a) = Just <$> g a +-- +-- > traverse _ (Left e) = pure (Left e) +-- > traverse g (Right a) = Right <$> g a +-- +-- For @List@, empty is __@[]@__ and @singleton@ is __@(:[])@__, so we have: +-- +-- > traverse _ [] = pure [] +-- > traverse g [a] = fmap (:[]) (g a) +-- > = (:) <$> (g a) <*> traverse g [] +-- > = liftA2 (:) (g a) (traverse g []) +-- +-- * When the structure is built by adding one more element via __@prepend@__ +-- or __@append@__, traversal amounts to: +-- +-- > traverse g (prepend a t0) = prepend <$> (g a) <*> traverse g t0 +-- > = liftA2 prepend (g a) (traverse g t0) +-- +-- > traverse g (append t0 a) = append <$> traverse g t0 <*> g a +-- > = liftA2 append (traverse g t0) (g a) +-- +-- The origin of the combinatorial product when __@f@__ is @List@ should now +-- be apparent, when __@traverse g t0@__ has __@n@__ elements and __@g a@__ +-- has __@m@__ elements, the /non-deterministic/ 'Applicative' instance of +-- @List@ will produce a result with __@m * n@__ elements. +-- +-- * When combining larger building blocks, we again use __@('<*>')@__ to +-- combine the traversals of the components. With bare elements __@a@__ +-- mapped to __@f b@__ via __@g@__, and composite traversable +-- sub-structures transformed via __@traverse g@__: +-- +-- > traverse g (combine a1 a2 ... an) = +-- > combine <$> t1 <*> t2 <*> ... <*> tn +-- > where +-- > t1 = g a1 -- if a1 fills a slot of type @a@ +-- > = traverse g a1 -- if a1 is a traversable substructure +-- > ... ditto for the remaining constructor arguments ... +-- +-- The above definitions sequence the 'Applicative' effects of __@f@__ in the +-- expected order while producing results of the expected shape __@t@__. +-- +-- For lists this becomes: +-- +-- > traverse g [] = pure [] +-- > traverse g (x:xs) = liftA2 (:) (g a) (traverse g xs) +-- +-- The actual definition of 'traverse' for lists is an equivalent +-- right fold in order to facilitate list /fusion/. +-- +-- > traverse g = foldr (\x r -> liftA2 (:) (g x) r) (pure []) + +------------------ + +-- $advanced +-- +-- #advanced# +-- In the sections below we'll examine some advanced choices of 'Applicative' +-- effects that give rise to very different transformations of @Traversable@ +-- structures. +-- +-- These examples cover the implementations of 'fmapDefault', 'foldMapDefault', +-- 'mapAccumL' and 'mapAccumR' functions illustrating the use of 'Identity', +-- 'Const' and stateful 'Applicative' effects. The [ZipList](#ziplist) example +-- illustrates the use of a less-well known 'Applicative' instance for lists. +-- +-- This is optional material, which is not essential to a basic understanding of +-- @Traversable@ structures. If this is your first encounter with @Traversable@ +-- structures, you can come back to these at a later date. + +-- $coercion +-- +-- #coercion# +-- Some of the examples make use of an advanced Haskell feature, namely +-- @newtype@ /coercion/. This is done for two reasons: +-- +-- * Use of 'coerce' makes it possible to avoid cluttering the code with +-- functions that wrap and unwrap /newtype/ terms, which at runtime are +-- indistinguishable from the underlying value. Coercion is particularly +-- convenient when one would have to otherwise apply multiple newtype +-- constructors to function arguments, and then peel off multiple layers +-- of same from the function output. +-- +-- * Use of 'coerce' can produce more efficient code, by reusing the original +-- value, rather than allocating space for a wrapped clone. +-- +-- If you're not familiar with 'coerce', don't worry, it is just a shorthand +-- that, e.g., given: +-- +-- > newtype Foo a = MkFoo { getFoo :: a } +-- > newtype Bar a = MkBar { getBar :: a } +-- > newtype Baz a = MkBaz { getBaz :: a } +-- > f :: Baz Int -> Bar (Foo String) +-- +-- makes it possible to write: +-- +-- > x :: Int -> String +-- > x = coerce f +-- +-- instead of +-- +-- > x = getFoo . getBar . f . MkBaz + +------------------ + +-- $identity +-- +-- #identity# +-- The simplest Applicative functor is 'Identity', which just wraps and unwraps +-- pure values and function application. This allows us to define +-- 'fmapDefault': +-- +-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +-- > import Data.Coercible (coerce) +-- > +-- > fmapDefault :: forall t a b. Traversable t => (a -> b) -> t a -> t b +-- > fmapDefault = coerce (traverse @t @Identity @a @b) +-- +-- The use of [coercion](#coercion) avoids the need to explicitly wrap and +-- unwrap terms via 'Identity' and 'runIdentity'. +-- +-- As noted in [Overview](#overview), 'fmapDefault' can only be used to define +-- the requisite 'Functor' instance of a 'Traversable' structure when the +-- 'traverse' method is explicitly implemented. An infinite loop would result +-- if in addition 'traverse' were defined in terms of 'sequenceA' and 'fmap'. + +------------------ + +-- $stateful +-- +-- #stateful# +-- Applicative functors that thread a changing state through a computation are +-- an interesting use-case for 'traverse'. The 'mapAccumL' and 'mapAccumR' +-- functions in this module are each defined in terms of such traversals. +-- +-- We first define a simplified (not a monad transformer) version of +-- 'Control.Monad.Trans.State.State' that threads a state __@s@__ through a +-- chain of computations left to right. Its @('<*>')@ operator passes the +-- input state first to its left argument, and then the resulting state is +-- passed to its right argument, which returns the final state. +-- +-- > newtype StateL s a = StateL { runStateL :: s -> (s, a) } +-- > +-- > instance Functor (StateL s) where +-- > fmap f (StateL kx) = StateL $ \ s -> +-- > let (s', x) = kx s in (s', f x) +-- > +-- > instance Applicative (StateL s) where +-- > pure a = StateL $ \s -> (s, a) +-- > (StateL kf) <*> (StateL kx) = StateL $ \ s -> +-- > let { (s', f) = kf s +-- > ; (s'', x) = kx s' } in (s'', f x) +-- > liftA2 f (StateL kx) (StateL ky) = StateL $ \ s -> +-- > let { (s', x) = kx s +-- > ; (s'', y) = ky s' } in (s'', f x y) +-- +-- With @StateL@, we can define 'mapAccumL' as follows: +-- +-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +-- > mapAccumL :: forall t s a b. Traversable t +-- > => (s -> a -> (s, b)) -> s -> t a -> (s, t b) +-- > mapAccumL g s ts = coerce (traverse @t @(StateL s) @a @b) (flip g) ts s +-- +-- The use of [coercion](#coercion) avoids the need to explicitly wrap and +-- unwrap __@newtype@__ terms. +-- +-- The type of __@flip g@__ is coercible to __@a -> StateL b@__, which makes it +-- suitable for use with 'traverse'. As part of the Applicative +-- [construction](#construction) of __@StateL (t b)@__ the state updates will +-- thread left-to-right along the sequence of elements of __@t a@__. +-- +-- While 'mapAccumR' has a type signature identical to 'mapAccumL', it differs +-- in the expected order of evaluation of effects, which must take place +-- right-to-left. +-- +-- For this we need a variant control structure @StateR@, which threads the +-- state right-to-left, by passing the input state to its right argument and +-- then using the resulting state as an input to its left argument: +-- +-- > newtype StateR s a = StateR { runStateR :: s -> (s, a) } +-- > +-- > instance Functor (StateR s) where +-- > fmap f (StateR kx) = StateR $ \s -> +-- > let (s', x) = kx s in (s', f x) +-- > +-- > instance Applicative (StateR s) where +-- > pure a = StateR $ \s -> (s, a) +-- > (StateR kf) <*> (StateR kx) = StateR $ \ s -> +-- > let { (s', x) = kx s +-- > ; (s'', f) = kf s' } in (s'', f x) +-- > liftA2 f (StateR kx) (StateR ky) = StateR $ \ s -> +-- > let { (s', y) = ky s +-- > ; (s'', x) = kx s' } in (s'', f x y) +-- +-- With @StateR@, we can define 'mapAccumR' as follows: +-- +-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +-- > mapAccumR :: forall t s a b. Traversable t +-- > => (s -> a -> (s, b)) -> s -> t a -> (s, t b) +-- > mapAccumR g s0 ts = coerce (traverse @t @(StateR s) @a @b) (flip g) ts s0 +-- +-- The use of [coercion](#coercion) avoids the need to explicitly wrap and +-- unwrap __@newtype@__ terms. +-- +-- Various stateful traversals can be constructed from 'mapAccumL' and +-- 'mapAccumR' for suitable choices of @g@, or built directly along similar +-- lines. + +------------------ + +-- $phantom +-- +-- #phantom# +-- The 'Const' Functor enables applications of 'traverse' that summarise the +-- input structure to an output value without constructing any output values +-- of the same type or shape. +-- +-- As noted [above](#overview), the @Foldable@ superclass constraint is +-- justified by the fact that it is possible to construct 'foldMap', 'foldr', +-- etc., from 'traverse'. The technique used is useful in its own right, and +-- is explored below. +-- +-- A key feature of folds is that they can reduce the input structure to a +-- summary value. Often neither the input structure nor a mutated clone is +-- needed once the fold is computed, and through list fusion the input may not +-- even have been memory resident in its entirety at the same time. +-- +-- The 'traverse' method does not at first seem to be a suitable building block +-- for folds, because its return value __@f (t b)@__ appears to retain mutated +-- copies of the input structure. But the presence of __@t b@__ in the type +-- signature need not mean that terms of type __@t b@__ are actually embedded +-- in __@f (t b)@__. The simplest way to elide the excess terms is by basing +-- the Applicative functor used with 'traverse' on 'Const'. +-- +-- Not only does __@Const a b@__ hold just an __@a@__ value, with the __@b@__ +-- parameter merely a /phantom/ type, but when __@m@__ has a 'Monoid' instance, +-- __@Const m@__ is an 'Applicative' functor: +-- +-- > import Data.Coerce (coerce) +-- > newtype Const a b = Const { getConst :: a } deriving (Eq, Ord, Show) -- etc. +-- > instance Functor (Const m) where fmap = const coerce +-- > instance Monoid m => Applicative (Const m) where +-- > pure _ = Const mempty +-- > (<*>) = coerce (mappend :: m -> m -> m) +-- > liftA2 _ = coerce (mappend :: m -> m -> m) +-- +-- The use of [coercion](#coercion) avoids the need to explicitly wrap and +-- unwrap __@newtype@__ terms. +-- +-- We can therefore define a specialisation of 'traverse': +-- +-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +-- > traverseC :: forall t a m. (Monoid m, Traversable t) +-- > => (a -> Const m ()) -> t a -> Const m (t ()) +-- > traverseC = traverse @t @(Const m) @a @() +-- +-- For which the Applicative [construction](#construction) of 'traverse' +-- leads to: +-- +-- prop> null ts ==> traverseC g ts = Const mempty +-- prop> traverseC g (prepend x xs) = Const (g x) <> traverseC g xs +-- +-- In other words, this makes it possible to define: +-- +-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +-- > foldMapDefault :: forall t a m. (Monoid m, Traversable t) => (a -> m) -> t a -> m +-- > foldMapDefault = coerce (traverse @t @(Const m) @a @()) +-- +-- Which is sufficient to define a 'Foldable' superclass instance: +-- +-- The use of [coercion](#coercion) avoids the need to explicitly wrap and +-- unwrap __@newtype@__ terms. +-- +-- > instance Traversable t => Foldable t where foldMap = foldMapDefault +-- +-- It may however be instructive to also directly define candidate default +-- implementations of 'foldr' and 'foldl'', which take a bit more machinery +-- to construct: +-- +-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +-- > import Data.Coerce (coerce) +-- > import Data.Functor.Const (Const(..)) +-- > import Data.Semigroup (Dual(..), Endo(..)) +-- > import GHC.Exts (oneShot) +-- > +-- > foldrDefault :: forall t a b. Traversable t +-- > => (a -> b -> b) -> b -> t a -> b +-- > foldrDefault f z = \t -> +-- > coerce (traverse @t @(Const (Endo b)) @a @()) f t z +-- > +-- > foldlDefault' :: forall t a b. Traversable t => (b -> a -> b) -> b -> t a -> b +-- > foldlDefault' f z = \t -> +-- > coerce (traverse @t @(Const (Dual (Endo b))) @a @()) f' t z +-- > where +-- > f' :: a -> b -> b +-- > f' a = oneShot $ \ b -> b `seq` f b a +-- +-- In the above we're using the __@'Data.Monoid.Endo' b@__ 'Monoid' and its +-- 'Dual' to compose a sequence of __@b -> b@__ accumulator updates in either +-- left-to-right or right-to-left order. +-- +-- The use of 'seq' in the definition of __@foldlDefault'@__ ensures strictness +-- in the accumulator. +-- +-- The use of [coercion](#coercion) avoids the need to explicitly wrap and +-- unwrap __@newtype@__ terms. +-- +-- The 'GHC.Exts.oneShot' function gives a hint to the compiler that aids in +-- correct optimisation of lambda terms that fire at most once (for each +-- element __@a@__) and so should not try to pre-compute and re-use +-- subexpressions that pay off only on repeated execution. Otherwise, it is +-- just the identity function. + +------------------ + +-- $ziplist +-- +-- #ziplist# +-- As a warm-up for looking at the 'ZipList' 'Applicative' functor, we'll first +-- look at a simpler analogue. First define a fixed width 2-element @Vec2@ +-- type, whose 'Applicative' instance combines a pair of functions with a pair of +-- values by applying each function to the corresponding value slot: +-- +-- > data Vec2 a = Vec2 a a +-- > instance Functor Vec2 where +-- > fmap f (Vec2 a b) = Vec2 (f a) (f b) +-- > instance Applicative Vec2 where +-- > pure x = Vec2 x x +-- > liftA2 f (Vec2 a b) (Vec2 p q) = Vec2 (f a p) (f b q) +-- > instance Foldable Vec2 where +-- > foldr f z (Vec2 a b) = f a (f b z) +-- > foldMap f (Vec2 a b) = f a <> f b +-- > instance Traversable Vec2 where +-- > traverse f (Vec2 a b) = Vec2 <$> f a <*> f b +-- +-- Along with a similar definition for fixed width 3-element vectors: +-- +-- > data Vec3 a = Vec3 a a a +-- > instance Functor Vec3 where +-- > fmap f (Vec3 x y z) = Vec3 (f x) (f y) (f z) +-- > instance Applicative Vec3 where +-- > pure x = Vec3 x x x +-- > liftA2 f (Vec3 p q r) (Vec3 x y z) = Vec3 (f p x) (f q y) (f r z) +-- > instance Foldable Vec3 where +-- > foldr f z (Vec3 a b c) = f a (f b (f c z)) +-- > foldMap f (Vec3 a b c) = f a <> f b <> f c +-- > instance Traversable Vec3 where +-- > traverse f (Vec3 a b c) = Vec3 <$> f a <*> f b <*> f c +-- +-- With the above definitions, @'sequenceA'@ (same as @'traverse' 'id'@) acts +-- as a /matrix transpose/ operation on @Vec2 (Vec3 Int)@ producing a +-- corresponding @Vec3 (Vec2 Int)@: +-- +-- Let __@t = Vec2 (Vec3 1 2 3) (Vec3 4 5 6)@__ be our 'Traversable' structure, +-- and __@g = id :: Vec3 Int -> Vec3 Int@__ be the function used to traverse +-- __@t@__. We then have: +-- +-- > traverse g t = Vec2 <$> (Vec3 1 2 3) <*> (Vec3 4 5 6) +-- > = Vec3 (Vec2 1 4) (Vec2 2 5) (Vec2 3 6) +-- +-- This construction can be generalised from fixed width vectors to variable +-- length lists via 'Control.Applicative.ZipList'. This gives a transpose +-- operation that works well for lists of equal length. If some of the lists +-- are longer than others, they're truncated to the longest common length. +-- +-- We've already looked at the standard 'Applicative' instance of @List@ for +-- which applying __@m@__ functions __@f1, f2, ..., fm@__ to __@n@__ input +-- values __@a1, a2, ..., an@__ produces __@m * n@__ outputs: +-- +-- >>> :set -XTupleSections +-- >>> [("f1",), ("f2",), ("f3",)] <*> [1,2] +-- [("f1",1),("f1",2),("f2",1),("f2",2),("f3",1),("f3",2)] +-- +-- There are however two more common ways to turn lists into 'Applicative' +-- control structures. The first is via __@'Const' [a]@__, since lists are +-- monoids under concatenation, and we've already seen that __@'Const' m@__ is +-- an 'Applicative' functor when __@m@__ is a 'Monoid'. The second, is based +-- on 'Data.List.zipWith', and is called 'Control.Applicative.ZipList': +-- +-- > {-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- > newtype ZipList a = ZipList { getZipList :: [a] } +-- > deriving (Show, Eq, ..., Functor) +-- > +-- > instance Applicative ZipList where +-- > liftA2 f (ZipList xs) (ZipList ys) = ZipList $ zipWith f xs ys +-- > pure x = repeat x +-- +-- The 'liftA2' definition is clear enough, instead of applying __@f@__ to each +-- pair __@(x, y)@__ drawn independently from the __@xs@__ and __@ys@__, only +-- corresponding pairs at each index in the two lists are used. +-- +-- The definition of 'pure' may look surprising, but it is needed to ensure +-- that the instance is lawful: +-- +-- prop> liftA2 f (pure x) ys == fmap (f x) ys +-- +-- Since __@ys@__ can have any length, we need to provide an infinite supply +-- of __@x@__ values in __@pure x@__ in order to have a value to pair with +-- each element __@y@__. +-- +-- When 'Control.Applicative.ZipList' is the 'Applicative' functor used in the +-- [construction](#construction) of a traversal, a ZipList holding a partially +-- built structure with __@m@__ elements is combined with a component holding +-- __@n@__ elements via 'zipWith', resulting in __@min m n@__ outputs! +-- +-- Therefore 'traverse' with __@g :: a -> ZipList b@__ will produce a @ZipList@ +-- of __@t b@__ structures whose element count is the minimum length of the +-- ZipLists __@g a@__ with __@a@__ ranging over the elements of __@t@__. When +-- __@t@__ is empty, the length is infinite (as expected for a minimum of an +-- empty set). +-- +-- If the structure __@t@__ holds values of type __@ZipList a@__, we can use +-- the identity function __@id :: ZipList a -> ZipList a@__ for the first +-- argument of 'traverse': +-- +-- > traverse (id :: ZipList a -> ZipList a) :: t (ZipList a) -> ZipList (t a) +-- +-- The number of elements in the output @ZipList@ will be the length of the +-- shortest @ZipList@ element of __@t@__. Each output __@t a@__ will have the +-- /same shape/ as the input __@t (ZipList a)@__, i.e. will share its number of +-- elements. +-- +-- If we think of the elements of __@t (ZipList a)@__ as its rows, and the +-- elements of each individual @ZipList@ as the columns of that row, we see +-- that our traversal implements a /transpose/ operation swapping the rows +-- and columns of __@t@__, after first truncating all the rows to the column +-- count of the shortest one. +-- +-- Since in fact __@'traverse' id@__ is just 'sequenceA' the above boils down +-- to a rather concise definition of /transpose/, with [coercion](#coercion) +-- used to implicitly wrap and unwrap the @ZipList@ @newtype@ as needed, giving +-- a function that operates on a list of lists: +-- +-- >>> :set -XScopedTypeVariables +-- >>> import Control.Applicative (ZipList(..)) +-- >>> import Data.Coerce (coerce) +-- >>> +-- >>> :{ +-- >>> 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 +-- unwrap __@ZipList@__ terms. + +------------------ + +-- $laws +-- +-- #laws# +-- A definition of 'traverse' must satisfy the following laws: +-- +-- [Naturality] +-- @t . 'traverse' f = 'traverse' (t . f)@ +-- for every applicative transformation @t@ +-- +-- [Identity] +-- @'traverse' 'Identity' = 'Identity'@ +-- +-- [Composition] +-- @'traverse' ('Data.Functor.Compose.Compose' . 'fmap' g . f) +-- = 'Data.Functor.Compose.Compose' . 'fmap' ('traverse' g) . 'traverse' f@ +-- +-- A definition of 'sequenceA' must satisfy the following laws: +-- +-- [Naturality] +-- @t . 'sequenceA' = 'sequenceA' . 'fmap' t@ +-- for every applicative transformation @t@ +-- +-- [Identity] +-- @'sequenceA' . 'fmap' 'Identity' = 'Identity'@ +-- +-- [Composition] +-- @'sequenceA' . 'fmap' 'Data.Functor.Compose.Compose' +-- = 'Data.Functor.Compose.Compose' . 'fmap' 'sequenceA' . 'sequenceA'@ +-- +-- where an /applicative transformation/ is a function +-- +-- @t :: (Applicative f, Applicative g) => f a -> g a@ +-- +-- preserving the 'Applicative' operations, i.e. +-- +-- @ +-- t ('pure' x) = 'pure' x +-- t (f '<*>' x) = t f '<*>' t x +-- @ +-- +-- and the identity functor 'Identity' and composition functors +-- 'Data.Functor.Compose.Compose' are from "Data.Functor.Identity" and +-- "Data.Functor.Compose". +-- +-- A result of the naturality law is a purity law for 'traverse' +-- +-- @'traverse' 'pure' = 'pure'@ +-- +-- The superclass instances should satisfy the following: +-- +-- * In the 'Functor' instance, 'fmap' should be equivalent to traversal +-- with the identity applicative functor ('fmapDefault'). +-- +-- * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be +-- equivalent to traversal with a constant applicative functor +-- ('foldMapDefault'). +-- +-- Note: the 'Functor' superclass means that (in GHC) Traversable structures +-- cannot impose any constraints on the element type. A Haskell implementation +-- that supports constrained functors could make it possible to define +-- constrained @Traversable@ structures. + +------------------ + +-- $also +-- +-- * \"The Essence of the Iterator Pattern\", +-- by Jeremy Gibbons and Bruno Oliveira, +-- in /Mathematically-Structured Functional Programming/, 2006, online at +-- . +-- +-- * \"Applicative Programming with Effects\", +-- by Conor McBride and Ross Paterson, +-- /Journal of Functional Programming/ 18:1 (2008) 1-13, online at +-- . +-- +-- * \"An Investigation of the Laws of Traversals\", +-- by Mauro Jaskelioff and Ondrej Rypacek, +-- in /Mathematically-Structured Functional Programming/, 2012, online at +-- . diff --git a/src/Data/Tuple.hs b/src/Data/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tuple.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Tuple +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Functions associated with the tuple data types. +-- + +module Data.Tuple + (Solo(..), + getSolo, + fst, + snd, + curry, + uncurry, + swap + ) where + +import GHC.Internal.Data.Tuple diff --git a/src/Data/Type/Bool.hs b/src/Data/Type/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Bool.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE Safe #-} + +{-# LANGUAGE ExplicitNamespaces #-} + +-- | +-- +-- Module : Data.Type.Bool +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : not portable +-- +-- Basic operations on type-level Booleans. +-- +-- @since 4.7.0.0 + +module Data.Type.Bool + (If, + type (&&), + type (||), + Not + ) where + +import GHC.Internal.Data.Type.Bool diff --git a/src/Data/Type/Coercion.hs b/src/Data/Type/Coercion.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Coercion.hs @@ -0,0 +1,24 @@ +-- | +-- +-- Module : Data.Type.Coercion +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : not portable +-- +-- Definition of representational equality ('Coercion'). +-- +-- @since 4.7.0.0 + +module Data.Type.Coercion + (Coercion(..), + coerceWith, + gcoerceWith, + sym, + trans, + repr, + TestCoercion(..) + ) where + +import GHC.Internal.Data.Type.Coercion diff --git a/src/Data/Type/Equality.hs b/src/Data/Type/Equality.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Equality.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE Safe #-} + +{-# LANGUAGE ExplicitNamespaces #-} + +-- | +-- +-- Module : Data.Type.Equality +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : not portable +-- +-- Definition of propositional equality @(':~:')@. Pattern-matching on a variable +-- of type @(a ':~:' b)@ produces a proof that @a '~' b@. +-- +-- @since 4.7.0.0 + +module Data.Type.Equality + (-- * The equality types + type (~), + type (~~), + (:~:)(..), + (:~~:)(..), + -- * Working with equality + sym, + trans, + castWith, + gcastWith, + apply, + inner, + outer, + -- * Inferring equality from other types + TestEquality(..), + -- * Boolean type-level equality + type (==) + ) where + +import GHC.Internal.Data.Type.Equality diff --git a/src/Data/Type/Ord.hs b/src/Data/Type/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Ord.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Safe #-} + +{-# LANGUAGE ExplicitNamespaces #-} + +-- | +-- +-- Module : Data.Type.Ord +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : not portable +-- +-- Basic operations on type-level Orderings. +-- +-- @since 4.16.0.0 + +module Data.Type.Ord + (Compare, + OrderingI(..), + type (<=), + type (<=?), + type (>=), + type (>=?), + type (>), + type (>?), + type (<), + type ( +-- + +module Data.Typeable + (-- * The Typeable class + Typeable, + typeOf, + typeRep, + -- * Propositional equality + (:~:)(Refl), + (:~~:)(HRefl), + -- * Type-safe cast + cast, + eqT, + heqT, + decT, + hdecT, + gcast, + -- * Generalized casts for higher-order kinds + gcast1, + gcast2, + -- * A canonical proxy type + Proxy(..), + -- * Type representations + TypeRep, + rnfTypeRep, + showsTypeRep, + mkFunTy, + -- * Observing type representations + funResultTy, + splitTyConApp, + typeRepArgs, + typeRepTyCon, + typeRepFingerprint, + -- * Type constructors + TyCon, + tyConPackage, + tyConModule, + tyConName, + rnfTyCon, + tyConFingerprint, + -- * For backwards compatibility + typeOf1, + typeOf2, + typeOf3, + typeOf4, + typeOf5, + typeOf6, + typeOf7, + trLiftedRep + ) where + +import GHC.Internal.Data.Typeable diff --git a/src/Data/Unique.hs b/src/Data/Unique.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unique.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Unique +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable +-- +-- An abstract interface to a unique symbol generator. +-- + +module Data.Unique + (-- * Unique objects + Unique, + newUnique, + hashUnique + ) where + +import GHC.Internal.Data.Unique diff --git a/src/Data/Version.hs b/src/Data/Version.hs new file mode 100644 --- /dev/null +++ b/src/Data/Version.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : Data.Version +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (local universal quantification in ReadP) +-- +-- A general API for representation and manipulation of versions. +-- +-- Versioning schemes are many and varied, so the version +-- representation provided by this library is intended to be a +-- compromise between complete generality, where almost no common +-- functionality could reasonably be provided, and fixing a particular +-- versioning scheme, which would probably be too restrictive. +-- +-- So the approach taken here is to provide a representation which +-- subsumes many of the versioning schemes commonly in use, and we +-- provide implementations of 'Eq', 'Ord' and conversion to\/from 'String' +-- which will be appropriate for some applications, but not all. +-- + +module Data.Version ( + -- * The @Version@ type + Version(..), + -- * A concrete representation of @Version@ + showVersion, parseVersion, + -- * Constructor function + makeVersion + ) where + +import GHC.Internal.Data.Version diff --git a/src/Data/Void.hs b/src/Data/Void.hs new file mode 100644 --- /dev/null +++ b/src/Data/Void.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Copyright : (C) 2008-2014 Edward Kmett +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- A logically uninhabited data type, used to indicate that a given +-- term should not exist. +-- +-- @since 4.8.0.0 + +module Data.Void + (Void, + absurd, + vacuous + ) where + +import GHC.Internal.Data.Void diff --git a/src/Data/Word.hs b/src/Data/Word.hs new file mode 100644 --- /dev/null +++ b/src/Data/Word.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Data.Word +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Unsigned integer types. +-- + +module Data.Word + (-- * Unsigned integral types + Word, + Word8, + Word16, + Word32, + Word64, + -- * byte swapping + byteSwap16, + byteSwap32, + byteSwap64, + -- * bit reversal + bitReverse8, + bitReverse16, + bitReverse32, + bitReverse64, + -- * Notes + -- $notes + ) where + +import GHC.Internal.Word + +{- $notes + +* All arithmetic is performed modulo 2^n, where n is the number of + bits in the type. One non-obvious consequence of this is that 'Prelude.negate' + should /not/ raise an error on negative arguments. + +* For coercing between any two integer types, use + 'Prelude.fromIntegral', which is specialized for all the + common cases so should be fast enough. Coercing word types to and + from integer types preserves representation, not sign. + +* An unbounded size unsigned integer type is available with + 'Numeric.Natural.Natural'. + +* The rules that hold for 'Prelude.Enum' instances over a bounded type + such as 'Prelude.Int' (see the section of the Haskell report dealing + with arithmetic sequences) also hold for the 'Prelude.Enum' instances + over the various 'Word' types defined here. + +* Right and left shifts by amounts greater than or equal to the width + of the type result in a zero result. This is contrary to the + behaviour in C, which is undefined; a common interpretation is to + truncate the shift count to the width of the type, for example @1 \<\< + 32 == 1@ in some C implementations. +-} diff --git a/src/Debug/Trace.hs b/src/Debug/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Trace.hs @@ -0,0 +1,95 @@ +-- | +-- +-- Module : Debug.Trace +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Functions for tracing and monitoring execution. +-- +-- These can be useful for investigating bugs or performance problems. +-- They should /not/ be used in production code. +-- + +module Debug.Trace + (-- * Tracing + -- $tracing + trace, + traceId, + traceShow, + traceShowId, + traceWith, + traceShowWith, + traceStack, + traceIO, + traceM, + traceShowM, + putTraceMsg, + + -- * Eventlog tracing + -- $eventlog_tracing + traceEvent, + traceEventWith, + traceEventIO, + flushEventLog, + + -- * Execution phase markers + -- $markers + traceMarker, + traceMarkerIO, + ) where + +import GHC.Internal.Debug.Trace + +-- $setup +-- >>> import Prelude + +-- $tracing +-- +-- The 'trace', 'traceShow' and 'traceIO' functions print messages to an output +-- stream. They are intended for \"printf debugging\", that is: tracing the flow +-- of execution and printing interesting values. +-- +-- All these functions evaluate the message completely before printing +-- it; so if the message is not fully defined, none of it will be +-- printed. +-- +-- The usual output stream is 'GHC.Internal.System.IO.stderr'. For Windows GUI applications +-- (that have no stderr) the output is directed to the Windows debug console. +-- Some implementations of these functions may decorate the string that\'s +-- output to indicate that you\'re tracing. + +-- $eventlog_tracing +-- +-- Eventlog tracing is a performance profiling system. These functions emit +-- extra events into the eventlog. In combination with eventlog profiling +-- tools these functions can be used for monitoring execution and +-- investigating performance problems. +-- +-- Currently only GHC provides eventlog profiling, see the GHC user guide for +-- details on how to use it. These function exists for other Haskell +-- implementations but no events are emitted. Note that the string message is +-- always evaluated, whether or not profiling is available or enabled. + +-- $markers +-- +-- When looking at a profile for the execution of a program we often want to +-- be able to mark certain points or phases in the execution and see that +-- visually in the profile. +-- +-- For example, a program might have several distinct phases with different +-- performance or resource behaviour in each phase. To properly interpret the +-- profile graph we really want to see when each phase starts and ends. +-- +-- Markers let us do this: we can annotate the program to emit a marker at +-- an appropriate point during execution and then see that in a profile. +-- +-- Currently this feature is only supported in GHC by the eventlog tracing +-- system, but in future it may also be supported by the heap profiling or +-- other profiling tools. These function exists for other Haskell +-- implementations but they have no effect. Note that the string message is +-- always evaluated, whether or not profiling is available or enabled. + diff --git a/src/Foreign.hs b/src/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/Foreign.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A collection of data types, classes, and functions for interfacing +-- with another programming language. +-- + +module Foreign + ( module Data.Bits + , module Data.Int + , module Data.Word + , module Foreign.Ptr + , module Foreign.ForeignPtr + , module Foreign.StablePtr + , module Foreign.Storable + , module Foreign.Marshal + ) where + +import Data.Bits +import Data.Int +import Data.Word +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.StablePtr +import Foreign.Storable +import Foreign.Marshal diff --git a/src/Foreign/C.hs b/src/Foreign/C.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/C.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.C +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Bundles the C specific FFI library functionality +-- + +module Foreign.C + (module Foreign.C.Types, + module Foreign.C.String, + module Foreign.C.Error + ) where + +import Foreign.C.Types +import Foreign.C.String +import Foreign.C.Error diff --git a/src/Foreign/C/ConstPtr.hs b/src/Foreign/C/ConstPtr.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/C/ConstPtr.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.C.ConstPtr +-- Copyright : (c) GHC Developers +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- This module provides typed @const@ pointers to foreign data. It is part +-- of the Foreign Function Interface (FFI). +-- + +module Foreign.C.ConstPtr + (ConstPtr(..) + ) where + +import GHC.Internal.Foreign.C.ConstPtr diff --git a/src/Foreign/C/Error.hs b/src/Foreign/C/Error.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/C/Error.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.C.Error +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- C-specific Marshalling support: Handling of C \"errno\" error codes. +-- + +module Foreign.C.Error + (-- * Haskell representations of @errno@ values + Errno(..), + -- ** Common @errno@ symbols + -- | Different operating systems and\/or C libraries often support + -- different values of @errno@. This module defines the common values, + -- but due to the open definition of 'Errno' users may add definitions + -- which are not predefined. + eOK, + e2BIG, + eACCES, + eADDRINUSE, + eADDRNOTAVAIL, + eADV, + eAFNOSUPPORT, + eAGAIN, + eALREADY, + eBADF, + eBADMSG, + eBADRPC, + eBUSY, + eCHILD, + eCOMM, + eCONNABORTED, + eCONNREFUSED, + eCONNRESET, + eDEADLK, + eDESTADDRREQ, + eDIRTY, + eDOM, + eDQUOT, + eEXIST, + eFAULT, + eFBIG, + eFTYPE, + eHOSTDOWN, + eHOSTUNREACH, + eIDRM, + eILSEQ, + eINPROGRESS, + eINTR, + eINVAL, + eIO, + eISCONN, + eISDIR, + eLOOP, + eMFILE, + eMLINK, + eMSGSIZE, + eMULTIHOP, + eNAMETOOLONG, + eNETDOWN, + eNETRESET, + eNETUNREACH, + eNFILE, + eNOBUFS, + eNODATA, + eNODEV, + eNOENT, + eNOEXEC, + eNOLCK, + eNOLINK, + eNOMEM, + eNOMSG, + eNONET, + eNOPROTOOPT, + eNOSPC, + eNOSR, + eNOSTR, + eNOSYS, + eNOTBLK, + eNOTCONN, + eNOTDIR, + eNOTEMPTY, + eNOTSOCK, + eNOTSUP, + eNOTTY, + eNXIO, + eOPNOTSUPP, + ePERM, + ePFNOSUPPORT, + ePIPE, + ePROCLIM, + ePROCUNAVAIL, + ePROGMISMATCH, + ePROGUNAVAIL, + ePROTO, + ePROTONOSUPPORT, + ePROTOTYPE, + eRANGE, + eREMCHG, + eREMOTE, + eROFS, + eRPCMISMATCH, + eRREMOTE, + eSHUTDOWN, + eSOCKTNOSUPPORT, + eSPIPE, + eSRCH, + eSRMNT, + eSTALE, + eTIME, + eTIMEDOUT, + eTOOMANYREFS, + eTXTBSY, + eUSERS, + eWOULDBLOCK, + eXDEV, + -- ** 'Errno' functions + isValidErrno, + getErrno, + resetErrno, + errnoToIOError, + throwErrno, + -- ** Guards for IO operations that may fail + throwErrnoIf, + throwErrnoIf_, + throwErrnoIfRetry, + throwErrnoIfRetry_, + throwErrnoIfMinus1, + throwErrnoIfMinus1_, + throwErrnoIfMinus1Retry, + throwErrnoIfMinus1Retry_, + throwErrnoIfNull, + throwErrnoIfNullRetry, + throwErrnoIfRetryMayBlock, + throwErrnoIfRetryMayBlock_, + throwErrnoIfMinus1RetryMayBlock, + throwErrnoIfMinus1RetryMayBlock_, + throwErrnoIfNullRetryMayBlock, + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ + ) where + +import GHC.Internal.Foreign.C.Error diff --git a/src/Foreign/C/String.hs b/src/Foreign/C/String.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/C/String.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : Foreign.C.String +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Utilities for primitive marshalling of C strings. +-- +-- The marshalling converts each Haskell character, representing a Unicode +-- code point, to one or more bytes in a manner that, by default, is +-- determined by the current locale. As a consequence, no guarantees +-- can be made about the relative length of a Haskell string and its +-- corresponding C string, and therefore all the marshalling routines +-- include memory allocation. The translation between Unicode and the +-- encoding of the current locale may be lossy. +-- + +module Foreign.C.String ( + -- * C strings + + CString, + CStringLen, + + -- ** Using a locale-dependent encoding + + -- | These functions are different from their @CAString@ counterparts + -- in that they will use an encoding determined by the current locale, + -- rather than always assuming ASCII. + + -- conversion of C strings into Haskell strings + -- + peekCString, + peekCStringLen, + + -- conversion of Haskell strings into C strings + -- + newCString, + newCStringLen, + + -- conversion of Haskell strings into C strings using temporary storage + -- + withCString, + withCStringLen, + + charIsRepresentable, + + -- ** Using 8-bit characters + + -- | These variants of the above functions are for use with C libraries + -- that are ignorant of Unicode. These functions should be used with + -- care, as a loss of information can occur. + + castCharToCChar, + castCCharToChar, + + castCharToCUChar, + castCUCharToChar, + castCharToCSChar, + castCSCharToChar, + + peekCAString, + peekCAStringLen, + newCAString, + newCAStringLen, + withCAString, + withCAStringLen, + + -- * C wide strings + + -- | These variants of the above functions are for use with C libraries + -- that encode Unicode using the C @wchar_t@ type in a system-dependent + -- way. The only encodings supported are + -- + -- * UTF-32 (the C compiler defines @__STDC_ISO_10646__@), or + -- + -- * UTF-16 (as used on Windows systems). + + CWString, + CWStringLen, + + peekCWString, + peekCWStringLen, + newCWString, + newCWStringLen, + withCWString, + withCWStringLen, + + ) where + +import GHC.Internal.Foreign.C.String diff --git a/src/Foreign/C/Types.hs b/src/Foreign/C/Types.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/C/Types.hs @@ -0,0 +1,84 @@ +-- | +-- +-- Module : Foreign.C.Types +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Mapping of C types to corresponding Haskell types. +-- + +module Foreign.C.Types + (-- * Representations of C types + -- $ctypes + -- ** #platform# Platform differences + -- | This module contains platform specific information about types. + -- __/As such, the types presented on this page reflect the/__ + -- __/platform on which the documentation was generated and may/__ + -- __/not coincide with the types on your platform./__ + -- ** Integral types + -- | These types are represented as @newtype@s of + -- types in "Data.Int" and "Data.Word", and are instances of + -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read', + -- 'Prelude.Show', 'Prelude.Enum', 'Data.Typeable.Typeable', + -- 'Storable', 'Prelude.Bounded', 'Prelude.Real', 'Prelude.Integral' + -- and 'Bits'. + CChar(..), + CSChar(..), + CUChar(..), + CShort(..), + CUShort(..), + CInt(..), + CUInt(..), + CLong(..), + CULong(..), + CPtrdiff(..), + CSize(..), + CWchar(..), + CSigAtomic(..), + CLLong(..), + CULLong(..), + CBool(..), + CIntPtr(..), + CUIntPtr(..), + CIntMax(..), + CUIntMax(..), + -- ** Numeric types + -- | These types are represented as @newtype@s of basic + -- foreign types, and are instances of + -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read', + -- 'Prelude.Show', 'Prelude.Enum', 'Data.Typeable.Typeable' and + -- 'Storable'. + CClock(..), + CTime(..), + CUSeconds(..), + CSUSeconds(..), + -- | To convert 'CTime' to 'Data.Time.UTCTime', use the following: + -- + -- > \t -> posixSecondsToUTCTime (realToFrac t :: POSIXTime) + + -- ** Floating types + -- | These types are represented as @newtype@s of + -- 'Prelude.Float' and 'Prelude.Double', and are instances of + -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read', + -- 'Prelude.Show', 'Prelude.Enum', 'Data.Typeable.Typeable', 'Storable', + -- 'Prelude.Real', 'Prelude.Fractional', 'Prelude.Floating', + -- 'Prelude.RealFrac' and 'Prelude.RealFloat'. That does mean + -- that `CFloat`'s (respectively `CDouble`'s) instances of + -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num' and + -- 'Prelude.Fractional' are as badly behaved as `Prelude.Float`'s + -- (respectively `Prelude.Double`'s). + CFloat(..), + CDouble(..), + -- XXX GHC doesn't support CLDouble yet + -- , CLDouble(..) + -- ** Other types + CFile, + CFpos, + CJmpBuf + ) where + +import GHC.Internal.Foreign.C.Types diff --git a/src/Foreign/Concurrent.hs b/src/Foreign/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Concurrent.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.Concurrent +-- Copyright : (c) The University of Glasgow 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires concurrency) +-- +-- FFI datatypes and operations that use or require concurrency (GHC only). +-- + +module Foreign.Concurrent + (-- * Concurrency-based 'ForeignPtr' operations + -- | These functions generalize their namesakes in the portable + -- "Foreign.ForeignPtr" module by allowing arbitrary 'IO' actions + -- as finalizers. These finalizers necessarily run in a separate + -- thread, cf. /Destructors, Finalizers and Synchronization/, + -- by Hans Boehm, /POPL/, 2003. + newForeignPtr, + addForeignPtrFinalizer + ) where + +import GHC.Internal.Foreign.Concurrent diff --git a/src/Foreign/ForeignPtr.hs b/src/Foreign/ForeignPtr.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/ForeignPtr.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.ForeignPtr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'ForeignPtr' type and operations. This module is part of the +-- Foreign Function Interface (FFI) and will usually be imported via +-- the "Foreign" module. +-- +-- For non-portable support of Haskell finalizers, see the +-- "Foreign.Concurrent" module. +-- + +module Foreign.ForeignPtr + (-- * Finalised data pointers + ForeignPtr, + FinalizerPtr, + FinalizerEnvPtr, + -- ** Basic operations + newForeignPtr, + newForeignPtr_, + addForeignPtrFinalizer, + newForeignPtrEnv, + addForeignPtrFinalizerEnv, + withForeignPtr, + finalizeForeignPtr, + -- ** Low-level operations + touchForeignPtr, + castForeignPtr, + plusForeignPtr, + -- ** Allocating managed memory + mallocForeignPtr, + mallocForeignPtrBytes, + mallocForeignPtrArray, + mallocForeignPtrArray0 + ) where + +import GHC.Internal.Foreign.ForeignPtr diff --git a/src/Foreign/ForeignPtr/Safe.hs b/src/Foreign/ForeignPtr/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/ForeignPtr/Safe.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- +-- Module : Foreign.ForeignPtr.Safe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'ForeignPtr' type and operations. This module is part of the +-- Foreign Function Interface (FFI) and will usually be imported via +-- the "Foreign" module. +-- +-- Safe API Only. +-- + +module Foreign.ForeignPtr.Safe + {-# DEPRECATED "Safe is now the default, please use GHC.Internal.Foreign.ForeignPtr instead" #-} + (-- * Finalised data pointers + ForeignPtr, + FinalizerPtr, + FinalizerEnvPtr, + -- ** Basic operations + newForeignPtr, + newForeignPtr_, + addForeignPtrFinalizer, + newForeignPtrEnv, + addForeignPtrFinalizerEnv, + withForeignPtr, + finalizeForeignPtr, + -- ** Low-level operations + touchForeignPtr, + castForeignPtr, + -- ** Allocating managed memory + mallocForeignPtr, + mallocForeignPtrBytes, + mallocForeignPtrArray, + mallocForeignPtrArray0 + ) where + +import GHC.Internal.Foreign.ForeignPtr.Imp diff --git a/src/Foreign/ForeignPtr/Unsafe.hs b/src/Foreign/ForeignPtr/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/ForeignPtr/Unsafe.hs @@ -0,0 +1,23 @@ +-- | +-- +-- Module : Foreign.ForeignPtr.Unsafe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'ForeignPtr' type and operations. This module is part of the +-- Foreign Function Interface (FFI) and will usually be imported via +-- the "Foreign" module. +-- +-- Unsafe API Only. +-- + +module Foreign.ForeignPtr.Unsafe + (-- ** Unsafe low-level operations + unsafeForeignPtrToPtr + ) where + +import GHC.Internal.Foreign.ForeignPtr.Unsafe diff --git a/src/Foreign/Marshal.hs b/src/Foreign/Marshal.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Marshal.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.Marshal +-- Copyright : (c) The FFI task force 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Marshalling support +-- + +module Foreign.Marshal + (-- | The module "Foreign.Marshal.Safe" re-exports the other modules in the + -- @Foreign.Marshal@ hierarchy (except for @Foreign.Marshal.Unsafe@): + module Foreign.Marshal.Alloc, + module Foreign.Marshal.Array, + module Foreign.Marshal.Error, + module Foreign.Marshal.Pool, + module Foreign.Marshal.Utils + ) where + +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Marshal.Error +import Foreign.Marshal.Pool +import Foreign.Marshal.Utils diff --git a/src/Foreign/Marshal/Alloc.hs b/src/Foreign/Marshal/Alloc.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Marshal/Alloc.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.Marshal.Alloc +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The module "Foreign.Marshal.Alloc" provides operations to allocate and +-- deallocate blocks of raw memory (i.e., unstructured chunks of memory +-- outside of the area maintained by the Haskell storage manager). These +-- memory blocks are commonly used to pass compound data structures to +-- foreign functions or to provide space in which compound result values +-- are obtained from foreign functions. +-- +-- If any of the allocation functions fails, an exception is thrown. +-- In some cases, memory exhaustion may mean the process is terminated. +-- If 'free' or 'reallocBytes' is applied to a memory area +-- that has been allocated with 'alloca' or 'allocaBytes', the +-- behaviour is undefined. Any further access to memory areas allocated with +-- 'alloca' or 'allocaBytes', after the computation that was passed to +-- the allocation function has terminated, leads to undefined behaviour. Any +-- further access to the memory area referenced by a pointer passed to +-- 'realloc', 'reallocBytes', or 'free' entails undefined +-- behaviour. +-- +-- All storage allocated by functions that allocate based on a /size in bytes/ +-- must be sufficiently aligned for any of the basic foreign types +-- that fits into the newly allocated storage. All storage allocated by +-- functions that allocate based on a specific type must be sufficiently +-- aligned for that type. Array allocation routines need to obey the same +-- alignment constraints for each array element. +-- +-- The underlying implementation is wrapping the @@ +-- @malloc@, @realloc@, and @free@. +-- In other words it should be safe to allocate using C-@malloc@, +-- and free memory with 'free' from this module. +-- + +module Foreign.Marshal.Alloc + (-- * Memory allocation + -- ** Local allocation + alloca, + allocaBytes, + allocaBytesAligned, + -- ** Dynamic allocation + malloc, + mallocBytes, + calloc, + callocBytes, + realloc, + reallocBytes, + free, + finalizerFree + ) where + +import GHC.Internal.Foreign.Marshal.Alloc diff --git a/src/Foreign/Marshal/Array.hs b/src/Foreign/Marshal/Array.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Marshal/Array.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.Marshal.Array +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Marshalling support: routines allocating, storing, and retrieving Haskell +-- lists that are represented as arrays in the foreign language +-- + +module Foreign.Marshal.Array + (-- * Marshalling arrays + -- ** Allocation + mallocArray, + mallocArray0, + allocaArray, + allocaArray0, + reallocArray, + reallocArray0, + callocArray, + callocArray0, + -- ** Marshalling + peekArray, + peekArray0, + pokeArray, + pokeArray0, + -- ** Combined allocation and marshalling + newArray, + newArray0, + withArray, + withArray0, + withArrayLen, + withArrayLen0, + -- ** Copying + -- | (argument order: destination, source) + copyArray, + moveArray, + -- ** Finding the length + lengthArray0, + -- ** Indexing + advancePtr + ) where + +import GHC.Internal.Foreign.Marshal.Array diff --git a/src/Foreign/Marshal/Error.hs b/src/Foreign/Marshal/Error.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Marshal/Error.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.Marshal.Error +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Routines for testing return values and raising a 'userError' exception +-- in case of values indicating an error state. +-- + +module Foreign.Marshal.Error + (throwIf, + throwIf_, + throwIfNeg, + throwIfNeg_, + throwIfNull, + void + ) where + +import GHC.Internal.Foreign.Marshal.Error diff --git a/src/Foreign/Marshal/Pool.hs b/src/Foreign/Marshal/Pool.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Marshal/Pool.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.Marshal.Pool +-- Copyright : (c) Sven Panne 2002-2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : sven.panne@aedion.de +-- Stability : provisional +-- Portability : portable +-- +-- This module contains support for pooled memory management. Under this scheme, +-- (re-)allocations belong to a given pool, and everything in a pool is +-- deallocated when the pool itself is deallocated. This is useful when +-- 'Foreign.Marshal.Alloc.alloca' with its implicit allocation and deallocation +-- is not flexible enough, but explicit uses of 'Foreign.Marshal.Alloc.malloc' +-- and 'free' are too awkward. +-- + +module Foreign.Marshal.Pool + (-- * Pool management + Pool, + newPool, + freePool, + withPool, + -- * (Re-)Allocation within a pool + pooledMalloc, + pooledMallocBytes, + pooledRealloc, + pooledReallocBytes, + pooledMallocArray, + pooledMallocArray0, + pooledReallocArray, + pooledReallocArray0, + -- * Combined allocation and marshalling + pooledNew, + pooledNewArray, + pooledNewArray0 + ) where + +import GHC.Internal.Foreign.Marshal.Pool diff --git a/src/Foreign/Marshal/Safe.hs b/src/Foreign/Marshal/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Marshal/Safe.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.Marshal.Safe +-- Copyright : (c) The FFI task force 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Marshalling support +-- +-- Safe API Only. +-- + +module Foreign.Marshal.Safe + (-- | The module "Foreign.Marshal.Safe" re-exports the other modules in the + -- @Foreign.Marshal@ hierarchy: + module Foreign.Marshal.Alloc, + module Foreign.Marshal.Array, + module Foreign.Marshal.Error, + module Foreign.Marshal.Pool, + module Foreign.Marshal.Utils + ) where + +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Marshal.Error +import Foreign.Marshal.Pool +import Foreign.Marshal.Utils diff --git a/src/Foreign/Marshal/Unsafe.hs b/src/Foreign/Marshal/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Marshal/Unsafe.hs @@ -0,0 +1,19 @@ +-- | +-- +-- Module : Foreign.Marshal.Unsafe +-- Copyright : (c) The FFI task force 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Marshalling support. Unsafe API. +-- + +module Foreign.Marshal.Unsafe + (-- * Unsafe functions + unsafeLocalState + ) where + +import GHC.Internal.Foreign.Marshal.Unsafe diff --git a/src/Foreign/Marshal/Utils.hs b/src/Foreign/Marshal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Marshal/Utils.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.Marshal.Utils +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Utilities for primitive marshaling +-- + +module Foreign.Marshal.Utils + (-- * General marshalling utilities + -- ** Combined allocation and marshalling + with, + new, + -- ** Marshalling of Boolean values (non-zero corresponds to 'True') + fromBool, + toBool, + -- ** Marshalling of Maybe values + maybeNew, + maybeWith, + maybePeek, + -- ** Marshalling lists of storable objects + withMany, + -- ** Haskellish interface to memcpy and memmove + -- | (argument order: destination, source) + + copyBytes, + moveBytes, + -- ** Filling up memory area with required values + fillBytes + ) where + +import GHC.Internal.Foreign.Marshal.Utils diff --git a/src/Foreign/Ptr.hs b/src/Foreign/Ptr.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Ptr.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.Ptr +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- This module provides typed pointers to foreign data. It is part +-- of the Foreign Function Interface (FFI) and will normally be +-- imported via the "Foreign" module. +-- + +module Foreign.Ptr + (-- * Data pointers + Ptr, + nullPtr, + castPtr, + plusPtr, + alignPtr, + minusPtr, + -- * Function pointers + FunPtr, + nullFunPtr, + castFunPtr, + castFunPtrToPtr, + castPtrToFunPtr, + freeHaskellFunPtr, + -- * Integral types with lossless conversion to and from pointers + IntPtr(..), + ptrToIntPtr, + intPtrToPtr, + WordPtr(..), + ptrToWordPtr, + wordPtrToPtr + ) where + +import GHC.Internal.Foreign.Ptr diff --git a/src/Foreign/Safe.hs b/src/Foreign/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Safe.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.Safe +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A collection of data types, classes, and functions for interfacing +-- with another programming language. +-- +-- Safe API Only. +-- + +module Foreign.Safe {-# DEPRECATED "Safe is now the default, please use Foreign instead" #-} + (module Data.Bits, + module Data.Int, + module Data.Word, + module Foreign.Ptr, + module Foreign.ForeignPtr, + module Foreign.StablePtr, + module Foreign.Storable, + module Foreign.Marshal + ) where + +import Data.Bits +import Data.Int +import Data.Word +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.StablePtr +import Foreign.Storable +import Foreign.Marshal + diff --git a/src/Foreign/StablePtr.hs b/src/Foreign/StablePtr.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/StablePtr.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.StablePtr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- This module is part of the Foreign Function Interface (FFI) and will usually +-- be imported via the module "Foreign". +-- + +module Foreign.StablePtr + (-- * Stable references to Haskell values + StablePtr, + newStablePtr, + deRefStablePtr, + freeStablePtr, + castStablePtrToPtr, + castPtrToStablePtr, + -- ** The C-side interface + -- $cinterface + ) where + +import GHC.Internal.Foreign.StablePtr + +-- $cinterface +-- +-- The following definition is available to C programs inter-operating with +-- Haskell code when including the header @HsFFI.h@. +-- +-- > typedef void *HsStablePtr; /* C representation of a StablePtr */ +-- +-- Note that no assumptions may be made about the values representing stable +-- pointers. In fact, they need not even be valid memory addresses. The only +-- guarantee provided is that if they are passed back to Haskell land, the +-- function 'deRefStablePtr' will be able to reconstruct the +-- Haskell value referred to by the stable pointer. + diff --git a/src/Foreign/Storable.hs b/src/Foreign/Storable.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Storable.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Foreign.Storable +-- Copyright : (c) The FFI task force 2001 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The module "Foreign.Storable" provides most elementary support for +-- marshalling and is part of the language-independent portion of the +-- Foreign Function Interface (FFI), and will normally be imported via +-- the "Foreign" module. +-- + +module Foreign.Storable + (Storable(sizeOf, alignment, peekElemOff, pokeElemOff, peekByteOff, pokeByteOff, peek, poke) + ) where + +import GHC.Internal.Foreign.Storable diff --git a/src/GHC/Arr.hs b/src/GHC/Arr.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Arr.hs @@ -0,0 +1,77 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.Arr +-- 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) +-- +-- GHC\'s array implementation. +-- +-- /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. +-- + +module GHC.Arr + (Ix(..), + Array(..), + STArray(..), + arrEleBottom, + array, + listArray, + (!), + safeRangeSize, + negRange, + safeIndex, + badSafeIndex, + bounds, + numElements, + numElementsSTArray, + indices, + elems, + assocs, + accumArray, + adjust, + (//), + accum, + amap, + ixmap, + eqArray, + cmpArray, + cmpIntArray, + newSTArray, + boundsSTArray, + readSTArray, + writeSTArray, + freezeSTArray, + thawSTArray, + foldlElems, + foldlElems', + foldl1Elems, + foldrElems, + foldrElems', + foldr1Elems, + -- * Unsafe operations + fill, + done, + unsafeArray, + unsafeArray', + lessSafeIndex, + unsafeAt, + unsafeReplace, + unsafeAccumArray, + unsafeAccumArray', + unsafeAccum, + unsafeReadSTArray, + unsafeWriteSTArray, + unsafeFreezeSTArray, + unsafeThawSTArray + ) where + +import GHC.Internal.Arr diff --git a/src/GHC/ArrayArray.hs b/src/GHC/ArrayArray.hs new file mode 100644 --- /dev/null +++ b/src/GHC/ArrayArray.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE Safe #-} + +{-# LANGUAGE MagicHash #-} + +-- | +-- +-- Module : GHC.ArrayArray +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Legacy interface for arrays of arrays. +-- Deprecated, because the 'Array#' type can now store arrays directly. +-- Consider simply using 'Array#' instead of 'ArrayArray#'. +-- +-- Use GHC.Exts instead of importing this module directly. +-- + +module GHC.ArrayArray + (ArrayArray#(..), + MutableArrayArray#(..), + newArrayArray#, + unsafeFreezeArrayArray#, + sizeofArrayArray#, + sizeofMutableArrayArray#, + indexByteArrayArray#, + indexArrayArrayArray#, + readByteArrayArray#, + readMutableByteArrayArray#, + readArrayArrayArray#, + readMutableArrayArrayArray#, + writeByteArrayArray#, + writeMutableByteArrayArray#, + writeArrayArrayArray#, + writeMutableArrayArrayArray#, + copyArrayArray#, + copyMutableArrayArray#, + sameArrayArray#, + sameMutableArrayArray# + ) where + +import GHC.Internal.ArrayArray diff --git a/src/GHC/Base.hs b/src/GHC/Base.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Base.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Base +-- Copyright : (c) The University of Glasgow, 1992-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Basic data types and classes. +-- + +-- N.B. This is a legacy module which we would at some point like to +-- deprecate and drop from `base`. In short, everything found here is +-- better imported from elsewhere. Until we have done so we prefer to +-- keep the export list as specific as possible (e.g. avoiding module +-- exports) to avoid changes in `ghc-internal` inadvertently +-- compromising the stability of this interface. + +module GHC.Base + ( module GHC.Types + , module GHC.Prim + , module GHC.Prim.Ext + , module GHC.Prim.PtrEq + , module GHC.Internal.Err + , module GHC.Internal.Maybe + + -- * Equality and ordering + , IP(..) + , Eq(..) + , Ord(..) + -- ** Monomorphic equality operators + , eqInt, neInt + , eqWord, neWord + , eqChar, neChar + , eqFloat, eqDouble + , gtInt, geInt, leInt, ltInt, compareInt, compareInt# + , gtWord, geWord, leWord, ltWord, compareWord, compareWord# + + -- * C Strings + , unpackCString#, unpackAppendCString#, unpackFoldrCString# + , cstringLength# + , unpackCStringUtf8#, unpackAppendCStringUtf8#, unpackFoldrCStringUtf8# + , unpackNBytes# + + -- * Magic combinators + , inline, noinline, lazy, oneShot, runRW#, seq#, DataToTag(..) + , WithDict(withDict) + + -- * Functions over 'Bool' + , (&&), (||), not + + -- Void + , Void + , absurd + , vacuous + + -- * Semigroup/Monoid + , Semigroup(..) + , Monoid(..) + + -- * Functors + , Functor(..) + , Applicative(..) + , (<**>) + , liftA + , liftA3 + , join + , Monad(..) + , (=<<) + , when + , sequence + , mapM + , liftM + , liftM2 + , liftM3 + , liftM4 + , liftM5 + , ap + , Alternative(..) + , MonadPlus(..) + + -- Lists + , NonEmpty(..) + , foldr + , build + , augment + , map + , mapFB + , (++) + , String + , unsafeChr + , ord + , eqString + , minInt, maxInt + + -- * Miscellanea + , otherwise + , id + , assert + , breakpoint + , breakpointCond + , Opaque(..) + , const + , (.) + , flip + , ($) + , ($!) + , until + , asTypeOf + + -- * IO + , returnIO + , bindIO + , thenIO + , failIO + , unIO + + -- * Low-level integer utilities + , getTag + , quotInt + , remInt + , divInt + , modInt + , quotRemInt + , divModInt + , shift_mask + , shiftL# + , shiftRL# + , iShiftL# + , iShiftRA# + , iShiftRL# + , divInt#, divInt8#, divInt16#, divInt32# + , modInt#, modInt8#, modInt16#, modInt32# + , divModInt#, divModInt8#, divModInt16#, divModInt32# + ) where + +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#(..), + Tuple0#, + Tuple1#, + Tuple2#, + Tuple3#, + Tuple4#, + Tuple5#, + Tuple6#, + Tuple7#, + Tuple8#, + Tuple9#, + Tuple10#, + Tuple11#, + Tuple12#, + Tuple13#, + Tuple14#, + Tuple15#, + Tuple16#, + Tuple17#, + Tuple18#, + Tuple19#, + Tuple20#, + Tuple21#, + Tuple22#, + Tuple23#, + Tuple24#, + Tuple25#, + Tuple26#, + Tuple27#, + Tuple28#, + Tuple29#, + Tuple30#, + Tuple31#, + Tuple32#, + Tuple33#, + Tuple34#, + Tuple35#, + Tuple36#, + Tuple37#, + Tuple38#, + Tuple39#, + Tuple40#, + Tuple41#, + Tuple42#, + Tuple43#, + Tuple44#, + Tuple45#, + Tuple46#, + Tuple47#, + Tuple48#, + Tuple49#, + Tuple50#, + Tuple51#, + Tuple52#, + Tuple53#, + Tuple54#, + Tuple55#, + Tuple56#, + Tuple57#, + Tuple58#, + Tuple59#, + Tuple60#, + Tuple61#, + Tuple62#, + Tuple63#, + Tuple64#, + Sum2#, + Sum3#, + Sum4#, + Sum5#, + Sum6#, + Sum7#, + Sum8#, + Sum9#, + Sum10#, + Sum11#, + Sum12#, + Sum13#, + Sum14#, + Sum15#, + Sum16#, + Sum17#, + Sum18#, + Sum19#, + Sum20#, + Sum21#, + Sum22#, + Sum23#, + Sum24#, + Sum25#, + Sum26#, + Sum27#, + Sum28#, + Sum29#, + Sum30#, + Sum31#, + Sum32#, + Sum33#, + Sum34#, + Sum35#, + Sum36#, + Sum37#, + Sum38#, + Sum39#, + Sum40#, + Sum41#, + Sum42#, + Sum43#, + Sum44#, + Sum45#, + Sum46#, + Sum47#, + Sum48#, + Sum49#, + Sum50#, + Sum51#, + Sum52#, + Sum53#, + Sum54#, + Sum55#, + Sum56#, + Sum57#, + Sum58#, + Sum59#, + Sum60#, + Sum61#, + Sum62#, + Sum63#, + ) diff --git a/src/GHC/Bits.hs b/src/GHC/Bits.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Bits.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.Bits +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- This module defines bitwise operations for signed and unsigned +-- integers. Instances of the class 'Bits' for the 'Int' and +-- 'Integer' types are available from this module, and instances for +-- explicitly sized integral types are available from the +-- "Data.Int" and "Data.Word" modules. +-- + +module GHC.Bits + (Bits((.&.), (.|.), xor, complement, shift, rotate, zeroBits, bit, setBit, clearBit, complementBit, testBit, bitSizeMaybe, bitSize, isSigned, shiftL, shiftR, unsafeShiftL, unsafeShiftR, rotateL, rotateR, popCount), + FiniteBits(finiteBitSize, countLeadingZeros, countTrailingZeros), + bitDefault, + testBitDefault, + popCountDefault, + toIntegralSized + ) where + +import GHC.Internal.Bits diff --git a/src/GHC/ByteOrder.hs b/src/GHC/ByteOrder.hs new file mode 100644 --- /dev/null +++ b/src/GHC/ByteOrder.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.ByteOrder +-- 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) +-- +-- Target byte ordering. +-- +-- @since 4.11.0.0 + +module GHC.ByteOrder + (ByteOrder(..), + targetByteOrder + ) where + +import GHC.Internal.ByteOrder diff --git a/src/GHC/Char.hs b/src/GHC/Char.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Char.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Safe #-} + +module GHC.Char + (-- * Utilities + chr, + -- * Monomorphic equality operators + -- | See GHC.Classes#matching_overloaded_methods_in_rules + eqChar, + neChar + ) where + +import GHC.Internal.Char diff --git a/src/GHC/Clock.hs b/src/GHC/Clock.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Clock.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : GHC.Clock +-- License : BSD-style (see the file LICENSE in this distribution) +-- +-- Stability : internal +-- Portability : portable +-- +-- System monotonic time. +-- + +module GHC.Clock + ( getMonotonicTime + , getMonotonicTimeNSec + ) where + +import GHC.Internal.Clock diff --git a/src/GHC/Conc.hs b/src/GHC/Conc.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Conc.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_HADDOCK not-home #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Conc +-- Copyright : (c) The University of Glasgow, 1994-2023 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Basic concurrency stuff. +-- +-- /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. +-- +----------------------------------------------------------------------------- + +-- No: #hide, because bits of this module are exposed by the stm package. +-- However, we don't want this module to be the home location for the +-- bits it exports, we'd rather have Control.Concurrent and the other +-- higher level modules be the home. Hence: #not-home + +module GHC.Conc + ( ThreadId(..) + + -- * Forking and suchlike + , forkIO + , forkIOWithUnmask + , forkOn + , forkOnWithUnmask + , numCapabilities + , getNumCapabilities + , setNumCapabilities + , getNumProcessors + , numSparks + , childHandler + , myThreadId + , killThread + , throwTo + , par + , pseq + , runSparks + , yield + , labelThread + , mkWeakThreadId + , listThreads + + , ThreadStatus(..), BlockReason(..) + , threadStatus + , threadCapability + + , newStablePtrPrimMVar, PrimMVar + + -- * Waiting + , threadDelay + , registerDelay + , threadWaitRead + , threadWaitWrite + , threadWaitReadSTM + , threadWaitWriteSTM + , closeFdWith + + -- * Allocation counter and limit + , setAllocationCounter + , getAllocationCounter + , enableAllocationLimit + , disableAllocationLimit + + -- * TVars + , STM(..) + , atomically + , retry + , orElse + , throwSTM + , catchSTM + , TVar(..) + , newTVar + , newTVarIO + , readTVar + , readTVarIO + , writeTVar + , unsafeIOToSTM + + -- * Miscellaneous + , withMVar +#if defined(mingw32_HOST_OS) + , asyncRead + , asyncWrite + , asyncDoProc + + , asyncReadBA + , asyncWriteBA +#endif + +#if !defined(mingw32_HOST_OS) + , Signal, HandlerFun, setHandler, runHandlers +#endif + + , ensureIOManagerIsRunning + , ioManagerCapabilitiesChanged + +#if defined(mingw32_HOST_OS) + , ConsoleEvent(..) + , win32ConsoleHandler + , toWin32ConsoleEvent +#endif + , setUncaughtExceptionHandler + , getUncaughtExceptionHandler + + , reportError, reportStackOverflow, reportHeapOverflow + ) where + +import GHC.Internal.Conc.IO +import GHC.Internal.Conc.Sync + +#if !defined(mingw32_HOST_OS) +import GHC.Internal.Conc.Signal +#endif diff --git a/src/GHC/Conc/IO.hs b/src/GHC/Conc/IO.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Conc/IO.hs @@ -0,0 +1,35 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.Conc.IO +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Basic concurrency stuff. +-- +-- /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. +-- + +module GHC.Conc.IO + (ensureIOManagerIsRunning, + ioManagerCapabilitiesChanged, + interruptIOManager, + -- * Waiting + threadDelay, + registerDelay, + threadWaitRead, + threadWaitWrite, + threadWaitReadSTM, + threadWaitWriteSTM, + closeFdWith + ) where + +import GHC.Internal.Conc.IO diff --git a/src/GHC/Conc/POSIX.hs b/src/GHC/Conc/POSIX.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Conc/POSIX.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Conc.POSIX +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Windows I/O manager +-- +-- This is the I/O manager based on posix FDs for windows. +-- When using the winio manager these functions may not +-- be used as they will behave in unexpected ways. +-- +-- TODO: This manager is currently the default. But we will eventually +-- switch to use winio instead. +-- + +module GHC.Conc.POSIX + ( ensureIOManagerIsRunning + , interruptIOManager + + -- * Waiting + , threadDelay + , registerDelay + + -- * Miscellaneous + , asyncRead + , asyncWrite + , asyncDoProc + + , asyncReadBA + , asyncWriteBA + + , module GHC.Internal.Event.Windows.ConsoleEvent + ) where + +import GHC.Internal.Conc.POSIX +import GHC.Internal.Event.Windows.ConsoleEvent diff --git a/src/GHC/Conc/POSIX/Const.hs b/src/GHC/Conc/POSIX/Const.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Conc/POSIX/Const.hs @@ -0,0 +1,5 @@ +module GHC.Conc.POSIX.Const + ( io_MANAGER_WAKEUP, io_MANAGER_DIE + ) where + +import GHC.Internal.Conc.POSIX.Const diff --git a/src/GHC/Conc/Signal.hs b/src/GHC/Conc/Signal.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Conc/Signal.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Safe #-} + +module GHC.Conc.Signal + (Signal, + HandlerFun, + setHandler, + runHandlers, + runHandlersPtr + ) where + +import GHC.Internal.Conc.Signal diff --git a/src/GHC/Conc/Sync.hs b/src/GHC/Conc/Sync.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Conc/Sync.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Conc.Sync +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Basic concurrency stuff. +-- + +module GHC.Conc.Sync + ( + -- * Threads + ThreadId(..) + , fromThreadId + , showThreadId + , myThreadId + , killThread + , throwTo + , yield + , labelThread + , labelThreadByteArray# + , mkWeakThreadId + -- ** Queries + , listThreads + , threadLabel + , ThreadStatus(..), BlockReason(..) + , threadStatus + , threadCapability + + -- * Forking and suchlike + , forkIO + , forkIOWithUnmask + , forkOn + , forkOnWithUnmask + + -- * Capabilities + , numCapabilities + , getNumCapabilities + , setNumCapabilities + , getNumProcessors + + -- * Sparks + , numSparks + , childHandler + , par + , pseq + , runSparks + + -- * PrimMVar + , newStablePtrPrimMVar, PrimMVar + + -- * Allocation counter and quota + , setAllocationCounter + , getAllocationCounter + , enableAllocationLimit + , disableAllocationLimit + + -- * TVars + , STM(..) + , atomically + , retry + , orElse + , throwSTM + , catchSTM + , TVar(..) + , newTVar + , newTVarIO + , readTVar + , readTVarIO + , writeTVar + , unsafeIOToSTM + + -- * Miscellaneous + , withMVar + , modifyMVar_ + + , setUncaughtExceptionHandler + , getUncaughtExceptionHandler + + , reportError, reportStackOverflow, reportHeapOverflow + + , sharedCAF + ) where + +import GHC.Internal.Conc.Sync diff --git a/src/GHC/Conc/WinIO.hs b/src/GHC/Conc/WinIO.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Conc/WinIO.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Conc.WinIO +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Windows I/O Completion Port interface to the one defined in +-- GHC.Event.Windows. +-- +-- This module is an indirection to keep things in the same structure as before +-- but also to keep the new code where the actual I/O manager is. As such it +-- just re-exports "GHC.Event.Windows.Thread" +-- + +module GHC.Conc.WinIO + ( module GHC.Internal.Event.Windows.Thread ) where + +import GHC.Internal.Event.Windows.Thread diff --git a/src/GHC/Conc/Windows.hs b/src/GHC/Conc/Windows.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Conc/Windows.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} + +-- | +-- Module : GHC.Internal.Conc.Windows +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Windows I/O manager interfaces. Depending on which I/O Subsystem is used +-- requests will be routed to different places. +-- +-- +module GHC.Conc.Windows + +#if defined(javascript_HOST_ARCH) + () where + +#else + ( ensureIOManagerIsRunning + , interruptIOManager + + -- * Waiting + , threadDelay + , registerDelay + + -- * Miscellaneous + , asyncRead + , asyncWrite + , asyncDoProc + + , asyncReadBA + , asyncWriteBA + + -- * Console event handler + , module GHC.Internal.Event.Windows.ConsoleEvent + ) where + +import GHC.Internal.Conc.Windows +import GHC.Internal.Event.Windows.ConsoleEvent + +#endif diff --git a/src/GHC/ConsoleHandler.hs b/src/GHC/ConsoleHandler.hs new file mode 100644 --- /dev/null +++ b/src/GHC/ConsoleHandler.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} + +-- | +-- Module : GHC.ConsoleHandler +-- Copyright : (c) The University of Glasgow +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- NB. the contents of this module are only available on Windows. +-- +-- Installing Win32 console handlers. +-- + +#if !defined(mingw32_HOST_OS) + +module GHC.ConsoleHandler () where + +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import Prelude () -- for build ordering + +#else + +module GHC.ConsoleHandler + ( Handler(..) + , installHandler + , ConsoleEvent(..) + ) where + +import GHC.Internal.ConsoleHandler + +#endif + diff --git a/src/GHC/Constants.hs b/src/GHC/Constants.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Constants.hs @@ -0,0 +1,6 @@ +-- TODO: Deprecate +module GHC.Constants where + +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Types () -- for build ordering + diff --git a/src/GHC/Desugar.hs b/src/GHC/Desugar.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Desugar.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +----------------------------------------------------------------------------- +-- | +-- +-- Module : GHC.Desugar +-- Copyright : (c) The University of Glasgow, 2007 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : deprecated () +-- Portability : non-portable (GHC extensions) +-- +-- Support code for desugaring in GHC +-- +-- /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. +-- +----------------------------------------------------------------------------- + +#if __GLASGOW_HASKELL >= 914 +#error "GHC.Desugar should be removed in GHC 9.14" +#endif + +module GHC.Desugar + {-# 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/Encoding/UTF8.hs b/src/GHC/Encoding/UTF8.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Encoding/UTF8.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE MagicHash #-} + +-- | +-- +-- Module : GHC.Encoding.UTF8 +-- Copyright : (c) The University of Glasgow, 1994-2023 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- /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. +-- +-- Simple UTF-8 codecs supporting non-streaming encoding/decoding. +-- For encoding where codepoints may be broken across buffers, +-- see "GHC.IO.Encoding.UTF8". +-- +-- This is one of several UTF-8 implementations provided by GHC; see Note +-- [GHC's many UTF-8 implementations] in "GHC.Encoding.UTF8" for an +-- overview. +-- + +module GHC.Encoding.UTF8 + (-- * Decoding single characters + utf8DecodeCharAddr#, + utf8DecodeCharPtr, + utf8DecodeCharByteArray#, + -- * Decoding strings + utf8DecodeByteArray#, + utf8DecodeForeignPtr, + -- * Counting characters + utf8CountCharsByteArray#, + -- * Comparison + utf8CompareByteArray#, + -- * Encoding strings + utf8EncodePtr, + utf8EncodeByteArray#, + utf8EncodedLength + ) where + +import GHC.Internal.Encoding.UTF8 diff --git a/src/GHC/Enum.hs b/src/GHC/Enum.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Enum.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Enum +-- Copyright : (c) The University of Glasgow, 1992-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- The 'Enum' and 'Bounded' classes. +-- + +module GHC.Enum( + Bounded(..), Enum(..), + boundedEnumFrom, boundedEnumFromThen, + toEnumError, fromEnumError, succError, predError, + ) where + +import GHC.Internal.Enum diff --git a/src/GHC/Environment.hs b/src/GHC/Environment.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Environment.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE Safe #-} + +module GHC.Environment + (getFullArgs + ) where + +import GHC.Internal.Environment diff --git a/src/GHC/Err.hs b/src/GHC/Err.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Err.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Err +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- The "GHC.Err" module defines the code for the wired-in error functions, +-- which have a special type in the compiler (with \"open tyvars\"). +-- +-- We cannot define these functions in a module where they might be used +-- (e.g., "GHC.Base"), because the magical wired-in type will get confused +-- with what the typechecker figures out. +-- + +module GHC.Err( absentErr, error, errorWithoutStackTrace, undefined ) where + +import GHC.Internal.Err diff --git a/src/GHC/Event.hs b/src/GHC/Event.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Event.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} + +-- | +-- This module provides scalable event notification for file +-- descriptors and timeouts. +-- +-- This module should be considered GHC internal. +-- +-- ---------------------------------------------------------------------------- + +#if defined(javascript_HOST_ARCH) + +module GHC.Event ( ) where + +#else + +module GHC.Event + (-- * Types + EventManager, + TimerManager, + -- * Creation + getSystemEventManager, + new, + getSystemTimerManager, + -- * Registering interest in I/O events + Event, + evtRead, + evtWrite, + IOCallback, + FdKey(keyFd), + Lifetime(..), + registerFd, + unregisterFd, + unregisterFd_, + closeFd, + -- * Registering interest in timeout events + TimeoutCallback, + TimeoutKey, + registerTimeout, + updateTimeout, + unregisterTimeout + ) where + +import GHC.Internal.Event + +#endif diff --git a/src/GHC/Event/TimeOut.hs b/src/GHC/Event/TimeOut.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Event/TimeOut.hs @@ -0,0 +1,24 @@ +-- | +-- Module : GHC.Event.TimeOut +-- Copyright : (c) Tamar Christina 2018 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable +-- +-- Common Timer definitions shared between WinIO and RIO. +-- +-- /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. + +module GHC.Event.TimeOut + ( TimeoutQueue + , TimeoutCallback + , TimeoutEdit + , TimeoutKey(..) + ) where + +import GHC.Internal.Event.TimeOut diff --git a/src/GHC/Event/Windows.hs b/src/GHC/Event/Windows.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Event/Windows.hs @@ -0,0 +1,61 @@ +-- | +-- Module : GHC.Event.Windows +-- Copyright : (c) Tamar Christina 2018 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable +-- +-- WinIO Windows event manager. +-- + +module GHC.Event.Windows ( + -- * Manager + Manager, + getSystemManager, + interruptSystemManager, + wakeupIOManager, + processRemoteCompletion, + + -- * Overlapped I/O + associateHandle, + associateHandle', + withOverlapped, + withOverlappedEx, + StartCallback, + StartIOCallback, + CbResult(..), + CompletionCallback, + LPOVERLAPPED, + + -- * Timeouts + TimeoutCallback, + TimeoutKey, + Seconds, + registerTimeout, + updateTimeout, + unregisterTimeout, + + -- * Utilities + withException, + ioSuccess, + ioFailed, + ioFailedAny, + getLastError, + + -- * I/O Result type + IOResult(..), + + -- * I/O Event notifications + HandleData (..), -- seal for release + HandleKey (handleValue), + registerHandle, + unregisterHandle, + + -- * Console events + module GHC.Internal.Event.Windows.ConsoleEvent +) where + +import GHC.Internal.Event.Windows +import GHC.Internal.Event.Windows.ConsoleEvent diff --git a/src/GHC/Event/Windows/Clock.hs b/src/GHC/Event/Windows/Clock.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Event/Windows/Clock.hs @@ -0,0 +1,12 @@ +module GHC.Event.Windows.Clock ( + Clock, + Seconds, + getTime, + getClock, + + -- * Specific implementations + queryPerformanceCounter, + getTickCount64 +) where + +import GHC.Internal.Event.Windows.Clock diff --git a/src/GHC/Event/Windows/ConsoleEvent.hs b/src/GHC/Event/Windows/ConsoleEvent.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Event/Windows/ConsoleEvent.hs @@ -0,0 +1,21 @@ +-- | +-- Module : GHC.Event.Windows.ConsoleEvent +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Windows I/O manager interfaces. Depending on which I/O Subsystem is used +-- requests will be routed to different places. +-- + +module GHC.Event.Windows.ConsoleEvent ( + ConsoleEvent (..), + start_console_handler, + toWin32ConsoleEvent, + win32ConsoleHandler +) where + +import GHC.Internal.Event.Windows.ConsoleEvent diff --git a/src/GHC/Event/Windows/FFI.hs b/src/GHC/Event/Windows/FFI.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Event/Windows/FFI.hs @@ -0,0 +1,59 @@ +-- | +-- Module : GHC.Event.Windows.FFI +-- Copyright : (c) Tamar Christina 2019 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable +-- +-- WinIO Windows API Foreign Function imports +-- + +module GHC.Event.Windows.FFI ( + -- * IOCP + IOCP(..), + CompletionKey, + newIOCP, + associateHandleWithIOCP, + getQueuedCompletionStatusEx, + postQueuedCompletionStatus, + getOverlappedResult, + + -- * Completion Data + CompletionData(..), + CompletionCallback, + withRequest, + + -- * Overlapped + OVERLAPPED, + LPOVERLAPPED, + OVERLAPPED_ENTRY(..), + LPOVERLAPPED_ENTRY, + HASKELL_OVERLAPPED, + LPHASKELL_OVERLAPPED, + allocOverlapped, + zeroOverlapped, + pokeOffsetOverlapped, + overlappedIOStatus, + overlappedIONumBytes, + + -- * Cancel pending I/O + cancelIoEx, + cancelIoEx', + + -- * Monotonic time + + -- ** GetTickCount + getTickCount64, + + -- ** QueryPerformanceCounter + queryPerformanceCounter, + queryPerformanceFrequency, + + -- ** Miscellaneous + throwWinErr, + setLastError + ) where + +import GHC.Internal.Event.Windows.FFI diff --git a/src/GHC/Event/Windows/ManagedThreadPool.hs b/src/GHC/Event/Windows/ManagedThreadPool.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Event/Windows/ManagedThreadPool.hs @@ -0,0 +1,23 @@ +-- | +-- Module : GHC.Event.Windows.ManagedThreadPool +-- Copyright : (c) Tamar Christina 2019 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable +-- +-- WinIO Windows Managed Thread pool API. This thread pool scales dynamically +-- based on demand. +-- +------------------------------------------------------------------------------- + +module GHC.Event.Windows.ManagedThreadPool + ( ThreadPool(..) + , startThreadPool + , notifyRunning + , notifyWaiting + , monitorThreadPool + ) where + +import GHC.Internal.Event.Windows.ManagedThreadPool diff --git a/src/GHC/Event/Windows/Thread.hs b/src/GHC/Event/Windows/Thread.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Event/Windows/Thread.hs @@ -0,0 +1,8 @@ +module GHC.Event.Windows.Thread ( + ensureIOManagerIsRunning, + interruptIOManager, + threadDelay, + registerDelay, +) where + +import GHC.Internal.Event.Windows.Thread diff --git a/src/GHC/Exception.hs b/src/GHC/Exception.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Exception.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Exception +-- Copyright : (c) The University of Glasgow, 1998-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Exceptions and exception-handling functions. +-- +-- /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. +-- + +module GHC.Exception + ( -- * 'Exception' class + Exception(..) + + -- * 'SomeException' + , SomeException(..) + + -- * Throwing + , throw + + -- * Concrete exceptions + -- ** Arithmetic exceptions + , ArithException(..) + , divZeroException + , overflowException + , ratioZeroDenomException + , underflowException + -- ** 'ErrorCall' + , ErrorCall(..) + , errorCallException + , errorCallWithCallStackException + + -- * Reexports + -- Re-export CallStack and SrcLoc from GHC.Types + , CallStack, fromCallSiteList, getCallStack, prettyCallStack + , prettyCallStackLines + , SrcLoc(..), prettySrcLoc + ) where + +import GHC.Internal.Exception + +-- XXX: This is a temporary workaround to ensure correct build ordering +-- despite #24436 since `GHC.Internal.Stack` has a .hs-boot file which +-- `ghc -M` does not track correctly. +-- This dependency should be removed when #24436 is fixed. +import GHC.Internal.Stack () diff --git a/src/GHC/Exception/Type.hs b/src/GHC/Exception/Type.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Exception/Type.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Exception.Type +-- Copyright : (c) The University of Glasgow, 1998-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Exceptions and exception-handling functions. +-- + +module GHC.Exception.Type + ( Exception(..) -- Class + , SomeException(..), ArithException(..) + , divZeroException, overflowException, ratioZeroDenomException + , underflowException + ) where + +import GHC.Internal.Exception.Type diff --git a/src/GHC/ExecutionStack.hs b/src/GHC/ExecutionStack.hs new file mode 100644 --- /dev/null +++ b/src/GHC/ExecutionStack.hs @@ -0,0 +1,38 @@ +-- | +-- +-- Module : GHC.ExecutionStack +-- 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) +-- +-- This is a module for efficient stack traces. This stack trace implementation +-- is considered low overhead. Basic usage looks like this: +-- +-- @ +-- import GHC.ExecutionStack +-- +-- myFunction :: IO () +-- myFunction = do +-- putStrLn =<< showStackTrace +-- @ +-- +-- Your GHC must have been built with @libdw@ support for this to work. +-- +-- @ +-- user@host:~$ ghc --info | grep libdw +-- ,("RTS expects libdw","YES") +-- @ +-- +-- @since 4.9.0.0 + +module GHC.ExecutionStack + (Location(..), + SrcLoc(..), + getStackTrace, + showStackTrace + ) where + +import GHC.Internal.ExecutionStack diff --git a/src/GHC/Exts.hs b/src/GHC/Exts.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Exts.hs @@ -0,0 +1,386 @@ +{-# LANGUAGE MagicHash #-} + +-- | +-- +-- Module : GHC.Exts +-- Copyright : (c) The University of Glasgow 2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- GHC Extensions: this is the Approved Way to get at GHC-specific extensions. +-- +-- Note: no other @base@ module should import this module. + +-- See Note [Where do we export PrimOps] for details about how to expose primops +-- to users. + +module GHC.Exts + (-- ** Pointer types + Ptr(..), + FunPtr(..), + -- ** Other primitive types + module GHC.Types, + -- ** Legacy interface for arrays of arrays + module GHC.Internal.ArrayArray, + -- * Primitive operations + module GHC.Prim, + module GHC.Prim.Ext, + -- ** Running 'RealWorld' state thread + runRW#, + -- ** Bit shift operations + shiftL#, + shiftRL#, + iShiftL#, + iShiftRA#, + iShiftRL#, + -- ** Pointer comparison operations + reallyUnsafePtrEquality, + unsafePtrEquality#, + eqStableName#, + sameArray#, + sameMutableArray#, + sameSmallArray#, + sameSmallMutableArray#, + sameByteArray#, + sameMutableByteArray#, + sameMVar#, + sameMutVar#, + sameTVar#, + samePromptTag#, + -- ** Compat wrapper + atomicModifyMutVar#, + -- ** Resize functions + -- | Resizing arrays of boxed elements is currently handled in + -- library space (rather than being a primop) since there is not + -- an efficient way to grow arrays. However, resize operations + -- may become primops in a future release of GHC. + resizeSmallMutableArray#, + -- ** Fusion + build, + augment, + -- * Overloaded lists + IsList(..), + -- * Transform comprehensions + Down(..), + groupWith, + sortWith, + the, + -- * Strings + -- ** Overloaded string literals + IsString(..), + -- ** CString + unpackCString#, + unpackAppendCString#, + unpackFoldrCString#, + unpackCStringUtf8#, + unpackNBytes#, + cstringLength#, + -- * Debugging + -- ** Breakpoints + breakpoint, + breakpointCond, + -- ** Event logging + traceEvent, + -- ** The call stack + currentCallStack, + -- * Ids with special behaviour + inline, + noinline, + lazy, + oneShot, + considerAccessible, + seq#, + -- * SpecConstr annotations + SpecConstrAnnotation(..), + SPEC(..), + -- * Coercions + -- ** Safe coercions + -- | These are available from the /Trustworthy/ module "Data.Coerce" as well. + -- + -- @since 4.7.0.0 + coerce, + -- ** Very unsafe coercion + unsafeCoerce#, + -- ** Casting class dictionaries with single methods + WithDict(..), + -- * Converting ADTs to constructor tags + DataToTag(..), + -- * The maximum tuple size + maxTupleSize + ) where + +import GHC.Internal.Exts +import GHC.Internal.ArrayArray +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) + , 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 ( + IO, -- Exported from "GHC.IO" + Type, -- Exported from "Data.Kind" + -- GHC's internal representation of 'TyCon's, for 'Typeable' + Module, TrName, TyCon, TypeLitSort, KindRep, KindBndr, + Unit#, + Solo#(..), + Tuple0#, + Tuple1#, + Tuple2#, + Tuple3#, + Tuple4#, + Tuple5#, + Tuple6#, + Tuple7#, + Tuple8#, + Tuple9#, + Tuple10#, + Tuple11#, + Tuple12#, + Tuple13#, + Tuple14#, + Tuple15#, + Tuple16#, + Tuple17#, + Tuple18#, + Tuple19#, + Tuple20#, + Tuple21#, + Tuple22#, + Tuple23#, + Tuple24#, + Tuple25#, + Tuple26#, + Tuple27#, + Tuple28#, + Tuple29#, + Tuple30#, + Tuple31#, + Tuple32#, + Tuple33#, + Tuple34#, + Tuple35#, + Tuple36#, + Tuple37#, + Tuple38#, + Tuple39#, + Tuple40#, + Tuple41#, + Tuple42#, + Tuple43#, + Tuple44#, + Tuple45#, + Tuple46#, + Tuple47#, + Tuple48#, + Tuple49#, + Tuple50#, + Tuple51#, + Tuple52#, + Tuple53#, + Tuple54#, + Tuple55#, + Tuple56#, + Tuple57#, + Tuple58#, + Tuple59#, + Tuple60#, + Tuple61#, + Tuple62#, + Tuple63#, + Tuple64#, + Sum2#, + Sum3#, + Sum4#, + Sum5#, + Sum6#, + Sum7#, + Sum8#, + Sum9#, + Sum10#, + Sum11#, + Sum12#, + Sum13#, + Sum14#, + Sum15#, + Sum16#, + Sum17#, + Sum18#, + Sum19#, + Sum20#, + Sum21#, + Sum22#, + Sum23#, + Sum24#, + Sum25#, + Sum26#, + Sum27#, + Sum28#, + Sum29#, + Sum30#, + Sum31#, + Sum32#, + Sum33#, + Sum34#, + Sum35#, + Sum36#, + Sum37#, + Sum38#, + Sum39#, + Sum40#, + Sum41#, + Sum42#, + Sum43#, + Sum44#, + Sum45#, + Sum46#, + Sum47#, + Sum48#, + Sum49#, + Sum50#, + Sum51#, + Sum52#, + Sum53#, + Sum54#, + Sum55#, + Sum56#, + Sum57#, + Sum58#, + Sum59#, + Sum60#, + Sum61#, + Sum62#, + Sum63#, + ) diff --git a/src/GHC/Fingerprint.hs b/src/GHC/Fingerprint.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Fingerprint.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Safe #-} + +module GHC.Fingerprint ( + Fingerprint(..), fingerprint0, + fingerprintData, + fingerprintString, + fingerprintFingerprints, + getFileHash + ) where + +import GHC.Internal.Fingerprint diff --git a/src/GHC/Fingerprint/Type.hs b/src/GHC/Fingerprint/Type.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Fingerprint/Type.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.Fingerprint.Type +-- Copyright : (c) The University of Glasgow, 1994-2023 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Fingerprints for recompilation checking and ABI versioning, and +-- implementing fast comparison of Typeable. +-- +-- /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. + +module GHC.Fingerprint.Type + (Fingerprint(..) + ) where + +import GHC.Internal.Fingerprint.Type diff --git a/src/GHC/Float.hs b/src/GHC/Float.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Float.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.Float +-- Copyright : (c) The University of Glasgow 1994-2002 +-- Portions obtained from hbc (c) Lennart Augusstson +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The types 'Float' and 'Double', the classes 'Floating' and 'RealFloat' and +-- casting between Word32 and Float and Word64 and Double. +-- + +module GHC.Float + (-- * Classes + Floating(..), + RealFloat(..), + -- * 'Float' + Float(..), + Float#, + -- ** Conversion + float2Int, + int2Float, + word2Float, + integerToFloat#, + naturalToFloat#, + rationalToFloat, + castWord32ToFloat, + castFloatToWord32, + castWord32ToFloat#, + castFloatToWord32#, + float2Double, + -- ** Operations + floorFloat, + ceilingFloat, + truncateFloat, + roundFloat, + properFractionFloat, + -- ** Predicate + isFloatDenormalized, + isFloatFinite, + isFloatInfinite, + isFloatNaN, + isFloatNegativeZero, + -- ** Comparison + gtFloat, + geFloat, + leFloat, + ltFloat, + -- ** Arithmetic + plusFloat, + minusFloat, + timesFloat, + divideFloat, + negateFloat, + expFloat, + expm1Float, + logFloat, + log1pFloat, + sqrtFloat, + fabsFloat, + sinFloat, + cosFloat, + tanFloat, + asinFloat, + acosFloat, + atanFloat, + sinhFloat, + coshFloat, + tanhFloat, + asinhFloat, + acoshFloat, + atanhFloat, + -- * 'Double' + Double(..), + Double#, + -- ** Conversion + double2Int, + int2Double, + word2Double, + integerToDouble#, + naturalToDouble#, + rationalToDouble, + castWord64ToDouble, + castDoubleToWord64, + castWord64ToDouble#, + castDoubleToWord64#, + double2Float, + -- ** Operations + floorDouble, + ceilingDouble, + truncateDouble, + roundDouble, + properFractionDouble, + -- ** Predicate + isDoubleDenormalized, + isDoubleFinite, + isDoubleInfinite, + isDoubleNaN, + isDoubleNegativeZero, + -- ** Comparison + gtDouble, + geDouble, + leDouble, + ltDouble, + -- ** Arithmetic + plusDouble, + minusDouble, + timesDouble, + divideDouble, + negateDouble, + expDouble, + expm1Double, + logDouble, + log1pDouble, + sqrtDouble, + fabsDouble, + sinDouble, + cosDouble, + tanDouble, + asinDouble, + acosDouble, + atanDouble, + sinhDouble, + coshDouble, + tanhDouble, + asinhDouble, + acoshDouble, + atanhDouble, + -- * Formatting + showFloat, + FFFormat(..), + formatRealFloat, + formatRealFloatAlt, + showSignedFloat, + -- * Operations + log1mexpOrd, + roundTo, + floatToDigits, + integerToBinaryFloat', + fromRat, + fromRat', + roundingMode#, + -- * Monomorphic equality operators + -- | See GHC.Classes#matching_overloaded_methods_in_rules + eqFloat, + eqDouble, + -- * Internal + -- | These may vanish in a future release + clamp, + expt, + expts, + expts10, + fromRat'', + maxExpt, + maxExpt10, + minExpt, + powerDouble, + powerFloat, + stgDoubleToWord64, + stgFloatToWord32, + stgWord64ToDouble, + stgWord32ToFloat + ) where + +import GHC.Internal.Float diff --git a/src/GHC/Float/ConversionUtils.hs b/src/GHC/Float/ConversionUtils.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Float/ConversionUtils.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.Float.ConversionUtils +-- Copyright : (c) Daniel Fischer 2010 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Utilities for conversion between Double/Float and Rational +-- + +module GHC.Float.ConversionUtils + (elimZerosInteger, + elimZerosInt# + ) where + +import GHC.Internal.Float.ConversionUtils diff --git a/src/GHC/Float/RealFracMethods.hs b/src/GHC/Float/RealFracMethods.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Float/RealFracMethods.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.Float.RealFracMethods +-- Copyright : (c) Daniel Fischer 2010 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Methods for the RealFrac instances for 'Float' and 'Double', +-- with specialised versions for 'Int'. +-- +-- Moved to their own module to not bloat "GHC.Float" further. +-- +-- /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. +-- + +module GHC.Float.RealFracMethods + (-- * Double methods + -- ** Integer results + properFractionDoubleInteger, + truncateDoubleInteger, + floorDoubleInteger, + ceilingDoubleInteger, + roundDoubleInteger, + -- ** Int results + properFractionDoubleInt, + floorDoubleInt, + ceilingDoubleInt, + roundDoubleInt, + -- * Double/Int conversions, wrapped primops + double2Int, + int2Double, + -- * Float methods + -- ** Integer results + properFractionFloatInteger, + truncateFloatInteger, + floorFloatInteger, + ceilingFloatInteger, + roundFloatInteger, + -- ** Int results + properFractionFloatInt, + floorFloatInt, + ceilingFloatInt, + roundFloatInt, + -- * Float/Int conversions, wrapped primops + float2Int, + int2Float + ) where + +import GHC.Internal.Float.RealFracMethods diff --git a/src/GHC/Foreign.hs b/src/GHC/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Foreign.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.Foreign +-- Copyright : (c) The University of Glasgow, 2008-2011 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Foreign marshalling support for CStrings with configurable encodings +-- + +module GHC.Foreign + (-- * C strings with a configurable encoding + CString, + CStringLen, + -- * Conversion of C strings into Haskell strings + peekCString, + peekCStringLen, + -- * Conversion of Haskell strings into C strings + newCString, + newCStringLen, + newCStringLen0, + -- * Conversion of Haskell strings into C strings using temporary storage + withCString, + withCStringLen, + withCStringLen0, + withCStringsLen, + charIsRepresentable + ) where + +import GHC.Internal.Foreign.C.String.Encoding diff --git a/src/GHC/ForeignPtr.hs b/src/GHC/ForeignPtr.hs new file mode 100644 --- /dev/null +++ b/src/GHC/ForeignPtr.hs @@ -0,0 +1,93 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.ForeignPtr +-- Copyright : (c) The University of Glasgow, 1992-2003 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- GHC's implementation of the 'ForeignPtr' data type. +-- + +module GHC.ForeignPtr + ( + -- * Types + ForeignPtr(..), + ForeignPtrContents(..), + Finalizers(..), + FinalizerPtr, + FinalizerEnvPtr, + -- * Create + newForeignPtr_, + mallocForeignPtr, + mallocPlainForeignPtr, + mallocForeignPtrBytes, + mallocPlainForeignPtrBytes, + mallocForeignPtrAlignedBytes, + mallocPlainForeignPtrAlignedBytes, + newConcForeignPtr, + -- * Add Finalizers + addForeignPtrFinalizer, + addForeignPtrFinalizerEnv, + addForeignPtrConcFinalizer, + -- * Conversion + unsafeForeignPtrToPtr, + castForeignPtr, + plusForeignPtr, + -- * Control over lifetype + withForeignPtr, + unsafeWithForeignPtr, + touchForeignPtr, + -- * Finalization + finalizeForeignPtr + -- * Commentary + -- $commentary + ) where + +import GHC.Internal.ForeignPtr + +{- $commentary + +This is a high-level overview of how 'ForeignPtr' works. +The implementation of 'ForeignPtr' must accomplish several goals: + +1. Invoke a finalizer once a foreign pointer becomes unreachable. +2. Support augmentation of finalizers, i.e. 'addForeignPtrFinalizer'. + As a motivating example, suppose that the payload of a foreign + pointer is C struct @bar@ that has an optionally NULL pointer field + @foo@ to an unmanaged heap object. Initially, @foo@ is NULL, and + later the program uses @malloc@, initializes the object, and assigns + @foo@ the address returned by @malloc@. When the foreign pointer + becomes unreachable, it is now necessary to first @free@ the object + pointed to by @foo@ and then invoke whatever finalizer was associated + with @bar@. That is, finalizers must be invoked in the opposite order + they are added. +3. Allow users to invoke a finalizer promptly if they know that the + foreign pointer is unreachable, i.e. 'finalizeForeignPtr'. + +How can these goals be accomplished? Goal 1 suggests that weak references +and finalizers (via 'Weak#' and 'mkWeak#') are necessary. But how should +they be used and what should their key be? Certainly not 'ForeignPtr' or +'ForeignPtrContents'. See the warning in "GHC.Weak" about weak pointers with +lifted (non-primitive) keys. The two finalizer-supporting data constructors of +'ForeignPtr' have an @'IORef' 'Finalizers'@ (backed by 'MutVar#') field. +This gets used in two different ways depending on the kind of finalizer: + +* 'HaskellFinalizers': The first @addForeignPtrConcFinalizer_@ call uses + 'mkWeak#' to attach the finalizer @foreignPtrFinalizer@ to the 'MutVar#'. + The resulting 'Weak#' is discarded (see @addForeignPtrConcFinalizer_@). + Subsequent calls to @addForeignPtrConcFinalizer_@ (goal 2) just add + finalizers onto the list in the 'HaskellFinalizers' data constructor. +* 'CFinalizers': The first 'addForeignPtrFinalizer' call uses + 'mkWeakNoFinalizer#' to create a 'Weak#'. The 'Weak#' is preserved in the + 'CFinalizers' data constructor. Both the first call and subsequent + calls (goal 2) use 'addCFinalizerToWeak#' to attach finalizers to the + 'Weak#' itself. Also, see Note [MallocPtr finalizers] for discussion of + the key and value of this 'Weak#'. + +In either case, the runtime invokes the appropriate finalizers when the +'ForeignPtr' becomes unreachable. +-} diff --git a/src/GHC/GHCi.hs b/src/GHC/GHCi.hs new file mode 100644 --- /dev/null +++ b/src/GHC/GHCi.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.GHCi +-- Copyright : (c) The University of Glasgow 2012 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The GHCi Monad lifting interface. +-- +-- EXPERIMENTAL! DON'T USE. +-- +-- /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. +-- + +module GHC.GHCi + {-# WARNING "This is an unstable interface." #-} + (GHCiSandboxIO(..), + NoIO() + ) where + +import GHC.Internal.GHCi diff --git a/src/GHC/GHCi/Helpers.hs b/src/GHC/GHCi/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/GHC/GHCi/Helpers.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.GHCi.Helpers +-- Copyright : (c) The GHC Developers +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Various helpers used by the GHCi shell. +-- +-- /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. +-- + +module GHC.GHCi.Helpers + (disableBuffering, + flushAll, + evalWrapper + ) where + +import GHC.Internal.GHCi.Helpers diff --git a/src/GHC/Generics.hs b/src/GHC/Generics.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Generics.hs @@ -0,0 +1,694 @@ +{-# LANGUAGE Safe #-} + +{-# LANGUAGE ExplicitNamespaces #-} + +-- | +-- Module : GHC.Generics +-- Copyright : (c) Universiteit Utrecht 2010-2011, University of Oxford 2012-2014 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- @since 4.6.0.0 +-- +-- If you're using @GHC.Generics@, you should consider using the +-- package, which +-- contains many useful generic functions. + +module GHC.Generics ( +-- * Introduction +-- +-- | +-- +-- Datatype-generic functions are based on the idea of converting values of +-- a datatype @T@ into corresponding values of a (nearly) isomorphic type @'Rep' T@. +-- The type @'Rep' T@ is +-- built from a limited set of type constructors, all provided by this module. A +-- datatype-generic function is then an overloaded function with instances +-- for most of these type constructors, together with a wrapper that performs +-- the mapping between @T@ and @'Rep' T@. By using this technique, we merely need +-- a few generic instances in order to implement functionality that works for any +-- representable type. +-- +-- Representable types are collected in the 'Generic' class, which defines the +-- associated type 'Rep' as well as conversion functions 'from' and 'to'. +-- Typically, you will not define 'Generic' instances by hand, but have the compiler +-- derive them for you. + +-- ** Representing datatypes +-- +-- | +-- +-- The key to defining your own datatype-generic functions is to understand how to +-- represent datatypes using the given set of type constructors. +-- +-- Let us look at an example first: +-- +-- @ +-- data Tree a = Leaf a | Node (Tree a) (Tree a) +-- deriving 'Generic' +-- @ +-- +-- The above declaration (which requires the language pragma @DeriveGeneric@) +-- causes the following representation to be generated: +-- +-- @ +-- instance 'Generic' (Tree a) where +-- type 'Rep' (Tree a) = +-- 'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False) +-- ('S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ('Rec0' a)) +-- ':+:' +-- 'C1' ('MetaCons \"Node\" 'PrefixI 'False) +-- ('S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ('Rec0' (Tree a)) +-- ':*:' +-- 'S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ('Rec0' (Tree a)))) +-- ... +-- @ +-- +-- /Hint:/ You can obtain information about the code being generated from GHC by passing +-- the @-ddump-deriv@ flag. In GHCi, you can expand a type family such as 'Rep' using +-- the @:kind!@ command. +-- +-- This is a lot of information! However, most of it is actually merely meta-information +-- that makes names of datatypes and constructors and more available on the type level. +-- +-- Here is a reduced representation for @Tree@ with nearly all meta-information removed, +-- for now keeping only the most essential aspects: +-- +-- @ +-- instance 'Generic' (Tree a) where +-- type 'Rep' (Tree a) = +-- 'Rec0' a +-- ':+:' +-- ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a)) +-- @ +-- +-- The @Tree@ datatype has two constructors. The representation of individual constructors +-- is combined using the binary type constructor ':+:'. +-- +-- The first constructor consists of a single field, which is the parameter @a@. This is +-- represented as @'Rec0' a@. +-- +-- The second constructor consists of two fields. Each is a recursive field of type @Tree a@, +-- represented as @'Rec0' (Tree a)@. Representations of individual fields are combined using +-- the binary type constructor ':*:'. +-- +-- Now let us explain the additional tags being used in the complete representation: +-- +-- * The @'S1' ('MetaSel 'Nothing 'NoSourceUnpackedness 'NoSourceStrictness +-- 'DecidedLazy)@ tag indicates several things. The @'Nothing@ indicates +-- that there is no record field selector associated with this field of +-- the constructor (if there were, it would have been marked @'Just +-- \"recordName\"@ instead). The other types contain meta-information on +-- the field's strictness: +-- +-- * There is no @{\-\# UNPACK \#-\}@ or @{\-\# NOUNPACK \#-\}@ annotation +-- in the source, so it is tagged with @'NoSourceUnpackedness@. +-- +-- * There is no strictness (@!@) or laziness (@~@) annotation in the +-- source, so it is tagged with @'NoSourceStrictness@. +-- +-- * The compiler infers that the field is lazy, so it is tagged with +-- @'DecidedLazy@. Bear in mind that what the compiler decides may be +-- quite different from what is written in the source. See +-- 'DecidedStrictness' for a more detailed explanation. +-- +-- The @'MetaSel@ type is also an instance of the type class 'Selector', +-- which can be used to obtain information about the field at the value +-- level. +-- +-- * The @'C1' ('MetaCons \"Leaf\" 'PrefixI 'False)@ and +-- @'C1' ('MetaCons \"Node\" 'PrefixI 'False)@ invocations indicate that the enclosed part is +-- the representation of the first and second constructor of datatype @Tree@, respectively. +-- Here, the meta-information regarding constructor names, fixity and whether +-- it has named fields or not is encoded at the type level. The @'MetaCons@ +-- type is also an instance of the type class 'Constructor'. This type class can be used +-- to obtain information about the constructor at the value level. +-- +-- * The @'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False)@ tag +-- indicates that the enclosed part is the representation of the +-- datatype @Tree@. Again, the meta-information is encoded at the type level. +-- The @'MetaData@ type is an instance of class 'Datatype', which +-- can be used to obtain the name of a datatype, the module it has been +-- defined in, the package it is located under, and whether it has been +-- defined using @data@ or @newtype@ at the value level. + +-- ** Derived and fundamental representation types +-- +-- | +-- +-- There are many datatype-generic functions that do not distinguish between positions that +-- are parameters or positions that are recursive calls. There are also many datatype-generic +-- functions that do not care about the names of datatypes and constructors at all. To keep +-- the number of cases to consider in generic functions in such a situation to a minimum, +-- it turns out that many of the type constructors introduced above are actually synonyms, +-- defining them to be variants of a smaller set of constructors. + +-- *** Individual fields of constructors: 'K1' +-- +-- | +-- +-- The type constructor 'Rec0' is a variant of 'K1': +-- +-- @ +-- type 'Rec0' = 'K1' 'R' +-- @ +-- +-- Here, 'R' is a type-level proxy that does not have any associated values. +-- +-- There used to be another variant of 'K1' (namely @Par0@), but it has since +-- been deprecated. + +-- *** Meta information: 'M1' +-- +-- | +-- +-- The type constructors 'S1', 'C1' and 'D1' are all variants of 'M1': +-- +-- @ +-- type 'S1' = 'M1' 'S' +-- type 'C1' = 'M1' 'C' +-- type 'D1' = 'M1' 'D' +-- @ +-- +-- The types 'S', 'C' and 'D' are once again type-level proxies, just used to create +-- several variants of 'M1'. + +-- *** Additional generic representation type constructors +-- +-- | +-- +-- Next to 'K1', 'M1', ':+:' and ':*:' there are a few more type constructors that occur +-- in the representations of other datatypes. + +-- **** Empty datatypes: 'V1' +-- +-- | +-- +-- For empty datatypes, 'V1' is used as a representation. For example, +-- +-- @ +-- data Empty deriving 'Generic' +-- @ +-- +-- yields +-- +-- @ +-- instance 'Generic' Empty where +-- type 'Rep' Empty = +-- 'D1' ('MetaData \"Empty\" \"Main\" \"package-name\" 'False) 'V1' +-- @ + +-- **** Constructors without fields: 'U1' +-- +-- | +-- +-- If a constructor has no arguments, then 'U1' is used as its representation. For example +-- the representation of 'Bool' is +-- +-- @ +-- instance 'Generic' Bool where +-- type 'Rep' Bool = +-- 'D1' ('MetaData \"Bool\" \"Data.Bool\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"False\" 'PrefixI 'False) 'U1' ':+:' 'C1' ('MetaCons \"True\" 'PrefixI 'False) 'U1') +-- @ + +-- *** Representation of types with many constructors or many fields +-- +-- | +-- +-- As ':+:' and ':*:' are just binary operators, one might ask what happens if the +-- datatype has more than two constructors, or a constructor with more than two +-- fields. The answer is simple: the operators are used several times, to combine +-- all the constructors and fields as needed. However, users /should not rely on +-- a specific nesting strategy/ for ':+:' and ':*:' being used. The compiler is +-- free to choose any nesting it prefers. (In practice, the current implementation +-- tries to produce a more-or-less balanced nesting, so that the traversal of +-- the structure of the datatype from the root to a particular component can be +-- performed in logarithmic rather than linear time.) + +-- ** Defining datatype-generic functions +-- +-- | +-- +-- A datatype-generic function comprises two parts: +-- +-- 1. /Generic instances/ for the function, implementing it for most of the representation +-- type constructors introduced above. +-- +-- 2. A /wrapper/ that for any datatype that is in `Generic`, performs the conversion +-- between the original value and its `Rep`-based representation and then invokes the +-- generic instances. +-- +-- As an example, let us look at a function @encode@ that produces a naive, but lossless +-- bit encoding of values of various datatypes. So we are aiming to define a function +-- +-- @ +-- encode :: 'Generic' a => a -> [Bool] +-- @ +-- +-- where we use 'Bool' as our datatype for bits. +-- +-- For part 1, we define a class @Encode'@. Perhaps surprisingly, this class is parameterized +-- over a type constructor @f@ of kind @* -> *@. This is a technicality: all the representation +-- type constructors operate with kind @* -> *@ as base kind. But the type argument is never +-- being used. This may be changed at some point in the future. The class has a single method, +-- and we use the type we want our final function to have, but we replace the occurrences of +-- the generic type argument @a@ with @f p@ (where the @p@ is any argument; it will not be used). +-- +-- > class Encode' f where +-- > encode' :: f p -> [Bool] +-- +-- With the goal in mind to make @encode@ work on @Tree@ and other datatypes, we now define +-- instances for the representation type constructors 'V1', 'U1', ':+:', ':*:', 'K1', and 'M1'. + +-- *** Definition of the generic representation types +-- +-- | +-- +-- In order to be able to do this, we need to know the actual definitions of these types: +-- +-- @ +-- data 'V1' p -- lifted version of Empty +-- data 'U1' p = 'U1' -- lifted version of () +-- data (':+:') f g p = 'L1' (f p) | 'R1' (g p) -- lifted version of 'Either' +-- data (':*:') f g p = (f p) ':*:' (g p) -- lifted version of (,) +-- newtype 'K1' i c p = 'K1' { 'unK1' :: c } -- a container for a c +-- newtype 'M1' i t f p = 'M1' { 'unM1' :: f p } -- a wrapper +-- @ +-- +-- So, 'U1' is just the unit type, ':+:' is just a binary choice like 'Either', +-- ':*:' is a binary pair like the pair constructor @(,)@, and 'K1' is a value +-- of a specific type @c@, and 'M1' wraps a value of the generic type argument, +-- which in the lifted world is an @f p@ (where we do not care about @p@). + +-- *** Generic instances +-- +-- | +-- +-- To deal with the 'V1' case, we use the following code (which requires the pragma @EmptyCase@): +-- +-- @ +-- instance Encode' 'V1' where +-- encode' x = case x of { } +-- @ +-- +-- There are no values of type @V1 p@ to pass, so it is impossible for this +-- function to be invoked. One can ask why it is useful to define an instance +-- for 'V1' at all in this case? Well, an empty type can be used as an argument +-- to a non-empty type, and you might still want to encode the resulting type. +-- As a somewhat contrived example, consider @[Empty]@, which is not an empty +-- type, but contains just the empty list. The 'V1' instance ensures that we +-- can call the generic function on such types. +-- +-- There is exactly one value of type 'U1', so encoding it requires no +-- knowledge, and we can use zero bits: +-- +-- @ +-- instance Encode' 'U1' where +-- encode' 'U1' = [] +-- @ +-- +-- In the case for ':+:', we produce 'False' or 'True' depending on whether +-- the constructor of the value provided is located on the left or on the right: +-- +-- @ +-- instance (Encode' f, Encode' g) => Encode' (f ':+:' g) where +-- encode' ('L1' x) = False : encode' x +-- encode' ('R1' x) = True : encode' x +-- @ +-- +-- (Note that this encoding strategy may not be reliable across different +-- versions of GHC. Recall that the compiler is free to choose any nesting +-- of ':+:' it chooses, so if GHC chooses @(a ':+:' b) ':+:' c@, then the +-- encoding for @a@ would be @[False, False]@, @b@ would be @[False, True]@, +-- and @c@ would be @[True]@. However, if GHC chooses @a ':+:' (b ':+:' c)@, +-- then the encoding for @a@ would be @[False]@, @b@ would be @[True, False]@, +-- and @c@ would be @[True, True]@.) +-- +-- In the case for ':*:', we append the encodings of the two subcomponents: +-- +-- @ +-- instance (Encode' f, Encode' g) => Encode' (f ':*:' g) where +-- encode' (x ':*:' y) = encode' x ++ encode' y +-- @ +-- +-- The case for 'K1' is rather interesting. Here, we call the final function +-- @encode@ that we yet have to define, recursively. We will use another type +-- class @Encode@ for that function: +-- +-- @ +-- instance (Encode c) => Encode' ('K1' i c) where +-- encode' ('K1' x) = encode x +-- @ +-- +-- Note how we can define a uniform instance for 'M1', because we completely +-- disregard all meta-information: +-- +-- @ +-- instance (Encode' f) => Encode' ('M1' i t f) where +-- encode' ('M1' x) = encode' x +-- @ +-- +-- Unlike in 'K1', the instance for 'M1' refers to @encode'@, not @encode@. + +-- *** The wrapper and generic default +-- +-- | +-- +-- We now define class @Encode@ for the actual @encode@ function: +-- +-- @ +-- class Encode a where +-- encode :: a -> [Bool] +-- default encode :: (Generic a, Encode' (Rep a)) => a -> [Bool] +-- encode x = encode' ('from' x) +-- @ +-- +-- The incoming @x@ is converted using 'from', then we dispatch to the +-- generic instances using @encode'@. We use this as a default definition +-- for @encode@. We need the @default encode@ signature because ordinary +-- Haskell default methods must not introduce additional class constraints, +-- but our generic default does. +-- +-- Defining a particular instance is now as simple as saying +-- +-- @ +-- instance (Encode a) => Encode (Tree a) +-- @ +-- +-- The generic default is being used. In the future, it will hopefully be +-- possible to use @deriving Encode@ as well, but GHC does not yet support +-- that syntax for this situation. +-- +-- Having @Encode@ as a class has the advantage that we can define +-- non-generic special cases, which is particularly useful for abstract +-- datatypes that have no structural representation. For example, given +-- a suitable integer encoding function @encodeInt@, we can define +-- +-- @ +-- instance Encode Int where +-- encode = encodeInt +-- @ + +-- *** Omitting generic instances +-- +-- | +-- +-- It is not always required to provide instances for all the generic +-- representation types, but omitting instances restricts the set of +-- datatypes the functions will work for: +-- +-- * If no ':+:' instance is given, the function may still work for +-- empty datatypes or datatypes that have a single constructor, +-- but will fail on datatypes with more than one constructor. +-- +-- * If no ':*:' instance is given, the function may still work for +-- datatypes where each constructor has just zero or one field, +-- in particular for enumeration types. +-- +-- * If no 'K1' instance is given, the function may still work for +-- enumeration types, where no constructor has any fields. +-- +-- * If no 'V1' instance is given, the function may still work for +-- any datatype that is not empty. +-- +-- * If no 'U1' instance is given, the function may still work for +-- any datatype where each constructor has at least one field. +-- +-- An 'M1' instance is always required (but it can just ignore the +-- meta-information, as is the case for @encode@ above). +-- +-- ** Generic constructor classes +-- +-- | +-- +-- Datatype-generic functions as defined above work for a large class +-- of datatypes, including parameterized datatypes. (We have used @Tree@ +-- as our example above, which is of kind @* -> *@.) However, the +-- 'Generic' class ranges over types of kind @*@, and therefore, the +-- resulting generic functions (such as @encode@) must be parameterized +-- by a generic type argument of kind @*@. +-- +-- What if we want to define generic classes that range over type +-- constructors (such as 'Data.Functor.Functor', +-- 'Data.Traversable.Traversable', or 'Data.Foldable.Foldable')? + +-- *** The 'Generic1' class +-- +-- | +-- +-- Like 'Generic', there is a class 'Generic1' that defines a +-- representation 'Rep1' and conversion functions 'from1' and 'to1', +-- only that 'Generic1' ranges over types of kind @* -> *@. (More generally, +-- it can range over types of kind @k -> *@, for any kind @k@, if the +-- @PolyKinds@ extension is enabled. More on this later.) +-- The 'Generic1' class is also derivable. +-- +-- The representation 'Rep1' is ever so slightly different from 'Rep'. +-- Let us look at @Tree@ as an example again: +-- +-- @ +-- data Tree a = Leaf a | Node (Tree a) (Tree a) +-- deriving 'Generic1' +-- @ +-- +-- The above declaration causes the following representation to be generated: +-- +-- @ +-- instance 'Generic1' Tree where +-- type 'Rep1' Tree = +-- 'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False) +-- ('S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- 'Par1') +-- ':+:' +-- 'C1' ('MetaCons \"Node\" 'PrefixI 'False) +-- ('S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ('Rec1' Tree) +-- ':*:' +-- 'S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ('Rec1' Tree))) +-- ... +-- @ +-- +-- The representation reuses 'D1', 'C1', 'S1' (and thereby 'M1') as well +-- as ':+:' and ':*:' from 'Rep'. (This reusability is the reason that we +-- carry around the dummy type argument for kind-@*@-types, but there are +-- already enough different names involved without duplicating each of +-- these.) +-- +-- What's different is that we now use 'Par1' to refer to the parameter +-- (and that parameter, which used to be @a@), is not mentioned explicitly +-- by name anywhere; and we use 'Rec1' to refer to a recursive use of @Tree a@. + +-- *** Representation of @* -> *@ types +-- +-- | +-- +-- Unlike 'Rec0', the 'Par1' and 'Rec1' type constructors do not +-- map to 'K1'. They are defined directly, as follows: +-- +-- @ +-- newtype 'Par1' p = 'Par1' { 'unPar1' :: p } -- gives access to parameter p +-- newtype 'Rec1' f p = 'Rec1' { 'unRec1' :: f p } -- a wrapper +-- @ +-- +-- In 'Par1', the parameter @p@ is used for the first time, whereas 'Rec1' simply +-- wraps an application of @f@ to @p@. +-- +-- Note that 'K1' (in the guise of 'Rec0') can still occur in a 'Rep1' representation, +-- namely when the datatype has a field that does not mention the parameter. +-- +-- The declaration +-- +-- @ +-- data WithInt a = WithInt Int a +-- deriving 'Generic1' +-- @ +-- +-- yields +-- +-- @ +-- instance 'Generic1' WithInt where +-- type 'Rep1' WithInt = +-- 'D1' ('MetaData \"WithInt\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"WithInt\" 'PrefixI 'False) +-- ('S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ('Rec0' Int) +-- ':*:' +-- 'S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- 'Par1')) +-- @ +-- +-- If the parameter @a@ appears underneath a composition of other type constructors, +-- then the representation involves composition, too: +-- +-- @ +-- data Rose a = Fork a [Rose a] +-- @ +-- +-- yields +-- +-- @ +-- instance 'Generic1' Rose where +-- type 'Rep1' Rose = +-- 'D1' ('MetaData \"Rose\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"Fork\" 'PrefixI 'False) +-- ('S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- 'Par1' +-- ':*:' +-- 'S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ([] ':.:' 'Rec1' Rose))) +-- @ +-- +-- where +-- +-- @ +-- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) } +-- @ + +-- *** Representation of @k -> *@ types +-- +-- | +-- +-- The 'Generic1' class can be generalized to range over types of kind +-- @k -> *@, for any kind @k@. To do so, derive a 'Generic1' instance with the +-- @PolyKinds@ extension enabled. For example, the declaration +-- +-- @ +-- data Proxy (a :: k) = Proxy deriving 'Generic1' +-- @ +-- +-- yields a slightly different instance depending on whether @PolyKinds@ is +-- enabled. If compiled without @PolyKinds@, then @'Rep1' Proxy :: * -> *@, but +-- if compiled with @PolyKinds@, then @'Rep1' Proxy :: k -> *@. + +-- *** Representation of unlifted types +-- +-- | +-- +-- If one were to attempt to derive a Generic instance for a datatype with an +-- unlifted argument (for example, 'Int#'), one might expect the occurrence of +-- the 'Int#' argument to be marked with @'Rec0' 'Int#'@. This won't work, +-- though, since 'Int#' is of an unlifted kind, and 'Rec0' expects a type of +-- kind @*@. +-- +-- One solution would be to represent an occurrence of 'Int#' with 'Rec0 Int' +-- instead. With this approach, however, the programmer has no way of knowing +-- whether the 'Int' is actually an 'Int#' in disguise. +-- +-- Instead of reusing 'Rec0', a separate data family 'URec' is used to mark +-- occurrences of common unlifted types: +-- +-- @ +-- data family URec a p +-- +-- data instance 'URec' ('Ptr' ()) p = 'UAddr' { 'uAddr#' :: 'Addr#' } +-- data instance 'URec' 'Char' p = 'UChar' { 'uChar#' :: 'Char#' } +-- data instance 'URec' 'Double' p = 'UDouble' { 'uDouble#' :: 'Double#' } +-- data instance 'URec' 'Int' p = 'UFloat' { 'uFloat#' :: 'Float#' } +-- data instance 'URec' 'Float' p = 'UInt' { 'uInt#' :: 'Int#' } +-- data instance 'URec' 'Word' p = 'UWord' { 'uWord#' :: 'Word#' } +-- @ +-- +-- Several type synonyms are provided for convenience: +-- +-- @ +-- type 'UAddr' = 'URec' ('Ptr' ()) +-- type 'UChar' = 'URec' 'Char' +-- type 'UDouble' = 'URec' 'Double' +-- type 'UFloat' = 'URec' 'Float' +-- type 'UInt' = 'URec' 'Int' +-- type 'UWord' = 'URec' 'Word' +-- @ +-- +-- The declaration +-- +-- @ +-- data IntHash = IntHash Int# +-- deriving 'Generic' +-- @ +-- +-- yields +-- +-- @ +-- instance 'Generic' IntHash where +-- type 'Rep' IntHash = +-- 'D1' ('MetaData \"IntHash\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"IntHash\" 'PrefixI 'False) +-- ('S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- 'UInt')) +-- @ +-- +-- Currently, only the six unlifted types listed above are generated, but this +-- may be extended to encompass more unlifted types in the future. + + -- * Generic representation types + V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) + , (:+:)(..), (:*:)(..), (:.:)(..) + + -- ** Unboxed representation types + , URec(..) + , type UAddr, type UChar, type UDouble + , type UFloat, type UInt, type UWord + + -- ** Synonyms for convenience + , Rec0, R + , D1, C1, S1, D, C, S + + -- * Meta-information + , Datatype(..), Constructor(..), Selector(..) + , Fixity(..), FixityI(..), Associativity(..), prec + , SourceUnpackedness(..), SourceStrictness(..), DecidedStrictness(..) + , Meta(..) + + -- * Generic type classes + , Generic(..) + , Generic1(..) + + -- * Generic wrapper + , Generically(..) + , Generically1(..) + ) where + +import GHC.Internal.Generics diff --git a/src/GHC/IO.hs b/src/GHC/IO.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.IO +-- Copyright : (c) The University of Glasgow 1994-2023 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Definitions for the 'IO' monad and its friends. +-- +-- /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. +-- + +module GHC.IO ( + IO(..), unIO, liftIO, mplusIO, + unsafePerformIO, unsafeInterleaveIO, + unsafeDupablePerformIO, unsafeDupableInterleaveIO, + noDuplicate, + + -- To and from ST + stToIO, ioToST, unsafeIOToST, unsafeSTToIO, + + FilePath, + + catch, catchException, catchAny, throwIO, + mask, mask_, uninterruptibleMask, uninterruptibleMask_, + MaskingState(..), getMaskingState, + unsafeUnmask, interruptible, + onException, bracket, finally, evaluate, + mkUserError + ) where + +import GHC.Internal.IO diff --git a/src/GHC/IO/Buffer.hs b/src/GHC/IO/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Buffer.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.IO.Buffer +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Buffers used in the IO system +-- +-- /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. +-- + +module GHC.IO.Buffer + (-- * Buffers of any element + Buffer(..), + BufferState(..), + CharBuffer, + CharBufElem, + -- ** Creation + newByteBuffer, + newCharBuffer, + newBuffer, + emptyBuffer, + -- ** Insertion/removal + bufferRemove, + bufferAdd, + slideContents, + bufferAdjustL, + bufferAddOffset, + bufferAdjustOffset, + -- ** Inspecting + isEmptyBuffer, + isFullBuffer, + isFullCharBuffer, + isWriteBuffer, + bufferElems, + bufferAvailable, + bufferOffset, + summaryBuffer, + -- ** Operating on the raw buffer as a Ptr + withBuffer, + withRawBuffer, + -- ** Assertions + checkBuffer, + -- * Raw buffers + RawBuffer, + readWord8Buf, + writeWord8Buf, + RawCharBuffer, + peekCharBuf, + readCharBuf, + writeCharBuf, + readCharBufPtr, + writeCharBufPtr, + charSize + ) where + +import GHC.Internal.IO.Buffer diff --git a/src/GHC/IO/BufferedIO.hs b/src/GHC/IO/BufferedIO.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/BufferedIO.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.IO.BufferedIO +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Class of buffered IO devices +-- + +module GHC.IO.BufferedIO + (BufferedIO(..), + readBuf, + readBufNonBlocking, + writeBuf, + writeBufNonBlocking + ) where + +import GHC.Internal.IO.BufferedIO diff --git a/src/GHC/IO/Device.hs b/src/GHC/IO/Device.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Device.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : GHC.IO.Device +-- Copyright : (c) The University of Glasgow, 1994-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Type classes for I/O providers. +-- +-- /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. +-- + +module GHC.IO.Device ( + RawIO(..), + IODevice(..), + IODeviceType(..), + SeekMode(..) + ) where + +import GHC.Internal.IO.Device diff --git a/src/GHC/IO/Encoding.hs b/src/GHC/IO/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Encoding.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.IO.Encoding +-- Copyright : (c) The University of Glasgow, 2008-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Text codecs for I/O +-- +-- /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. +-- + +module GHC.IO.Encoding + (BufferCodec(..), + TextEncoding(..), + TextEncoder, + TextDecoder, + CodingProgress(..), + latin1, + latin1_encode, + latin1_decode, + utf8, + utf8_bom, + utf16, + utf16le, + utf16be, + utf32, + utf32le, + utf32be, + initLocaleEncoding, + getLocaleEncoding, + getFileSystemEncoding, + getForeignEncoding, + setLocaleEncoding, + setFileSystemEncoding, + setForeignEncoding, + char8, + mkTextEncoding, + argvEncoding + ) where + +import GHC.Internal.IO.Encoding diff --git a/src/GHC/IO/Encoding/CodePage.hs b/src/GHC/IO/Encoding/CodePage.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Encoding/CodePage.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} + +#if ! defined(mingw32_HOST_OS) + +module GHC.IO.Encoding.CodePage ( ) where + +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import Prelude () -- for build ordering + +#else + +module GHC.IO.Encoding.CodePage + ( codePageEncoding, mkCodePageEncoding, + localeEncoding, mkLocaleEncoding, CodePage, + getCurrentCodePage + ) where + +import GHC.Internal.IO.Encoding.CodePage + +#endif diff --git a/src/GHC/IO/Encoding/CodePage/API.hs b/src/GHC/IO/Encoding/CodePage/API.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Encoding/CodePage/API.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE Safe #-} + +module GHC.IO.Encoding.CodePage.API ( + mkCodePageEncoding + ) where + +import GHC.Internal.IO.Encoding.CodePage.API diff --git a/src/GHC/IO/Encoding/CodePage/Table.hs b/src/GHC/IO/Encoding/CodePage/Table.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Encoding/CodePage/Table.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Trustworthy #-} + +module GHC.IO.Encoding.CodePage.Table + ( module GHC.Internal.IO.Encoding.CodePage.Table + ) where + +import GHC.Internal.IO.Encoding.CodePage.Table + diff --git a/src/GHC/IO/Encoding/Failure.hs b/src/GHC/IO/Encoding/Failure.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Encoding/Failure.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE MagicHash #-} + +-- | +-- +-- Module : GHC.IO.Encoding.Failure +-- Copyright : (c) The University of Glasgow, 2008-2011 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Types for specifying how text encoding/decoding fails +-- + +module GHC.IO.Encoding.Failure + (CodingFailureMode(..), + codingFailureModeSuffix, + isSurrogate, + recoverDecode, + recoverEncode, + recoverDecode#, + recoverEncode# + ) where + +import GHC.Internal.IO.Encoding.Failure diff --git a/src/GHC/IO/Encoding/Iconv.hs b/src/GHC/IO/Encoding/Iconv.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Encoding/Iconv.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.IO.Encoding.Iconv +-- Copyright : (c) The University of Glasgow, 2008-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- This module provides text encoding/decoding using iconv +-- + +module GHC.IO.Encoding.Iconv +#if !defined(mingw32_HOST_OS) + (iconvEncoding, + mkIconvEncoding, + localeEncodingName + ) where + +import GHC.Internal.IO.Encoding.Iconv + +#else + ( ) where + +#endif diff --git a/src/GHC/IO/Encoding/Latin1.hs b/src/GHC/IO/Encoding/Latin1.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Encoding/Latin1.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.IO.Encoding.Latin1 +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Single-byte encodings that map directly to Unicode code points. +-- +-- Portions Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- + +module GHC.IO.Encoding.Latin1 + (latin1, + mkLatin1, + latin1_checked, + mkLatin1_checked, + ascii, + mkAscii, + latin1_decode, + ascii_decode, + latin1_encode, + latin1_checked_encode, + ascii_encode + ) where + +import GHC.Internal.IO.Encoding.Latin1 diff --git a/src/GHC/IO/Encoding/Types.hs b/src/GHC/IO/Encoding/Types.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Encoding/Types.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- +-- Module : GHC.IO.Encoding.Types +-- Copyright : (c) The University of Glasgow, 2008-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Types for text encoding/decoding +-- + +module GHC.IO.Encoding.Types + (BufferCodec(..), + TextEncoding(..), + TextEncoder, + TextDecoder, + CodeBuffer, + EncodeBuffer, + DecodeBuffer, + CodingProgress(..), + DecodeBuffer#, + EncodeBuffer#, + DecodingBuffer#, + EncodingBuffer# + ) where + +import GHC.Internal.IO.Encoding.Types diff --git a/src/GHC/IO/Encoding/UTF16.hs b/src/GHC/IO/Encoding/UTF16.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Encoding/UTF16.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.IO.Encoding.UTF16 +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- UTF-16 Codecs for the IO library +-- +-- Portions Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- + +module GHC.IO.Encoding.UTF16 + (utf16, + mkUTF16, + utf16_decode, + utf16_encode, + utf16be, + mkUTF16be, + utf16be_decode, + utf16be_encode, + utf16le, + mkUTF16le, + utf16le_decode, + utf16le_encode + ) where + +import GHC.Internal.IO.Encoding.UTF16 diff --git a/src/GHC/IO/Encoding/UTF32.hs b/src/GHC/IO/Encoding/UTF32.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Encoding/UTF32.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.IO.Encoding.UTF32 +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- UTF-32 Codecs for the IO library +-- +-- Portions Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- + +module GHC.IO.Encoding.UTF32 + (utf32, + mkUTF32, + utf32_decode, + utf32_encode, + utf32be, + mkUTF32be, + utf32be_decode, + utf32be_encode, + utf32le, + mkUTF32le, + utf32le_decode, + utf32le_encode + ) where + +import GHC.Internal.IO.Encoding.UTF32 diff --git a/src/GHC/IO/Encoding/UTF8.hs b/src/GHC/IO/Encoding/UTF8.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Encoding/UTF8.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.IO.Encoding.UTF8 +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- UTF-8 Codec for the IO library +-- +-- This is one of several UTF-8 implementations provided by GHC; see Note +-- [GHC's many UTF-8 implementations] in "GHC.Encoding.UTF8" for an +-- overview. +-- +-- Portions Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- + +module GHC.IO.Encoding.UTF8 + (utf8, + mkUTF8, + utf8_bom, + mkUTF8_bom + ) where + +import GHC.Internal.IO.Encoding.UTF8 diff --git a/src/GHC/IO/Exception.hs b/src/GHC/IO/Exception.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Exception.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.IO.Exception +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- IO-related Exception types and functions +-- +-- /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. +-- + +module GHC.IO.Exception ( + BlockedIndefinitelyOnMVar(..), blockedIndefinitelyOnMVar, + BlockedIndefinitelyOnSTM(..), blockedIndefinitelyOnSTM, + Deadlock(..), + AllocationLimitExceeded(..), allocationLimitExceeded, + AssertionFailed(..), + CompactionFailed(..), + cannotCompactFunction, cannotCompactPinned, cannotCompactMutable, + + SomeAsyncException(..), + asyncExceptionToException, asyncExceptionFromException, + AsyncException(..), stackOverflow, heapOverflow, + + ArrayException(..), + ExitCode(..), + FixIOException (..), + + ioException, + ioError, + IOError, + IOException(..), + IOErrorType(..), + userError, + assertError, + unsupportedOperation, + untangle, + ) where + +import GHC.Internal.IO.Exception + diff --git a/src/GHC/IO/FD.hs b/src/GHC/IO/FD.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/FD.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.IO.FD +-- Copyright : (c) The University of Glasgow, 1994-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Raw read/write operations on file descriptors +-- + +module GHC.IO.FD + (FD(..), + openFileWith, + openFile, + mkFD, + release, + setNonBlockingMode, + readRawBufferPtr, + readRawBufferPtrNoBlock, + writeRawBufferPtr, + stdin, + stdout, + stderr + ) where + +import GHC.Internal.IO.FD diff --git a/src/GHC/IO/Handle.hs b/src/GHC/IO/Handle.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Handle.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.IO.Handle +-- Copyright : (c) The University of Glasgow, 1994-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable +-- +-- External API for GHC's Handle implementation +-- + +module GHC.IO.Handle + (Handle, + BufferMode(..), + mkFileHandle, + mkDuplexHandle, + hFileSize, + hSetFileSize, + hIsEOF, + isEOF, + hLookAhead, + hSetBuffering, + hSetBinaryMode, + hSetEncoding, + hGetEncoding, + hFlush, + hFlushAll, + hDuplicate, + hDuplicateTo, + hClose, + hClose_help, + LockMode(..), + hLock, + hTryLock, + HandlePosition, + HandlePosn(..), + hGetPosn, + hSetPosn, + SeekMode(..), + hSeek, + hTell, + hIsOpen, + hIsClosed, + hIsReadable, + hIsWritable, + hGetBuffering, + hIsSeekable, + hSetEcho, + hGetEcho, + hIsTerminalDevice, + hSetNewlineMode, + Newline(..), + NewlineMode(..), + nativeNewline, + noNewlineTranslation, + universalNewlineMode, + nativeNewlineMode, + hShow, + hWaitForInput, + hGetChar, + hGetLine, + hGetContents, + hGetContents', + hPutChar, + hPutStr, + hGetBuf, + hGetBufNonBlocking, + hPutBuf, + hPutBufNonBlocking + ) where + +import GHC.Internal.IO.Handle diff --git a/src/GHC/IO/Handle/FD.hs b/src/GHC/IO/Handle/FD.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Handle/FD.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.IO.Handle.FD +-- Copyright : (c) The University of Glasgow, 1994-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Handle operations implemented by file descriptors (FDs) +-- +-- @since 4.2.0.0 +-- + +module GHC.IO.Handle.FD + (stdin, + stdout, + stderr, + openFile, + withFile, + openBinaryFile, + withBinaryFile, + openFileBlocking, + withFileBlocking, + mkHandleFromFD, + fdToHandle, + fdToHandle', + handleToFd + ) where + +import GHC.Internal.IO.Handle.FD diff --git a/src/GHC/IO/Handle/Internals.hs b/src/GHC/IO/Handle/Internals.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Handle/Internals.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.IO.Handle.Internals +-- Copyright : (c) The University of Glasgow, 1994-2001 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- This module defines the basic operations on I\/O \"handles\". All +-- of the operations defined here are independent of the underlying +-- device. +-- +-- /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. +-- + +module GHC.IO.Handle.Internals + (withHandle, + withHandle', + withHandle_, + withHandle__', + withHandle_', + withAllHandles__, + wantWritableHandle, + wantReadableHandle, + wantReadableHandle_, + wantSeekableHandle, + mkHandle, + mkFileHandle, + mkFileHandleNoFinalizer, + mkDuplexHandle, + mkDuplexHandleNoFinalizer, + addHandleFinalizer, + openTextEncoding, + closeTextCodecs, + initBufferState, + dEFAULT_CHAR_BUFFER_SIZE, + flushBuffer, + flushWriteBuffer, + flushCharReadBuffer, + flushCharBuffer, + flushByteReadBuffer, + flushByteWriteBuffer, + readTextDevice, + writeCharBuffer, + readTextDeviceNonBlocking, + decodeByteBuf, + augmentIOError, + ioe_closedHandle, + ioe_semiclosedHandle, + ioe_EOF, + ioe_notReadable, + ioe_notWritable, + ioe_finalizedHandle, + ioe_bufsiz, + hClose_impl, + hClose_help, + hLookAhead_, + HandleFinalizer, + handleFinalizer, + debugIO, + traceIO + ) where + +import GHC.Internal.IO.Handle.Internals diff --git a/src/GHC/IO/Handle/Lock.hs b/src/GHC/IO/Handle/Lock.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Handle/Lock.hs @@ -0,0 +1,9 @@ +module GHC.IO.Handle.Lock + (FileLockingNotSupported(..), + LockMode(..), + hLock, + hTryLock, + hUnlock + ) where + +import GHC.Internal.IO.Handle.Lock diff --git a/src/GHC/IO/Handle/Text.hs b/src/GHC/IO/Handle/Text.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Handle/Text.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.IO.Handle.Text +-- Copyright : (c) The University of Glasgow, 1992-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- String I\/O functions +-- +-- /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. +-- + +module GHC.IO.Handle.Text ( + hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, + commitBuffer', -- hack, see below + hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, + memcpy, hPutStrLn, hGetContents', + ) where + +import GHC.Internal.IO.Handle.Text diff --git a/src/GHC/IO/Handle/Types.hs b/src/GHC/IO/Handle/Types.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Handle/Types.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.IO.Handle.Types +-- Copyright : (c) The University of Glasgow, 1994-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Basic types for the implementation of IO Handles. +-- +-- /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. +-- + +module GHC.IO.Handle.Types ( + Handle(..), Handle__(..), showHandle, + checkHandleInvariants, + BufferList(..), + HandleType(..), + isReadableHandleType, isWritableHandleType, isReadWriteHandleType, + isAppendHandleType, + BufferMode(..), + BufferCodec(..), + NewlineMode(..), Newline(..), nativeNewline, + universalNewlineMode, noNewlineTranslation, nativeNewlineMode + ) where + +import GHC.Internal.IO.Handle.Types diff --git a/src/GHC/IO/Handle/Windows.hs b/src/GHC/IO/Handle/Windows.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Handle/Windows.hs @@ -0,0 +1,20 @@ +-- | +-- Module : GHC.IO.Handle.Windows +-- Copyright : (c) The University of Glasgow, 2017 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Handle operations implemented by Windows native handles +-- +----------------------------------------------------------------------------- + +module GHC.IO.Handle.Windows ( + stdin, stdout, stderr, + openFile, openBinaryFile, openFileBlocking, + handleToHANDLE, mkHandleFromHANDLE + ) where + +import GHC.Internal.IO.Handle.Windows diff --git a/src/GHC/IO/IOMode.hs b/src/GHC/IO/IOMode.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/IOMode.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.IO.IOMode +-- Copyright : (c) The University of Glasgow, 1994-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- The IOMode type +-- + +module GHC.IO.IOMode + (IOMode(..) + ) where + +import GHC.Internal.IO.IOMode diff --git a/src/GHC/IO/StdHandles.hs b/src/GHC/IO/StdHandles.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/StdHandles.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.IO.StdHandles +-- Copyright : (c) The University of Glasgow, 2017 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- This model abstracts away the platform specific handles that can be toggled +-- through the RTS. +-- + +module GHC.IO.StdHandles + (stdin, + stdout, + stderr, + openFile, + openBinaryFile, + openFileBlocking, + withFile, + withBinaryFile, + withFileBlocking + ) where + +import GHC.Internal.IO.StdHandles diff --git a/src/GHC/IO/SubSystem.hs b/src/GHC/IO/SubSystem.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/SubSystem.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.IO.SubSystem +-- Copyright : (c) The University of Glasgow, 2017 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- The 'IoSubSystem' control interface. These methods can be used to disambiguate +-- between the two operations. +-- +-- /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. +-- + +module GHC.IO.SubSystem + (withIoSubSystem, + withIoSubSystem', + whenIoSubSystem, + ioSubSystem, + IoSubSystem(..), + conditional, + (), + isWindowsNativeIO + ) where + +import GHC.Internal.IO.SubSystem diff --git a/src/GHC/IO/Unsafe.hs b/src/GHC/IO/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Unsafe.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.IO.Unsafe +-- Copyright : (c) The University of Glasgow 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Unsafe IO operations +-- + +module GHC.IO.Unsafe + (unsafePerformIO, + unsafeInterleaveIO, + unsafeDupablePerformIO, + unsafeDupableInterleaveIO, + noDuplicate + ) where + +import GHC.Internal.IO.Unsafe diff --git a/src/GHC/IO/Windows/Encoding.hs b/src/GHC/IO/Windows/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Windows/Encoding.hs @@ -0,0 +1,25 @@ +-- | +-- Module : System.Win32.Encoding +-- Copyright : 2012 shelarcy +-- License : BSD-style +-- +-- Maintainer : shelarcy@gmail.com +-- Stability : Provisional +-- Portability : Non-portable (Win32 API) +-- +-- Encode/Decode multibyte character using Win32 API. +-- + +module GHC.IO.Windows.Encoding + ( encodeMultiByte + , encodeMultiByteIO + , encodeMultiByteRawIO + , decodeMultiByte + , decodeMultiByteIO + , wideCharToMultiByte + , multiByteToWideChar + , withGhcInternalToUTF16 + , withUTF16ToGhcInternal + ) where + +import GHC.Internal.IO.Windows.Encoding diff --git a/src/GHC/IO/Windows/Handle.hs b/src/GHC/IO/Windows/Handle.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Windows/Handle.hs @@ -0,0 +1,40 @@ +-- | +-- Module : GHC.IO.Windows.Handle +-- Copyright : (c) The University of Glasgow, 2017 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Raw read/write operations on Windows Handles +-- + +module GHC.IO.Windows.Handle + ( -- * Basic Types + NativeHandle(), + ConsoleHandle(), + IoHandle(), + HANDLE, + Io(), + + -- * Utility functions + convertHandle, + toHANDLE, + fromHANDLE, + handleToMode, + isAsynchronous, + optimizeFileAccess, + + -- * Standard Handles + stdin, + stdout, + stderr, + + -- * File utilities + openFile, + openFileAsTemp, + release + ) where + +import GHC.Internal.IO.Windows.Handle diff --git a/src/GHC/IO/Windows/Paths.hs b/src/GHC/IO/Windows/Paths.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Windows/Paths.hs @@ -0,0 +1,18 @@ +-- | +-- Module : GHC.IO.Windows.Paths +-- Copyright : (c) The University of Glasgow, 2017 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Windows FilePath handling utility for GHC code. +-- +----------------------------------------------------------------------------- + +module GHC.IO.Windows.Paths + ( getDevicePath + ) where + +import GHC.Internal.IO.Windows.Paths diff --git a/src/GHC/IOArray.hs b/src/GHC/IOArray.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IOArray.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.IOArray +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The IOArray type +-- + +module GHC.IOArray + (IOArray(..), + newIOArray, + unsafeReadIOArray, + unsafeWriteIOArray, + readIOArray, + writeIOArray, + boundsIOArray + ) where + +import GHC.Internal.IOArray diff --git a/src/GHC/IORef.hs b/src/GHC/IORef.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IORef.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.IORef +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The IORef type +-- + +module GHC.IORef + (IORef(..), + newIORef, + readIORef, + writeIORef, + atomicModifyIORef2Lazy, + atomicModifyIORef2, + atomicModifyIORefLazy_, + atomicModifyIORef'_, + atomicModifyIORefP, + atomicSwapIORef, + atomicModifyIORef' + ) where + +import GHC.Internal.IORef diff --git a/src/GHC/InfoProv.hs b/src/GHC/InfoProv.hs new file mode 100644 --- /dev/null +++ b/src/GHC/InfoProv.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : GHC.InfoProv +-- Copyright : (c) The University of Glasgow 2011 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Access to GHC's info-table provenance metadata. +-- +-- /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.18.0.0 +-- + +module GHC.InfoProv + ( InfoProv(..) + , ipLoc + , ipeProv + , whereFrom + -- * Internals + , InfoProvEnt + , peekInfoProv + ) where + +import GHC.Internal.InfoProv diff --git a/src/GHC/Int.hs b/src/GHC/Int.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Int.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.Int +-- 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) +-- +-- The sized integral datatypes, 'Int8', 'Int16', 'Int32', and 'Int64'. +-- + +module GHC.Int + (Int(..), + Int8(..), + Int16(..), + Int32(..), + Int64(..), + uncheckedIShiftL64#, + uncheckedIShiftRA64#, + shiftRLInt8#, + shiftRLInt16#, + shiftRLInt32#, + -- * Equality operators + -- | See GHC.Classes#matching_overloaded_methods_in_rules + eqInt, + neInt, + gtInt, + geInt, + ltInt, + leInt, + eqInt8, + neInt8, + gtInt8, + geInt8, + ltInt8, + leInt8, + eqInt16, + neInt16, + gtInt16, + geInt16, + ltInt16, + leInt16, + eqInt32, + neInt32, + gtInt32, + geInt32, + ltInt32, + leInt32, + eqInt64, + neInt64, + gtInt64, + geInt64, + ltInt64, + leInt64 + ) where + +import GHC.Internal.Int diff --git a/src/GHC/Integer.hs b/src/GHC/Integer.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Integer.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Compatibility module for pre-@ghc-bignum@ code. + +module GHC.Integer + (Integer, + -- * Construct 'Integer's + smallInteger, + wordToInteger, + -- * Conversion to other integral types + integerToWord, + integerToInt, + -- * Helpers for 'RealFloat' type-class operations + encodeFloatInteger, + encodeDoubleInteger, + decodeDoubleInteger, + -- * Arithmetic operations + plusInteger, + minusInteger, + timesInteger, + negateInteger, + absInteger, + signumInteger, + divModInteger, + divInteger, + modInteger, + quotRemInteger, + quotInteger, + remInteger, + -- * Comparison predicates + eqInteger, + neqInteger, + leInteger, + gtInteger, + ltInteger, + geInteger, + compareInteger, + -- ** 'Int#'-boolean valued versions of comparison predicates + -- | These operations return @0#@ and @1#@ instead of 'False' and + -- 'True' respectively. See + -- + -- for more details + eqInteger#, + neqInteger#, + leInteger#, + gtInteger#, + ltInteger#, + geInteger#, + -- * Bit-operations + andInteger, + orInteger, + xorInteger, + complementInteger, + shiftLInteger, + shiftRInteger, + testBitInteger, + popCountInteger, + bitInteger, + -- * Hashing + hashInteger + ) where + +import GHC.Internal.Integer diff --git a/src/GHC/Integer/Logarithms.hs b/src/GHC/Integer/Logarithms.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Integer/Logarithms.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE MagicHash #-} + +-- | +-- Compatibility module for pre-@ghc-bignum@ code. + +module GHC.Integer.Logarithms + (wordLog2#, + integerLog2#, + integerLogBase# + ) where + +import GHC.Internal.Integer.Logarithms diff --git a/src/GHC/IsList.hs b/src/GHC/IsList.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IsList.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.IsList +-- Copyright : (c) The University of Glasgow 2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- @since 4.17.0.0 + +module GHC.IsList + (IsList(..) + ) where + +import GHC.Internal.IsList diff --git a/src/GHC/Ix.hs b/src/GHC/Ix.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Ix.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.Ix +-- 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) +-- +-- GHC\'s Ix typeclass implementation. +-- + +module GHC.Ix + (Ix(..), + indexError + ) where + +import GHC.Internal.Ix diff --git a/src/GHC/JS/Foreign/Callback.hs b/src/GHC/JS/Foreign/Callback.hs new file mode 100644 --- /dev/null +++ b/src/GHC/JS/Foreign/Callback.hs @@ -0,0 +1,22 @@ +module GHC.JS.Foreign.Callback + ( Callback + , OnBlocked(..) + , releaseCallback + -- * asynchronous callbacks + , asyncCallback + , asyncCallback1 + , asyncCallback2 + , asyncCallback3 + -- * synchronous callbacks + , syncCallback + , syncCallback1 + , syncCallback2 + , syncCallback3 + -- * synchronous callbacks that return a value + , syncCallback' + , syncCallback1' + , syncCallback2' + , syncCallback3' + ) where + +import GHC.Internal.JS.Foreign.Callback diff --git a/src/GHC/JS/Prim.hs b/src/GHC/JS/Prim.hs new file mode 100644 --- /dev/null +++ b/src/GHC/JS/Prim.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +module GHC.JS.Prim + ( JSVal(..), JSVal# + , JSException(..) + , WouldBlockException(..) +#if defined(javascript_HOST_ARCH) + , toIO + , resolve + , resolveIO + , mkJSException + , fromJSString + , toJSString + , toJSArray + , fromJSArray + , fromJSInt + , toJSInt + , isNull + , isUndefined + , jsNull + , getProp + , getProp' + , getProp# + , unsafeGetProp + , unsafeGetProp' + , unsafeGetProp# + , unpackJSString# + , unpackJSStringUtf8# + , unsafeUnpackJSString# + , unsafeUnpackJSStringUtf8# + , unpackJSStringUtf8## + , unsafeUnpackJSStringUtf8## +#endif + ) where + +import GHC.Internal.JS.Prim + diff --git a/src/GHC/JS/Prim/Internal.hs b/src/GHC/JS/Prim/Internal.hs new file mode 100644 --- /dev/null +++ b/src/GHC/JS/Prim/Internal.hs @@ -0,0 +1,10 @@ +module GHC.JS.Prim.Internal + ( blockedIndefinitelyOnMVar + , blockedIndefinitelyOnSTM + , wouldBlock + , ignoreException + , setCurrentThreadResultException + , setCurrentThreadResultValue + ) where + +import GHC.Internal.JS.Prim.Internal diff --git a/src/GHC/JS/Prim/Internal/Build.hs b/src/GHC/JS/Prim/Internal/Build.hs new file mode 100644 --- /dev/null +++ b/src/GHC/JS/Prim/Internal/Build.hs @@ -0,0 +1,147 @@ +{-# 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) + () where +#else + ( buildArrayI + , buildArrayM + , buildObjectI + , buildObjectM + , buildArrayI1 + , buildArrayI2 + , buildArrayI3 + , buildArrayI4 + , buildArrayI5 + , buildArrayI6 + , buildArrayI7 + , buildArrayI8 + , buildArrayI9 + , buildArrayI10 + , buildArrayI11 + , buildArrayI12 + , buildArrayI13 + , buildArrayI14 + , buildArrayI15 + , buildArrayI16 + , buildArrayI17 + , buildArrayI18 + , buildArrayI19 + , buildArrayI20 + , buildArrayI21 + , buildArrayI22 + , buildArrayI23 + , buildArrayI24 + , buildArrayI25 + , buildArrayI26 + , buildArrayI27 + , buildArrayI28 + , buildArrayI29 + , buildArrayI30 + , buildArrayI31 + , buildArrayI32 + , buildArrayM1 + , buildArrayM2 + , buildArrayM3 + , buildArrayM4 + , buildArrayM5 + , buildArrayM6 + , buildArrayM7 + , buildArrayM8 + , buildArrayM9 + , buildArrayM10 + , buildArrayM11 + , buildArrayM12 + , buildArrayM13 + , buildArrayM14 + , buildArrayM15 + , buildArrayM16 + , buildArrayM17 + , buildArrayM18 + , buildArrayM19 + , buildArrayM20 + , buildArrayM21 + , buildArrayM22 + , buildArrayM23 + , buildArrayM24 + , buildArrayM25 + , buildArrayM26 + , buildArrayM27 + , buildArrayM28 + , buildArrayM29 + , buildArrayM30 + , buildArrayM31 + , buildArrayM32 + , buildObjectI1 + , buildObjectI2 + , buildObjectI3 + , buildObjectI4 + , buildObjectI5 + , buildObjectI6 + , buildObjectI7 + , buildObjectI8 + , buildObjectI9 + , buildObjectI10 + , buildObjectI11 + , buildObjectI12 + , buildObjectI13 + , buildObjectI14 + , buildObjectI15 + , buildObjectI16 + , buildObjectI17 + , buildObjectI18 + , buildObjectI19 + , buildObjectI20 + , buildObjectI21 + , buildObjectI22 + , buildObjectI23 + , buildObjectI24 + , buildObjectI25 + , buildObjectI26 + , buildObjectI27 + , buildObjectI28 + , buildObjectI29 + , buildObjectI30 + , buildObjectI31 + , buildObjectI32 + , buildObjectM1 + , buildObjectM2 + , buildObjectM3 + , buildObjectM4 + , buildObjectM5 + , buildObjectM6 + , buildObjectM7 + , buildObjectM8 + , buildObjectM9 + , buildObjectM10 + , buildObjectM11 + , buildObjectM12 + , buildObjectM13 + , buildObjectM14 + , buildObjectM15 + , buildObjectM16 + , buildObjectM17 + , buildObjectM18 + , buildObjectM19 + , buildObjectM20 + , buildObjectM21 + , buildObjectM22 + , buildObjectM23 + , buildObjectM24 + , buildObjectM25 + , buildObjectM26 + , buildObjectM27 + , buildObjectM28 + , buildObjectM29 + , buildObjectM30 + , buildObjectM31 + , buildObjectM32 + ) where + +import GHC.Internal.JS.Prim.Internal.Build + +#endif + diff --git a/src/GHC/List.hs b/src/GHC/List.hs new file mode 100644 --- /dev/null +++ b/src/GHC/List.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE Safe #-} + + +-- | +-- +-- Module : GHC.List +-- Copyright : (c) The University of Glasgow 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The List data type and its operations +-- + +module GHC.List ( + + -- * The list data type + List, + + -- * List-monomorphic Foldable methods and misc functions + foldr, foldr', foldr1, + foldl, foldl', foldl1, + null, length, elem, notElem, + maximum, minimum, sum, product, and, or, any, all, + + -- * Other functions + foldl1', concat, concatMap, + map, (++), filter, lookup, + head, last, tail, init, uncons, unsnoc, (!?), (!!), + scanl, scanl1, scanl', scanr, scanr1, + iterate, iterate', repeat, replicate, cycle, + take, drop, splitAt, takeWhile, dropWhile, span, break, reverse, + zip, zip3, zipWith, zipWith3, unzip, unzip3, + errorEmptyList, + + -- * GHC List fusion + augment, build, + + ) where + +import GHC.Internal.List diff --git a/src/GHC/MVar.hs b/src/GHC/MVar.hs new file mode 100644 --- /dev/null +++ b/src/GHC/MVar.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.MVar +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The MVar type +-- + +module GHC.MVar + (-- * MVars + MVar(..), + newMVar, + newEmptyMVar, + takeMVar, + readMVar, + putMVar, + tryTakeMVar, + tryPutMVar, + tryReadMVar, + isEmptyMVar, + addMVarFinalizer + ) where + +import GHC.Internal.MVar diff --git a/src/GHC/Maybe.hs b/src/GHC/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Maybe.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Maybe +-- 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) +-- +-- The 'Maybe' type. + +module GHC.Maybe + (Maybe(..)) where + +import GHC.Internal.Maybe diff --git a/src/GHC/Natural.hs b/src/GHC/Natural.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Natural.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Compatibility module for pre ghc-bignum code. + +module GHC.Natural + (Natural(NatS#, NatJ#), + BigNat(..), + mkNatural, + isValidNatural, + -- * Arithmetic + plusNatural, + minusNatural, + minusNaturalMaybe, + timesNatural, + negateNatural, + signumNatural, + quotRemNatural, + quotNatural, + remNatural, + gcdNatural, + lcmNatural, + -- * Bits + andNatural, + orNatural, + xorNatural, + bitNatural, + testBitNatural, + popCountNatural, + shiftLNatural, + shiftRNatural, + -- * Conversions + naturalToInteger, + naturalToWord, + naturalToWordMaybe, + wordToNatural, + wordToNatural#, + naturalFromInteger, + -- * Modular arithmetic + powModNatural + ) where + +import GHC.Internal.Natural diff --git a/src/GHC/Num.hs b/src/GHC/Num.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Num.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Num +-- Copyright : (c) The University of Glasgow 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The 'Num' class and the 'Integer' type. +-- + +module GHC.Num + ( Num(..) + , subtract + , quotRemInteger + , module GHC.Num.Integer + , module GHC.Num.Natural + ) +where + +import GHC.Internal.Num +import GHC.Num.Integer +import GHC.Num.Natural 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/OldList.hs b/src/GHC/OldList.hs new file mode 100644 --- /dev/null +++ b/src/GHC/OldList.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.OldList +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- This legacy module provides access to the list-specialised operations +-- of "Data.List". This module may go away again in future GHC versions and +-- is provided as transitional tool to access some of the list-specialised +-- operations that had to be generalised due to the implementation of the +-- . +-- +-- If the operations needed are available in "GHC.List", it's +-- recommended to avoid importing this module and use "GHC.List" +-- instead for now. +-- +-- @since 4.8.0.0 + +module GHC.OldList (module GHC.Internal.Data.OldList) where + +import GHC.Internal.Data.OldList diff --git a/src/GHC/OverloadedLabels.hs b/src/GHC/OverloadedLabels.hs new file mode 100644 --- /dev/null +++ b/src/GHC/OverloadedLabels.hs @@ -0,0 +1,32 @@ +-- | +-- +-- Module : GHC.OverloadedLabels +-- Copyright : (c) Adam Gundry 2015-2016 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- This module defines the 'IsLabel' class used by the +-- @OverloadedLabels@ extension. See the +-- +-- for more details. +-- +-- When @OverloadedLabels@ is enabled, if GHC sees an occurrence of +-- the overloaded label syntax @#foo@, it is replaced with +-- +-- > fromLabel @"foo" :: alpha +-- +-- plus a wanted constraint @IsLabel "foo" alpha@. +-- +-- Note that if @RebindableSyntax@ is enabled, the desugaring of +-- overloaded label syntax will make use of whatever @fromLabel@ is in +-- scope. +-- + +module GHC.OverloadedLabels + (IsLabel(..) + ) where + +import GHC.Internal.OverloadedLabels diff --git a/src/GHC/Profiling.hs b/src/GHC/Profiling.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Profiling.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Safe #-} + +-- | +-- @since 4.7.0.0 + +module GHC.Profiling + (-- * Cost Centre Profiling + startProfTimer, + stopProfTimer, + -- * Heap Profiling + startHeapProfTimer, + stopHeapProfTimer, + requestHeapCensus + ) where + +import GHC.Internal.Profiling diff --git a/src/GHC/Ptr.hs b/src/GHC/Ptr.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Ptr.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Ptr +-- Copyright : (c) The FFI Task Force, 2000-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ffi@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The 'Ptr' and 'FunPtr' types and operations. +-- + +module GHC.Ptr ( + Ptr(..), FunPtr(..), + nullPtr, castPtr, plusPtr, alignPtr, minusPtr, + nullFunPtr, castFunPtr, + + -- * Unsafe functions + castFunPtrToPtr, castPtrToFunPtr, + ) where + +import GHC.Internal.Ptr diff --git a/src/GHC/RTS/Flags.hs b/src/GHC/RTS/Flags.hs new file mode 100644 --- /dev/null +++ b/src/GHC/RTS/Flags.hs @@ -0,0 +1,474 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | +-- Module : GHC.RTS.Flags +-- 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) +-- +-- /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. +-- +-- Descriptions of flags can be seen in +-- , +-- or by running RTS help message using @+RTS --help@. +-- +-- @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 + , RTSFlags (..) + , GiveGCStats (..) + , GCFlags (..) + , ConcFlags (..) + , MiscFlags (..) + , IoManagerFlag (..) + , DebugFlags (..) + , DoCostCentres (..) + , CCFlags (..) + , DoHeapProfile (..) + , ProfFlags (..) + , DoTrace (..) + , TraceFlags (..) + , TickyFlags (..) + , ParFlags (..) + , HpcFlags (..) + , {-# DEPRECATED "import GHC.IO.SubSystem (IoSubSystem (..))" #-} + IoSubSystem (..) + , getRTSFlags + , getGCFlags + , getConcFlags + , getMiscFlags + , getDebugFlags + , getCCFlags + , getProfFlags + , getTraceFlags + , getTickyFlags + , getParFlags + , getHpcFlags + ) where + +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/Read.hs b/src/GHC/Read.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Read.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Read +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The 'Read' class and instances for basic data types. +-- + +module GHC.Read + ( -- * Class + Read(..) + + -- * ReadS type + , ReadS + + -- * Haskell 2010 compatibility + , lex + , lexLitChar + , readLitChar + , lexDigits + + -- * Defining readers + , lexP, expectP + , paren + , parens + , list + , choose + , readListDefault, readListPrecDefault + , readNumber + , readField + , readFieldHash + , readSymField + + , readParen + ) + where + +import GHC.Internal.Read diff --git a/src/GHC/Real.hs b/src/GHC/Real.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Real.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Real +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The types 'Ratio' and 'Rational', and the classes 'Real', 'Fractional', +-- 'Integral', and 'RealFrac'. +-- + +module GHC.Real + ( -- * Classes + Real(..) + , Integral(..) + , Fractional(..) + , RealFrac(..) + + -- * Conversion + , fromIntegral + , realToFrac + + -- * Formatting + , showSigned + + -- * Predicates + , even + , odd + + -- * Arithmetic + , (^) + , (^^) + , gcd + , lcm + + -- * 'Ratio' + , Ratio(..) + , Rational + , infinity + , notANumber + + -- * 'Enum' helpers + , numericEnumFrom + , numericEnumFromThen + , numericEnumFromTo + , numericEnumFromThenTo + , integralEnumFrom + , integralEnumFromThen + , integralEnumFromTo + , integralEnumFromThenTo + + -- ** Construction + , (%) + + -- ** Projection + , numerator + , denominator + + -- ** Operations + , reduce + + -- * Internal + , ratioPrec + , ratioPrec1 + , divZeroError + , ratioZeroDenominatorError + , overflowError + , underflowError + , mkRationalBase2 + , mkRationalBase10 + , FractionalExponentBase(..) + , (^%^) + , (^^%^^) + , mkRationalWithExponentBase + , powImpl + , powImplAcc + ) where + +import GHC.Internal.Real diff --git a/src/GHC/Records.hs b/src/GHC/Records.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Records.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.Records +-- Copyright : (c) Adam Gundry 2015-2016 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- This module defines the 'HasField' class used by the +-- @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(..) + ) where + +import GHC.Internal.Records diff --git a/src/GHC/ResponseFile.hs b/src/GHC/ResponseFile.hs new file mode 100644 --- /dev/null +++ b/src/GHC/ResponseFile.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : GHC.ResponseFile +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : portable +-- +-- GCC style response files. +-- +-- @since 4.12.0.0 + +module GHC.ResponseFile ( + getArgsWithResponseFiles, + unescapeArgs, + escapeArgs, + expandResponse + ) where + +import GHC.Internal.ResponseFile diff --git a/src/GHC/ST.hs b/src/GHC/ST.hs new file mode 100644 --- /dev/null +++ b/src/GHC/ST.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.ST +-- Copyright : (c) The University of Glasgow, 1992-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The 'ST' Monad. +-- + +module GHC.ST + (ST(..), + STret(..), + STRep, + runST, + -- * Unsafe functions + liftST, + unsafeInterleaveST, + unsafeDupableInterleaveST + ) where + +import GHC.Internal.ST diff --git a/src/GHC/STRef.hs b/src/GHC/STRef.hs new file mode 100644 --- /dev/null +++ b/src/GHC/STRef.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.STRef +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- References in the 'ST' monad. +-- + +module GHC.STRef + (STRef(..), + newSTRef, + readSTRef, + writeSTRef + ) where + +import GHC.Internal.STRef diff --git a/src/GHC/Show.hs b/src/GHC/Show.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Show.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Show +-- Copyright : (c) The University of Glasgow, 1992-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The 'Show' class, and related operations. +-- + +module GHC.Show + ( + Show(..), ShowS, + + -- * Show support code + shows, showChar, showString, showMultiLineString, + showParen, showList__, showCommaSpace, showSpace, + showLitChar, showLitString, protectEsc, + intToDigit, showSignedInt, + appPrec, appPrec1, + + -- * Character operations + asciiTab, + ) where + +import GHC.Internal.Show diff --git a/src/GHC/Stable.hs b/src/GHC/Stable.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stable.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : GHC.Stable +-- Copyright : (c) The University of Glasgow, 1992-2004 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ffi@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Stable pointers. +-- + +module GHC.Stable ( + StablePtr(..), + newStablePtr, + deRefStablePtr, + freeStablePtr, + castStablePtrToPtr, + castPtrToStablePtr + ) where + +import GHC.Internal.Stable diff --git a/src/GHC/StableName.hs b/src/GHC/StableName.hs new file mode 100644 --- /dev/null +++ b/src/GHC/StableName.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : System.Mem.StableName +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable +-- +-- Stable names are a way of performing fast ( \(\mathcal{O}(1)\) ), +-- not-quite-exact comparison between objects. +-- +-- Stable names solve the following problem: suppose you want to build +-- a hash table with Haskell objects as keys, but you want to use +-- pointer equality for comparison; maybe because the keys are large +-- and hashing would be slow, or perhaps because the keys are infinite +-- in size. We can\'t build a hash table using the address of the +-- object as the key, because objects get moved around by the garbage +-- collector, meaning a re-hash would be necessary after every garbage +-- collection. +-- + +module GHC.StableName + (-- * Stable Names + StableName(..), + makeStableName, + hashStableName, + eqStableName + ) where + +import GHC.Internal.StableName diff --git a/src/GHC/Stack.hs b/src/GHC/Stack.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : GHC.Stack +-- Copyright : (c) The University of Glasgow 2011 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Access to GHC's call-stack simulation +-- +-- @since 4.5.0.0 + +module GHC.Stack + (errorWithStackTrace, + -- * Profiling call stacks + currentCallStack, + whoCreated, + -- * HasCallStack call stacks + CallStack, + HasCallStack, + callStack, + emptyCallStack, + freezeCallStack, + fromCallSiteList, + getCallStack, + popCallStack, + prettyCallStack, + pushCallStack, + withFrozenCallStack, + -- * Source locations + SrcLoc(..), + prettySrcLoc, + -- * Internals + CostCentreStack, + CostCentre, + getCurrentCCS, + getCCSOf, + clearCCS, + ccsCC, + ccsParent, + ccLabel, + ccModule, + ccSrcSpan, + ccsToStrings, + renderStack + ) where + +import GHC.Internal.Stack diff --git a/src/GHC/Stack/CCS.hs b/src/GHC/Stack/CCS.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/CCS.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : GHC.Stack.CCS +-- Copyright : (c) The University of Glasgow 2011 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Access to GHC's call-stack simulation +-- +-- @since 4.5.0.0 + +module GHC.Stack.CCS ( + -- * Call stacks + currentCallStack, + whoCreated, + + -- * Internals + CostCentreStack, + CostCentre, + getCurrentCCS, + getCCSOf, + clearCCS, + ccsCC, + ccsParent, + ccLabel, + ccModule, + ccSrcSpan, + ccsToStrings, + renderStack, + ) where + +import GHC.Internal.Stack.CCS diff --git a/src/GHC/Stack/CloneStack.hs b/src/GHC/Stack/CloneStack.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/CloneStack.hs @@ -0,0 +1,20 @@ +-- | +-- This module exposes an interface for capturing the state of a thread's +-- execution stack for diagnostics purposes: 'cloneMyStack', +-- 'cloneThreadStack'. +-- +-- Such a "cloned" stack can be decoded with 'decode' to a stack trace, given +-- that the @-finfo-table-map@ is enabled. +-- +-- @since 4.17.0.0 + +module GHC.Stack.CloneStack ( + StackSnapshot(..), + StackEntry(..), + cloneMyStack, + cloneThreadStack, + decode + ) where + +import GHC.Internal.Stack.CloneStack +import GHC.Internal.Stack.Decode diff --git a/src/GHC/Stack/Types.hs b/src/GHC/Stack/Types.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Types.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.Stack.Types +-- Copyright : (c) The University of Glasgow 2015 +-- License : see libraries/ghc-prim/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Type definitions for implicit call-stacks. +-- Use "GHC.Stack" from the base package instead of importing this +-- module directly. +-- +-- /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. +-- + +module GHC.Stack.Types + (-- * Implicit call stacks + CallStack(..), + HasCallStack, + emptyCallStack, + freezeCallStack, + fromCallSiteList, + getCallStack, + pushCallStack, + -- * Source locations + SrcLoc(..) + ) where + +import GHC.Internal.Stack.Types diff --git a/src/GHC/StaticPtr.hs b/src/GHC/StaticPtr.hs new file mode 100644 --- /dev/null +++ b/src/GHC/StaticPtr.hs @@ -0,0 +1,44 @@ +-- | +-- Module : GHC.StaticPtr +-- Copyright : (C) 2014 I/O Tweag +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Symbolic references to values. +-- +-- References to values are usually implemented with memory addresses, and this +-- is practical when communicating values between the different pieces of a +-- single process. +-- +-- When values are communicated across different processes running in possibly +-- different machines, though, addresses are no longer useful since each +-- process may use different addresses to store a given value. +-- +-- To solve such concern, the references provided by this module offer a key +-- that can be used to locate the values on each process. Each process maintains +-- a global table of references which can be looked up with a given key. This +-- table is known as the Static Pointer Table. The reference can then be +-- dereferenced to obtain the value. +-- +-- The various communicating processes need to agree on the keys used to refer +-- to the values in the Static Pointer Table, or lookups will fail. Only +-- processes launched from the same program binary are guaranteed to use the +-- same set of keys. +-- + +module GHC.StaticPtr + ( StaticPtr + , deRefStaticPtr + , StaticKey + , staticKey + , unsafeLookupStaticPtr + , StaticPtrInfo(..) + , staticPtrInfo + , staticPtrKeys + , IsStatic(..) + ) where + +import GHC.Internal.StaticPtr diff --git a/src/GHC/Stats.hs b/src/GHC/Stats.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stats.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} + +-- | +-- Module : RTS.Stats +-- 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) +-- +-- This module provides access to internal garbage collection and +-- memory usage statistics. These statistics are not available unless +-- a program is run with the @-T@ RTS flag. +-- +-- /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. +-- +-- @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 + RTSStats(..), GCDetails(..), RtsTime + , getRTSStats + , getRTSStatsEnabled + ) where + + +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/Storable.hs b/src/GHC/Storable.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Storable.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.Storable +-- Copyright : (c) The FFI task force, 2000-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ffi@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Helper functions for "Foreign.Storable" +-- + +module GHC.Storable + (readWideCharOffPtr, + readIntOffPtr, + readWordOffPtr, + readPtrOffPtr, + readFunPtrOffPtr, + readFloatOffPtr, + readDoubleOffPtr, + readStablePtrOffPtr, + readInt8OffPtr, + readInt16OffPtr, + readInt32OffPtr, + readInt64OffPtr, + readWord8OffPtr, + readWord16OffPtr, + readWord32OffPtr, + readWord64OffPtr, + writeWideCharOffPtr, + writeIntOffPtr, + writeWordOffPtr, + writePtrOffPtr, + writeFunPtrOffPtr, + writeFloatOffPtr, + writeDoubleOffPtr, + writeStablePtrOffPtr, + writeInt8OffPtr, + writeInt16OffPtr, + writeInt32OffPtr, + writeInt64OffPtr, + writeWord8OffPtr, + writeWord16OffPtr, + writeWord32OffPtr, + writeWord64OffPtr + ) where + +import GHC.Internal.Storable diff --git a/src/GHC/TopHandler.hs b/src/GHC/TopHandler.hs new file mode 100644 --- /dev/null +++ b/src/GHC/TopHandler.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.TopHandler +-- Copyright : (c) The University of Glasgow, 2001-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Support for catching exceptions raised during top-level computations +-- (e.g. @Main.main@, 'Control.Concurrent.forkIO', and foreign exports) +-- +-- /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. +-- + +module GHC.TopHandler + (runMainIO, + runIO, + runIOFastExit, + runNonIO, + topHandler, + topHandlerFastExit, + reportStackOverflow, + reportError, + flushStdHandles + ) where + +import GHC.Internal.TopHandler diff --git a/src/GHC/TypeError.hs b/src/GHC/TypeError.hs new file mode 100644 --- /dev/null +++ b/src/GHC/TypeError.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +{-| +This module exports: + + - The 'TypeError' type family, which is used to provide custom type + errors. This is a type-level analogue to the term level error function. + - The 'ErrorMessage' kind, used to define custom error messages. + - The 'Unsatisfiable' constraint, a more principled variant of 'TypeError' + which gives a more predictable way of reporting custom type errors. + +@since 4.17.0.0 +-} + +module GHC.TypeError + ( ErrorMessage (..) + , TypeError + , Assert + , Unsatisfiable, unsatisfiable + ) where + +import GHC.Internal.TypeError diff --git a/src/GHC/TypeLits.hs b/src/GHC/TypeLits.hs new file mode 100644 --- /dev/null +++ b/src/GHC/TypeLits.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoStarIsType #-} + +-- | +-- +-- GHC's @DataKinds@ language extension lifts data constructors, natural +-- numbers, and strings to the type level. This module provides the +-- primitives needed for working with type-level numbers (the 'Nat' kind), +-- strings (the 'Symbol' kind), and characters (the 'Char' kind). It also defines the 'TypeError' type +-- family, a feature that makes use of type-level strings to support user +-- defined type errors. +-- +-- For now, this module is the API for working with type-level literals. +-- However, please note that it is a work in progress and is subject to change. +-- Once the design of the @DataKinds@ feature is more stable, this will be +-- considered only an internal GHC module, and the programmer interface for +-- working with type-level data will be defined in a separate library. +-- +-- @since 4.6.0.0 +-- + +module GHC.TypeLits + (-- * Kinds + Natural, + Nat, + Symbol, + -- * Linking type and value level + KnownNat(natSing), + natVal, + natVal', + KnownSymbol(symbolSing), + symbolVal, + symbolVal', + KnownChar(charSing), + charVal, + charVal', + SomeNat(..), + SomeSymbol(..), + SomeChar(..), + someNatVal, + someSymbolVal, + someCharVal, + sameNat, + sameSymbol, + sameChar, + decideNat, + decideSymbol, + decideChar, + OrderingI(..), + cmpNat, + cmpSymbol, + cmpChar, + -- ** Singleton values + SNat, + SSymbol, + SChar, + pattern SNat, + pattern SSymbol, + pattern SChar, + fromSNat, + fromSSymbol, + fromSChar, + withSomeSNat, + withSomeSSymbol, + withSomeSChar, + withKnownNat, + withKnownSymbol, + withKnownChar, + -- * Functions on type literals + type (<=), + type (<=?), + type (+), + type (*), + type (^), + type (-), + type Div, + type Mod, + type Log2, + AppendSymbol, + CmpNat, + CmpSymbol, + CmpChar, + ConsSymbol, + UnconsSymbol, + CharToNat, + NatToChar, + -- * User-defined type errors + TypeError, + ErrorMessage(..) + ) where + +import GHC.Internal.TypeLits diff --git a/src/GHC/TypeNats.hs b/src/GHC/TypeNats.hs new file mode 100644 --- /dev/null +++ b/src/GHC/TypeNats.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoStarIsType #-} + +-- | +-- This module is an internal GHC module. It declares the constants used +-- in the implementation of type-level natural numbers. The programmer interface +-- for working with type-level naturals should be defined in a separate module. +-- +-- @since 4.10.0.0 +-- + +module GHC.TypeNats + (-- * Nat Kind + Natural, + Nat, + -- * Linking type and value level + KnownNat(natSing), + natVal, + natVal', + SomeNat(..), + someNatVal, + sameNat, + decideNat, + -- ** Singleton values + SNat, + pattern SNat, + fromSNat, + withSomeSNat, + withKnownNat, + -- * Functions on type literals + type (<=), + type (<=?), + type (+), + type (*), + type (^), + type (-), + CmpNat, + cmpNat, + Div, + Mod, + Log2 + ) where + +import GHC.Internal.TypeNats diff --git a/src/GHC/Unicode.hs b/src/GHC/Unicode.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Unicode.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.Unicode +-- Copyright : (c) The University of Glasgow, 2003 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Implementations for the character predicates (isLower, isUpper, etc.) +-- and the conversions (toUpper, toLower). The implementation uses +-- libunicode on Unix systems if that is available. +-- + +module GHC.Unicode + (unicodeVersion, + GeneralCategory(..), + generalCategory, + isAscii, + isLatin1, + isControl, + isAsciiUpper, + isAsciiLower, + isPrint, + isSpace, + isUpper, + isUpperCase, + isLower, + isLowerCase, + isAlpha, + isDigit, + isOctDigit, + isHexDigit, + isAlphaNum, + isPunctuation, + isSymbol, + toUpper, + toLower, + toTitle + ) where + +import GHC.Internal.Unicode diff --git a/src/GHC/Weak.hs b/src/GHC/Weak.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Weak.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.Weak +-- Copyright : (c) The University of Glasgow, 1998-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Weak pointers. +-- + +module GHC.Weak + (Weak(..), + mkWeak, + deRefWeak, + finalize, + -- * Handling exceptions + -- | When an exception is thrown by a finalizer called by the + -- garbage collector, GHC calls a global handler which can be set with + -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by + -- this handler will be ignored. + setFinalizerExceptionHandler, + getFinalizerExceptionHandler, + printToHandleFinalizerExceptionHandler + ) where + +import GHC.Internal.Weak diff --git a/src/GHC/Weak/Finalize.hs b/src/GHC/Weak/Finalize.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Weak/Finalize.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE MagicHash #-} +module GHC.Weak.Finalize + ( -- * Handling exceptions + -- | When an exception is thrown by a finalizer called by the + -- garbage collector, GHC calls a global handler which can be set with + -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by + -- this handler will be ignored. + setFinalizerExceptionHandler + , getFinalizerExceptionHandler + , printToHandleFinalizerExceptionHandler + -- * Internal + , 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/GHC/Windows.hs b/src/GHC/Windows.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Windows.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} + +-- | +-- Module : GHC.Windows +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Windows functionality used by several modules. +-- +-- ToDo: this just duplicates part of System.Win32.Types, which isn't +-- available yet. We should move some Win32 functionality down here, +-- maybe as part of the grand reorganisation of the base package... +-- + +module GHC.Windows +#if defined(javascript_HOST_ARCH) + ( ) where + +#else + ( + -- * Types + BOOL, + LPBOOL, + BYTE, + DWORD, + DDWORD, + UINT, + ULONG, + ErrCode, + HANDLE, + LPWSTR, + LPTSTR, + LPCTSTR, + LPVOID, + LPDWORD, + LPSTR, + LPCSTR, + LPCWSTR, + WORD, + UCHAR, + NTSTATUS, + + -- * Constants + iNFINITE, + iNVALID_HANDLE_VALUE, + + -- * System errors + throwGetLastError, + failWith, + getLastError, + getErrorMessage, + errCodeToIOError, + + -- ** Guards for system calls that might fail + failIf, + failIf_, + failIfNull, + failIfZero, + failIfFalse_, + failUnlessSuccess, + failUnlessSuccessOr, + + -- ** Mapping system errors to errno + -- $errno + c_maperrno, + c_maperrno_func, + + -- * Misc + ddwordToDwords, + dwordsToDdword, + nullHANDLE, + ) where + +#endif + +import GHC.Internal.Windows + diff --git a/src/GHC/Word.hs b/src/GHC/Word.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Word.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- +-- Module : GHC.Word +-- 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) +-- +-- Sized unsigned integral types: 'Word', 'Word8', 'Word16', 'Word32', and +-- 'Word64'. +-- + +module GHC.Word + (Word(..), + Word8(..), + Word16(..), + Word32(..), + Word64(..), + -- * Shifts + uncheckedShiftL64#, + uncheckedShiftRL64#, + -- * Byte swapping + byteSwap16, + byteSwap32, + byteSwap64, + -- * Bit reversal + bitReverse8, + bitReverse16, + bitReverse32, + bitReverse64, + -- * Equality operators + -- | See GHC.Classes#matching_overloaded_methods_in_rules + eqWord, + neWord, + gtWord, + geWord, + ltWord, + leWord, + eqWord8, + neWord8, + gtWord8, + geWord8, + ltWord8, + leWord8, + eqWord16, + neWord16, + gtWord16, + geWord16, + ltWord16, + leWord16, + eqWord32, + neWord32, + gtWord32, + geWord32, + ltWord32, + leWord32, + eqWord64, + neWord64, + gtWord64, + geWord64, + ltWord64, + leWord64 + ) where + +import GHC.Internal.Word diff --git a/src/Numeric.hs b/src/Numeric.hs new file mode 100644 --- /dev/null +++ b/src/Numeric.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Numeric +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Odds and ends, mostly functions for reading and showing +-- 'RealFloat'-like kind of values. +-- + +module Numeric + (-- * Showing + showSigned, + showIntAtBase, + showInt, + showBin, + showHex, + showOct, + showEFloat, + showFFloat, + showGFloat, + showFFloatAlt, + showGFloatAlt, + showFloat, + showHFloat, + floatToDigits, + -- * Reading + -- | /NB:/ 'readInt' is the \'dual\' of 'showIntAtBase', + -- and 'readDec' is the \`dual\' of 'showInt'. + -- The inconsistent naming is a historical accident. + readSigned, + readInt, + readBin, + readDec, + readOct, + readHex, + readFloat, + lexDigits, + -- * Miscellaneous + fromRat, + Floating(..) + ) where + +import GHC.Internal.Numeric diff --git a/src/Numeric/Natural.hs b/src/Numeric/Natural.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Natural.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Numeric.Natural +-- Copyright : (C) 2014 Herbert Valerio Riedel, +-- (C) 2011 Edward Kmett +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The arbitrary-precision 'Natural' number type. +-- +-- @since 4.8.0.0 + +module Numeric.Natural + (Natural, + minusNaturalMaybe + ) where + +import GHC.Internal.Numeric.Natural diff --git a/src/Prelude.hs b/src/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Prelude.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ExplicitNamespaces #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Prelude +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- The Prelude: a standard module. The Prelude is imported by default +-- into all Haskell modules unless either there is an explicit import +-- statement for it, or the NoImplicitPrelude extension is enabled. +-- +----------------------------------------------------------------------------- + +module Prelude ( + + -- * Standard types, classes and related functions + + -- ** Basic data types + Bool(False, True), + (&&), (||), not, otherwise, + + Maybe(Nothing, Just), + maybe, + + Either(Left, Right), + either, + + Ordering(LT, EQ, GT), + Char, String, + + -- *** Tuples + fst, snd, curry, uncurry, + + -- ** Basic type classes + Eq((==), (/=)), + Ord(compare, (<), (<=), (>=), (>), max, min), + Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen, + enumFromTo, enumFromThenTo), + Bounded(minBound, maxBound), + + -- ** Numbers + + -- *** Numeric types + Int, Integer, Float, Double, + Rational, Word, + + -- *** Numeric type classes + Num((+), (-), (*), negate, abs, signum, fromInteger), + Real(toRational), + Integral(quot, rem, div, mod, quotRem, divMod, toInteger), + Fractional((/), recip, fromRational), + Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan, + asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh), + RealFrac(properFraction, truncate, round, ceiling, floor), + RealFloat(floatRadix, floatDigits, floatRange, decodeFloat, + encodeFloat, exponent, significand, scaleFloat, isNaN, + isInfinite, isDenormalized, isIEEE, isNegativeZero, atan2), + + -- *** Numeric functions + subtract, even, odd, gcd, lcm, (^), (^^), + fromIntegral, realToFrac, + + -- ** Semigroups and Monoids + Semigroup((<>)), + Monoid(mempty, mappend, mconcat), + + -- ** Monads and functors + Functor(fmap, (<$)), (<$>), + Applicative(pure, (<*>), (*>), (<*), liftA2), + Monad((>>=), (>>), return), + MonadFail(fail), + mapM_, sequence_, (=<<), + + -- ** Folds and traversals + Foldable(elem, -- :: (Foldable t, Eq a) => a -> t a -> Bool + -- fold, -- :: Monoid m => t m -> m + foldMap, -- :: Monoid m => (a -> m) -> t a -> m + foldr, -- :: (a -> b -> b) -> b -> t a -> b + -- foldr', -- :: (a -> b -> b) -> b -> t a -> b + foldl, -- :: (b -> a -> b) -> b -> t a -> b + foldl', -- :: (b -> a -> b) -> b -> t a -> b + foldr1, -- :: (a -> a -> a) -> t a -> a + foldl1, -- :: (a -> a -> a) -> t a -> a + maximum, -- :: (Foldable t, Ord a) => t a -> a + minimum, -- :: (Foldable t, Ord a) => t a -> a + product, -- :: (Foldable t, Num a) => t a -> a + sum), -- :: Num a => t a -> a + -- toList) -- :: Foldable t => t a -> [a] + + Traversable(traverse, sequenceA, mapM, sequence), + + -- ** Miscellaneous functions + id, const, (.), flip, ($), until, + asTypeOf, error, errorWithoutStackTrace, undefined, + seq, ($!), + + -- * List operations + List.map, (List.++), List.filter, + List.head, List.last, List.tail, List.init, (List.!!), + Foldable.null, Foldable.length, + List.reverse, + -- *** Special folds + Foldable.and, Foldable.or, Foldable.any, Foldable.all, + Foldable.concat, Foldable.concatMap, + -- ** Building lists + -- *** Scans + List.scanl, List.scanl1, List.scanr, List.scanr1, + -- *** Infinite lists + List.iterate, List.repeat, List.replicate, List.cycle, + -- ** Sublists + List.take, List.drop, + List.takeWhile, List.dropWhile, + List.span, List.break, + List.splitAt, + -- ** Searching lists + Foldable.notElem, + List.lookup, + -- ** Zipping and unzipping lists + List.zip, List.zip3, + List.zipWith, List.zipWith3, + List.unzip, List.unzip3, + -- ** Functions on strings + List.lines, List.words, List.unlines, List.unwords, + + -- * Converting to and from @String@ + -- ** Converting to @String@ + ShowS, + Show(showsPrec, showList, show), + shows, + showChar, showString, showParen, + -- ** Converting from @String@ + ReadS, + Read(readsPrec, readList), + reads, readParen, read, lex, + + -- * Basic Input and output + IO, + -- ** Simple I\/O operations + -- All I/O functions defined here are character oriented. The + -- treatment of the newline character will vary on different systems. + -- For example, two characters of input, return and linefeed, may + -- read as a single newline character. These functions cannot be + -- used portably for binary I/O. + -- *** Output functions + putChar, + putStr, putStrLn, print, + -- *** Input functions + getChar, + getLine, getContents, interact, + -- *** Files + FilePath, + readFile, writeFile, appendFile, readIO, readLn, + -- ** Exception handling in the I\/O monad + IOError, ioError, userError, + + -- ** The equality types + type (~) + ) where + +import GHC.Internal.Control.Monad +import GHC.Internal.System.IO +import GHC.Internal.System.IO.Error +import qualified GHC.Internal.Data.List as List +import GHC.Internal.Data.Either +import GHC.Internal.Data.Foldable ( Foldable(..) ) +import qualified GHC.Internal.Data.Foldable as Foldable +import GHC.Internal.Data.Functor ( (<$>) ) +import GHC.Internal.Data.Maybe +import GHC.Internal.Data.Traversable ( Traversable(..) ) +import GHC.Internal.Data.Tuple + +import GHC.Internal.Base hiding ( foldr, mapM, sequence ) +import GHC.Internal.Text.Read +import GHC.Internal.Enum +import GHC.Internal.Num +import GHC.Internal.Real +import GHC.Internal.Float +import GHC.Internal.Show diff --git a/src/System/CPUTime.hsc b/src/System/CPUTime.hsc new file mode 100644 --- /dev/null +++ b/src/System/CPUTime.hsc @@ -0,0 +1,71 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, CApiFFI #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.CPUTime +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The standard CPUTime library. +-- +----------------------------------------------------------------------------- + +#include "HsFFI.h" +#include "HsBaseConfig.h" + +-- For various _POSIX_* #defines +#if defined(HAVE_UNISTD_H) +#include +#endif + +module System.CPUTime + ( getCPUTime + , cpuTimePrecision + ) where + +import Prelude +import System.IO.Unsafe (unsafePerformIO) + +-- Here is where we decide which backend to use +#if defined(mingw32_HOST_OS) +import qualified System.CPUTime.Windows as I + +#elif defined(javascript_HOST_ARCH) +import qualified System.CPUTime.Javascript as I + +#elif _POSIX_TIMERS > 0 && defined(_POSIX_CPUTIME) && _POSIX_CPUTIME >= 0 +import qualified System.CPUTime.Posix.ClockGetTime as I + +#elif defined(HAVE_GETRUSAGE) && ! solaris2_HOST_OS +import qualified System.CPUTime.Posix.RUsage as I + +-- @getrusage()@ is right royal pain to deal with when targeting multiple +-- versions of Solaris, since some versions supply it in libc (2.3 and 2.5), +-- while 2.4 has got it in libucb (I wouldn't be too surprised if it was back +-- again in libucb in 2.6..) +-- +-- Avoid the problem by resorting to times() instead. +#elif defined(HAVE_TIMES) +import qualified System.CPUTime.Posix.Times as I + +#else +import qualified System.CPUTime.Unsupported as I +#endif + +-- | The 'cpuTimePrecision' constant is the smallest measurable difference +-- in CPU time that the implementation can record, and is given as an +-- integral number of picoseconds. +cpuTimePrecision :: Integer +cpuTimePrecision = unsafePerformIO I.getCpuTimePrecision +{-# NOINLINE cpuTimePrecision #-} + +-- | Computation 'getCPUTime' returns the number of picoseconds CPU time +-- used by the current program. The precision of this result is +-- implementation-dependent. +getCPUTime :: IO Integer +getCPUTime = I.getCPUTime diff --git a/src/System/CPUTime/Javascript.hs b/src/System/CPUTime/Javascript.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUTime/Javascript.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE JavaScriptFFI #-} + +module System.CPUTime.Javascript + ( getCPUTime + , getCpuTimePrecision + ) +where + +import qualified System.CPUTime.Unsupported as I +import Prelude + +getCpuTimePrecision :: IO Integer +getCpuTimePrecision = toInteger <$> js_cpuTimePrecision + +getCPUTime :: IO Integer +getCPUTime = do + t <- js_getCPUTime + if t == -1 then I.getCPUTime + else pure (1000 * round t) + +foreign import javascript unsafe + "(() => { return h$cpuTimePrecision(); })" + js_cpuTimePrecision :: IO Int + +foreign import javascript unsafe + "(() => { return h$getCPUTime(); })" + js_getCPUTime :: IO Double diff --git a/src/System/CPUTime/Posix/ClockGetTime.hsc b/src/System/CPUTime/Posix/ClockGetTime.hsc new file mode 100644 --- /dev/null +++ b/src/System/CPUTime/Posix/ClockGetTime.hsc @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP, CApiFFI, NumDecimals #-} + +#include "HsFFI.h" +#include "HsBaseConfig.h" +#include +#include + +module System.CPUTime.Posix.ClockGetTime + ( getCPUTime + , getCpuTimePrecision + ) where + +import Prelude + +#if _POSIX_TIMERS > 0 && defined(_POSIX_CPUTIME) && _POSIX_CPUTIME >= 0 + +import Foreign +import Foreign.C +import System.CPUTime.Utils + +getCPUTime :: IO Integer +getCPUTime = fmap snd $ withTimespec $ \ts -> + throwErrnoIfMinus1_ "clock_gettime" + $ clock_gettime cLOCK_PROCESS_CPUTIME_ID ts + +getCpuTimePrecision :: IO Integer +getCpuTimePrecision = fmap snd $ withTimespec $ \ts -> + throwErrnoIfMinus1_ "clock_getres" + $ clock_getres cLOCK_PROCESS_CPUTIME_ID ts + +data Timespec + +-- | Perform the given action to fill in a @struct timespec@, returning the +-- result of the action and the value of the @timespec@ in picoseconds. +withTimespec :: (Ptr Timespec -> IO a) -> IO (a, Integer) +withTimespec action = + allocaBytes (# const sizeof(struct timespec)) $ \p_ts -> do + r <- action p_ts + u_sec <- (#peek struct timespec,tv_sec) p_ts :: IO CTime + u_nsec <- (#peek struct timespec,tv_nsec) p_ts :: IO CLong + return (r, cTimeToInteger u_sec * 1e12 + fromIntegral u_nsec * 1e3) + +foreign import capi unsafe "time.h clock_getres" clock_getres :: CUIntPtr -> Ptr Timespec -> IO CInt +foreign import capi unsafe "time.h clock_gettime" clock_gettime :: CUIntPtr -> Ptr Timespec -> IO CInt + +#if HAVE_DECL_CLOCK_PROCESS_CPUTIME_ID +foreign import capi unsafe "time.h value CLOCK_PROCESS_CPUTIME_ID" cLOCK_PROCESS_CPUTIME_ID :: CUIntPtr +#else +foreign import capi unsafe "time.h value CLOCK_MONOTONIC" cLOCK_PROCESS_CPUTIME_ID :: CUIntPtr +#endif // HAVE_DECL_CLOCK_PROCESS_CPUTIME_ID + +#else + +-- This should never happen +getCPUTime :: IO Integer +getCPUTime = error "System.CPUTime.Posix.ClockGetTime: Unsupported" + +getCpuTimePrecision :: IO Integer +getCpuTimePrecision = error "System.CPUTime.Posix.ClockGetTime: Unsupported" + +#endif // _POSIX_CPUTIME diff --git a/src/System/CPUTime/Posix/RUsage.hsc b/src/System/CPUTime/Posix/RUsage.hsc new file mode 100644 --- /dev/null +++ b/src/System/CPUTime/Posix/RUsage.hsc @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP, CApiFFI, NumDecimals #-} + +#include "HsFFI.h" +#include "HsBaseConfig.h" + +module System.CPUTime.Posix.RUsage + ( getCPUTime + , getCpuTimePrecision + ) where + +import Prelude +import Data.Ratio +import Foreign +import Foreign.C +import System.CPUTime.Utils + +-- For struct rusage +#if HAVE_SYS_RESOURCE_H +#include +#endif + +#if HAVE_GETRUSAGE + +getCPUTime :: IO Integer +getCPUTime = allocaBytes (#const sizeof(struct rusage)) $ \ p_rusage -> do + throwErrnoIfMinus1_ "getrusage" $ getrusage (#const RUSAGE_SELF) p_rusage + + let ru_utime = (#ptr struct rusage, ru_utime) p_rusage + let ru_stime = (#ptr struct rusage, ru_stime) p_rusage + u_sec <- (#peek struct timeval,tv_sec) ru_utime :: IO CTime + u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CSUSeconds + s_sec <- (#peek struct timeval,tv_sec) ru_stime :: IO CTime + s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CSUSeconds + let usec = cTimeToInteger u_sec * 1e6 + csuSecondsToInteger u_usec + + cTimeToInteger s_sec * 1e6 + csuSecondsToInteger s_usec + return (usec * 1e6) + +type CRUsage = () +foreign import capi unsafe "HsBase.h getrusage" getrusage :: CInt -> Ptr CRUsage -> IO CInt + +getCpuTimePrecision :: IO Integer +getCpuTimePrecision = + return $ round ((1e12::Integer) % fromIntegral clk_tck) + +foreign import ccall unsafe clk_tck :: CLong + +#else + +getCPUTime :: IO Integer +getCPUTime = fail "System.CPUTime.Posix.RUsage.getCPUTime" + +getCpuTimePrecision :: IO Integer +getCpuTimePrecision = fail "System.CPUTime.Posix.RUsage.getCpuTimePrecision" + +#endif diff --git a/src/System/CPUTime/Posix/Times.hsc b/src/System/CPUTime/Posix/Times.hsc new file mode 100644 --- /dev/null +++ b/src/System/CPUTime/Posix/Times.hsc @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP, CApiFFI, NumDecimals #-} + +#include "HsFFI.h" +#include "HsBaseConfig.h" + +module System.CPUTime.Posix.Times + ( getCPUTime + , getCpuTimePrecision + ) where + +import Prelude +import Foreign +import Data.Ratio +import GHC.Internal.Foreign.C.Types +import System.CPUTime.Utils + +-- for struct tms +#if HAVE_SYS_TIMES_H +#include +#endif + +#if HAVE_TIMES + +getCPUTime :: IO Integer +getCPUTime = allocaBytes (#const sizeof(struct tms)) $ \ p_tms -> do + _ <- times p_tms + u_ticks <- (#peek struct tms,tms_utime) p_tms :: IO CClock + s_ticks <- (#peek struct tms,tms_stime) p_tms :: IO CClock + return (( (cClockToInteger u_ticks + cClockToInteger s_ticks) * 1e12) + `div` fromIntegral clockTicks) + +type CTms = () +foreign import ccall unsafe times :: Ptr CTms -> IO CClock + +getCpuTimePrecision :: IO Integer +getCpuTimePrecision = + return $ round ((1e12::Integer) % clockTicks) + +foreign import ccall unsafe clk_tck :: CLong + +clockTicks :: Integer +clockTicks = fromIntegral clk_tck + +#else + +getCPUTime :: IO Integer +getCPUTime = fail "System.CPUTime.Posix.Times.getCPUTime" + +getCpuTimePrecision :: IO Integer +getCpuTimePrecision = fail "System.CPUTime.Posix.Times.getCpuTimePrecision" + +#endif diff --git a/src/System/CPUTime/Unsupported.hs b/src/System/CPUTime/Unsupported.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUTime/Unsupported.hs @@ -0,0 +1,21 @@ +module System.CPUTime.Unsupported + ( getCPUTime + , getCpuTimePrecision + ) where + +import GHC.Internal.IO.Exception +import Prelude + +getCPUTime :: IO Integer +getCPUTime = + ioError (IOError Nothing UnsupportedOperation + "getCPUTime" + "can't get CPU time" + Nothing Nothing) + +getCpuTimePrecision :: IO Integer +getCpuTimePrecision = + ioError (IOError Nothing UnsupportedOperation + "cpuTimePrecision" + "can't get CPU time" + Nothing Nothing) diff --git a/src/System/CPUTime/Utils.hs b/src/System/CPUTime/Utils.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUTime/Utils.hs @@ -0,0 +1,21 @@ +module System.CPUTime.Utils + ( -- * Integer conversions + -- | These types have no 'Integral' instances in the Haskell report + -- so we must do this ourselves. + cClockToInteger + , cTimeToInteger + , csuSecondsToInteger + ) where + +import GHC.Internal.Foreign.C.Types +import GHC.Num.Integer (Integer) +import GHC.Internal.Real (fromIntegral) + +cClockToInteger :: CClock -> Integer +cClockToInteger (CClock n) = fromIntegral n + +cTimeToInteger :: CTime -> Integer +cTimeToInteger (CTime n) = fromIntegral n + +csuSecondsToInteger :: CSUSeconds -> Integer +csuSecondsToInteger (CSUSeconds n) = fromIntegral n diff --git a/src/System/CPUTime/Windows.hsc b/src/System/CPUTime/Windows.hsc new file mode 100644 --- /dev/null +++ b/src/System/CPUTime/Windows.hsc @@ -0,0 +1,68 @@ +{-# LANGUAGE CPP, CApiFFI, NondecreasingIndentation, NumDecimals #-} + +#include "HsFFI.h" +#include "HsBaseConfig.h" + +module System.CPUTime.Windows + ( getCPUTime + , getCpuTimePrecision + ) where + +import GHC.Internal.Foreign.Ptr +import GHC.Internal.Foreign.Marshal.Alloc +import GHC.Internal.Foreign.Marshal.Utils +import GHC.Internal.Foreign.Storable +import GHC.Internal.Foreign.C.Types +import GHC.Internal.Word +import Prelude + +-- For FILETIME etc. on Windows +#if HAVE_WINDOWS_H +#include +#endif + +getCPUTime :: IO Integer +getCPUTime = do + -- NOTE: GetProcessTimes() is only supported on NT-based OSes. + -- The counts reported by GetProcessTimes() are in 100-ns (10^-7) units. + allocaBytes (#const sizeof(FILETIME)) $ \ p_creationTime -> do + allocaBytes (#const sizeof(FILETIME)) $ \ p_exitTime -> do + allocaBytes (#const sizeof(FILETIME)) $ \ p_kernelTime -> do + allocaBytes (#const sizeof(FILETIME)) $ \ p_userTime -> do + pid <- getCurrentProcess + ok <- getProcessTimes pid p_creationTime p_exitTime p_kernelTime p_userTime + if toBool ok then do + ut <- ft2psecs p_userTime + kt <- ft2psecs p_kernelTime + return (ut + kt) + else return 0 + where + ft2psecs :: Ptr FILETIME -> IO Integer + ft2psecs ft = do + high <- (#peek FILETIME,dwHighDateTime) ft :: IO Word32 + low <- (#peek FILETIME,dwLowDateTime) ft :: IO Word32 + -- Convert 100-ns units to picosecs (10^-12) + -- => multiply by 10^5. + return (((fromIntegral high) * (2^(32::Int)) + (fromIntegral low)) * 100000) + + -- ToDo: pin down elapsed times to just the OS thread(s) that + -- are evaluating/managing Haskell code. + +-- While it's hard to get reliable numbers, the consensus is that Windows only provides +-- 16 millisecond resolution in GetProcessTimes (see Python PEP 0418) +getCpuTimePrecision :: IO Integer +getCpuTimePrecision = return 16e9 + +type FILETIME = () +type HANDLE = () + +-- need proper Haskell names (initial lower-case character) +#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) || 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 +#error Unknown mingw32 arch +#endif diff --git a/src/System/Console/GetOpt.hs b/src/System/Console/GetOpt.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/GetOpt.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Console.GetOpt +-- Copyright : (c) Sven Panne 2002-2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- This module provides facilities for parsing the command-line options +-- in a standalone program. It is essentially a Haskell port of the GNU +-- @getopt@ library. +-- +----------------------------------------------------------------------------- + +{- +Sven Panne Oct. 1996 (small +changes Dec. 1997) + +Two rather obscure features are missing: The Bash 2.0 non-option hack +(if you don't already know it, you probably don't want to hear about +it...) and the recognition of long options with a single dash +(e.g. '-help' is recognised as '--help', as long as there is no short +option 'h'). + +Other differences between GNU's getopt and this implementation: + +* To enforce a coherent description of options and arguments, there + are explanation fields in the option/argument descriptor. + +* Error messages are now more informative, but no longer POSIX + compliant... :-( + +And a final Haskell advertisement: The GNU C implementation uses well +over 1100 lines, we need only 195 here, including a 46 line example! +:-) +-} + +module System.Console.GetOpt ( + -- * GetOpt + getOpt, getOpt', + usageInfo, + ArgOrder(..), + OptDescr(..), + ArgDescr(..), + + -- * Examples + + -- |To hopefully illuminate the role of the different data structures, + -- here are the command-line options for a (very simple) compiler, + -- done in two different ways. + -- The difference arises because the type of 'getOpt' is + -- parameterized by the type of values derived from flags. + + -- ** Interpreting flags as concrete values + -- $example1 + + -- ** Interpreting flags as transformations of an options record + -- $example2 +) where + +import Prelude +import GHC.Internal.Data.List ( isPrefixOf, find ) + +-- |What to do with options following non-options +data ArgOrder a + = RequireOrder -- ^ no option processing after first non-option + | Permute -- ^ freely intersperse options and non-options + | ReturnInOrder (String -> a) -- ^ wrap non-options into options + +{-| +Each 'OptDescr' describes a single option. + +The arguments to 'Option' are: + +* list of short option characters + +* list of long option strings (without \"--\") + +* argument descriptor + +* explanation of option for user +-} +data OptDescr a = -- description of a single options: + Option [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user + +-- |Describes whether an option takes an argument or not, and if so +-- how the argument is injected into a value of type @a@. +data ArgDescr a + = NoArg a -- ^ no argument expected + | ReqArg (String -> a) String -- ^ option requires argument + | OptArg (Maybe String -> a) String -- ^ optional argument + +-- | @since 4.7.0.0 +instance Functor ArgOrder where + fmap _ RequireOrder = RequireOrder + fmap _ Permute = Permute + fmap f (ReturnInOrder g) = ReturnInOrder (f . g) + +-- | @since 4.7.0.0 +instance Functor OptDescr where + fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c + +-- | @since 4.7.0.0 +instance Functor ArgDescr where + fmap f (NoArg a) = NoArg (f a) + fmap f (ReqArg g s) = ReqArg (f . g) s + fmap f (OptArg g s) = OptArg (f . g) s + +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | UnreqOpt String -- an un-recognized option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +-- | Return a string describing the usage of a command, derived from +-- the header (first argument) and the options described by the +-- second argument. +usageInfo :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted description of options +usageInfo header optDescr = unlines (header:table) + where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr + table = zipWith3 paste (sameLen ss) (sameLen ls) ds + paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z + sameLen xs = flushLeft ((maximum . map length) xs) xs + flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] + +fmtOpt :: OptDescr a -> [(String,String,String)] +fmtOpt (Option sos los ad descr) = + case lines descr of + [] -> [(sosFmt,losFmt,"")] + (d:ds) -> (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ] + where sepBy _ [] = "" + sepBy _ [x] = x + sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs + sosFmt = sepBy ',' (map (fmtShort ad) sos) + losFmt = sepBy ',' (map (fmtLong ad) los) + +fmtShort :: ArgDescr a -> Char -> String +fmtShort (NoArg _ ) so = "-" ++ [so] +fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad +fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]" + +fmtLong :: ArgDescr a -> String -> String +fmtLong (NoArg _ ) lo = "--" ++ lo +fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad +fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" + +{-| +Process the command-line, and return the list of values that matched +(and those that didn\'t). The arguments are: + +* The order requirements (see 'ArgOrder') + +* The option descriptions (see 'OptDescr') + +* The actual command line arguments (presumably got from + 'GHC.Internal.System.Environment.getArgs'). + +'getOpt' returns a triple consisting of the option arguments, a list +of non-options, and a list of error messages. +-} +getOpt :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String],[String]) -- (options,non-options,error messages) +getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) + where (os,xs,us,es) = getOpt' ordering optDescr args + +{-| +This is almost the same as 'getOpt', but returns a quadruple +consisting of the option arguments, a list of non-options, a list of +unrecognized options, and a list of error messages. +-} +getOpt' :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) +getOpt' _ _ [] = ([],[],[],[]) +getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering + where procNextOpt (Opt o) _ = (o:os,xs,us,es) + procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) + procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) + procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) + procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) + procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) + procNextOpt EndOfOpts Permute = ([],rest,[],[]) + procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) + procNextOpt (OptErr e) _ = (os,xs,us,e:es) + + (opt,rest) = getNext arg args optDescr + (os,xs,us,es) = getOpt' ordering optDescr rest + +-- take a look at the next cmd line arg and decide what to do with it +getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) +getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr +getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr +getNext a rest _ = (NonOpt a,rest) + +-- handle long option +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +longOpt ls rs optDescr = long ads arg rs + where (opt,arg) = break (=='=') ls + getWith p = [ o | o@(Option _ xs _ _) <- optDescr + , find (p opt) xs /= Nothing ] + exact = getWith (==) + options = if null exact then getWith isPrefixOf else exact + ads = [ ad | Option _ _ ad _ <- options ] + optStr = ("--"++opt) + + long (_:_:_) _ rest = (errAmbig options optStr,rest) + long [NoArg a ] [] rest = (Opt a,rest) + long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) + long [ReqArg _ d] [] [] = (errReq d optStr,[]) + long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) + long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) + long [OptArg f _] [] rest = (Opt (f Nothing),rest) + long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) + long _ _ rest = (UnreqOpt ("--"++ls),rest) + +-- handle short option +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +shortOpt y ys rs optDescr = short ads ys rs + where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] + ads = [ ad | Option _ _ ad _ <- options ] + optStr = '-':[y] + + short (_:_:_) _ rest = (errAmbig options optStr,rest) + short (NoArg a :_) [] rest = (Opt a,rest) + short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) + short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) + short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) + short (ReqArg f _:_) xs rest = (Opt (f xs),rest) + short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) + short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) + short [] [] rest = (UnreqOpt optStr,rest) + short [] xs rest = (UnreqOpt optStr,('-':xs):rest) + +-- miscellaneous error formatting + +errAmbig :: [OptDescr a] -> String -> OptKind a +errAmbig ods optStr = OptErr (usageInfo header ods) + where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" + +errReq :: String -> String -> OptKind a +errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") + +errUnrec :: String -> String +errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" + +errNoArg :: String -> OptKind a +errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") + +{- +----------------------------------------------------------------------------------------- +-- and here a small and hopefully enlightening example: + +data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show + +options :: [OptDescr Flag] +options = + [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", + Option ['V','?'] ["version","release"] (NoArg Version) "show version info", + Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", + Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] + +out :: Maybe String -> Flag +out Nothing = Output "stdout" +out (Just o) = Output o + +test :: ArgOrder Flag -> [String] -> String +test order cmdline = case getOpt order options cmdline of + (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" + (_,_,errs) -> concat errs ++ usageInfo header options + where header = "Usage: foobar [OPTION...] files..." + +-- example runs: +-- putStr (test RequireOrder ["foo","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["foo","-v"]) +-- ==> options=[Verbose] args=["foo"] +-- putStr (test (ReturnInOrder Arg) ["foo","-v"]) +-- ==> options=[Arg "foo", Verbose] args=[] +-- putStr (test Permute ["foo","--","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["-?o","--name","bar","--na=baz"]) +-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] +-- putStr (test Permute ["--ver","foo"]) +-- ==> option `--ver' is ambiguous; could be one of: +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- Usage: foobar [OPTION...] files... +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- -o[FILE] --output[=FILE] use FILE for dump +-- -n USER --name=USER only dump USER's files +----------------------------------------------------------------------------------------- +-} + +{- $example1 + +A simple choice for the type associated with flags is to define a type +@Flag@ as an algebraic type representing the possible flags and their +arguments: + +> module Opts1 where +> +> import System.Console.GetOpt +> import GHC.Internal.Data.Maybe ( fromMaybe ) +> +> data Flag +> = Verbose | Version +> | Input String | Output String | LibDir String +> deriving Show +> +> options :: [OptDescr Flag] +> options = +> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" +> , Option ['V','?'] ["version"] (NoArg Version) "show version number" +> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" +> , Option ['c'] [] (OptArg inp "FILE") "input FILE" +> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" +> ] +> +> inp,outp :: Maybe String -> Flag +> outp = Output . fromMaybe "stdout" +> inp = Input . fromMaybe "stdin" +> +> compilerOpts :: [String] -> IO ([Flag], [String]) +> compilerOpts argv = +> case getOpt Permute options argv of +> (o,n,[] ) -> return (o,n) +> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) +> where header = "Usage: ic [OPTION...] files..." + +Then the rest of the program will use the constructed list of flags +to determine it\'s behaviour. + +-} + +{- $example2 + +A different approach is to group the option values in a record of type +@Options@, and have each flag yield a function of type +@Options -> Options@ transforming this record. + +> module Opts2 where +> +> import System.Console.GetOpt +> import GHC.Internal.Data.Maybe ( fromMaybe ) +> +> data Options = Options +> { optVerbose :: Bool +> , optShowVersion :: Bool +> , optOutput :: Maybe FilePath +> , optInput :: Maybe FilePath +> , optLibDirs :: [FilePath] +> } deriving Show +> +> defaultOptions = Options +> { optVerbose = False +> , optShowVersion = False +> , optOutput = Nothing +> , optInput = Nothing +> , optLibDirs = [] +> } +> +> options :: [OptDescr (Options -> Options)] +> options = +> [ Option ['v'] ["verbose"] +> (NoArg (\ opts -> opts { optVerbose = True })) +> "chatty output on stderr" +> , Option ['V','?'] ["version"] +> (NoArg (\ opts -> opts { optShowVersion = True })) +> "show version number" +> , Option ['o'] ["output"] +> (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output") +> "FILE") +> "output FILE" +> , Option ['c'] [] +> (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input") +> "FILE") +> "input FILE" +> , Option ['L'] ["libdir"] +> (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR") +> "library directory" +> ] +> +> compilerOpts :: [String] -> IO (Options, [String]) +> compilerOpts argv = +> case getOpt Permute options argv of +> (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) +> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) +> where header = "Usage: ic [OPTION...] files..." + +Similarly, each flag could yield a monadic function transforming a record, +of type @Options -> IO Options@ (or any other monad), allowing option +processing to perform actions of the chosen monad, e.g. printing help or +version messages, checking that file arguments exist, etc. + +-} + diff --git a/src/System/Environment.hs b/src/System/Environment.hs new file mode 100644 --- /dev/null +++ b/src/System/Environment.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : System.Environment +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Miscellaneous information about the system environment. +-- + +module System.Environment + ( + getArgs, + getProgName, + executablePath, + getExecutablePath, + getEnv, + lookupEnv, + setEnv, + unsetEnv, + withArgs, + withProgName, + getEnvironment, + ) where + +import GHC.Internal.System.Environment diff --git a/src/System/Environment/Blank.hs b/src/System/Environment/Blank.hs new file mode 100644 --- /dev/null +++ b/src/System/Environment/Blank.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : System.Environment.Blank +-- Copyright : (c) Habib Alamin 2017 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A setEnv implementation that allows blank environment variables. Mimics +-- the `System.Posix.Env` module from the @unix@ package, but with support +-- for Windows too. +-- +-- The matrix of platforms that: +-- +-- * support @putenv("FOO")@ to unset environment variables, +-- * support @putenv("FOO=")@ to unset environment variables or set them +-- to blank values, +-- * support @unsetenv@ to unset environment variables, +-- * support @setenv@ to set environment variables, +-- * etc. +-- +-- is very complicated. Some platforms don't support unsetting of environment +-- variables at all. +-- + +module System.Environment.Blank + ( + module System.Environment, + getEnv, + getEnvDefault, + setEnv, + unsetEnv, + ) where + +import System.Environment + ( + getArgs, + getProgName, + getExecutablePath, + withArgs, + withProgName, + getEnvironment + ) + +import GHC.Internal.System.Environment.Blank diff --git a/src/System/Exit.hs b/src/System/Exit.hs new file mode 100644 --- /dev/null +++ b/src/System/Exit.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : System.Exit +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Exiting the program. +-- + +module System.Exit + (ExitCode(ExitSuccess, ExitFailure), + exitWith, + exitFailure, + exitSuccess, + die + ) where + +import GHC.Internal.System.Exit diff --git a/src/System/IO.hs b/src/System/IO.hs new file mode 100644 --- /dev/null +++ b/src/System/IO.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : System.IO +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- The standard IO API. +-- + +module System.IO + (-- * Examples + -- $stdio_examples + + -- * The IO monad + IO, + fixIO, + -- * Files and handles + FilePath, + Handle, + -- | GHC note: a 'Handle' will be automatically closed when the garbage + -- collector detects that it has become unreferenced by the program. + -- However, relying on this behaviour is not generally recommended: + -- the garbage collector is unpredictable. If possible, use + -- an explicit 'hClose' to close 'Handle's when they are no longer + -- required. GHC does not currently attempt to free up file + -- descriptors when they have run out, it is your responsibility to + -- ensure that this doesn't happen. + + -- ** Standard handles + -- | Three handles are allocated during program initialisation, + -- and are initially open. + stdin, + stdout, + stderr, + -- * Opening and closing files + -- ** Opening files + withFile, + openFile, + IOMode(ReadMode, WriteMode, AppendMode, ReadWriteMode), + -- ** Closing files + hClose, + -- ** Special cases + -- | These functions are also exported by the "Prelude". + readFile, + readFile', + writeFile, + appendFile, + -- ** File locking + -- $locking + -- * Operations on handles + -- ** Determining and changing the size of a file + hFileSize, + hSetFileSize, + -- ** Detecting the end of input + hIsEOF, + isEOF, + -- ** Buffering operations + BufferMode(NoBuffering, LineBuffering, BlockBuffering), + hSetBuffering, + hGetBuffering, + hFlush, + -- ** Repositioning handles + hGetPosn, + hSetPosn, + HandlePosn, + hSeek, + SeekMode(AbsoluteSeek, RelativeSeek, SeekFromEnd), + hTell, + -- ** Handle properties + hIsOpen, + hIsClosed, + hIsReadable, + hIsWritable, + hIsSeekable, + -- ** Terminal operations (not portable: GHC only) + hIsTerminalDevice, + hSetEcho, + hGetEcho, + -- ** Showing handle state (not portable: GHC only) + hShow, + -- * Text input and output + -- ** Text input + hWaitForInput, + hReady, + hGetChar, + hGetLine, + hLookAhead, + hGetContents, + hGetContents', + -- ** Text output + hPutChar, + hPutStr, + hPutStrLn, + hPrint, + -- ** Special cases for standard input and output + -- | These functions are also exported by the "Prelude". + interact, + putChar, + putStr, + putStrLn, + print, + getChar, + getLine, + getContents, + getContents', + readIO, + readLn, + -- * Binary input and output + withBinaryFile, + openBinaryFile, + hSetBinaryMode, + hPutBuf, + hGetBuf, + hGetBufSome, + hPutBufNonBlocking, + hGetBufNonBlocking, + -- * Temporary files + openTempFile, + openBinaryTempFile, + openTempFileWithDefaultPermissions, + openBinaryTempFileWithDefaultPermissions, + -- * Unicode encoding\/decoding + -- | A text-mode 'Handle' has an associated 'TextEncoding', which + -- is used to decode bytes into Unicode characters when reading, + -- and encode Unicode characters into bytes when writing. + -- + -- The default 'TextEncoding' is the same as the default encoding + -- on your system, which is also available as 'localeEncoding'. + -- (GHC note: on Windows, we currently do not support double-byte + -- encodings; if the console\'s code page is unsupported, then + -- 'localeEncoding' will be 'latin1'.) + -- + -- Encoding and decoding errors are always detected and reported, + -- except during lazy I/O ('hGetContents', 'getContents', and + -- 'readFile'), where a decoding error merely results in + -- termination of the character stream, as with other I/O errors. + hSetEncoding, + hGetEncoding, + -- ** Unicode encodings + TextEncoding, + latin1, + utf8, + utf8_bom, + utf16, + utf16le, + utf16be, + utf32, + utf32le, + utf32be, + localeEncoding, + char8, + mkTextEncoding, + -- * Newline conversion + -- | In Haskell, a newline is always represented by the character + -- @\'\\n\'@. However, in files and external character streams, a + -- newline may be represented by another character sequence, such + -- as @\'\\r\\n\'@. + -- + -- A text-mode 'Handle' has an associated 'NewlineMode' that + -- specifies how to translate newline characters. The + -- 'NewlineMode' specifies the input and output translation + -- separately, so that for instance you can translate @\'\\r\\n\'@ + -- to @\'\\n\'@ on input, but leave newlines as @\'\\n\'@ on output. + -- + -- The default 'NewlineMode' for a 'Handle' is + -- 'nativeNewlineMode', which does no translation on Unix systems, + -- but translates @\'\\r\\n\'@ to @\'\\n\'@ and back on Windows. + -- + -- Binary-mode 'Handle's do no newline translation at all. + + hSetNewlineMode, + Newline(..), + nativeNewline, + NewlineMode(..), + noNewlineTranslation, + universalNewlineMode, + nativeNewlineMode + ) where + +import GHC.Internal.System.IO + +-- $locking +-- Implementations should enforce as far as possible, at least locally to the +-- Haskell process, multiple-reader single-writer locking on files. +-- That is, /there may either be many handles on the same file which manage input, or just one handle on the file which manages output/. If any +-- open or semi-closed handle is managing a file for output, no new +-- handle can be allocated for that file. If any open or semi-closed +-- handle is managing a file for input, new handles can only be allocated +-- if they do not manage output. Whether two files are the same is +-- implementation-dependent, but they should normally be the same if they +-- have the same absolute path name and neither has been renamed, for +-- example. +-- +-- /Warning/: the 'readFile' operation holds a semi-closed handle on +-- the file until the entire contents of the file have been consumed. +-- 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/IO/Error.hs b/src/System/IO/Error.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Error.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : System.IO.Error +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Standard IO Errors. +-- + +module System.IO.Error + (-- * I\/O errors + IOError, + userError, + mkIOError, + annotateIOError, + -- ** Classifying I\/O errors + isAlreadyExistsError, + isDoesNotExistError, + isAlreadyInUseError, + isFullError, + isEOFError, + isIllegalOperation, + isPermissionError, + isUserError, + isResourceVanishedError, + -- ** Attributes of I\/O errors + ioeGetErrorType, + ioeGetLocation, + ioeGetErrorString, + ioeGetHandle, + ioeGetFileName, + ioeSetErrorType, + ioeSetErrorString, + ioeSetLocation, + ioeSetHandle, + ioeSetFileName, + -- * Types of I\/O error + IOErrorType, + alreadyExistsErrorType, + doesNotExistErrorType, + alreadyInUseErrorType, + fullErrorType, + eofErrorType, + illegalOperationErrorType, + permissionErrorType, + userErrorType, + resourceVanishedErrorType, + -- ** 'IOErrorType' predicates + isAlreadyExistsErrorType, + isDoesNotExistErrorType, + isAlreadyInUseErrorType, + isFullErrorType, + isEOFErrorType, + isIllegalOperationErrorType, + isPermissionErrorType, + isUserErrorType, + isResourceVanishedErrorType, + -- * Throwing and catching I\/O errors + ioError, + catchIOError, + tryIOError, + modifyIOError + ) where + +import GHC.Internal.System.IO.Error diff --git a/src/System/IO/Unsafe.hs b/src/System/IO/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Unsafe.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.IO.Unsafe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- \"Unsafe\" IO operations. +-- +----------------------------------------------------------------------------- + +module System.IO.Unsafe ( + -- * Unsafe 'System.IO.IO' operations + unsafePerformIO, + unsafeDupablePerformIO, + unsafeInterleaveIO, + unsafeFixIO, + ) where + +import GHC.Internal.Base +import GHC.Internal.IO +import GHC.Internal.IORef +import GHC.Internal.Exception +import GHC.Internal.Control.Exception + +-- | A slightly faster version of `GHC.Internal.System.IO.fixIO` that may not be +-- safe to use with multiple threads. The unsafety arises when used +-- like this: +-- +-- > unsafeFixIO $ \r -> do +-- > forkIO (print r) +-- > return (...) +-- +-- In this case, the child thread will receive a @NonTermination@ +-- exception instead of waiting for the value of @r@ to be computed. +-- +-- @since 4.5.0.0 +unsafeFixIO :: (a -> IO a) -> IO a +unsafeFixIO k = do + ref <- newIORef (throw NonTermination) + ans <- unsafeDupableInterleaveIO (readIORef ref) + result <- k ans + writeIORef ref result + return result diff --git a/src/System/Info.hs b/src/System/Info.hs new file mode 100644 --- /dev/null +++ b/src/System/Info.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Info +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Information about the characteristics of the host +-- system lucky enough to run your program. +-- +-- For a comprehensive listing of supported platforms, please refer to +-- https://gitlab.haskell.org/ghc/ghc/-/wikis/platforms +----------------------------------------------------------------------------- + +module System.Info + ( os + , arch + , compilerName + , compilerVersion + , fullCompilerVersion + ) where + +import GHC.Internal.Data.Version (Version (..)) +import Prelude + +-- | The version of 'compilerName' with which the program was compiled +-- or is being interpreted. +-- +-- ==== __Example__ +-- > ghci> compilerVersion +-- > Version {versionBranch = [8,8], versionTags = []} +compilerVersion :: Version +compilerVersion = Version [major, minor] [] + where (major, minor) = compilerVersionRaw `divMod` 100 + +-- | The full version of 'compilerName' with which the program was compiled +-- or is being interpreted. It includes the major, minor, revision and an additional +-- identifier, generally in the form "". +fullCompilerVersion :: Version +fullCompilerVersion = Version version [] + where + version :: [Int] + version = fmap read $ splitVersion __GLASGOW_HASKELL_FULL_VERSION__ + +splitVersion :: String -> [String] +splitVersion s = + case dropWhile (== '.') s of + "" -> [] + s' -> let (w, s'') = break (== '.') s' + in w : splitVersion s'' + +#include "ghcplatform.h" + +-- | The operating system on which the program is running. +-- Common values include: +-- +-- * "darwin" — macOS +-- * "freebsd" +-- * "linux" +-- * "linux-android" +-- * "mingw32" — Windows +-- * "netbsd" +-- * "openbsd" +os :: String +os = HOST_OS + +-- | The machine architecture on which the program is running. +-- Common values include: +-- +-- * "aarch64" +-- * "alpha" +-- * "arm" +-- * "hppa" +-- * "hppa1_1" +-- * "i386" +-- * "ia64" +-- * "m68k" +-- * "mips" +-- * "mipseb" +-- * "mipsel" +-- * "nios2" +-- * "powerpc" +-- * "powerpc64" +-- * "powerpc64le" +-- * "riscv32" +-- * "riscv64" +-- * "loongarch32" +-- * "loongarch64" +-- * "rs6000" +-- * "s390" +-- * "s390x" +-- * "sh4" +-- * "sparc" +-- * "sparc64" +-- * "vax" +-- * "x86_64" +arch :: String +arch = HOST_ARCH + +-- | The Haskell implementation with which the program was compiled +-- or is being interpreted. +-- On the GHC platform, the value is "ghc". +compilerName :: String +compilerName = "ghc" + +compilerVersionRaw :: Int +compilerVersionRaw = __GLASGOW_HASKELL__ diff --git a/src/System/Mem.hs b/src/System/Mem.hs new file mode 100644 --- /dev/null +++ b/src/System/Mem.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : System.Mem +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Memory-related system things. +-- + +module System.Mem + (-- * Garbage collection + performGC, + performMajorGC, + performBlockingMajorGC, + performMinorGC, + -- * Allocation counter and limits + setAllocationCounter, + getAllocationCounter, + enableAllocationLimit, + disableAllocationLimit + ) where + +import GHC.Internal.System.Mem diff --git a/src/System/Mem/StableName.hs b/src/System/Mem/StableName.hs new file mode 100644 --- /dev/null +++ b/src/System/Mem/StableName.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : System.Mem.StableName +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable +-- +-- Stable names are a way of performing fast ( \(\mathcal{O}(1)\) ), +-- not-quite-exact comparison between objects. +-- +-- Stable names solve the following problem: suppose you want to build +-- a hash table with Haskell objects as keys, but you want to use +-- pointer equality for comparison; maybe because the keys are large +-- and hashing would be slow, or perhaps because the keys are infinite +-- in size. We can\'t build a hash table using the address of the +-- object as the key, because objects get moved around by the garbage +-- collector, meaning a re-hash would be necessary after every garbage +-- collection. +-- +-- See [Stretching the storage manager: weak pointers and stable names in +-- Haskell](https://www.microsoft.com/en-us/research/publication/stretching-the-storage-manager-weak-pointers-and-stable-names-in-haskell/) +-- by Simon Peyton Jones, Simon Marlow and Conal Elliott for detailed discussion +-- of stable names. An implementation of a memo table with stable names +-- can be found in [@stable-memo@](https://hackage.haskell.org/package/stable-memo) +-- package. +-- + +module System.Mem.StableName + (-- * Stable Names + StableName, + makeStableName, + hashStableName, + eqStableName + ) where + +import GHC.Internal.System.Mem.StableName diff --git a/src/System/Mem/Weak.hs b/src/System/Mem/Weak.hs new file mode 100644 --- /dev/null +++ b/src/System/Mem/Weak.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Mem.Weak +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable +-- +-- In general terms, a weak pointer is a reference to an object that is +-- not followed by the garbage collector - that is, the existence of a +-- weak pointer to an object has no effect on the lifetime of that +-- object. A weak pointer can be de-referenced to find out +-- whether the object it refers to is still alive or not, and if so +-- to return the object itself. +-- +-- Weak pointers are particularly useful for caches and memo tables. +-- To build a memo table, you build a data structure +-- mapping from the function argument (the key) to its result (the +-- value). When you apply the function to a new argument you first +-- check whether the key\/value pair is already in the memo table. +-- The key point is that the memo table itself should not keep the +-- key and value alive. So the table should contain a weak pointer +-- to the key, not an ordinary pointer. The pointer to the value must +-- not be weak, because the only reference to the value might indeed be +-- from the memo table. +-- +-- So it looks as if the memo table will keep all its values +-- alive for ever. One way to solve this is to purge the table +-- occasionally, by deleting entries whose keys have died. +-- +-- The weak pointers in this module +-- support another approach, called /finalization/. +-- When the key referred to by a weak pointer dies, the storage manager +-- arranges to run a programmer-specified finalizer. In the case of memo +-- tables, for example, the finalizer could remove the key\/value pair +-- from the memo table. +-- +-- Another difficulty with the memo table is that the value of a +-- key\/value pair might itself contain a pointer to the key. +-- So the memo table keeps the value alive, which keeps the key alive, +-- even though there may be no other references to the key so both should +-- die. The weak pointers in this module provide a slight +-- generalisation of the basic weak-pointer idea, in which each +-- weak pointer actually contains both a key and a value. +-- +-- See [Stretching the storage manager: weak pointers and stable names in +-- Haskell](https://www.microsoft.com/en-us/research/publication/stretching-the-storage-manager-weak-pointers-and-stable-names-in-haskell/) +-- by Simon Peyton Jones, Simon Marlow and Conal Elliott for detailed discussion +-- of weak pointers. An implementation of a memo table with weak pointers +-- can be found in [@stable-memo@](https://hackage.haskell.org/package/stable-memo) +-- package. +-- +----------------------------------------------------------------------------- + +module System.Mem.Weak ( + -- * The @Weak@ type + Weak, -- abstract + + -- * The general interface + mkWeak, + deRefWeak, + finalize, + + -- * Specialised versions + mkWeakPtr, + addFinalizer, + mkWeakPair, + -- replaceFinaliser + + -- * Handling exceptions + -- | When an exception is thrown by a finalizer called by the + -- garbage collector, GHC calls a global handler which can be set with + -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by + -- this handler will be ignored. + setFinalizerExceptionHandler, + getFinalizerExceptionHandler, + printToHandleFinalizerExceptionHandler, + + -- * A precise semantics + + -- $precise + + -- * Implementation notes + + -- $notes + ) where + +import Prelude +import GHC.Internal.Weak + +-- | A specialised version of 'mkWeak', where the key and the value are +-- the same object: +-- +-- > mkWeakPtr key finalizer = mkWeak key key finalizer +-- +mkWeakPtr :: k -> Maybe (IO ()) -> IO (Weak k) +mkWeakPtr key finalizer = mkWeak key key finalizer + +{-| + A specialised version of 'mkWeakPtr', where the 'Weak' object + returned is simply thrown away (however the finalizer will be + remembered by the garbage collector, and will still be run + when the key becomes unreachable). + + Note: adding a finalizer to a 'Foreign.ForeignPtr.ForeignPtr' using + 'addFinalizer' won't work; use the specialised version + 'GHC.Internal.Foreign.ForeignPtr.addForeignPtrFinalizer' instead. For discussion + see the 'Weak' type. +. +-} +addFinalizer :: key -> IO () -> IO () +addFinalizer key finalizer = do + _ <- mkWeakPtr key (Just finalizer) -- throw it away + return () + +-- | A specialised version of 'mkWeak' where the value is actually a pair +-- of the key and value passed to 'mkWeakPair': +-- +-- > mkWeakPair key val finalizer = mkWeak key (key,val) finalizer +-- +-- The advantage of this is that the key can be retrieved by 'deRefWeak' +-- in addition to the value. +mkWeakPair :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v)) +mkWeakPair key val finalizer = mkWeak key (key,val) finalizer + + +{- $precise + +The above informal specification is fine for simple situations, but +matters can get complicated. In particular, it needs to be clear +exactly when a key dies, so that any weak pointers that refer to it +can be finalized. Suppose, for example, the value of one weak pointer +refers to the key of another...does that keep the key alive? + +The behaviour is simply this: + + * If a weak pointer (object) refers to an /unreachable/ + key, it may be finalized. + + * Finalization means (a) arrange that subsequent calls + to 'deRefWeak' return 'Nothing'; and (b) run the finalizer. + +This behaviour depends on what it means for a key to be reachable. +Informally, something is reachable if it can be reached by following +ordinary pointers from the root set, but not following weak pointers. +We define reachability more precisely as follows. + +A heap object is /reachable/ if: + + * It is a member of the /root set/. + + * It is directly pointed to by a reachable object, other than + a weak pointer object. + + * It is a weak pointer object whose key is reachable. + + * It is the value or finalizer of a weak pointer object whose key is reachable. +-} + +{- $notes + +A finalizer is not always called after its weak pointer\'s object becomes +unreachable. If the object becomes unreachable right before the program exits, +then GC may not be performed. Finalizers run during GC, so finalizers associated +with the object do not run if GC does not happen. + +Other than the above caveat, users can always expect that a finalizer will be +run after its weak pointer\'s object becomes unreachable. + +If a finalizer throws an exception, the exception is silently caught without +notice. See the commit of issue + for details. Writing a +finalizer that throws exceptions is discouraged. + +-} diff --git a/src/System/Posix/Internals.hs b/src/System/Posix/Internals.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/Internals.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Module : System.Posix.Internals +-- Copyright : (c) The University of Glasgow, 1992-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (requires POSIX) +-- +-- POSIX support layer for the standard libraries. +-- +-- /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. +-- +-- This module is built on *every* platform, including Win32. +-- +-- Non-POSIX compliant in order to support the following features: +-- * S_ISSOCK (no sockets in POSIX) +-- + +module System.Posix.Internals + ( module GHC.Internal.System.Posix.Internals -- TODO: deprecate + ) where + +import GHC.Internal.System.Posix.Internals diff --git a/src/System/Posix/Types.hs b/src/System/Posix/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/Types.hs @@ -0,0 +1,25 @@ +-- | +-- +-- Module : System.Posix.Types +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX data types: Haskell equivalents of the types defined by the +-- @\@ C header on a POSIX system. +-- + +module System.Posix.Types + (-- * POSIX data types + -- ** Platform differences + -- | This module contains platform specific information about types. + -- __/As such the types presented on this page reflect the platform + -- on which the documentation was generated and may not coincide with + -- the types on your platform./__ + module GHC.Internal.System.Posix.Types + ) where + +import GHC.Internal.System.Posix.Types diff --git a/src/System/Timeout.hs b/src/System/Timeout.hs new file mode 100644 --- /dev/null +++ b/src/System/Timeout.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + +------------------------------------------------------------------------------- +-- | +-- Module : System.Timeout +-- Copyright : (c) The University of Glasgow 2007 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable +-- +-- Attach a timeout event to arbitrary 'IO' computations. +-- +------------------------------------------------------------------------------- +-- TODO: Inspect is still suitable. +module System.Timeout ( Timeout, timeout ) where + +#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH) +import GHC.Internal.Control.Monad +import GHC.Internal.Event (getSystemTimerManager, + registerTimeout, unregisterTimeout) +#endif + +import Control.Concurrent +import GHC.Internal.Control.Exception (Exception(..), handleJust, bracket, + uninterruptibleMask_, + asyncExceptionToException, + asyncExceptionFromException) +import GHC.Internal.Data.Unique (Unique, newUnique) +import GHC.Conc (labelThread) +import Prelude + +-- $setup +-- >>> import Prelude +-- >>> import Control.Concurrent (threadDelay) + +-- An internal type that is thrown as a dynamic exception to +-- interrupt the running IO computation when the timeout has +-- expired. + +-- | An exception thrown to a thread by 'timeout' to interrupt a timed-out +-- computation. +-- +-- @since 4.0 +newtype Timeout = Timeout Unique deriving Eq + +-- | @since 4.0 +instance Show Timeout where + show _ = "<>" + +-- Timeout is a child of SomeAsyncException +-- | @since 4.7.0.0 +instance Exception Timeout where + toException = asyncExceptionToException + fromException = asyncExceptionFromException + +-- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result +-- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result +-- is available before the timeout expires, @Just a@ is returned. A negative +-- timeout interval means \"wait indefinitely\". When specifying long timeouts, +-- be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only +-- 2147483647 μs, less than 36 minutes. +-- Consider using @Control.Concurrent.Timeout.timeout@ from @unbounded-delays@ package. +-- +-- >>> timeout 1000000 (threadDelay 1000 *> pure "finished on time") +-- Just "finished on time" +-- +-- >>> timeout 10000 (threadDelay 100000 *> pure "finished on time") +-- Nothing +-- +-- The design of this combinator was guided by the objective that @timeout n f@ +-- should behave exactly the same as @f@ as long as @f@ doesn't time out. This +-- means that @f@ has the same 'myThreadId' it would have without the timeout +-- wrapper. Any exceptions @f@ might throw cancel the timeout and propagate +-- further up. It also possible for @f@ to receive exceptions thrown to it by +-- another thread. +-- +-- A tricky implementation detail is the question of how to abort an @IO@ +-- computation. This combinator relies on asynchronous exceptions internally +-- (namely throwing the computation the 'Timeout' exception). The technique +-- works very well for computations executing inside of the Haskell runtime +-- system, but it doesn't work at all for non-Haskell code. Foreign function +-- calls, for example, cannot be timed out with this combinator simply because +-- an arbitrary C function cannot receive asynchronous exceptions. When +-- @timeout@ is used to wrap an FFI call that blocks, no timeout event can be +-- delivered until the FFI call returns, which pretty much negates the purpose +-- of the combinator. In practice, however, this limitation is less severe than +-- it may sound. Standard I\/O functions like 'GHC.Internal.System.IO.hGetBuf', +-- 'GHC.Internal.System.IO.hPutBuf', Network.Socket.accept, or 'GHC.Internal.System.IO.hWaitForInput' +-- appear to be blocking, but they really don't because the runtime system uses +-- scheduling mechanisms like @select(2)@ to perform asynchronous I\/O, so it +-- is possible to interrupt standard socket I\/O or file I\/O using this +-- combinator. +--- +-- Note that 'timeout' cancels the computation by throwing it the 'Timeout' +-- exception. Consequently blanket exception handlers (e.g. catching +-- 'SomeException') within the computation will break the timeout behavior. +timeout :: Int -> IO a -> IO (Maybe a) +timeout n f + | n < 0 = fmap Just f + | n == 0 = return Nothing +#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH) + | rtsSupportsBoundThreads = do + -- In the threaded RTS, we use the Timer Manager to delay the + -- (fairly expensive) 'forkIO' call until the timeout has expired. + -- + -- An additional thread is required for the actual delivery of + -- the Timeout exception because killThread (or another throwTo) + -- is the only way to reliably interrupt a throwTo in flight. + pid <- myThreadId + ex <- fmap Timeout newUnique + tm <- getSystemTimerManager + -- 'lock' synchronizes the timeout handler and the main thread: + -- * the main thread can disable the handler by writing to 'lock'; + -- * the handler communicates the spawned thread's id through 'lock'. + -- These two cases are mutually exclusive. + lock <- newEmptyMVar + let handleTimeout = do + v <- isEmptyMVar lock + when v $ void $ forkIOWithUnmask $ \unmask -> unmask $ do + tid <- myThreadId + labelThread tid "timeout worker" + v2 <- tryPutMVar lock tid + when v2 $ throwTo pid ex + cleanupTimeout key = uninterruptibleMask_ $ do + v <- tryPutMVar lock undefined + if v then unregisterTimeout tm key + else takeMVar lock >>= killThread + handleJust (\e -> if e == ex then Just () else Nothing) + (\_ -> return Nothing) + (bracket (registerTimeout tm n handleTimeout) + cleanupTimeout + (\_ -> fmap Just f)) +#endif + | otherwise = do + pid <- myThreadId + ex <- fmap Timeout newUnique + handleJust (\e -> if e == ex then Just () else Nothing) + (\_ -> return Nothing) + (bracket (forkIOWithUnmask $ \unmask -> do + tid <- myThreadId + labelThread tid "timeout worker" + unmask $ threadDelay n >> throwTo pid ex) + (uninterruptibleMask_ . killThread) + (\_ -> fmap Just f)) + -- #7719 explains why we need uninterruptibleMask_ above. diff --git a/src/Text/ParserCombinators/ReadP.hs b/src/Text/ParserCombinators/ReadP.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/ReadP.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Text.ParserCombinators.ReadP +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (local universal quantification) +-- +-- This is a module of parser combinators, originally written by Koen Claessen. +-- It parses all alternatives in parallel, so it never keeps hold of +-- the beginning of the input string, a common source of space leaks with +-- other parsers. The @('+++')@ choice combinator is genuinely commutative; +-- it makes no difference which branch is \"shorter\". + +module Text.ParserCombinators.ReadP + (-- * The 'ReadP' type + ReadP, + -- * Primitive operations + get, + look, + (+++), + (<++), + gather, + -- * Other operations + pfail, + eof, + satisfy, + char, + string, + munch, + munch1, + skipSpaces, + choice, + count, + between, + option, + optional, + many, + many1, + skipMany, + skipMany1, + sepBy, + sepBy1, + endBy, + endBy1, + chainr, + chainl, + chainl1, + chainr1, + manyTill, + -- * Running a parser + ReadS, + readP_to_S, + readS_to_P, + -- * Properties + -- $properties + ) where + +import GHC.Internal.Text.ParserCombinators.ReadP diff --git a/src/Text/ParserCombinators/ReadPrec.hs b/src/Text/ParserCombinators/ReadPrec.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/ReadPrec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Text.ParserCombinators.ReadPrec +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (uses Text.ParserCombinators.ReadP) +-- +-- This module defines parser combinators for precedence parsing. + +module Text.ParserCombinators.ReadPrec + (ReadPrec, + -- * Precedences + Prec, + minPrec, + -- * Precedence operations + lift, + prec, + step, + reset, + -- * Other operations + -- | All are based directly on their similarly-named 'ReadP' counterparts. + get, + look, + (+++), + (<++), + pfail, + choice, + -- * Converters + readPrec_to_P, + readP_to_Prec, + readPrec_to_S, + readS_to_Prec + ) where + +import GHC.Internal.Text.ParserCombinators.ReadPrec diff --git a/src/Text/Printf.hs b/src/Text/Printf.hs new file mode 100644 --- /dev/null +++ b/src/Text/Printf.hs @@ -0,0 +1,919 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Text.Printf +-- Copyright : (c) Lennart Augustsson and Bart Massey 2013 +-- License : BSD-style (see the file LICENSE in this distribution) +-- +-- Maintainer : Bart Massey +-- Stability : provisional +-- Portability : portable +-- +-- A C @printf(3)@-like formatter. This version has been +-- extended by Bart Massey as per the recommendations of +-- John Meacham and Simon Marlow +-- +-- to support extensible formatting for new datatypes. It +-- has also been extended to support almost all C +-- @printf(3)@ syntax. +----------------------------------------------------------------------------- + +module Text.Printf( +-- * Printing Functions + printf, hPrintf, +-- * Extending To New Types +-- +-- | This 'printf' can be extended to format types +-- other than those provided for by default. This +-- is done by instantiating 'PrintfArg' and providing +-- a 'formatArg' for the type. It is possible to +-- provide a 'parseFormat' to process type-specific +-- modifiers, but the default instance is usually +-- the best choice. +-- +-- For example: +-- +-- > instance PrintfArg () where +-- > formatArg x fmt | fmtChar (vFmt 'U' fmt) == 'U' = +-- > formatString "()" (fmt { fmtChar = 's', fmtPrecision = Nothing }) +-- > formatArg _ fmt = errorBadFormat $ fmtChar fmt +-- > +-- > main :: IO () +-- > main = printf "[%-3.1U]\n" () +-- +-- prints \"@[() ]@\". Note the use of 'formatString' to +-- take care of field formatting specifications in a convenient +-- way. + PrintfArg(..), + FieldFormatter, + FieldFormat(..), + FormatAdjustment(..), FormatSign(..), + vFmt, +-- ** Handling Type-specific Modifiers +-- +-- | In the unlikely case that modifier characters of +-- some kind are desirable for a user-provided type, +-- a 'ModifierParser' can be provided to process these +-- characters. The resulting modifiers will appear in +-- the 'FieldFormat' for use by the type-specific formatter. + ModifierParser, FormatParse(..), +-- ** Standard Formatters +-- +-- | These formatters for standard types are provided for +-- convenience in writing new type-specific formatters: +-- a common pattern is to throw to 'formatString' or +-- 'formatInteger' to do most of the format handling for +-- a new type. + formatString, formatChar, formatInt, + formatInteger, formatRealFloat, +-- ** Raising Errors +-- +-- | These functions are used internally to raise various +-- errors, and are exported for use by new type-specific +-- formatters. + errorBadFormat, errorShortFormat, errorMissingArgument, + errorBadArgument, + perror, +-- * Implementation Internals +-- | These types are needed for implementing processing +-- variable numbers of arguments to 'printf' and 'hPrintf'. +-- Their implementation is intentionally not visible from +-- this module. If you attempt to pass an argument of a type +-- which is not an instance of the appropriate class to +-- 'printf' or 'hPrintf', then the compiler will report it +-- as a missing instance of 'PrintfArg'. (All 'PrintfArg' +-- instances are 'PrintfType' instances.) + PrintfType, HPrintfType, +-- | This class is needed as a Haskell98 compatibility +-- workaround for the lack of FlexibleInstances. + IsChar(..) +) where + +import Prelude +import Data.Char +import GHC.Internal.Int +import GHC.Internal.Data.List (stripPrefix) +import GHC.Internal.Word +import GHC.Internal.Numeric +import GHC.Internal.Numeric.Natural +import GHC.Internal.System.IO + +-- $setup +-- >>> import Prelude + +------------------- + +-- | Format a variable number of arguments with the C-style formatting string. +-- +-- >>> printf "%s, %d, %.4f" "hello" 123 pi +-- hello, 123, 3.1416 +-- +-- The return value is either 'String' or @('IO' a)@ (which +-- should be @('IO' ())@, but Haskell's type system +-- makes this hard). +-- +-- The format string consists of ordinary characters and +-- /conversion specifications/, which specify how to format +-- one of the arguments to 'printf' in the output string. A +-- format specification is introduced by the @%@ character; +-- this character can be self-escaped into the format string +-- using @%%@. A format specification ends with a +-- /format character/ that provides the primary information about +-- how to format the value. The rest of the conversion +-- specification is optional. In order, one may have flag +-- characters, a width specifier, a precision specifier, and +-- type-specific modifier characters. +-- +-- Unlike C @printf(3)@, the formatting of this 'printf' +-- is driven by the argument type; formatting is type specific. The +-- types formatted by 'printf' \"out of the box\" are: +-- +-- * 'Integral' types, including 'Char' +-- +-- * 'String' +-- +-- * 'RealFloat' types +-- +-- 'printf' is also extensible to support other types: see below. +-- +-- A conversion specification begins with the +-- character @%@, followed by zero or more of the following flags: +-- +-- > - left adjust (default is right adjust) +-- > + always use a sign (+ or -) for signed conversions +-- > space leading space for positive numbers in signed conversions +-- > 0 pad with zeros rather than spaces +-- > # use an \"alternate form\": see below +-- +-- When both flags are given, @-@ overrides @0@ and @+@ overrides space. +-- A negative width specifier in a @*@ conversion is treated as +-- positive but implies the left adjust flag. +-- +-- The \"alternate form\" for unsigned radix conversions is +-- as in C @printf(3)@: +-- +-- > %o prefix with a leading 0 if needed +-- > %x prefix with a leading 0x if nonzero +-- > %X prefix with a leading 0X if nonzero +-- > %b prefix with a leading 0b if nonzero +-- > %[eEfFgG] ensure that the number contains a decimal point +-- +-- Any flags are followed optionally by a field width: +-- +-- > num field width +-- > * as num, but taken from argument list +-- +-- The field width is a minimum, not a maximum: it will be +-- expanded as needed to avoid mutilating a value. +-- +-- Any field width is followed optionally by a precision: +-- +-- > .num precision +-- > . same as .0 +-- > .* as num, but taken from argument list +-- +-- Negative precision is taken as 0. The meaning of the +-- precision depends on the conversion type. +-- +-- > Integral minimum number of digits to show +-- > RealFloat number of digits after the decimal point +-- > String maximum number of characters +-- +-- The precision for Integral types is accomplished by zero-padding. +-- If both precision and zero-pad are given for an Integral field, +-- the zero-pad is ignored. +-- +-- Any precision is followed optionally for Integral types +-- by a width modifier; the only use of this modifier being +-- to set the implicit size of the operand for conversion of +-- a negative operand to unsigned: +-- +-- > hh Int8 +-- > h Int16 +-- > l Int32 +-- > ll Int64 +-- > L Int64 +-- +-- The specification ends with a format character: +-- +-- > c character Integral +-- > d decimal Integral +-- > o octal Integral +-- > x hexadecimal Integral +-- > X hexadecimal Integral +-- > b binary Integral +-- > u unsigned decimal Integral +-- > f floating point RealFloat +-- > F floating point RealFloat +-- > g general format float RealFloat +-- > G general format float RealFloat +-- > e exponent format float RealFloat +-- > E exponent format float RealFloat +-- > s string String +-- > v default format any type +-- +-- The \"%v\" specifier is provided for all built-in types, +-- and should be provided for user-defined type formatters +-- as well. It picks a \"best\" representation for the given +-- type. For the built-in types the \"%v\" specifier is +-- converted as follows: +-- +-- > c Char +-- > u other unsigned Integral +-- > d other signed Integral +-- > g RealFloat +-- > s String +-- +-- Mismatch between the argument types and the format +-- string, as well as any other syntactic or semantic errors +-- in the format string, will cause an exception to be +-- thrown at runtime. +-- +-- Note that the formatting for 'RealFloat' types is +-- currently a bit different from that of C @printf(3)@, +-- conforming instead to 'GHC.Internal.Numeric.showEFloat', +-- 'GHC.Internal.Numeric.showFFloat' and 'GHC.Internal.Numeric.showGFloat' (and their +-- alternate versions 'GHC.Internal.Numeric.showFFloatAlt' and +-- 'GHC.Internal.Numeric.showGFloatAlt'). This is hard to fix: the fixed +-- versions would format in a backward-incompatible way. +-- In any case the Haskell behavior is generally more +-- sensible than the C behavior. A brief summary of some +-- key differences: +-- +-- * Haskell 'printf' never uses the default \"6-digit\" precision +-- used by C printf. +-- +-- * Haskell 'printf' treats the \"precision\" specifier as +-- indicating the number of digits after the decimal point. +-- +-- * Haskell 'printf' prints the exponent of e-format +-- numbers without a gratuitous plus sign, and with the +-- minimum possible number of digits. +-- +-- * Haskell 'printf' will place a zero after a decimal point when +-- possible. +printf :: (PrintfType r) => String -> r +printf fmts = spr fmts [] + +-- | Similar to 'printf', except that output is via the specified +-- 'Handle'. The return type is restricted to @('IO' a)@. +hPrintf :: (HPrintfType r) => Handle -> String -> r +hPrintf hdl fmts = hspr hdl fmts [] + +-- |The 'PrintfType' class provides the variable argument magic for +-- 'printf'. Its implementation is intentionally not visible from +-- this module. If you attempt to pass an argument of a type which +-- is not an instance of this class to 'printf' or 'hPrintf', then +-- the compiler will report it as a missing instance of 'PrintfArg'. +class PrintfType t where + spr :: String -> [UPrintf] -> t + +-- | The 'HPrintfType' class provides the variable argument magic for +-- 'hPrintf'. Its implementation is intentionally not visible from +-- this module. +class HPrintfType t where + hspr :: Handle -> String -> [UPrintf] -> t + +{- not allowed in Haskell 2010 +instance PrintfType String where + spr fmt args = uprintf fmt (reverse args) +-} +-- | @since 2.01 +instance (IsChar c) => PrintfType [c] where + spr fmts args = map fromChar (uprintf fmts (reverse args)) + +-- Note that this should really be (IO ()), but GHC's +-- type system won't readily let us say that without +-- bringing the GADTs. So we go conditional for these defs. + +-- | @since 4.7.0.0 +instance (a ~ ()) => PrintfType (IO a) where + spr fmts args = + putStr $ map fromChar $ uprintf fmts $ reverse args + +-- | @since 4.7.0.0 +instance (a ~ ()) => HPrintfType (IO a) where + hspr hdl fmts args = + hPutStr hdl (uprintf fmts (reverse args)) + +-- | @since 2.01 +instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where + spr fmts args = \ a -> spr fmts + ((parseFormat a, formatArg a) : args) + +-- | @since 2.01 +instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where + hspr hdl fmts args = \ a -> hspr hdl fmts + ((parseFormat a, formatArg a) : args) + +-- | Typeclass of 'printf'-formattable values. The 'formatArg' method +-- takes a value and a field format descriptor and either fails due +-- to a bad descriptor or produces a 'ShowS' as the result. The +-- default 'parseFormat' expects no modifiers: this is the normal +-- case. Minimal instance: 'formatArg'. +class PrintfArg a where + -- | @since 4.7.0.0 + formatArg :: a -> FieldFormatter + -- | @since 4.7.0.0 + parseFormat :: a -> ModifierParser + parseFormat _ (c : cs) = FormatParse "" c cs + parseFormat _ "" = errorShortFormat + +-- | @since 2.01 +instance PrintfArg Char where + formatArg = formatChar + parseFormat _ cf = parseIntFormat (undefined :: Int) cf + +-- | @since 2.01 +instance (IsChar c) => PrintfArg [c] where + formatArg = formatString + +-- | @since 2.01 +instance PrintfArg Int where + formatArg = formatInt + parseFormat = parseIntFormat + +-- | @since 2.01 +instance PrintfArg Int8 where + formatArg = formatInt + parseFormat = parseIntFormat + +-- | @since 2.01 +instance PrintfArg Int16 where + formatArg = formatInt + parseFormat = parseIntFormat + +-- | @since 2.01 +instance PrintfArg Int32 where + formatArg = formatInt + parseFormat = parseIntFormat + +-- | @since 2.01 +instance PrintfArg Int64 where + formatArg = formatInt + parseFormat = parseIntFormat + +-- | @since 2.01 +instance PrintfArg Word where + formatArg = formatInt + parseFormat = parseIntFormat + +-- | @since 2.01 +instance PrintfArg Word8 where + formatArg = formatInt + parseFormat = parseIntFormat + +-- | @since 2.01 +instance PrintfArg Word16 where + formatArg = formatInt + parseFormat = parseIntFormat + +-- | @since 2.01 +instance PrintfArg Word32 where + formatArg = formatInt + parseFormat = parseIntFormat + +-- | @since 2.01 +instance PrintfArg Word64 where + formatArg = formatInt + parseFormat = parseIntFormat + +-- | @since 2.01 +instance PrintfArg Integer where + formatArg = formatInteger + parseFormat = parseIntFormat + +-- | @since 4.8.0.0 +instance PrintfArg Natural where + formatArg = formatInteger . toInteger + parseFormat = parseIntFormat + +-- | @since 2.01 +instance PrintfArg Float where + formatArg = formatRealFloat + +-- | @since 2.01 +instance PrintfArg Double where + formatArg = formatRealFloat + +-- | This class, with only the one instance, is used as +-- a workaround for the fact that 'String', as a concrete +-- type, is not allowable as a typeclass instance. 'IsChar' +-- is exported for backward-compatibility. +class IsChar c where + -- | @since 4.7.0.0 + toChar :: c -> Char + -- | @since 4.7.0.0 + fromChar :: Char -> c + +-- | @since 2.01 +instance IsChar Char where + toChar c = c + fromChar c = c + +------------------- + +-- | Whether to left-adjust or zero-pad a field. These are +-- mutually exclusive, with 'LeftAdjust' taking precedence. +-- +-- @since 4.7.0.0 +data FormatAdjustment = LeftAdjust | ZeroPad + +-- | How to handle the sign of a numeric field. These are +-- mutually exclusive, with 'SignPlus' taking precedence. +-- +-- @since 4.7.0.0 +data FormatSign = SignPlus | SignSpace + +-- | Description of field formatting for 'formatArg'. See UNIX @printf(3)@ +-- for a description of how field formatting works. +-- +-- @since 4.7.0.0 +data FieldFormat = FieldFormat { + fmtWidth :: Maybe Int, -- ^ Total width of the field. + fmtPrecision :: Maybe Int, -- ^ Secondary field width specifier. + fmtAdjust :: Maybe FormatAdjustment, -- ^ Kind of filling or padding + -- to be done. + fmtSign :: Maybe FormatSign, -- ^ Whether to insist on a + -- plus sign for positive + -- numbers. + fmtAlternate :: Bool, -- ^ Indicates an "alternate + -- format". See @printf(3)@ + -- for the details, which + -- vary by argument spec. + fmtModifiers :: String, -- ^ Characters that appeared + -- immediately to the left of + -- 'fmtChar' in the format + -- and were accepted by the + -- type's 'parseFormat'. + -- Normally the empty string. + fmtChar :: Char -- ^ The format character + -- 'printf' was invoked + -- with. 'formatArg' should + -- fail unless this character + -- matches the type. It is + -- normal to handle many + -- different format + -- characters for a single + -- type. + } + +-- | The \"format parser\" walks over argument-type-specific +-- modifier characters to find the primary format character. +-- This is the type of its result. +-- +-- @since 4.7.0.0 +data FormatParse = FormatParse { + fpModifiers :: String, -- ^ Any modifiers found. + fpChar :: Char, -- ^ Primary format character. + fpRest :: String -- ^ Rest of the format string. + } + +-- Contains the "modifier letters" that can precede an +-- integer type. +intModifierMap :: [(String, Integer)] +intModifierMap = [ + ("hh", toInteger (minBound :: Int8)), + ("h", toInteger (minBound :: Int16)), + ("l", toInteger (minBound :: Int32)), + ("ll", toInteger (minBound :: Int64)), + ("L", toInteger (minBound :: Int64)) ] + +parseIntFormat :: a -> String -> FormatParse +parseIntFormat _ s = + case foldr matchPrefix Nothing intModifierMap of + Just m -> m + Nothing -> + case s of + c : cs -> FormatParse "" c cs + "" -> errorShortFormat + where + matchPrefix (p, _) m@(Just (FormatParse p0 _ _)) + | length p0 >= length p = m + | otherwise = case getFormat p of + Nothing -> m + Just fp -> Just fp + matchPrefix (p, _) Nothing = + getFormat p + getFormat p = + stripPrefix p s >>= fp + where + fp (c : cs) = Just $ FormatParse p c cs + fp "" = errorShortFormat + +-- | This is the type of a field formatter reified over its +-- argument. +-- +-- @since 4.7.0.0 +type FieldFormatter = FieldFormat -> ShowS + +-- | Type of a function that will parse modifier characters +-- from the format string. +-- +-- @since 4.7.0.0 +type ModifierParser = String -> FormatParse + +-- | Substitute a \'v\' format character with the given +-- default format character in the 'FieldFormat'. A +-- convenience for user-implemented types, which should +-- support \"%v\". +-- +-- @since 4.7.0.0 +vFmt :: Char -> FieldFormat -> FieldFormat +vFmt c ufmt@(FieldFormat {fmtChar = 'v'}) = ufmt {fmtChar = c} +vFmt _ ufmt = ufmt + +-- | Formatter for 'Char' values. +-- +-- @since 4.7.0.0 +formatChar :: Char -> FieldFormatter +formatChar x ufmt = + formatIntegral (Just 0) (toInteger $ ord x) $ vFmt 'c' ufmt + +-- | Formatter for 'String' values. +-- +-- @since 4.7.0.0 +formatString :: IsChar a => [a] -> FieldFormatter +formatString x ufmt = + case fmtChar $ vFmt 's' ufmt of + 's' -> map toChar . (adjust ufmt ("", ts) ++) + where + ts = map toChar $ trunc $ fmtPrecision ufmt + where + trunc Nothing = x + trunc (Just n) = take n x + c -> errorBadFormat c + +-- Possibly apply the int modifiers to get a new +-- int width for conversion. +fixupMods :: FieldFormat -> Maybe Integer -> Maybe Integer +fixupMods ufmt m = + let mods = fmtModifiers ufmt in + case mods of + "" -> m + _ -> case lookup mods intModifierMap of + Just m0 -> Just m0 + Nothing -> perror "unknown format modifier" + +-- | Formatter for 'Int' values. +-- +-- @since 4.7.0.0 +formatInt :: (Integral a, Bounded a) => a -> FieldFormatter +formatInt x ufmt = + let lb = toInteger $ minBound `asTypeOf` x + m = fixupMods ufmt (Just lb) + ufmt' = case lb of + 0 -> vFmt 'u' ufmt + _ -> ufmt + in + formatIntegral m (toInteger x) ufmt' + +-- | Formatter for 'Integer' values. +-- +-- @since 4.7.0.0 +formatInteger :: Integer -> FieldFormatter +formatInteger x ufmt = + let m = fixupMods ufmt Nothing in + formatIntegral m x ufmt + +-- All formatting for integral types is handled +-- consistently. The only difference is between Integer and +-- bounded types; this difference is handled by the 'm' +-- argument containing the lower bound. +formatIntegral :: Maybe Integer -> Integer -> FieldFormatter +formatIntegral m x ufmt0 = + let prec = fmtPrecision ufmt0 in + case fmtChar ufmt of + 'd' -> (adjustSigned ufmt (fmti prec x) ++) + 'i' -> (adjustSigned ufmt (fmti prec x) ++) + 'x' -> (adjust ufmt (fmtu 16 (alt "0x" x) prec m x) ++) + 'X' -> (adjust ufmt (upcase $ fmtu 16 (alt "0X" x) prec m x) ++) + 'b' -> (adjust ufmt (fmtu 2 (alt "0b" x) prec m x) ++) + 'o' -> (adjust ufmt (fmtu 8 (alt "0" x) prec m x) ++) + 'u' -> (adjust ufmt (fmtu 10 Nothing prec m x) ++) + 'c' | x >= fromIntegral (ord (minBound :: Char)) && + x <= fromIntegral (ord (maxBound :: Char)) && + fmtPrecision ufmt == Nothing && + fmtModifiers ufmt == "" -> + formatString [chr $ fromIntegral x] (ufmt { fmtChar = 's' }) + 'c' -> perror "illegal char conversion" + c -> errorBadFormat c + where + ufmt = vFmt 'd' $ case ufmt0 of + FieldFormat { fmtPrecision = Just _, fmtAdjust = Just ZeroPad } -> + ufmt0 { fmtAdjust = Nothing } + _ -> ufmt0 + alt _ 0 = Nothing + alt p _ = case fmtAlternate ufmt of + True -> Just p + False -> Nothing + upcase (s1, s2) = (s1, map toUpper s2) + +-- | Formatter for 'RealFloat' values. +-- +-- @since 4.7.0.0 +formatRealFloat :: RealFloat a => a -> FieldFormatter +formatRealFloat x ufmt = + let c = fmtChar $ vFmt 'g' ufmt + prec = fmtPrecision ufmt + alt = fmtAlternate ufmt + in + case c of + 'e' -> (adjustSigned ufmt (dfmt c prec alt x) ++) + 'E' -> (adjustSigned ufmt (dfmt c prec alt x) ++) + 'f' -> (adjustSigned ufmt (dfmt c prec alt x) ++) + 'F' -> (adjustSigned ufmt (dfmt c prec alt x) ++) + 'g' -> (adjustSigned ufmt (dfmt c prec alt x) ++) + 'G' -> (adjustSigned ufmt (dfmt c prec alt x) ++) + _ -> errorBadFormat c + +-- This is the type carried around for arguments in +-- the varargs code. +type UPrintf = (ModifierParser, FieldFormatter) + +-- Given a format string and a list of formatting functions +-- (the actual argument value having already been baked into +-- each of these functions before delivery), return the +-- actual formatted text string. +uprintf :: String -> [UPrintf] -> String +uprintf s us = uprintfs s us "" + +-- This function does the actual work, producing a ShowS +-- instead of a string, for future expansion and for +-- misguided efficiency. +uprintfs :: String -> [UPrintf] -> ShowS +uprintfs "" [] = id +uprintfs "" (_:_) = errorShortFormat +uprintfs ('%':'%':cs) us = ('%' :) . uprintfs cs us +uprintfs ('%':_) [] = errorMissingArgument +uprintfs ('%':cs) us@(_:_) = fmt cs us +uprintfs (c:cs) us = (c :) . uprintfs cs us + +-- Given a suffix of the format string starting just after +-- the percent sign, and the list of remaining unprocessed +-- arguments in the form described above, format the portion +-- of the output described by this field description, and +-- then continue with 'uprintfs'. +fmt :: String -> [UPrintf] -> ShowS +fmt cs0 us0 = + case getSpecs False False Nothing False cs0 us0 of + (_, _, []) -> errorMissingArgument + (ufmt, cs, (_, u) : us) -> u ufmt . uprintfs cs us + +-- Given field formatting information, and a tuple +-- consisting of a prefix (for example, a minus sign) that +-- is supposed to go before the argument value and a string +-- representing the value, return the properly padded and +-- formatted result. +adjust :: FieldFormat -> (String, String) -> String +adjust ufmt (pre, str) = + let naturalWidth = length pre + length str + zero = case fmtAdjust ufmt of + Just ZeroPad -> True + _ -> False + left = case fmtAdjust ufmt of + Just LeftAdjust -> True + _ -> False + fill = case fmtWidth ufmt of + Just width | naturalWidth < width -> + let fillchar = if zero then '0' else ' ' in + replicate (width - naturalWidth) fillchar + _ -> "" + in + if left + then pre ++ str ++ fill + else if zero + then pre ++ fill ++ str + else fill ++ pre ++ str + +-- For positive numbers with an explicit sign field ("+" or +-- " "), adjust accordingly. +adjustSigned :: FieldFormat -> (String, String) -> String +adjustSigned ufmt@(FieldFormat {fmtSign = Just SignPlus}) ("", str) = + adjust ufmt ("+", str) +adjustSigned ufmt@(FieldFormat {fmtSign = Just SignSpace}) ("", str) = + adjust ufmt (" ", str) +adjustSigned ufmt ps = + adjust ufmt ps + +-- Format a signed integer in the "default" fashion. +-- This will be subjected to adjust subsequently. +fmti :: Maybe Int -> Integer -> (String, String) +fmti prec i + | i < 0 = ("-", integral_prec prec (show (-i))) + | otherwise = ("", integral_prec prec (show i)) + +-- Format an unsigned integer in the "default" fashion. +-- This will be subjected to adjust subsequently. The 'b' +-- argument is the base, the 'pre' argument is the prefix, +-- and the '(Just m)' argument is the implicit lower-bound +-- size of the operand for conversion from signed to +-- unsigned. Thus, this function will refuse to convert an +-- unbounded negative integer to an unsigned string. +fmtu :: Integer -> Maybe String -> Maybe Int -> Maybe Integer -> Integer + -> (String, String) +fmtu b (Just pre) prec m i = + let ("", s) = fmtu b Nothing prec m i in + case pre of + "0" -> case s of + '0' : _ -> ("", s) + _ -> (pre, s) + _ -> (pre, s) +fmtu b Nothing prec0 m0 i0 = + case fmtu' prec0 m0 i0 of + Just s -> ("", s) + Nothing -> errorBadArgument + where + fmtu' :: Maybe Int -> Maybe Integer -> Integer -> Maybe String + fmtu' prec (Just m) i | i < 0 = + fmtu' prec Nothing (-2 * m + i) + fmtu' (Just prec) _ i | i >= 0 = + fmap (integral_prec (Just prec)) $ fmtu' Nothing Nothing i + fmtu' Nothing _ i | i >= 0 = + Just $ showIntAtBase b intToDigit i "" + fmtu' _ _ _ = Nothing + + +-- This is used by 'fmtu' and 'fmti' to zero-pad an +-- int-string to a required precision. +integral_prec :: Maybe Int -> String -> String +integral_prec Nothing integral = integral +integral_prec (Just 0) "0" = "" +integral_prec (Just prec) integral = + replicate (prec - length integral) '0' ++ integral + +stoi :: String -> (Int, String) +stoi cs = + let (as, cs') = span isDigit cs in + case as of + "" -> (0, cs') + _ -> (read as, cs') + +-- Figure out the FormatAdjustment, given: +-- width, precision, left-adjust, zero-fill +adjustment :: Maybe Int -> Maybe a -> Bool -> Bool + -> Maybe FormatAdjustment +adjustment w p l z = + case w of + Just n | n < 0 -> adjl p True z + _ -> adjl p l z + where + adjl _ True _ = Just LeftAdjust + adjl _ False True = Just ZeroPad + adjl _ _ _ = Nothing + +-- Parse the various format controls to get a format specification. +getSpecs :: Bool -> Bool -> Maybe FormatSign -> Bool -> String -> [UPrintf] + -> (FieldFormat, String, [UPrintf]) +getSpecs _ z s a ('-' : cs0) us = getSpecs True z s a cs0 us +getSpecs l z _ a ('+' : cs0) us = getSpecs l z (Just SignPlus) a cs0 us +getSpecs l z s a (' ' : cs0) us = + getSpecs l z ss a cs0 us + where + ss = case s of + Just SignPlus -> Just SignPlus + _ -> Just SignSpace +getSpecs l _ s a ('0' : cs0) us = getSpecs l True s a cs0 us +getSpecs l z s _ ('#' : cs0) us = getSpecs l z s True cs0 us +getSpecs l z s a ('*' : cs0) us = + let (us', n) = getStar us + ((p, cs''), us'') = case cs0 of + '.':'*':r -> + let (us''', p') = getStar us' in ((Just p', r), us''') + '.':r -> + let (p', r') = stoi r in ((Just p', r'), us') + _ -> + ((Nothing, cs0), us') + FormatParse ms c cs = + case us'' of + (ufmt, _) : _ -> ufmt cs'' + [] -> errorMissingArgument + in + (FieldFormat { + fmtWidth = Just (abs n), + fmtPrecision = p, + fmtAdjust = adjustment (Just n) p l z, + fmtSign = s, + fmtAlternate = a, + fmtModifiers = ms, + fmtChar = c}, cs, us'') +getSpecs l z s a ('.' : cs0) us = + let ((p, cs'), us') = case cs0 of + '*':cs'' -> let (us'', p') = getStar us in ((p', cs''), us'') + _ -> (stoi cs0, us) + FormatParse ms c cs = + case us' of + (ufmt, _) : _ -> ufmt cs' + [] -> errorMissingArgument + in + (FieldFormat { + fmtWidth = Nothing, + fmtPrecision = Just p, + fmtAdjust = adjustment Nothing (Just p) l z, + fmtSign = s, + fmtAlternate = a, + fmtModifiers = ms, + fmtChar = c}, cs, us') +getSpecs l z s a cs0@(c0 : _) us | isDigit c0 = + let (n, cs') = stoi cs0 + ((p, cs''), us') = case cs' of + '.' : '*' : r -> + let (us'', p') = getStar us in ((Just p', r), us'') + '.' : r -> + let (p', r') = stoi r in ((Just p', r'), us) + _ -> + ((Nothing, cs'), us) + FormatParse ms c cs = + case us' of + (ufmt, _) : _ -> ufmt cs'' + [] -> errorMissingArgument + in + (FieldFormat { + fmtWidth = Just (abs n), + fmtPrecision = p, + fmtAdjust = adjustment (Just n) p l z, + fmtSign = s, + fmtAlternate = a, + fmtModifiers = ms, + fmtChar = c}, cs, us') +getSpecs l z s a cs0@(_ : _) us = + let FormatParse ms c cs = + case us of + (ufmt, _) : _ -> ufmt cs0 + [] -> errorMissingArgument + in + (FieldFormat { + fmtWidth = Nothing, + fmtPrecision = Nothing, + fmtAdjust = adjustment Nothing Nothing l z, + fmtSign = s, + fmtAlternate = a, + fmtModifiers = ms, + fmtChar = c}, cs, us) +getSpecs _ _ _ _ "" _ = + errorShortFormat + +-- Process a star argument in a format specification. +getStar :: [UPrintf] -> ([UPrintf], Int) +getStar us = + let ufmt = FieldFormat { + fmtWidth = Nothing, + fmtPrecision = Nothing, + fmtAdjust = Nothing, + fmtSign = Nothing, + fmtAlternate = False, + fmtModifiers = "", + fmtChar = 'd' } in + case us of + [] -> errorMissingArgument + (_, nu) : us' -> (us', read (nu ufmt "")) + +-- Format a RealFloat value. +dfmt :: (RealFloat a) => Char -> Maybe Int -> Bool -> a -> (String, String) +dfmt c p a d = + let caseConvert = if isUpper c then map toUpper else id + showFunction = case toLower c of + 'e' -> showEFloat + 'f' -> if a then showFFloatAlt else showFFloat + 'g' -> if a then showGFloatAlt else showGFloat + _ -> perror "internal error: impossible dfmt" + result = caseConvert $ showFunction p d "" + in + case result of + '-' : cs -> ("-", cs) + cs -> ("" , cs) + + +-- | Raises an 'error' with a printf-specific prefix on the +-- message string. +-- +-- @since 4.7.0.0 +perror :: String -> a +perror s = errorWithoutStackTrace $ "printf: " ++ s + +-- | Calls 'perror' to indicate an unknown format letter for +-- a given type. +-- +-- @since 4.7.0.0 +errorBadFormat :: Char -> a +errorBadFormat c = perror $ "bad formatting char " ++ show c + +errorShortFormat, errorMissingArgument, errorBadArgument :: a +-- | Calls 'perror' to indicate that the format string ended +-- early. +-- +-- @since 4.7.0.0 +errorShortFormat = perror "formatting string ended prematurely" +-- | Calls 'perror' to indicate that there is a missing +-- argument in the argument list. +-- +-- @since 4.7.0.0 +errorMissingArgument = perror "argument list ended prematurely" +-- | Calls 'perror' to indicate that there is a type +-- error or similar in the given argument. +-- +-- @since 4.7.0.0 +errorBadArgument = perror "bad argument" diff --git a/src/Text/Read.hs b/src/Text/Read.hs new file mode 100644 --- /dev/null +++ b/src/Text/Read.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Text.Read +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (uses Text.ParserCombinators.ReadP) +-- +-- Converting strings to values. +-- +-- The "Text.Read" module is the canonical place to import for +-- 'Read'-class facilities. For GHC only, it offers an extended and much +-- improved 'Read' class, which constitutes a proposed alternative to the +-- Haskell 2010 'Read'. In particular, writing parsers is easier, and +-- the parsers are much more efficient. +-- + +module Text.Read + (-- * The 'Read' class + Read(..), + ReadS, + -- * Haskell 2010 functions + reads, + read, + readParen, + lex, + -- * New parsing functions + module Text.ParserCombinators.ReadPrec, + Lexeme(..), + lexP, + parens, + readListDefault, + readListPrecDefault, + readEither, + readMaybe + ) where + +import GHC.Internal.Text.Read +import Text.ParserCombinators.ReadPrec diff --git a/src/Text/Read/Lex.hs b/src/Text/Read/Lex.hs new file mode 100644 --- /dev/null +++ b/src/Text/Read/Lex.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Text.Read.Lex +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (uses Text.ParserCombinators.ReadP) +-- +-- The cut-down Haskell lexer, used by Text.Read +-- + +module Text.Read.Lex + (Lexeme(..), + Number, + numberToInteger, + numberToFixed, + numberToRational, + numberToRangedRational, + lex, + expect, + hsLex, + lexChar, + readBinP, + readIntP, + readOctP, + readDecP, + readHexP, + isSymbolChar + ) where + +import GHC.Internal.Text.Read.Lex diff --git a/src/Text/Show.hs b/src/Text/Show.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE Safe #-} + +-- | +-- +-- Module : Text.Show +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Converting values to readable strings: +-- the 'Show' class and associated functions. +-- + +module Text.Show + (ShowS, + Show(showsPrec, show, showList), + shows, + showChar, + showString, + showParen, + showListWith + ) where + +import GHC.Internal.Text.Show diff --git a/src/Text/Show/Functions.hs b/src/Text/Show/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Functions.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE Safe #-} +-- This module deliberately declares orphan instances: +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- +-- Module : Text.Show.Functions +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Optional instance of 'Text.Show.Show' for functions: +-- +-- > instance Show (a -> b) where +-- > showsPrec _ _ = showString "" +-- + +module Text.Show.Functions () where + +import Prelude + +-- | @since 2.01 +instance Show (a -> b) where + showsPrec _ _ = showString "" diff --git a/src/Type/Reflection.hs b/src/Type/Reflection.hs new file mode 100644 --- /dev/null +++ b/src/Type/Reflection.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE MagicHash #-} + +-- | +-- +-- Module : Type.Reflection +-- Copyright : (c) The University of Glasgow, CWI 2001--2017 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (requires GADTs and compiler support) +-- +-- This provides a type-indexed type representation mechanism, similar to that +-- described by, +-- +-- * Simon Peyton-Jones, Stephanie Weirich, Richard Eisenberg, +-- Dimitrios Vytiniotis. "". +-- /Proc. Philip Wadler's 60th birthday Festschrift/, Edinburgh (April 2016). +-- +-- The interface provides 'I.TypeRep', a type representation which can +-- be safely decomposed and composed. See "Data.Dynamic" for an example of this. +-- +-- @since 4.10.0.0 +-- + +module Type.Reflection + (-- * The Typeable class + Typeable, + typeRep, + withTypeable, + -- * Propositional equality + (:~:)(Refl), + (:~~:)(HRefl), + -- * Type representations + -- ** Type-Indexed + TypeRep, + pattern TypeRep, + typeOf, + pattern App, + pattern Con, + pattern Con', + pattern Fun, + typeRepTyCon, + rnfTypeRep, + eqTypeRep, + decTypeRep, + typeRepKind, + splitApps, + -- ** Quantified + SomeTypeRep(..), + someTypeRep, + someTypeRepTyCon, + rnfSomeTypeRep, + -- * Type constructors + TyCon, + tyConPackage, + tyConModule, + tyConName, + rnfTyCon, + -- * Module names + Module, + moduleName, + modulePackage, + rnfModule + ) where + +import GHC.Internal.Type.Reflection diff --git a/src/Type/Reflection/Unsafe.hs b/src/Type/Reflection/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Type/Reflection/Unsafe.hs @@ -0,0 +1,33 @@ +-- | +-- +-- Module : Type.Reflection.Unsafe +-- Copyright : (c) The University of Glasgow, CWI 2001--2015 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- The representations of the types 'TyCon' and 'TypeRep', and the function +-- 'mkTyCon' which is used by derived instances of 'Typeable' to construct +-- 'TyCon's. +-- +-- Be warned, these functions can be used to construct ill-kinded +-- type representations. +-- + +module Type.Reflection.Unsafe + (-- * Type representations + TypeRep, + mkTrApp, + mkTyCon, + typeRepFingerprint, + someTypeRepFingerprint, + -- * Kind representations + KindRep(..), + TypeLitSort(..), + -- * Type constructors + TyCon, + mkTrCon, + tyConKindRep, + tyConKindArgs, + tyConFingerprint + ) where + +import GHC.Internal.Type.Reflection.Unsafe diff --git a/src/Unsafe/Coerce.hs b/src/Unsafe/Coerce.hs new file mode 100644 --- /dev/null +++ b/src/Unsafe/Coerce.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE MagicHash #-} + +module Unsafe.Coerce + (unsafeCoerce, + unsafeCoerceUnlifted, + unsafeCoerceAddr, + unsafeEqualityProof, + UnsafeEquality(..), + unsafeCoerce# + ) where + +import GHC.Internal.Unsafe.Coerce