From 70a4766efafdbf3f55f203c821f90651ba2bc917 Mon Sep 17 00:00:00 2001 From: nathyong Date: Mon, 26 Sep 2016 21:58:22 +1000 Subject: [PATCH] Add GHC wired-in libraries --- app/Main.hs | 236 +- libraries/base/.authorspellings | 12 + libraries/base/.gitignore | 22 + libraries/base/Control/Applicative.hs | 111 + libraries/base/Control/Arrow.hs | 374 + libraries/base/Control/Category.hs | 67 + libraries/base/Control/Concurrent.hs | 668 ++ libraries/base/Control/Concurrent/Chan.hs | 166 + libraries/base/Control/Concurrent/MVar.hs | 274 + libraries/base/Control/Concurrent/QSem.hs | 130 + libraries/base/Control/Concurrent/QSemN.hs | 122 + libraries/base/Control/Exception.hs | 393 + libraries/base/Control/Exception/Base.hs | 422 ++ libraries/base/Control/Monad.hs | 285 + libraries/base/Control/Monad/Fail.hs | 78 + libraries/base/Control/Monad/Fix.hs | 123 + libraries/base/Control/Monad/IO/Class.hs | 36 + libraries/base/Control/Monad/Instances.hs | 19 + libraries/base/Control/Monad/ST.hs | 35 + libraries/base/Control/Monad/ST/Imp.hs | 38 + libraries/base/Control/Monad/ST/Lazy.hs | 34 + libraries/base/Control/Monad/ST/Lazy/Imp.hs | 149 + libraries/base/Control/Monad/ST/Lazy/Safe.hs | 36 + .../base/Control/Monad/ST/Lazy/Unsafe.hs | 28 + libraries/base/Control/Monad/ST/Safe.hs | 33 + libraries/base/Control/Monad/ST/Strict.hs | 22 + libraries/base/Control/Monad/ST/Unsafe.hs | 29 + libraries/base/Control/Monad/Zip.hs | 99 + libraries/base/Data/Bifunctor.hs | 105 + libraries/base/Data/Bits.hs | 659 ++ libraries/base/Data/Bool.hs | 61 + libraries/base/Data/Char.hs | 290 + libraries/base/Data/Coerce.hs | 29 + libraries/base/Data/Complex.hs | 231 + libraries/base/Data/Data.hs | 1818 +++++ libraries/base/Data/Dynamic.hs | 144 + libraries/base/Data/Either.hs | 295 + libraries/base/Data/Eq.hs | 22 + libraries/base/Data/Fixed.hs | 208 + libraries/base/Data/Foldable.hs | 623 ++ libraries/base/Data/Function.hs | 100 + libraries/base/Data/Functor.hs | 152 + libraries/base/Data/Functor/Classes.hs | 490 ++ libraries/base/Data/Functor/Compose.hs | 94 + libraries/base/Data/Functor/Const.hs | 69 + libraries/base/Data/Functor/Identity.hs | 111 + libraries/base/Data/Functor/Product.hs | 97 + libraries/base/Data/Functor/Sum.hs | 77 + libraries/base/Data/IORef.hs | 155 + libraries/base/Data/Int.hs | 55 + libraries/base/Data/Ix.hs | 64 + libraries/base/Data/Kind.hs | 19 + libraries/base/Data/List.hs | 242 + libraries/base/Data/List/NonEmpty.hs | 490 ++ libraries/base/Data/Maybe.hs | 300 + libraries/base/Data/Monoid.hs | 237 + libraries/base/Data/OldList.hs | 1193 +++ libraries/base/Data/Ord.hs | 52 + libraries/base/Data/Proxy.hs | 110 + libraries/base/Data/Ratio.hs | 73 + libraries/base/Data/STRef.hs | 54 + libraries/base/Data/STRef/Lazy.hs | 38 + libraries/base/Data/STRef/Strict.hs | 22 + libraries/base/Data/Semigroup.hs | 634 ++ libraries/base/Data/String.hs | 83 + libraries/base/Data/Traversable.hs | 333 + libraries/base/Data/Tuple.hs | 51 + libraries/base/Data/Type/Bool.hs | 55 + libraries/base/Data/Type/Coercion.hs | 99 + libraries/base/Data/Type/Equality.hs | 304 + libraries/base/Data/Typeable.hs | 131 + libraries/base/Data/Typeable/Internal.hs | 425 ++ libraries/base/Data/Unique.hs | 71 + libraries/base/Data/Version.hs | 132 + libraries/base/Data/Void.hs | 73 + libraries/base/Data/Word.hs | 60 + libraries/base/Debug/Trace.hs | 295 + libraries/base/Foreign.hs | 38 + libraries/base/Foreign/C.hs | 27 + libraries/base/Foreign/C/Error.hs | 575 ++ libraries/base/Foreign/C/String.hs | 459 ++ libraries/base/Foreign/C/Types.hs | 258 + libraries/base/Foreign/Concurrent.hs | 51 + libraries/base/Foreign/ForeignPtr.hs | 47 + libraries/base/Foreign/ForeignPtr/Imp.hs | 120 + libraries/base/Foreign/ForeignPtr/Safe.hs | 49 + libraries/base/Foreign/ForeignPtr/Unsafe.hs | 28 + libraries/base/Foreign/Marshal.hs | 34 + libraries/base/Foreign/Marshal/Alloc.hs | 226 + libraries/base/Foreign/Marshal/Array.hs | 280 + libraries/base/Foreign/Marshal/Error.hs | 78 + libraries/base/Foreign/Marshal/Pool.hs | 198 + libraries/base/Foreign/Marshal/Safe.hs | 36 + libraries/base/Foreign/Marshal/Unsafe.hs | 45 + libraries/base/Foreign/Marshal/Utils.hs | 187 + libraries/base/Foreign/Ptr.hs | 99 + libraries/base/Foreign/Safe.hs | 40 + libraries/base/Foreign/StablePtr.hs | 47 + libraries/base/Foreign/Storable.hs | 260 + libraries/base/GHC/Arr.hs | 901 +++ libraries/base/GHC/Base.hs | 1224 +++ libraries/base/GHC/Char.hs | 22 + libraries/base/GHC/Conc.hs | 119 + libraries/base/GHC/Conc/IO.hs | 203 + libraries/base/GHC/Conc/Signal.hs | 99 + libraries/base/GHC/Conc/Sync.hs | 894 +++ libraries/base/GHC/Conc/Windows.hs | 337 + libraries/base/GHC/ConsoleHandler.hs | 162 + libraries/base/GHC/Constants.hs | 10 + libraries/base/GHC/Desugar.hs | 41 + libraries/base/GHC/Enum.hs | 768 ++ libraries/base/GHC/Environment.hs | 66 + libraries/base/GHC/Err.hs | 84 + libraries/base/GHC/Event.hs | 46 + libraries/base/GHC/Event/Arr.hs | 32 + libraries/base/GHC/Event/Array.hs | 312 + libraries/base/GHC/Event/Clock.hsc | 17 + libraries/base/GHC/Event/Control.hs | 210 + libraries/base/GHC/Event/EPoll.hsc | 239 + libraries/base/GHC/Event/IntTable.hs | 144 + libraries/base/GHC/Event/Internal.hs | 209 + libraries/base/GHC/Event/KQueue.hsc | 294 + libraries/base/GHC/Event/Manager.hs | 520 ++ libraries/base/GHC/Event/PSQ.hs | 484 ++ libraries/base/GHC/Event/Poll.hsc | 211 + libraries/base/GHC/Event/Thread.hs | 362 + libraries/base/GHC/Event/TimerManager.hs | 243 + libraries/base/GHC/Event/Unique.hs | 43 + libraries/base/GHC/Exception.hs | 252 + libraries/base/GHC/Exception.hs-boot | 38 + libraries/base/GHC/ExecutionStack.hs | 50 + .../base/GHC/ExecutionStack/Internal.hsc | 238 + libraries/base/GHC/Exts.hs | 202 + libraries/base/GHC/Fingerprint.hs | 114 + libraries/base/GHC/Fingerprint.hs-boot | 14 + libraries/base/GHC/Fingerprint/Type.hs | 33 + libraries/base/GHC/Float.hs | 1241 ++++ libraries/base/GHC/Float/ConversionUtils.hs | 100 + libraries/base/GHC/Float/RealFracMethods.hs | 342 + libraries/base/GHC/Foreign.hs | 255 + libraries/base/GHC/ForeignPtr.hs | 445 ++ libraries/base/GHC/GHCi.hs | 49 + libraries/base/GHC/Generics.hs | 1262 ++++ libraries/base/GHC/IO.hs | 414 ++ libraries/base/GHC/IO.hs-boot | 9 + libraries/base/GHC/IO/Buffer.hs | 291 + libraries/base/GHC/IO/BufferedIO.hs | 126 + libraries/base/GHC/IO/Device.hs | 170 + libraries/base/GHC/IO/Encoding.hs | 290 + libraries/base/GHC/IO/Encoding.hs-boot | 10 + libraries/base/GHC/IO/Encoding/CodePage.hs | 184 + .../base/GHC/IO/Encoding/CodePage/API.hs | 428 ++ .../base/GHC/IO/Encoding/CodePage/Table.hs | 432 ++ libraries/base/GHC/IO/Encoding/Failure.hs | 203 + libraries/base/GHC/IO/Encoding/Iconv.hs | 201 + libraries/base/GHC/IO/Encoding/Latin1.hs | 230 + libraries/base/GHC/IO/Encoding/Types.hs | 132 + libraries/base/GHC/IO/Encoding/UTF16.hs | 359 + libraries/base/GHC/IO/Encoding/UTF32.hs | 336 + libraries/base/GHC/IO/Encoding/UTF8.hs | 362 + libraries/base/GHC/IO/Exception.hs | 396 + libraries/base/GHC/IO/Exception.hs-boot | 15 + libraries/base/GHC/IO/FD.hs | 674 ++ libraries/base/GHC/IO/Handle.hs | 743 ++ libraries/base/GHC/IO/Handle.hs-boot | 10 + libraries/base/GHC/IO/Handle/FD.hs | 291 + libraries/base/GHC/IO/Handle/FD.hs-boot | 10 + libraries/base/GHC/IO/Handle/Internals.hs | 949 +++ libraries/base/GHC/IO/Handle/Text.hs | 1006 +++ libraries/base/GHC/IO/Handle/Types.hs | 426 ++ libraries/base/GHC/IO/IOMode.hs | 30 + libraries/base/GHC/IO/Unsafe.hs | 180 + libraries/base/GHC/IOArray.hs | 76 + libraries/base/GHC/IORef.hs | 53 + libraries/base/GHC/Int.hs | 1151 +++ libraries/base/GHC/List.hs | 1002 +++ libraries/base/GHC/MVar.hs | 181 + libraries/base/GHC/Natural.hs | 636 ++ libraries/base/GHC/Num.hs | 99 + libraries/base/GHC/OldList.hs | 29 + libraries/base/GHC/OverloadedLabels.hs | 48 + libraries/base/GHC/PArr.hs | 37 + libraries/base/GHC/Pack.hs | 101 + libraries/base/GHC/Profiling.hs | 10 + libraries/base/GHC/Ptr.hs | 174 + libraries/base/GHC/RTS/Flags.hsc | 457 ++ libraries/base/GHC/Read.hs | 652 ++ libraries/base/GHC/Real.hs | 662 ++ libraries/base/GHC/ST.hs | 112 + libraries/base/GHC/STRef.hs | 49 + libraries/base/GHC/Show.hs | 523 ++ libraries/base/GHC/Stable.hs | 108 + libraries/base/GHC/Stack.hs | 101 + libraries/base/GHC/Stack/CCS.hs-boot | 16 + libraries/base/GHC/Stack/CCS.hsc | 120 + libraries/base/GHC/Stack/Types.hs | 217 + libraries/base/GHC/StaticPtr.hs | 122 + libraries/base/GHC/Stats.hsc | 173 + libraries/base/GHC/Storable.hs | 158 + libraries/base/GHC/TopHandler.hs | 254 + libraries/base/GHC/TypeLits.hs | 286 + libraries/base/GHC/Unicode.hs | 397 + libraries/base/GHC/Weak.hs | 156 + libraries/base/GHC/Windows.hs | 196 + libraries/base/GHC/Word.hs | 941 +++ libraries/base/LICENSE | 83 + libraries/base/Numeric.hs | 232 + libraries/base/Numeric/Natural.hs | 24 + libraries/base/Prelude.hs | 172 + libraries/base/Setup.hs | 6 + libraries/base/System/CPUTime.hsc | 161 + libraries/base/System/Console/GetOpt.hs | 407 + libraries/base/System/Environment.hs | 449 ++ .../System/Environment/ExecutablePath.hsc | 175 + libraries/base/System/Exit.hs | 82 + libraries/base/System/IO.hs | 596 ++ libraries/base/System/IO/Error.hs | 337 + libraries/base/System/IO/Unsafe.hs | 50 + libraries/base/System/Info.hs | 51 + libraries/base/System/Mem.hs | 46 + libraries/base/System/Mem/StableName.hs | 105 + libraries/base/System/Mem/Weak.hs | 142 + libraries/base/System/Posix/Internals.hs | 632 ++ libraries/base/System/Posix/Types.hs | 177 + libraries/base/System/Timeout.hs | 121 + .../base/Text/ParserCombinators/ReadP.hs | 515 ++ .../base/Text/ParserCombinators/ReadPrec.hs | 173 + libraries/base/Text/Printf.hs | 898 +++ libraries/base/Text/Read.hs | 90 + libraries/base/Text/Read/Lex.hs | 572 ++ libraries/base/Text/Show.hs | 34 + libraries/base/Text/Show/Functions.hs | 26 + libraries/base/Unsafe/Coerce.hs | 62 + libraries/base/aclocal.m4 | 229 + libraries/base/base.buildinfo.in | 4 + libraries/base/base.cabal | 373 + libraries/base/cbits/DarwinUtils.c | 22 + libraries/base/cbits/PrelIOUtils.c | 45 + libraries/base/cbits/README.Unicode | 8 + libraries/base/cbits/SetEnv.c | 11 + libraries/base/cbits/WCsubst.c | 4748 ++++++++++++ libraries/base/cbits/Win32Utils.c | 151 + libraries/base/cbits/consUtils.c | 111 + libraries/base/cbits/iconv.c | 25 + libraries/base/cbits/inputReady.c | 172 + libraries/base/cbits/md5.c | 238 + libraries/base/cbits/primFloat.c | 532 ++ libraries/base/cbits/rts.c | 42 + libraries/base/cbits/sysconf.c | 19 + libraries/base/cbits/ubconfc | 345 + libraries/base/changelog.md | 504 ++ libraries/base/codepages/MakeTable.hs | 265 + libraries/base/codepages/Makefile | 19 + libraries/base/config.guess | 1420 ++++ libraries/base/config.sub | 1794 +++++ libraries/base/configure.ac | 216 + libraries/base/include/CTypes.h | 54 + libraries/base/include/EventConfig.h.in | 91 + libraries/base/include/HsBase.h | 559 ++ libraries/base/include/HsEvent.h | 41 + libraries/base/include/WCsubst.h | 25 + libraries/base/include/consUtils.h | 13 + libraries/base/include/ieee-flpt.h | 35 + libraries/base/include/md5.h | 24 + libraries/base/install-sh | 527 ++ libraries/base/prologue.txt | 3 + libraries/base/tests/.gitignore | 276 + libraries/base/tests/CPUTime001.hs | 26 + libraries/base/tests/CPUTime001.stdout | 4 + libraries/base/tests/CatEntail.hs | 27 + libraries/base/tests/CatPairs.hs | 34 + libraries/base/tests/Concurrent/4876.stdout | 1 + libraries/base/tests/Concurrent/Chan001.hs | 109 + .../base/tests/Concurrent/Chan001.stdout | 3 + libraries/base/tests/Concurrent/Chan002.hs | 19 + .../base/tests/Concurrent/Chan002.stdout | 1 + libraries/base/tests/Concurrent/Chan003.hs | 17 + .../base/tests/Concurrent/Chan003.stdout | 1 + libraries/base/tests/Concurrent/MVar001.hs | 148 + .../base/tests/Concurrent/MVar001.stdout | 6 + libraries/base/tests/Concurrent/Makefile | 7 + .../base/tests/Concurrent/ThreadDelay001.hs | 27 + libraries/base/tests/Concurrent/all.T | 7 + libraries/base/tests/IO/IOError001.hs | 9 + libraries/base/tests/IO/IOError001.stdout | 2 + libraries/base/tests/IO/IOError002.hs | 5 + libraries/base/tests/IO/IOError002.stdout | 1 + libraries/base/tests/IO/Makefile | 52 + libraries/base/tests/IO/T2122.hs | 77 + libraries/base/tests/IO/T3307.hs | 52 + libraries/base/tests/IO/T3307.stdout | 12 + libraries/base/tests/IO/T4144.hs | 114 + libraries/base/tests/IO/T4144.stdout | 1 + libraries/base/tests/IO/T4808.hs | 13 + libraries/base/tests/IO/T4808.stderr | 1 + libraries/base/tests/IO/T4808.stdout | 1 + libraries/base/tests/IO/T4855.hs | 3 + libraries/base/tests/IO/T4855.stderr | 1 + libraries/base/tests/IO/T4895.hs | 9 + libraries/base/tests/IO/T4895.stdout | 1 + libraries/base/tests/IO/T7853.hs | 28 + libraries/base/tests/IO/T7853.stdout | 11 + libraries/base/tests/IO/all.T | 159 + libraries/base/tests/IO/concio001.hs | 6 + libraries/base/tests/IO/concio001.stdout | 2 + libraries/base/tests/IO/concio001.thr.stdout | 2 + libraries/base/tests/IO/concio002.hs | 14 + libraries/base/tests/IO/concio002.stdout | 4 + libraries/base/tests/IO/countReaders001.hs | 17 + .../base/tests/IO/countReaders001.stdout | 1 + libraries/base/tests/IO/decodingerror001.hs | 22 + libraries/base/tests/IO/decodingerror001.in1 | 1 + libraries/base/tests/IO/decodingerror001.in2 | 1 + .../base/tests/IO/decodingerror001.stdout | 10 + libraries/base/tests/IO/decodingerror002.hs | 23 + libraries/base/tests/IO/decodingerror002.in | 1 + .../base/tests/IO/decodingerror002.stdout | 4 + .../tests/IO/encoded-data/CP1251-UTF8.txt | 34 + .../base/tests/IO/encoded-data/CP1251.txt | 34 + .../base/tests/IO/encoded-data/CP936-UTF8.txt | 153 + .../base/tests/IO/encoded-data/CP936.txt | 153 + libraries/base/tests/IO/encoding001.hs | 64 + libraries/base/tests/IO/encoding002.hs | 65 + libraries/base/tests/IO/encoding002.stdout | 61 + libraries/base/tests/IO/encoding003.hs | 23 + libraries/base/tests/IO/encoding003.stdout | 1 + libraries/base/tests/IO/encoding004.hs | 107 + libraries/base/tests/IO/encoding004.stdout | 3 + libraries/base/tests/IO/encoding005.hs | 115 + libraries/base/tests/IO/encoding005.stdout | 5 + libraries/base/tests/IO/encodingerror001.hs | 27 + .../base/tests/IO/encodingerror001.stdout | 36 + libraries/base/tests/IO/environment001.hs | 16 + libraries/base/tests/IO/environment001.stdout | 6 + libraries/base/tests/IO/finalization001.hs | 26 + .../base/tests/IO/finalization001.stdout | 200 + libraries/base/tests/IO/hClose001.hs | 8 + libraries/base/tests/IO/hClose001.stdout | 1 + libraries/base/tests/IO/hClose002.hs | 32 + libraries/base/tests/IO/hClose002.stdout | 4 + .../IO/hClose002.stdout-i386-unknown-solaris2 | 4 + .../hClose002.stdout-x86_64-unknown-solaris2 | 4 + libraries/base/tests/IO/hClose003.hs | 42 + libraries/base/tests/IO/hClose003.stdout | 4 + libraries/base/tests/IO/hDuplicateTo001.hs | 25 + .../base/tests/IO/hDuplicateTo001.stderr | 2 + libraries/base/tests/IO/hFileSize001.hs | 8 + libraries/base/tests/IO/hFileSize001.stdout | 1 + libraries/base/tests/IO/hFileSize002.hs | 36 + libraries/base/tests/IO/hFileSize002.stdout | 5 + libraries/base/tests/IO/hFlush001.hs | 32 + libraries/base/tests/IO/hFlush001.stdout | 2 + libraries/base/tests/IO/hGetBuf001.hs | 218 + libraries/base/tests/IO/hGetBuf001.stdout | 117 + libraries/base/tests/IO/hGetBuffering001.hs | 21 + .../base/tests/IO/hGetBuffering001.stdout | 7 + libraries/base/tests/IO/hGetChar001.hs | 18 + libraries/base/tests/IO/hGetChar001.stdin | 2 + libraries/base/tests/IO/hGetChar001.stdout | 1 + libraries/base/tests/IO/hGetLine001.hs | 25 + libraries/base/tests/IO/hGetLine001.stdout | 100 + libraries/base/tests/IO/hGetLine002.hs | 17 + libraries/base/tests/IO/hGetLine002.stdin | 1 + libraries/base/tests/IO/hGetLine002.stdout | 2 + libraries/base/tests/IO/hGetLine003.hs | 9 + libraries/base/tests/IO/hGetLine003.stdin | 1 + libraries/base/tests/IO/hGetLine003.stdout | 2 + libraries/base/tests/IO/hGetPosn001.hs | 28 + libraries/base/tests/IO/hGetPosn001.in | 2 + libraries/base/tests/IO/hGetPosn001.stdout | 5 + libraries/base/tests/IO/hIsEOF001.hs | 8 + libraries/base/tests/IO/hIsEOF001.stdout | 2 + libraries/base/tests/IO/hIsEOF002.hs | 48 + libraries/base/tests/IO/hIsEOF002.stdout | 16 + libraries/base/tests/IO/hReady001.hs | 12 + libraries/base/tests/IO/hReady001.stdout | 2 + libraries/base/tests/IO/hReady002.hs | 10 + libraries/base/tests/IO/hReady002.stdout | 1 + libraries/base/tests/IO/hSeek001.hs | 29 + libraries/base/tests/IO/hSeek001.in | 1 + libraries/base/tests/IO/hSeek001.stdout | 7 + libraries/base/tests/IO/hSeek002.hs | 25 + libraries/base/tests/IO/hSeek002.stdout | 5 + libraries/base/tests/IO/hSeek003.hs | 51 + libraries/base/tests/IO/hSeek003.stdout | 24 + libraries/base/tests/IO/hSeek004.hs | 8 + libraries/base/tests/IO/hSeek004.stdout | 1 + libraries/base/tests/IO/hSetBuffering002.hs | 6 + .../base/tests/IO/hSetBuffering002.stdout | 6 + libraries/base/tests/IO/hSetBuffering003.hs | 80 + .../base/tests/IO/hSetBuffering003.stderr | 1 + .../base/tests/IO/hSetBuffering003.stdout | 22 + libraries/base/tests/IO/hSetBuffering004.hs | 10 + .../base/tests/IO/hSetBuffering004.stdout | 2 + libraries/base/tests/IO/hSetEncoding001.hs | 49 + libraries/base/tests/IO/hSetEncoding001.in | Bin 0 -> 2076 bytes .../base/tests/IO/hSetEncoding001.stdout | 90 + libraries/base/tests/IO/hSetEncoding002.hs | 13 + .../base/tests/IO/hSetEncoding002.stdout | 1 + .../base/tests/IO/ioeGetErrorString001.hs | 13 + .../base/tests/IO/ioeGetErrorString001.stdout | 1 + libraries/base/tests/IO/ioeGetFileName001.hs | 12 + .../base/tests/IO/ioeGetFileName001.stdout | 1 + libraries/base/tests/IO/ioeGetHandle001.hs | 13 + .../base/tests/IO/ioeGetHandle001.stdout | 1 + libraries/base/tests/IO/isEOF001.hs | 3 + libraries/base/tests/IO/isEOF001.stdout | 1 + libraries/base/tests/IO/latin1 | 5 + libraries/base/tests/IO/misc001.hs | 24 + libraries/base/tests/IO/misc001.stdout | 0 libraries/base/tests/IO/newline001.hs | 121 + libraries/base/tests/IO/openFile001.hs | 11 + libraries/base/tests/IO/openFile001.stdout | 1 + libraries/base/tests/IO/openFile002.hs | 6 + libraries/base/tests/IO/openFile002.stderr | 1 + libraries/base/tests/IO/openFile003.hs | 17 + libraries/base/tests/IO/openFile003.stdout | 4 + .../base/tests/IO/openFile003.stdout-mingw32 | 4 + .../tests/IO/openFile003.stdout-mips-sgi-irix | 4 + .../IO/openFile003.stdout-sparc-sun-solaris2 | 4 + libraries/base/tests/IO/openFile004.hs | 23 + libraries/base/tests/IO/openFile004.stdout | 1 + libraries/base/tests/IO/openFile005.hs | 45 + libraries/base/tests/IO/openFile005.stdout | 12 + libraries/base/tests/IO/openFile006.hs | 14 + libraries/base/tests/IO/openFile006.stdout | 2 + libraries/base/tests/IO/openFile007.hs | 18 + libraries/base/tests/IO/openFile007.stdout | 2 + libraries/base/tests/IO/openFile008.hs | 22 + libraries/base/tests/IO/openTempFile001.hs | 13 + libraries/base/tests/IO/putStr001.hs | 6 + libraries/base/tests/IO/putStr001.stdout | 1 + libraries/base/tests/IO/readFile001.hs | 26 + libraries/base/tests/IO/readFile001.stdout | 30 + libraries/base/tests/IO/readwrite001.hs | 23 + libraries/base/tests/IO/readwrite001.stdout | 3 + libraries/base/tests/IO/readwrite002.hs | 49 + libraries/base/tests/IO/readwrite002.stdout | 9 + libraries/base/tests/IO/readwrite003.hs | 12 + libraries/base/tests/IO/readwrite003.stdout | 4 + libraries/base/tests/IO/utf8-test | 3 + libraries/base/tests/Makefile | 7 + libraries/base/tests/Memo1.lhs | 135 + libraries/base/tests/Memo2.lhs | 135 + libraries/base/tests/Numeric/Makefile | 7 + libraries/base/tests/Numeric/all.T | 21 + libraries/base/tests/Numeric/num001.hs | 6 + libraries/base/tests/Numeric/num001.stdout | 1 + libraries/base/tests/Numeric/num002.hs | 20 + libraries/base/tests/Numeric/num002.stdout | 6 + .../Numeric/num002.stdout-alpha-dec-osf3 | 6 + .../tests/Numeric/num002.stdout-mips-sgi-irix | 6 + .../base/tests/Numeric/num002.stdout-ws-64 | 6 + .../num002.stdout-x86_64-unknown-openbsd | 6 + libraries/base/tests/Numeric/num003.hs | 20 + libraries/base/tests/Numeric/num003.stdout | 6 + .../Numeric/num003.stdout-alpha-dec-osf3 | 6 + .../tests/Numeric/num003.stdout-mips-sgi-irix | 6 + .../base/tests/Numeric/num003.stdout-ws-64 | 6 + .../num003.stdout-x86_64-unknown-openbsd | 6 + libraries/base/tests/Numeric/num004.hs | 20 + libraries/base/tests/Numeric/num004.stdout | 6 + .../Numeric/num004.stdout-alpha-dec-osf3 | 6 + .../tests/Numeric/num004.stdout-mips-sgi-irix | 6 + .../base/tests/Numeric/num004.stdout-ws-64 | 6 + .../num004.stdout-x86_64-unknown-openbsd | 6 + libraries/base/tests/Numeric/num005.hs | 23 + libraries/base/tests/Numeric/num005.stdout | 55 + .../Numeric/num005.stdout-alpha-dec-osf3 | 55 + .../tests/Numeric/num005.stdout-mips-sgi-irix | 55 + .../base/tests/Numeric/num005.stdout-ws-64 | 55 + .../num005.stdout-x86_64-unknown-openbsd | 55 + libraries/base/tests/Numeric/num006.hs | 28 + libraries/base/tests/Numeric/num006.stdout | 6 + libraries/base/tests/Numeric/num007.hs | 17 + libraries/base/tests/Numeric/num007.stdout | 9 + libraries/base/tests/Numeric/num008.hs | 57 + libraries/base/tests/Numeric/num008.stdout | 148 + libraries/base/tests/Numeric/num009.hs | 37 + libraries/base/tests/Numeric/num009.stdout | 1 + .../num009.stdout-i386-unknown-mingw32 | 16 + libraries/base/tests/Numeric/num010.hs | 29 + libraries/base/tests/Numeric/num010.stdout | 189 + libraries/base/tests/System/Makefile | 7 + libraries/base/tests/System/T5930.hs | 10 + libraries/base/tests/System/T5930.stdout | 2 + libraries/base/tests/System/Timeout001.hs | 10 + libraries/base/tests/System/all.T | 9 + libraries/base/tests/System/exitWith001.hs | 3 + .../base/tests/System/exitWith001.stdout | 0 libraries/base/tests/System/getArgs001.hs | 8 + libraries/base/tests/System/getArgs001.stdout | 1 + libraries/base/tests/System/getEnv001.hs | 15 + libraries/base/tests/System/getEnv001.stdout | 2 + libraries/base/tests/System/system001.hs | 18 + libraries/base/tests/System/system001.stdout | 18 + libraries/base/tests/T10149.hs | 19 + libraries/base/tests/T10149.stdout | 4 + libraries/base/tests/T11334a.hs | 11 + libraries/base/tests/T11334a.stdout | 3 + libraries/base/tests/T11555.hs | 9 + libraries/base/tests/T11555.stdout | 1 + libraries/base/tests/T2528.hs | 27 + libraries/base/tests/T2528.stdout | 4 + libraries/base/tests/T4006.hs | 8 + libraries/base/tests/T4006.stdout | 2 + libraries/base/tests/T5943.hs | 36 + libraries/base/tests/T5943.stdout | 7 + libraries/base/tests/T5962.hs | 8 + libraries/base/tests/T5962.stdout | 1 + libraries/base/tests/T7034.hs | 11 + libraries/base/tests/T7034.stdout | 6 + libraries/base/tests/T7457.hs | 2 + libraries/base/tests/T7457.stdout | 1 + libraries/base/tests/T7653.hs | 7 + libraries/base/tests/T7773.hs | 9 + libraries/base/tests/T7773.stdout | 2 + libraries/base/tests/T7787.hs | 8 + libraries/base/tests/T7787.stdout | 1 + libraries/base/tests/T8089.hs | 4 + libraries/base/tests/T8766.hs | 4 + libraries/base/tests/T8766.stdout | 1 + libraries/base/tests/T9111.hs | 10 + libraries/base/tests/T9395.hs | 2 + libraries/base/tests/T9395.stderr | 2 + libraries/base/tests/T9532.hs | 89 + libraries/base/tests/T9532.stdout | 1 + libraries/base/tests/T9586.hs | 8 + libraries/base/tests/T9681.hs | 3 + libraries/base/tests/T9681.stderr | 5 + libraries/base/tests/T9826.hs | 24 + libraries/base/tests/T9826.stdout | 1 + libraries/base/tests/T9848.hs | 14 + libraries/base/tests/T9848.stdout | 2 + libraries/base/tests/Text.Printf/Makefile | 7 + libraries/base/tests/Text.Printf/T1548.hs | 11 + libraries/base/tests/Text.Printf/T1548.stdout | 3 + libraries/base/tests/Text.Printf/all.T | 1 + libraries/base/tests/addr001.hs | 10 + libraries/base/tests/addr001.stdout | 2 + .../base/tests/addr001.stdout-alpha-dec-osf3 | 2 + .../base/tests/addr001.stdout-mips-sgi-irix | 2 + libraries/base/tests/addr001.stdout-ws-64 | 2 + .../addr001.stdout-x86_64-unknown-openbsd | 2 + libraries/base/tests/all.T | 215 + libraries/base/tests/assert.hs | 9 + libraries/base/tests/assert.stderr | 3 + libraries/base/tests/char001.hs | 43 + libraries/base/tests/char001.stdout | 18 + libraries/base/tests/char002.hs | 7 + libraries/base/tests/char002.stdout | 4 + libraries/base/tests/cstring001.hs | 18 + libraries/base/tests/data-fixed-show-read.hs | 29 + .../base/tests/data-fixed-show-read.stdout | 20 + libraries/base/tests/dynamic001.hs | 107 + libraries/base/tests/dynamic001.stdout | 42 + libraries/base/tests/dynamic002.hs | 91 + libraries/base/tests/dynamic002.stdout | 64 + libraries/base/tests/dynamic003.hs | 12 + libraries/base/tests/dynamic003.stdout | 1 + libraries/base/tests/dynamic004.hs | 36 + libraries/base/tests/dynamic004.stdout | 1 + libraries/base/tests/dynamic005.hs | 14 + libraries/base/tests/dynamic005.stdout | 1 + libraries/base/tests/echo001.hs | 13 + libraries/base/tests/echo001.stdout | 14 + libraries/base/tests/enum01.hs | 529 ++ libraries/base/tests/enum01.stdout | 246 + .../base/tests/enum01.stdout-alpha-dec-osf3 | 230 + libraries/base/tests/enum01.stdout-ws-64 | 246 + libraries/base/tests/enum02.hs | 266 + libraries/base/tests/enum02.stdout | 141 + .../base/tests/enum02.stdout-alpha-dec-osf3 | 141 + .../base/tests/enum02.stdout-mips-sgi-irix | 141 + libraries/base/tests/enum02.stdout-ws-64 | 141 + .../enum02.stdout-x86_64-unknown-openbsd | 141 + libraries/base/tests/enum03.hs | 269 + libraries/base/tests/enum03.stdout | 142 + .../base/tests/enum03.stdout-alpha-dec-osf3 | 142 + .../base/tests/enum03.stdout-mips-sgi-irix | 142 + libraries/base/tests/enum03.stdout-ws-64 | 142 + .../enum03.stdout-x86_64-unknown-openbsd | 142 + libraries/base/tests/enum04.hs | 14 + libraries/base/tests/enum04.stdout | 4 + libraries/base/tests/enumDouble.hs | 3 + libraries/base/tests/enumDouble.stdout | 1 + libraries/base/tests/enumRatio.hs | 3 + libraries/base/tests/enumRatio.stdout | 1 + libraries/base/tests/enum_processor.py | 28 + libraries/base/tests/exceptionsrun001.hs | 46 + libraries/base/tests/exceptionsrun001.stdout | 5 + libraries/base/tests/exceptionsrun002.hs | 95 + libraries/base/tests/exceptionsrun002.stdout | 40 + libraries/base/tests/fixed.hs | 19 + libraries/base/tests/fixed.stdout | 72 + libraries/base/tests/foldableArray.hs | 129 + libraries/base/tests/foldableArray.stdout | 13 + libraries/base/tests/genericNegative001.hs | 8 + .../base/tests/genericNegative001.stdout | 3 + libraries/base/tests/hGetBuf002.hs | 22 + libraries/base/tests/hGetBuf002.stdout | 44 + libraries/base/tests/hGetBuf003.hs | 26 + libraries/base/tests/hGetBuf003.stdout | 52 + libraries/base/tests/hPutBuf001.hs | 7 + libraries/base/tests/hPutBuf001.stdout | 1 + libraries/base/tests/hPutBuf002.hs | 9 + libraries/base/tests/hPutBuf002.stdout | 1 + libraries/base/tests/hTell001.hs | 63 + libraries/base/tests/hTell001.stdout | 38 + libraries/base/tests/hTell002.hs | 33 + libraries/base/tests/hTell002.stdout | Bin 0 -> 51 bytes libraries/base/tests/inits.hs | 28 + libraries/base/tests/ioref001.hs | 9 + libraries/base/tests/ioref001.stdout | 1 + libraries/base/tests/isSuffixOf.hs | 10 + libraries/base/tests/isSuffixOf.stdout | 84 + libraries/base/tests/ix001.hs | 4 + libraries/base/tests/ix001.stdout | 1 + libraries/base/tests/length001.hs | 8 + libraries/base/tests/length001.stdout | 2 + libraries/base/tests/lex001.hs | 39 + libraries/base/tests/lex001.stdout | 84 + libraries/base/tests/list001.hs | 152 + libraries/base/tests/list001.stdout | 54 + libraries/base/tests/list002.hs | 6 + libraries/base/tests/list002.stdout | 1 + libraries/base/tests/list003.hs | 7 + libraries/base/tests/list003.stdout | 1 + libraries/base/tests/memo001.hs | 19 + libraries/base/tests/memo001.stdout | 1 + libraries/base/tests/memo002.hs | 30 + libraries/base/tests/memo002.stdout | 44 + libraries/base/tests/packedstring001.hs | 11 + libraries/base/tests/packedstring001.stdout | 1 + libraries/base/tests/performGC001.hs | 5 + libraries/base/tests/performGC001.stdout | 0 libraries/base/tests/qsem001.hs | 87 + libraries/base/tests/qsem001.stdout | 5 + libraries/base/tests/qsemn001.hs | 109 + libraries/base/tests/qsemn001.stdout | 5 + libraries/base/tests/quotOverflow.hs | 33 + libraries/base/tests/quotOverflow.stdout | 45 + libraries/base/tests/rand001.hs | 22 + libraries/base/tests/rand001.stdout | 5 + libraries/base/tests/ratio001.hs | 4 + libraries/base/tests/ratio001.stdout | 1 + libraries/base/tests/readDouble001.hs | 11 + libraries/base/tests/readDouble001.stdout | 6 + libraries/base/tests/readFixed001.hs | 13 + libraries/base/tests/readFixed001.stdout | 6 + libraries/base/tests/readFloat.hs | 5 + libraries/base/tests/readFloat.stderr | 1 + libraries/base/tests/readInteger001.hs | 7 + libraries/base/tests/readInteger001.stdout | 2 + libraries/base/tests/readLitChar.hs | 12 + libraries/base/tests/readLitChar.stdout | 4 + libraries/base/tests/reads001.hs | 10 + libraries/base/tests/reads001.stdout | 4 + libraries/base/tests/show001.hs | 24 + libraries/base/tests/show001.stdout | 15 + libraries/base/tests/showDouble.hs | 41 + libraries/base/tests/showDouble.stdout | 22 + libraries/base/tests/stableptr001.hs | 19 + libraries/base/tests/stableptr001.stdout | 1 + libraries/base/tests/stableptr003.hs | 16 + libraries/base/tests/stableptr004.hs | 12 + libraries/base/tests/stableptr004.stdout | 2 + libraries/base/tests/stableptr005.hs | 22 + libraries/base/tests/stableptr005.stdout | 1 + libraries/base/tests/take001.hs | 5 + libraries/base/tests/take001.stdout | 1 + libraries/base/tests/tempfiles.hs | 36 + libraries/base/tests/tempfiles.stdout | 12 + libraries/base/tests/text001.hs | 15 + libraries/base/tests/text001.stdout | 1 + libraries/base/tests/topHandler01.hs | 16 + libraries/base/tests/topHandler01.stdout | 1 + libraries/base/tests/topHandler02.hs | 7 + libraries/base/tests/topHandler03.hs | 8 + libraries/base/tests/topHandler04.hs | 5 + libraries/base/tests/topHandler04.stderr | 2 + libraries/base/tests/trace001.hs | 10 + libraries/base/tests/trace001.stderr | 14 + libraries/base/tests/trace001.stdout | 1 + libraries/base/tests/tup001.hs | 33 + libraries/base/tests/tup001.stdout | 7 + libraries/base/tests/unicode001.hs | 46 + libraries/base/tests/unicode001.stdout | 14 + libraries/base/tests/unicode002.hs | 44 + libraries/base/tests/unicode002.stdout | 6555 +++++++++++++++++ libraries/base/tests/weak001.hs | 12 + libraries/ghc-prim/.gitignore | 4 + libraries/ghc-prim/GHC/CString.hs | 150 + libraries/ghc-prim/GHC/Classes.hs | 785 ++ libraries/ghc-prim/GHC/Debug.hs | 48 + libraries/ghc-prim/GHC/IntWord64.hs | 74 + libraries/ghc-prim/GHC/Magic.hs | 101 + libraries/ghc-prim/GHC/Prim.hs.tmp | 0 libraries/ghc-prim/GHC/Tuple.hs | 247 + .../ghc-prim}/GHC/Types.hs | 9 + libraries/ghc-prim/GHC/Types.source-stats | 18 + libraries/ghc-prim/LICENSE | 62 + libraries/ghc-prim/Setup.hs | 88 + libraries/ghc-prim/cbits/atomic.c | 320 + libraries/ghc-prim/cbits/bswap.c | 27 + libraries/ghc-prim/cbits/clz.c | 41 + libraries/ghc-prim/cbits/ctz.c | 57 + libraries/ghc-prim/cbits/debug.c | 10 + libraries/ghc-prim/cbits/longlong.c | 89 + libraries/ghc-prim/cbits/popcnt.c | 87 + libraries/ghc-prim/cbits/word2float.c | 15 + libraries/ghc-prim/changelog.md | 38 + libraries/ghc-prim/ghc-prim.cabal | 85 + libraries/ghc-prim/tests/T6026.hs | 10 + libraries/ghc-prim/tests/T6026.stdout | 1 + 715 files changed, 90264 insertions(+), 12 deletions(-) create mode 100644 libraries/base/.authorspellings create mode 100644 libraries/base/.gitignore create mode 100644 libraries/base/Control/Applicative.hs create mode 100644 libraries/base/Control/Arrow.hs create mode 100644 libraries/base/Control/Category.hs create mode 100644 libraries/base/Control/Concurrent.hs create mode 100644 libraries/base/Control/Concurrent/Chan.hs create mode 100644 libraries/base/Control/Concurrent/MVar.hs create mode 100644 libraries/base/Control/Concurrent/QSem.hs create mode 100644 libraries/base/Control/Concurrent/QSemN.hs create mode 100644 libraries/base/Control/Exception.hs create mode 100644 libraries/base/Control/Exception/Base.hs create mode 100644 libraries/base/Control/Monad.hs create mode 100644 libraries/base/Control/Monad/Fail.hs create mode 100644 libraries/base/Control/Monad/Fix.hs create mode 100644 libraries/base/Control/Monad/IO/Class.hs create mode 100644 libraries/base/Control/Monad/Instances.hs create mode 100644 libraries/base/Control/Monad/ST.hs create mode 100644 libraries/base/Control/Monad/ST/Imp.hs create mode 100644 libraries/base/Control/Monad/ST/Lazy.hs create mode 100644 libraries/base/Control/Monad/ST/Lazy/Imp.hs create mode 100644 libraries/base/Control/Monad/ST/Lazy/Safe.hs create mode 100644 libraries/base/Control/Monad/ST/Lazy/Unsafe.hs create mode 100644 libraries/base/Control/Monad/ST/Safe.hs create mode 100644 libraries/base/Control/Monad/ST/Strict.hs create mode 100644 libraries/base/Control/Monad/ST/Unsafe.hs create mode 100644 libraries/base/Control/Monad/Zip.hs create mode 100644 libraries/base/Data/Bifunctor.hs create mode 100644 libraries/base/Data/Bits.hs create mode 100644 libraries/base/Data/Bool.hs create mode 100644 libraries/base/Data/Char.hs create mode 100644 libraries/base/Data/Coerce.hs create mode 100644 libraries/base/Data/Complex.hs create mode 100644 libraries/base/Data/Data.hs create mode 100644 libraries/base/Data/Dynamic.hs create mode 100644 libraries/base/Data/Either.hs create mode 100644 libraries/base/Data/Eq.hs create mode 100644 libraries/base/Data/Fixed.hs create mode 100644 libraries/base/Data/Foldable.hs create mode 100644 libraries/base/Data/Function.hs create mode 100644 libraries/base/Data/Functor.hs create mode 100644 libraries/base/Data/Functor/Classes.hs create mode 100644 libraries/base/Data/Functor/Compose.hs create mode 100644 libraries/base/Data/Functor/Const.hs create mode 100644 libraries/base/Data/Functor/Identity.hs create mode 100644 libraries/base/Data/Functor/Product.hs create mode 100644 libraries/base/Data/Functor/Sum.hs create mode 100644 libraries/base/Data/IORef.hs create mode 100644 libraries/base/Data/Int.hs create mode 100644 libraries/base/Data/Ix.hs create mode 100644 libraries/base/Data/Kind.hs create mode 100644 libraries/base/Data/List.hs create mode 100644 libraries/base/Data/List/NonEmpty.hs create mode 100644 libraries/base/Data/Maybe.hs create mode 100644 libraries/base/Data/Monoid.hs create mode 100644 libraries/base/Data/OldList.hs create mode 100644 libraries/base/Data/Ord.hs create mode 100644 libraries/base/Data/Proxy.hs create mode 100644 libraries/base/Data/Ratio.hs create mode 100644 libraries/base/Data/STRef.hs create mode 100644 libraries/base/Data/STRef/Lazy.hs create mode 100644 libraries/base/Data/STRef/Strict.hs create mode 100644 libraries/base/Data/Semigroup.hs create mode 100644 libraries/base/Data/String.hs create mode 100644 libraries/base/Data/Traversable.hs create mode 100644 libraries/base/Data/Tuple.hs create mode 100644 libraries/base/Data/Type/Bool.hs create mode 100644 libraries/base/Data/Type/Coercion.hs create mode 100644 libraries/base/Data/Type/Equality.hs create mode 100644 libraries/base/Data/Typeable.hs create mode 100644 libraries/base/Data/Typeable/Internal.hs create mode 100644 libraries/base/Data/Unique.hs create mode 100644 libraries/base/Data/Version.hs create mode 100644 libraries/base/Data/Void.hs create mode 100644 libraries/base/Data/Word.hs create mode 100644 libraries/base/Debug/Trace.hs create mode 100644 libraries/base/Foreign.hs create mode 100644 libraries/base/Foreign/C.hs create mode 100644 libraries/base/Foreign/C/Error.hs create mode 100644 libraries/base/Foreign/C/String.hs create mode 100644 libraries/base/Foreign/C/Types.hs create mode 100644 libraries/base/Foreign/Concurrent.hs create mode 100644 libraries/base/Foreign/ForeignPtr.hs create mode 100644 libraries/base/Foreign/ForeignPtr/Imp.hs create mode 100644 libraries/base/Foreign/ForeignPtr/Safe.hs create mode 100644 libraries/base/Foreign/ForeignPtr/Unsafe.hs create mode 100644 libraries/base/Foreign/Marshal.hs create mode 100644 libraries/base/Foreign/Marshal/Alloc.hs create mode 100644 libraries/base/Foreign/Marshal/Array.hs create mode 100644 libraries/base/Foreign/Marshal/Error.hs create mode 100644 libraries/base/Foreign/Marshal/Pool.hs create mode 100644 libraries/base/Foreign/Marshal/Safe.hs create mode 100644 libraries/base/Foreign/Marshal/Unsafe.hs create mode 100644 libraries/base/Foreign/Marshal/Utils.hs create mode 100644 libraries/base/Foreign/Ptr.hs create mode 100644 libraries/base/Foreign/Safe.hs create mode 100644 libraries/base/Foreign/StablePtr.hs create mode 100644 libraries/base/Foreign/Storable.hs create mode 100644 libraries/base/GHC/Arr.hs create mode 100644 libraries/base/GHC/Base.hs create mode 100644 libraries/base/GHC/Char.hs create mode 100644 libraries/base/GHC/Conc.hs create mode 100644 libraries/base/GHC/Conc/IO.hs create mode 100644 libraries/base/GHC/Conc/Signal.hs create mode 100644 libraries/base/GHC/Conc/Sync.hs create mode 100644 libraries/base/GHC/Conc/Windows.hs create mode 100644 libraries/base/GHC/ConsoleHandler.hs create mode 100644 libraries/base/GHC/Constants.hs create mode 100644 libraries/base/GHC/Desugar.hs create mode 100644 libraries/base/GHC/Enum.hs create mode 100644 libraries/base/GHC/Environment.hs create mode 100644 libraries/base/GHC/Err.hs create mode 100644 libraries/base/GHC/Event.hs create mode 100644 libraries/base/GHC/Event/Arr.hs create mode 100644 libraries/base/GHC/Event/Array.hs create mode 100644 libraries/base/GHC/Event/Clock.hsc create mode 100644 libraries/base/GHC/Event/Control.hs create mode 100644 libraries/base/GHC/Event/EPoll.hsc create mode 100644 libraries/base/GHC/Event/IntTable.hs create mode 100644 libraries/base/GHC/Event/Internal.hs create mode 100644 libraries/base/GHC/Event/KQueue.hsc create mode 100644 libraries/base/GHC/Event/Manager.hs create mode 100644 libraries/base/GHC/Event/PSQ.hs create mode 100644 libraries/base/GHC/Event/Poll.hsc create mode 100644 libraries/base/GHC/Event/Thread.hs create mode 100644 libraries/base/GHC/Event/TimerManager.hs create mode 100644 libraries/base/GHC/Event/Unique.hs create mode 100644 libraries/base/GHC/Exception.hs create mode 100644 libraries/base/GHC/Exception.hs-boot create mode 100644 libraries/base/GHC/ExecutionStack.hs create mode 100644 libraries/base/GHC/ExecutionStack/Internal.hsc create mode 100755 libraries/base/GHC/Exts.hs create mode 100644 libraries/base/GHC/Fingerprint.hs create mode 100644 libraries/base/GHC/Fingerprint.hs-boot create mode 100644 libraries/base/GHC/Fingerprint/Type.hs create mode 100644 libraries/base/GHC/Float.hs create mode 100644 libraries/base/GHC/Float/ConversionUtils.hs create mode 100644 libraries/base/GHC/Float/RealFracMethods.hs create mode 100644 libraries/base/GHC/Foreign.hs create mode 100644 libraries/base/GHC/ForeignPtr.hs create mode 100644 libraries/base/GHC/GHCi.hs create mode 100644 libraries/base/GHC/Generics.hs create mode 100644 libraries/base/GHC/IO.hs create mode 100644 libraries/base/GHC/IO.hs-boot create mode 100644 libraries/base/GHC/IO/Buffer.hs create mode 100644 libraries/base/GHC/IO/BufferedIO.hs create mode 100644 libraries/base/GHC/IO/Device.hs create mode 100644 libraries/base/GHC/IO/Encoding.hs create mode 100644 libraries/base/GHC/IO/Encoding.hs-boot create mode 100644 libraries/base/GHC/IO/Encoding/CodePage.hs create mode 100644 libraries/base/GHC/IO/Encoding/CodePage/API.hs create mode 100644 libraries/base/GHC/IO/Encoding/CodePage/Table.hs create mode 100644 libraries/base/GHC/IO/Encoding/Failure.hs create mode 100644 libraries/base/GHC/IO/Encoding/Iconv.hs create mode 100644 libraries/base/GHC/IO/Encoding/Latin1.hs create mode 100644 libraries/base/GHC/IO/Encoding/Types.hs create mode 100644 libraries/base/GHC/IO/Encoding/UTF16.hs create mode 100644 libraries/base/GHC/IO/Encoding/UTF32.hs create mode 100644 libraries/base/GHC/IO/Encoding/UTF8.hs create mode 100644 libraries/base/GHC/IO/Exception.hs create mode 100644 libraries/base/GHC/IO/Exception.hs-boot create mode 100644 libraries/base/GHC/IO/FD.hs create mode 100644 libraries/base/GHC/IO/Handle.hs create mode 100644 libraries/base/GHC/IO/Handle.hs-boot create mode 100644 libraries/base/GHC/IO/Handle/FD.hs create mode 100644 libraries/base/GHC/IO/Handle/FD.hs-boot create mode 100644 libraries/base/GHC/IO/Handle/Internals.hs create mode 100644 libraries/base/GHC/IO/Handle/Text.hs create mode 100644 libraries/base/GHC/IO/Handle/Types.hs create mode 100644 libraries/base/GHC/IO/IOMode.hs create mode 100644 libraries/base/GHC/IO/Unsafe.hs create mode 100644 libraries/base/GHC/IOArray.hs create mode 100644 libraries/base/GHC/IORef.hs create mode 100644 libraries/base/GHC/Int.hs create mode 100644 libraries/base/GHC/List.hs create mode 100644 libraries/base/GHC/MVar.hs create mode 100644 libraries/base/GHC/Natural.hs create mode 100644 libraries/base/GHC/Num.hs create mode 100644 libraries/base/GHC/OldList.hs create mode 100644 libraries/base/GHC/OverloadedLabels.hs create mode 100644 libraries/base/GHC/PArr.hs create mode 100644 libraries/base/GHC/Pack.hs create mode 100644 libraries/base/GHC/Profiling.hs create mode 100644 libraries/base/GHC/Ptr.hs create mode 100644 libraries/base/GHC/RTS/Flags.hsc create mode 100644 libraries/base/GHC/Read.hs create mode 100644 libraries/base/GHC/Real.hs create mode 100644 libraries/base/GHC/ST.hs create mode 100644 libraries/base/GHC/STRef.hs create mode 100644 libraries/base/GHC/Show.hs create mode 100644 libraries/base/GHC/Stable.hs create mode 100644 libraries/base/GHC/Stack.hs create mode 100644 libraries/base/GHC/Stack/CCS.hs-boot create mode 100644 libraries/base/GHC/Stack/CCS.hsc create mode 100644 libraries/base/GHC/Stack/Types.hs create mode 100644 libraries/base/GHC/StaticPtr.hs create mode 100644 libraries/base/GHC/Stats.hsc create mode 100644 libraries/base/GHC/Storable.hs create mode 100644 libraries/base/GHC/TopHandler.hs create mode 100644 libraries/base/GHC/TypeLits.hs create mode 100644 libraries/base/GHC/Unicode.hs create mode 100644 libraries/base/GHC/Weak.hs create mode 100644 libraries/base/GHC/Windows.hs create mode 100644 libraries/base/GHC/Word.hs create mode 100644 libraries/base/LICENSE create mode 100644 libraries/base/Numeric.hs create mode 100644 libraries/base/Numeric/Natural.hs create mode 100644 libraries/base/Prelude.hs create mode 100644 libraries/base/Setup.hs create mode 100644 libraries/base/System/CPUTime.hsc create mode 100644 libraries/base/System/Console/GetOpt.hs create mode 100644 libraries/base/System/Environment.hs create mode 100644 libraries/base/System/Environment/ExecutablePath.hsc create mode 100644 libraries/base/System/Exit.hs create mode 100644 libraries/base/System/IO.hs create mode 100644 libraries/base/System/IO/Error.hs create mode 100644 libraries/base/System/IO/Unsafe.hs create mode 100644 libraries/base/System/Info.hs create mode 100644 libraries/base/System/Mem.hs create mode 100644 libraries/base/System/Mem/StableName.hs create mode 100644 libraries/base/System/Mem/Weak.hs create mode 100644 libraries/base/System/Posix/Internals.hs create mode 100644 libraries/base/System/Posix/Types.hs create mode 100644 libraries/base/System/Timeout.hs create mode 100644 libraries/base/Text/ParserCombinators/ReadP.hs create mode 100644 libraries/base/Text/ParserCombinators/ReadPrec.hs create mode 100644 libraries/base/Text/Printf.hs create mode 100644 libraries/base/Text/Read.hs create mode 100644 libraries/base/Text/Read/Lex.hs create mode 100644 libraries/base/Text/Show.hs create mode 100644 libraries/base/Text/Show/Functions.hs create mode 100644 libraries/base/Unsafe/Coerce.hs create mode 100644 libraries/base/aclocal.m4 create mode 100644 libraries/base/base.buildinfo.in create mode 100644 libraries/base/base.cabal create mode 100644 libraries/base/cbits/DarwinUtils.c create mode 100644 libraries/base/cbits/PrelIOUtils.c create mode 100644 libraries/base/cbits/README.Unicode create mode 100644 libraries/base/cbits/SetEnv.c create mode 100644 libraries/base/cbits/WCsubst.c create mode 100644 libraries/base/cbits/Win32Utils.c create mode 100644 libraries/base/cbits/consUtils.c create mode 100644 libraries/base/cbits/iconv.c create mode 100644 libraries/base/cbits/inputReady.c create mode 100644 libraries/base/cbits/md5.c create mode 100644 libraries/base/cbits/primFloat.c create mode 100644 libraries/base/cbits/rts.c create mode 100644 libraries/base/cbits/sysconf.c create mode 100644 libraries/base/cbits/ubconfc create mode 100644 libraries/base/changelog.md create mode 100644 libraries/base/codepages/MakeTable.hs create mode 100644 libraries/base/codepages/Makefile create mode 100644 libraries/base/config.guess create mode 100644 libraries/base/config.sub create mode 100644 libraries/base/configure.ac create mode 100644 libraries/base/include/CTypes.h create mode 100644 libraries/base/include/EventConfig.h.in create mode 100644 libraries/base/include/HsBase.h create mode 100644 libraries/base/include/HsEvent.h create mode 100644 libraries/base/include/WCsubst.h create mode 100644 libraries/base/include/consUtils.h create mode 100644 libraries/base/include/ieee-flpt.h create mode 100644 libraries/base/include/md5.h create mode 100644 libraries/base/install-sh create mode 100644 libraries/base/prologue.txt create mode 100644 libraries/base/tests/.gitignore create mode 100644 libraries/base/tests/CPUTime001.hs create mode 100644 libraries/base/tests/CPUTime001.stdout create mode 100644 libraries/base/tests/CatEntail.hs create mode 100644 libraries/base/tests/CatPairs.hs create mode 100644 libraries/base/tests/Concurrent/4876.stdout create mode 100644 libraries/base/tests/Concurrent/Chan001.hs create mode 100644 libraries/base/tests/Concurrent/Chan001.stdout create mode 100644 libraries/base/tests/Concurrent/Chan002.hs create mode 100644 libraries/base/tests/Concurrent/Chan002.stdout create mode 100644 libraries/base/tests/Concurrent/Chan003.hs create mode 100644 libraries/base/tests/Concurrent/Chan003.stdout create mode 100644 libraries/base/tests/Concurrent/MVar001.hs create mode 100644 libraries/base/tests/Concurrent/MVar001.stdout create mode 100644 libraries/base/tests/Concurrent/Makefile create mode 100644 libraries/base/tests/Concurrent/ThreadDelay001.hs create mode 100644 libraries/base/tests/Concurrent/all.T create mode 100644 libraries/base/tests/IO/IOError001.hs create mode 100644 libraries/base/tests/IO/IOError001.stdout create mode 100644 libraries/base/tests/IO/IOError002.hs create mode 100644 libraries/base/tests/IO/IOError002.stdout create mode 100644 libraries/base/tests/IO/Makefile create mode 100644 libraries/base/tests/IO/T2122.hs create mode 100644 libraries/base/tests/IO/T3307.hs create mode 100644 libraries/base/tests/IO/T3307.stdout create mode 100644 libraries/base/tests/IO/T4144.hs create mode 100644 libraries/base/tests/IO/T4144.stdout create mode 100644 libraries/base/tests/IO/T4808.hs create mode 100644 libraries/base/tests/IO/T4808.stderr create mode 100644 libraries/base/tests/IO/T4808.stdout create mode 100644 libraries/base/tests/IO/T4855.hs create mode 100644 libraries/base/tests/IO/T4855.stderr create mode 100644 libraries/base/tests/IO/T4895.hs create mode 100644 libraries/base/tests/IO/T4895.stdout create mode 100644 libraries/base/tests/IO/T7853.hs create mode 100644 libraries/base/tests/IO/T7853.stdout create mode 100644 libraries/base/tests/IO/all.T create mode 100644 libraries/base/tests/IO/concio001.hs create mode 100644 libraries/base/tests/IO/concio001.stdout create mode 100644 libraries/base/tests/IO/concio001.thr.stdout create mode 100644 libraries/base/tests/IO/concio002.hs create mode 100644 libraries/base/tests/IO/concio002.stdout create mode 100644 libraries/base/tests/IO/countReaders001.hs create mode 100644 libraries/base/tests/IO/countReaders001.stdout create mode 100644 libraries/base/tests/IO/decodingerror001.hs create mode 100644 libraries/base/tests/IO/decodingerror001.in1 create mode 100644 libraries/base/tests/IO/decodingerror001.in2 create mode 100644 libraries/base/tests/IO/decodingerror001.stdout create mode 100644 libraries/base/tests/IO/decodingerror002.hs create mode 100644 libraries/base/tests/IO/decodingerror002.in create mode 100644 libraries/base/tests/IO/decodingerror002.stdout create mode 100644 libraries/base/tests/IO/encoded-data/CP1251-UTF8.txt create mode 100644 libraries/base/tests/IO/encoded-data/CP1251.txt create mode 100644 libraries/base/tests/IO/encoded-data/CP936-UTF8.txt create mode 100644 libraries/base/tests/IO/encoded-data/CP936.txt create mode 100644 libraries/base/tests/IO/encoding001.hs create mode 100644 libraries/base/tests/IO/encoding002.hs create mode 100644 libraries/base/tests/IO/encoding002.stdout create mode 100644 libraries/base/tests/IO/encoding003.hs create mode 100644 libraries/base/tests/IO/encoding003.stdout create mode 100644 libraries/base/tests/IO/encoding004.hs create mode 100644 libraries/base/tests/IO/encoding004.stdout create mode 100644 libraries/base/tests/IO/encoding005.hs create mode 100644 libraries/base/tests/IO/encoding005.stdout create mode 100644 libraries/base/tests/IO/encodingerror001.hs create mode 100644 libraries/base/tests/IO/encodingerror001.stdout create mode 100644 libraries/base/tests/IO/environment001.hs create mode 100644 libraries/base/tests/IO/environment001.stdout create mode 100644 libraries/base/tests/IO/finalization001.hs create mode 100644 libraries/base/tests/IO/finalization001.stdout create mode 100644 libraries/base/tests/IO/hClose001.hs create mode 100644 libraries/base/tests/IO/hClose001.stdout create mode 100644 libraries/base/tests/IO/hClose002.hs create mode 100644 libraries/base/tests/IO/hClose002.stdout create mode 100644 libraries/base/tests/IO/hClose002.stdout-i386-unknown-solaris2 create mode 100644 libraries/base/tests/IO/hClose002.stdout-x86_64-unknown-solaris2 create mode 100644 libraries/base/tests/IO/hClose003.hs create mode 100644 libraries/base/tests/IO/hClose003.stdout create mode 100644 libraries/base/tests/IO/hDuplicateTo001.hs create mode 100644 libraries/base/tests/IO/hDuplicateTo001.stderr create mode 100644 libraries/base/tests/IO/hFileSize001.hs create mode 100644 libraries/base/tests/IO/hFileSize001.stdout create mode 100644 libraries/base/tests/IO/hFileSize002.hs create mode 100644 libraries/base/tests/IO/hFileSize002.stdout create mode 100644 libraries/base/tests/IO/hFlush001.hs create mode 100644 libraries/base/tests/IO/hFlush001.stdout create mode 100644 libraries/base/tests/IO/hGetBuf001.hs create mode 100644 libraries/base/tests/IO/hGetBuf001.stdout create mode 100644 libraries/base/tests/IO/hGetBuffering001.hs create mode 100644 libraries/base/tests/IO/hGetBuffering001.stdout create mode 100644 libraries/base/tests/IO/hGetChar001.hs create mode 100644 libraries/base/tests/IO/hGetChar001.stdin create mode 100644 libraries/base/tests/IO/hGetChar001.stdout create mode 100644 libraries/base/tests/IO/hGetLine001.hs create mode 100644 libraries/base/tests/IO/hGetLine001.stdout create mode 100644 libraries/base/tests/IO/hGetLine002.hs create mode 100644 libraries/base/tests/IO/hGetLine002.stdin create mode 100644 libraries/base/tests/IO/hGetLine002.stdout create mode 100644 libraries/base/tests/IO/hGetLine003.hs create mode 100644 libraries/base/tests/IO/hGetLine003.stdin create mode 100644 libraries/base/tests/IO/hGetLine003.stdout create mode 100644 libraries/base/tests/IO/hGetPosn001.hs create mode 100644 libraries/base/tests/IO/hGetPosn001.in create mode 100644 libraries/base/tests/IO/hGetPosn001.stdout create mode 100644 libraries/base/tests/IO/hIsEOF001.hs create mode 100644 libraries/base/tests/IO/hIsEOF001.stdout create mode 100644 libraries/base/tests/IO/hIsEOF002.hs create mode 100644 libraries/base/tests/IO/hIsEOF002.stdout create mode 100644 libraries/base/tests/IO/hReady001.hs create mode 100644 libraries/base/tests/IO/hReady001.stdout create mode 100644 libraries/base/tests/IO/hReady002.hs create mode 100644 libraries/base/tests/IO/hReady002.stdout create mode 100644 libraries/base/tests/IO/hSeek001.hs create mode 100644 libraries/base/tests/IO/hSeek001.in create mode 100644 libraries/base/tests/IO/hSeek001.stdout create mode 100644 libraries/base/tests/IO/hSeek002.hs create mode 100644 libraries/base/tests/IO/hSeek002.stdout create mode 100644 libraries/base/tests/IO/hSeek003.hs create mode 100644 libraries/base/tests/IO/hSeek003.stdout create mode 100644 libraries/base/tests/IO/hSeek004.hs create mode 100644 libraries/base/tests/IO/hSeek004.stdout create mode 100644 libraries/base/tests/IO/hSetBuffering002.hs create mode 100644 libraries/base/tests/IO/hSetBuffering002.stdout create mode 100644 libraries/base/tests/IO/hSetBuffering003.hs create mode 100644 libraries/base/tests/IO/hSetBuffering003.stderr create mode 100644 libraries/base/tests/IO/hSetBuffering003.stdout create mode 100644 libraries/base/tests/IO/hSetBuffering004.hs create mode 100644 libraries/base/tests/IO/hSetBuffering004.stdout create mode 100644 libraries/base/tests/IO/hSetEncoding001.hs create mode 100644 libraries/base/tests/IO/hSetEncoding001.in create mode 100644 libraries/base/tests/IO/hSetEncoding001.stdout create mode 100644 libraries/base/tests/IO/hSetEncoding002.hs create mode 100644 libraries/base/tests/IO/hSetEncoding002.stdout create mode 100644 libraries/base/tests/IO/ioeGetErrorString001.hs create mode 100644 libraries/base/tests/IO/ioeGetErrorString001.stdout create mode 100644 libraries/base/tests/IO/ioeGetFileName001.hs create mode 100644 libraries/base/tests/IO/ioeGetFileName001.stdout create mode 100644 libraries/base/tests/IO/ioeGetHandle001.hs create mode 100644 libraries/base/tests/IO/ioeGetHandle001.stdout create mode 100644 libraries/base/tests/IO/isEOF001.hs create mode 100644 libraries/base/tests/IO/isEOF001.stdout create mode 100644 libraries/base/tests/IO/latin1 create mode 100644 libraries/base/tests/IO/misc001.hs create mode 100644 libraries/base/tests/IO/misc001.stdout create mode 100644 libraries/base/tests/IO/newline001.hs create mode 100644 libraries/base/tests/IO/openFile001.hs create mode 100644 libraries/base/tests/IO/openFile001.stdout create mode 100644 libraries/base/tests/IO/openFile002.hs create mode 100644 libraries/base/tests/IO/openFile002.stderr create mode 100644 libraries/base/tests/IO/openFile003.hs create mode 100644 libraries/base/tests/IO/openFile003.stdout create mode 100644 libraries/base/tests/IO/openFile003.stdout-mingw32 create mode 100644 libraries/base/tests/IO/openFile003.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/IO/openFile003.stdout-sparc-sun-solaris2 create mode 100644 libraries/base/tests/IO/openFile004.hs create mode 100644 libraries/base/tests/IO/openFile004.stdout create mode 100644 libraries/base/tests/IO/openFile005.hs create mode 100644 libraries/base/tests/IO/openFile005.stdout create mode 100644 libraries/base/tests/IO/openFile006.hs create mode 100644 libraries/base/tests/IO/openFile006.stdout create mode 100644 libraries/base/tests/IO/openFile007.hs create mode 100644 libraries/base/tests/IO/openFile007.stdout create mode 100644 libraries/base/tests/IO/openFile008.hs create mode 100644 libraries/base/tests/IO/openTempFile001.hs create mode 100644 libraries/base/tests/IO/putStr001.hs create mode 100644 libraries/base/tests/IO/putStr001.stdout create mode 100644 libraries/base/tests/IO/readFile001.hs create mode 100644 libraries/base/tests/IO/readFile001.stdout create mode 100644 libraries/base/tests/IO/readwrite001.hs create mode 100644 libraries/base/tests/IO/readwrite001.stdout create mode 100644 libraries/base/tests/IO/readwrite002.hs create mode 100644 libraries/base/tests/IO/readwrite002.stdout create mode 100644 libraries/base/tests/IO/readwrite003.hs create mode 100644 libraries/base/tests/IO/readwrite003.stdout create mode 100644 libraries/base/tests/IO/utf8-test create mode 100644 libraries/base/tests/Makefile create mode 100644 libraries/base/tests/Memo1.lhs create mode 100644 libraries/base/tests/Memo2.lhs create mode 100644 libraries/base/tests/Numeric/Makefile create mode 100644 libraries/base/tests/Numeric/all.T create mode 100644 libraries/base/tests/Numeric/num001.hs create mode 100644 libraries/base/tests/Numeric/num001.stdout create mode 100644 libraries/base/tests/Numeric/num002.hs create mode 100644 libraries/base/tests/Numeric/num002.stdout create mode 100644 libraries/base/tests/Numeric/num002.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/Numeric/num002.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/Numeric/num002.stdout-ws-64 create mode 100644 libraries/base/tests/Numeric/num002.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/Numeric/num003.hs create mode 100644 libraries/base/tests/Numeric/num003.stdout create mode 100644 libraries/base/tests/Numeric/num003.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/Numeric/num003.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/Numeric/num003.stdout-ws-64 create mode 100644 libraries/base/tests/Numeric/num003.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/Numeric/num004.hs create mode 100644 libraries/base/tests/Numeric/num004.stdout create mode 100644 libraries/base/tests/Numeric/num004.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/Numeric/num004.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/Numeric/num004.stdout-ws-64 create mode 100644 libraries/base/tests/Numeric/num004.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/Numeric/num005.hs create mode 100644 libraries/base/tests/Numeric/num005.stdout create mode 100644 libraries/base/tests/Numeric/num005.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/Numeric/num005.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/Numeric/num005.stdout-ws-64 create mode 100644 libraries/base/tests/Numeric/num005.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/Numeric/num006.hs create mode 100644 libraries/base/tests/Numeric/num006.stdout create mode 100644 libraries/base/tests/Numeric/num007.hs create mode 100644 libraries/base/tests/Numeric/num007.stdout create mode 100644 libraries/base/tests/Numeric/num008.hs create mode 100644 libraries/base/tests/Numeric/num008.stdout create mode 100644 libraries/base/tests/Numeric/num009.hs create mode 100644 libraries/base/tests/Numeric/num009.stdout create mode 100644 libraries/base/tests/Numeric/num009.stdout-i386-unknown-mingw32 create mode 100644 libraries/base/tests/Numeric/num010.hs create mode 100644 libraries/base/tests/Numeric/num010.stdout create mode 100644 libraries/base/tests/System/Makefile create mode 100644 libraries/base/tests/System/T5930.hs create mode 100644 libraries/base/tests/System/T5930.stdout create mode 100644 libraries/base/tests/System/Timeout001.hs create mode 100644 libraries/base/tests/System/all.T create mode 100644 libraries/base/tests/System/exitWith001.hs create mode 100644 libraries/base/tests/System/exitWith001.stdout create mode 100644 libraries/base/tests/System/getArgs001.hs create mode 100644 libraries/base/tests/System/getArgs001.stdout create mode 100644 libraries/base/tests/System/getEnv001.hs create mode 100644 libraries/base/tests/System/getEnv001.stdout create mode 100644 libraries/base/tests/System/system001.hs create mode 100644 libraries/base/tests/System/system001.stdout create mode 100644 libraries/base/tests/T10149.hs create mode 100644 libraries/base/tests/T10149.stdout create mode 100644 libraries/base/tests/T11334a.hs create mode 100644 libraries/base/tests/T11334a.stdout create mode 100644 libraries/base/tests/T11555.hs create mode 100644 libraries/base/tests/T11555.stdout create mode 100644 libraries/base/tests/T2528.hs create mode 100644 libraries/base/tests/T2528.stdout create mode 100644 libraries/base/tests/T4006.hs create mode 100644 libraries/base/tests/T4006.stdout create mode 100644 libraries/base/tests/T5943.hs create mode 100644 libraries/base/tests/T5943.stdout create mode 100644 libraries/base/tests/T5962.hs create mode 100644 libraries/base/tests/T5962.stdout create mode 100644 libraries/base/tests/T7034.hs create mode 100644 libraries/base/tests/T7034.stdout create mode 100644 libraries/base/tests/T7457.hs create mode 100644 libraries/base/tests/T7457.stdout create mode 100644 libraries/base/tests/T7653.hs create mode 100644 libraries/base/tests/T7773.hs create mode 100644 libraries/base/tests/T7773.stdout create mode 100644 libraries/base/tests/T7787.hs create mode 100644 libraries/base/tests/T7787.stdout create mode 100644 libraries/base/tests/T8089.hs create mode 100644 libraries/base/tests/T8766.hs create mode 100644 libraries/base/tests/T8766.stdout create mode 100644 libraries/base/tests/T9111.hs create mode 100644 libraries/base/tests/T9395.hs create mode 100644 libraries/base/tests/T9395.stderr create mode 100644 libraries/base/tests/T9532.hs create mode 100644 libraries/base/tests/T9532.stdout create mode 100644 libraries/base/tests/T9586.hs create mode 100644 libraries/base/tests/T9681.hs create mode 100644 libraries/base/tests/T9681.stderr create mode 100644 libraries/base/tests/T9826.hs create mode 100644 libraries/base/tests/T9826.stdout create mode 100644 libraries/base/tests/T9848.hs create mode 100644 libraries/base/tests/T9848.stdout create mode 100644 libraries/base/tests/Text.Printf/Makefile create mode 100644 libraries/base/tests/Text.Printf/T1548.hs create mode 100644 libraries/base/tests/Text.Printf/T1548.stdout create mode 100644 libraries/base/tests/Text.Printf/all.T create mode 100644 libraries/base/tests/addr001.hs create mode 100644 libraries/base/tests/addr001.stdout create mode 100644 libraries/base/tests/addr001.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/addr001.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/addr001.stdout-ws-64 create mode 100644 libraries/base/tests/addr001.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/all.T create mode 100644 libraries/base/tests/assert.hs create mode 100644 libraries/base/tests/assert.stderr create mode 100644 libraries/base/tests/char001.hs create mode 100644 libraries/base/tests/char001.stdout create mode 100644 libraries/base/tests/char002.hs create mode 100644 libraries/base/tests/char002.stdout create mode 100644 libraries/base/tests/cstring001.hs create mode 100644 libraries/base/tests/data-fixed-show-read.hs create mode 100644 libraries/base/tests/data-fixed-show-read.stdout create mode 100644 libraries/base/tests/dynamic001.hs create mode 100644 libraries/base/tests/dynamic001.stdout create mode 100644 libraries/base/tests/dynamic002.hs create mode 100644 libraries/base/tests/dynamic002.stdout create mode 100644 libraries/base/tests/dynamic003.hs create mode 100644 libraries/base/tests/dynamic003.stdout create mode 100644 libraries/base/tests/dynamic004.hs create mode 100644 libraries/base/tests/dynamic004.stdout create mode 100644 libraries/base/tests/dynamic005.hs create mode 100644 libraries/base/tests/dynamic005.stdout create mode 100644 libraries/base/tests/echo001.hs create mode 100644 libraries/base/tests/echo001.stdout create mode 100644 libraries/base/tests/enum01.hs create mode 100644 libraries/base/tests/enum01.stdout create mode 100644 libraries/base/tests/enum01.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/enum01.stdout-ws-64 create mode 100644 libraries/base/tests/enum02.hs create mode 100644 libraries/base/tests/enum02.stdout create mode 100644 libraries/base/tests/enum02.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/enum02.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/enum02.stdout-ws-64 create mode 100644 libraries/base/tests/enum02.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/enum03.hs create mode 100644 libraries/base/tests/enum03.stdout create mode 100644 libraries/base/tests/enum03.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/enum03.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/enum03.stdout-ws-64 create mode 100644 libraries/base/tests/enum03.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/enum04.hs create mode 100644 libraries/base/tests/enum04.stdout create mode 100644 libraries/base/tests/enumDouble.hs create mode 100644 libraries/base/tests/enumDouble.stdout create mode 100644 libraries/base/tests/enumRatio.hs create mode 100644 libraries/base/tests/enumRatio.stdout create mode 100755 libraries/base/tests/enum_processor.py create mode 100644 libraries/base/tests/exceptionsrun001.hs create mode 100644 libraries/base/tests/exceptionsrun001.stdout create mode 100644 libraries/base/tests/exceptionsrun002.hs create mode 100644 libraries/base/tests/exceptionsrun002.stdout create mode 100644 libraries/base/tests/fixed.hs create mode 100644 libraries/base/tests/fixed.stdout create mode 100644 libraries/base/tests/foldableArray.hs create mode 100644 libraries/base/tests/foldableArray.stdout create mode 100644 libraries/base/tests/genericNegative001.hs create mode 100644 libraries/base/tests/genericNegative001.stdout create mode 100644 libraries/base/tests/hGetBuf002.hs create mode 100644 libraries/base/tests/hGetBuf002.stdout create mode 100644 libraries/base/tests/hGetBuf003.hs create mode 100644 libraries/base/tests/hGetBuf003.stdout create mode 100644 libraries/base/tests/hPutBuf001.hs create mode 100644 libraries/base/tests/hPutBuf001.stdout create mode 100644 libraries/base/tests/hPutBuf002.hs create mode 100644 libraries/base/tests/hPutBuf002.stdout create mode 100644 libraries/base/tests/hTell001.hs create mode 100644 libraries/base/tests/hTell001.stdout create mode 100644 libraries/base/tests/hTell002.hs create mode 100644 libraries/base/tests/hTell002.stdout create mode 100644 libraries/base/tests/inits.hs create mode 100644 libraries/base/tests/ioref001.hs create mode 100644 libraries/base/tests/ioref001.stdout create mode 100644 libraries/base/tests/isSuffixOf.hs create mode 100644 libraries/base/tests/isSuffixOf.stdout create mode 100644 libraries/base/tests/ix001.hs create mode 100644 libraries/base/tests/ix001.stdout create mode 100644 libraries/base/tests/length001.hs create mode 100644 libraries/base/tests/length001.stdout create mode 100644 libraries/base/tests/lex001.hs create mode 100644 libraries/base/tests/lex001.stdout create mode 100644 libraries/base/tests/list001.hs create mode 100644 libraries/base/tests/list001.stdout create mode 100644 libraries/base/tests/list002.hs create mode 100644 libraries/base/tests/list002.stdout create mode 100644 libraries/base/tests/list003.hs create mode 100644 libraries/base/tests/list003.stdout create mode 100644 libraries/base/tests/memo001.hs create mode 100644 libraries/base/tests/memo001.stdout create mode 100644 libraries/base/tests/memo002.hs create mode 100644 libraries/base/tests/memo002.stdout create mode 100644 libraries/base/tests/packedstring001.hs create mode 100644 libraries/base/tests/packedstring001.stdout create mode 100644 libraries/base/tests/performGC001.hs create mode 100644 libraries/base/tests/performGC001.stdout create mode 100644 libraries/base/tests/qsem001.hs create mode 100644 libraries/base/tests/qsem001.stdout create mode 100644 libraries/base/tests/qsemn001.hs create mode 100644 libraries/base/tests/qsemn001.stdout create mode 100644 libraries/base/tests/quotOverflow.hs create mode 100644 libraries/base/tests/quotOverflow.stdout create mode 100644 libraries/base/tests/rand001.hs create mode 100644 libraries/base/tests/rand001.stdout create mode 100644 libraries/base/tests/ratio001.hs create mode 100644 libraries/base/tests/ratio001.stdout create mode 100644 libraries/base/tests/readDouble001.hs create mode 100644 libraries/base/tests/readDouble001.stdout create mode 100644 libraries/base/tests/readFixed001.hs create mode 100644 libraries/base/tests/readFixed001.stdout create mode 100644 libraries/base/tests/readFloat.hs create mode 100644 libraries/base/tests/readFloat.stderr create mode 100644 libraries/base/tests/readInteger001.hs create mode 100644 libraries/base/tests/readInteger001.stdout create mode 100644 libraries/base/tests/readLitChar.hs create mode 100644 libraries/base/tests/readLitChar.stdout create mode 100644 libraries/base/tests/reads001.hs create mode 100644 libraries/base/tests/reads001.stdout create mode 100644 libraries/base/tests/show001.hs create mode 100644 libraries/base/tests/show001.stdout create mode 100644 libraries/base/tests/showDouble.hs create mode 100644 libraries/base/tests/showDouble.stdout create mode 100644 libraries/base/tests/stableptr001.hs create mode 100644 libraries/base/tests/stableptr001.stdout create mode 100644 libraries/base/tests/stableptr003.hs create mode 100644 libraries/base/tests/stableptr004.hs create mode 100644 libraries/base/tests/stableptr004.stdout create mode 100644 libraries/base/tests/stableptr005.hs create mode 100644 libraries/base/tests/stableptr005.stdout create mode 100644 libraries/base/tests/take001.hs create mode 100644 libraries/base/tests/take001.stdout create mode 100644 libraries/base/tests/tempfiles.hs create mode 100644 libraries/base/tests/tempfiles.stdout create mode 100644 libraries/base/tests/text001.hs create mode 100644 libraries/base/tests/text001.stdout create mode 100644 libraries/base/tests/topHandler01.hs create mode 100644 libraries/base/tests/topHandler01.stdout create mode 100644 libraries/base/tests/topHandler02.hs create mode 100644 libraries/base/tests/topHandler03.hs create mode 100644 libraries/base/tests/topHandler04.hs create mode 100644 libraries/base/tests/topHandler04.stderr create mode 100644 libraries/base/tests/trace001.hs create mode 100644 libraries/base/tests/trace001.stderr create mode 100644 libraries/base/tests/trace001.stdout create mode 100644 libraries/base/tests/tup001.hs create mode 100644 libraries/base/tests/tup001.stdout create mode 100644 libraries/base/tests/unicode001.hs create mode 100644 libraries/base/tests/unicode001.stdout create mode 100644 libraries/base/tests/unicode002.hs create mode 100644 libraries/base/tests/unicode002.stdout create mode 100644 libraries/base/tests/weak001.hs create mode 100644 libraries/ghc-prim/.gitignore create mode 100644 libraries/ghc-prim/GHC/CString.hs create mode 100644 libraries/ghc-prim/GHC/Classes.hs create mode 100644 libraries/ghc-prim/GHC/Debug.hs create mode 100644 libraries/ghc-prim/GHC/IntWord64.hs create mode 100644 libraries/ghc-prim/GHC/Magic.hs create mode 100644 libraries/ghc-prim/GHC/Prim.hs.tmp create mode 100644 libraries/ghc-prim/GHC/Tuple.hs rename {anuhc-prim => libraries/ghc-prim}/GHC/Types.hs (98%) create mode 100644 libraries/ghc-prim/GHC/Types.source-stats create mode 100644 libraries/ghc-prim/LICENSE create mode 100644 libraries/ghc-prim/Setup.hs create mode 100644 libraries/ghc-prim/cbits/atomic.c create mode 100644 libraries/ghc-prim/cbits/bswap.c create mode 100644 libraries/ghc-prim/cbits/clz.c create mode 100644 libraries/ghc-prim/cbits/ctz.c create mode 100644 libraries/ghc-prim/cbits/debug.c create mode 100644 libraries/ghc-prim/cbits/longlong.c create mode 100644 libraries/ghc-prim/cbits/popcnt.c create mode 100644 libraries/ghc-prim/cbits/word2float.c create mode 100644 libraries/ghc-prim/changelog.md create mode 100644 libraries/ghc-prim/ghc-prim.cabal create mode 100644 libraries/ghc-prim/tests/T6026.hs create mode 100644 libraries/ghc-prim/tests/T6026.stdout diff --git a/app/Main.hs b/app/Main.hs index 48e7ff7..44a94d9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -22,7 +22,6 @@ import System.Environment (getArgs) import System.Exit (exitFailure) import qualified Data.Sequence as Seq import qualified Data.Map.Strict as M -import System.Directory (listDirectory) import qualified Language.Haskell.GHC.Simple as GHC.Simple import Language.Haskell.GHC.Simple.Extra () @@ -35,6 +34,8 @@ import Mu.AST import Mu.Impl.RefImpl2 import Mu.Interface +import Debug.Trace + compilerConfig :: CompConfig compilerConfig = GHC.Simple.disableCodeGen $ @@ -49,26 +50,27 @@ main :: IO () main = do inputFiles <- getArgs b <- GHC.Simple.compileWith compilerConfig compileMu inputFiles - libresults <- compileLibraryFiles + libresults <- mapM compileLibraryFiles libraryFiles case b of Success results _ _ -> do - doResults lives $ mergeResults $ (loadPrim : libresults ++ results') + doResults lives $ mergeResults $ (loadPrim : concat libresults ++ results') where results' = fmap modCompiledModule (results) lives = toList $ foldMap getDefns results' getDefns (defns, _, _) = fmap toName defns Failure _ _ -> exitFailure -compileLibraryFiles :: IO [MuResult] -compileLibraryFiles = do - b <- getLibraryFiles >>= GHC.Simple.compileWith libconfig compileMu +compileLibraryFiles :: (String, [FilePath]) -> IO [MuResult] +compileLibraryFiles (packageKey, files) = do + traceM ("Compiling the library file " ++ packageKey) + b <- GHC.Simple.compileWith libconfig compileMu files case b of Success results _ _ -> return $ fmap modCompiledModule results Failure _ _ -> error "Could not compile internal bundle" where libconfig = compilerConfig { cfgGhcFlags = - ["-this-unit-id", "ghc-prim", "-ddump-stg", "-ddump-to-file"] + ["-this-unit-id", packageKey, "-ddump-stg", "-ddump-to-file"] } doResults :: [Name] -> MuMergedResult -> IO () @@ -93,12 +95,222 @@ doResults liveObjectNames (defns, topClosures, mainFunction) = do where defns' = M.elems defns -getLibraryFiles :: IO [FilePath] -getLibraryFiles = process =<< mapM listDirectory' - ["/Users/nathan/projects/microvm/anuhc/anuhc-prim/GHC/"] +-- | A list of all library files, indexed by their package-key. +-- TODO: fix this. +libraryFiles :: [(String, [FilePath])] +libraryFiles = [ ("ghc-prim", prefix ghcPrimFiles) + , ("base", prefix baseFiles) + ] where - process = return . (filter (".hs" `isSuffixOf`) . concat) - listDirectory' dir = listDirectory dir >>= return . (fmap (dir ++)) + prefix = fmap ("/Users/nathan/projects/microvm/anuhc/libraries/" ++) + ghcPrimFiles = + [ "ghc-prim/GHC/CString.hs" + , "ghc-prim/GHC/Classes.hs" + , "ghc-prim/GHC/Debug.hs" + , "ghc-prim/GHC/IntWord64.hs" + , "ghc-prim/GHC/Magic.hs" + -- , "ghc-prim/GHC/PrimopWrappers.hs" + , "ghc-prim/GHC/Tuple.hs" + , "ghc-prim/GHC/Types.hs" + ] + baseFiles = + [ "base/Control/Applicative.hs" + , "base/Control/Arrow.hs" + , "base/Control/Category.hs" + , "base/Control/Concurrent.hs" + , "base/Control/Concurrent/Chan.hs" + , "base/Control/Concurrent/MVar.hs" + , "base/Control/Concurrent/QSem.hs" + , "base/Control/Concurrent/QSemN.hs" + , "base/Control/Exception.hs" + , "base/Control/Exception/Base.hs" + , "base/Control/Monad.hs" + , "base/Control/Monad/Fail.hs" + , "base/Control/Monad/Fix.hs" + , "base/Control/Monad/Instances.hs" + , "base/Control/Monad/IO/Class.hs" + , "base/Control/Monad/ST.hs" + , "base/Control/Monad/ST/Lazy.hs" + , "base/Control/Monad/ST/Lazy/Safe.hs" + , "base/Control/Monad/ST/Lazy/Unsafe.hs" + , "base/Control/Monad/ST/Safe.hs" + , "base/Control/Monad/ST/Strict.hs" + , "base/Control/Monad/ST/Unsafe.hs" + , "base/Control/Monad/Zip.hs" + , "base/Data/Bifunctor.hs" + , "base/Data/Bits.hs" + , "base/Data/Bool.hs" + , "base/Data/Char.hs" + , "base/Data/Coerce.hs" + , "base/Data/Complex.hs" + , "base/Data/Data.hs" + , "base/Data/Dynamic.hs" + , "base/Data/Either.hs" + , "base/Data/Eq.hs" + , "base/Data/Fixed.hs" + , "base/Data/Foldable.hs" + , "base/Data/Function.hs" + , "base/Data/Functor.hs" + , "base/Data/Functor/Classes.hs" + , "base/Data/Functor/Compose.hs" + , "base/Data/Functor/Const.hs" + , "base/Data/Functor/Identity.hs" + , "base/Data/Functor/Product.hs" + , "base/Data/Functor/Sum.hs" + , "base/Data/IORef.hs" + , "base/Data/Int.hs" + , "base/Data/Ix.hs" + , "base/Data/Kind.hs" + , "base/Data/List.hs" + , "base/Data/List/NonEmpty.hs" + , "base/Data/Maybe.hs" + , "base/Data/Monoid.hs" + , "base/Data/Ord.hs" + , "base/Data/Proxy.hs" + , "base/Data/Ratio.hs" + , "base/Data/Semigroup.hs" + , "base/Data/STRef.hs" + , "base/Data/STRef/Lazy.hs" + , "base/Data/STRef/Strict.hs" + , "base/Data/String.hs" + , "base/Data/Traversable.hs" + , "base/Data/Tuple.hs" + , "base/Data/Type/Bool.hs" + , "base/Data/Type/Coercion.hs" + , "base/Data/Type/Equality.hs" + , "base/Data/Typeable.hs" + , "base/Data/Typeable/Internal.hs" + , "base/Data/Unique.hs" + , "base/Data/Version.hs" + , "base/Data/Void.hs" + , "base/Data/Word.hs" + , "base/Debug/Trace.hs" + , "base/Foreign.hs" + , "base/Foreign/C.hs" + , "base/Foreign/C/Error.hs" + , "base/Foreign/C/String.hs" + , "base/Foreign/C/Types.hs" + , "base/Foreign/Concurrent.hs" + , "base/Foreign/ForeignPtr.hs" + , "base/Foreign/ForeignPtr/Safe.hs" + , "base/Foreign/ForeignPtr/Unsafe.hs" + , "base/Foreign/Marshal.hs" + , "base/Foreign/Marshal/Alloc.hs" + , "base/Foreign/Marshal/Array.hs" + , "base/Foreign/Marshal/Error.hs" + , "base/Foreign/Marshal/Pool.hs" + , "base/Foreign/Marshal/Safe.hs" + , "base/Foreign/Marshal/Unsafe.hs" + , "base/Foreign/Marshal/Utils.hs" + , "base/Foreign/Ptr.hs" + , "base/Foreign/Safe.hs" + , "base/Foreign/StablePtr.hs" + , "base/Foreign/Storable.hs" + , "base/GHC/Arr.hs" + , "base/GHC/Base.hs" + , "base/GHC/Char.hs" + , "base/GHC/Conc.hs" + , "base/GHC/Conc/IO.hs" + , "base/GHC/Conc/Signal.hs" + , "base/GHC/Conc/Sync.hs" + , "base/GHC/ConsoleHandler.hs" + , "base/GHC/Constants.hs" + , "base/GHC/Desugar.hs" + , "base/GHC/Enum.hs" + , "base/GHC/Environment.hs" + , "base/GHC/Err.hs" + , "base/GHC/Exception.hs" + , "base/GHC/ExecutionStack.hs" + , "base/GHC/ExecutionStack/Internal.hs" + , "base/GHC/Exts.hs" + , "base/GHC/Fingerprint.hs" + , "base/GHC/Fingerprint/Type.hs" + , "base/GHC/Float.hs" + , "base/GHC/Float/ConversionUtils.hs" + , "base/GHC/Float/RealFracMethods.hs" + , "base/GHC/Foreign.hs" + , "base/GHC/ForeignPtr.hs" + , "base/GHC/GHCi.hs" + , "base/GHC/Generics.hs" + , "base/GHC/IO.hs" + , "base/GHC/IO/Buffer.hs" + , "base/GHC/IO/BufferedIO.hs" + , "base/GHC/IO/Device.hs" + , "base/GHC/IO/Encoding.hs" + , "base/GHC/IO/Encoding/CodePage.hs" + , "base/GHC/IO/Encoding/Failure.hs" + , "base/GHC/IO/Encoding/Iconv.hs" + , "base/GHC/IO/Encoding/Latin1.hs" + , "base/GHC/IO/Encoding/Types.hs" + , "base/GHC/IO/Encoding/UTF16.hs" + , "base/GHC/IO/Encoding/UTF32.hs" + , "base/GHC/IO/Encoding/UTF8.hs" + , "base/GHC/IO/Exception.hs" + , "base/GHC/IO/FD.hs" + , "base/GHC/IO/Handle.hs" + , "base/GHC/IO/Handle/FD.hs" + , "base/GHC/IO/Handle/Internals.hs" + , "base/GHC/IO/Handle/Text.hs" + , "base/GHC/IO/Handle/Types.hs" + , "base/GHC/IO/IOMode.hs" + , "base/GHC/IO/Unsafe.hs" + , "base/GHC/IOArray.hs" + , "base/GHC/IORef.hs" + , "base/GHC/Int.hs" + , "base/GHC/List.hs" + , "base/GHC/MVar.hs" + , "base/GHC/Natural.hs" + , "base/GHC/Num.hs" + , "base/GHC/OldList.hs" + , "base/GHC/OverloadedLabels.hs" + , "base/GHC/PArr.hs" + , "base/GHC/Pack.hs" + , "base/GHC/Profiling.hs" + , "base/GHC/Ptr.hs" + , "base/GHC/Read.hs" + , "base/GHC/Real.hs" + , "base/GHC/RTS/Flags.hs" + , "base/GHC/ST.hs" + , "base/GHC/StaticPtr.hs" + , "base/GHC/STRef.hs" + , "base/GHC/Show.hs" + , "base/GHC/Stable.hs" + , "base/GHC/Stack.hs" + , "base/GHC/Stack/CCS.hs" + , "base/GHC/Stack/Types.hs" + , "base/GHC/Stats.hs" + , "base/GHC/Storable.hs" + , "base/GHC/TopHandler.hs" + , "base/GHC/TypeLits.hs" + , "base/GHC/Unicode.hs" + , "base/GHC/Weak.hs" + , "base/GHC/Word.hs" + , "base/Numeric.hs" + , "base/Numeric/Natural.hs" + , "base/Prelude.hs" + , "base/System/CPUTime.hs" + , "base/System/Console/GetOpt.hs" + , "base/System/Environment.hs" + , "base/System/Exit.hs" + , "base/System/IO.hs" + , "base/System/IO/Error.hs" + , "base/System/IO/Unsafe.hs" + , "base/System/Info.hs" + , "base/System/Mem.hs" + , "base/System/Mem/StableName.hs" + , "base/System/Mem/Weak.hs" + , "base/System/Posix/Internals.hs" + , "base/System/Posix/Types.hs" + , "base/System/Timeout.hs" + , "base/Text/ParserCombinators/ReadP.hs" + , "base/Text/ParserCombinators/ReadPrec.hs" + , "base/Text/Printf.hs" + , "base/Text/Read.hs" + , "base/Text/Read/Lex.hs" + , "base/Text/Show.hs" + , "base/Text/Show/Functions.hs" + , "base/Unsafe/Coerce.hs" + ] -- printResult :: CompResult String -> IO () -- printResult result = do putStrLn errors diff --git a/libraries/base/.authorspellings b/libraries/base/.authorspellings new file mode 100644 index 0000000..7687ac6 --- /dev/null +++ b/libraries/base/.authorspellings @@ -0,0 +1,12 @@ +Simon Marlow , simonmar, simonmar@microsoft.com +Ross Paterson , ross +Sven Panne , panne +Malcolm Wallace , malcolm +Simon Peyton Jones , simonpj +Don Stewart , dons +Tim Harris , tharris +Lennart Augustsson , lennart.augustsson@credit-suisse.com +Duncan Coutts , duncan.coutts@worc.ox.ac.uk, duncan@well-typed.com +Ben Lippmeier , benl@cse.unsw.edu.au, Ben.Lippmeier@anu.edu.au +Manuel M T Chakravarty , chak +Jose Pedro Magalhaes , jpm@cs.uu.nl diff --git a/libraries/base/.gitignore b/libraries/base/.gitignore new file mode 100644 index 0000000..6a6d524 --- /dev/null +++ b/libraries/base/.gitignore @@ -0,0 +1,22 @@ +*.o +*.aux +*.hi +*.tix +*.exe + +# Backup files +*~ + +# Specific generated files +/GNUmakefile +/autom4te.cache/ +/base.buildinfo +/config.log +/config.status +/configure +/dist-install/ +/ghc.mk +/include/EventConfig.h +/include/HsBaseConfig.h +/include/HsBaseConfig.h.in + diff --git a/libraries/base/Control/Applicative.hs b/libraries/base/Control/Applicative.hs new file mode 100644 index 0000000..0892808 --- /dev/null +++ b/libraries/base/Control/Applicative.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- 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, liftA2, liftA3, + optional, + ) where + +import Control.Category hiding ((.), id) +import Control.Arrow +import Data.Maybe +import Data.Tuple +import Data.Eq +import Data.Ord +import Data.Foldable (Foldable(..)) +import Data.Functor ((<$>)) +import Data.Functor.Const (Const(..)) + +import GHC.Base +import GHC.Generics +import GHC.List (repeat, zipWith) +import GHC.Read (Read) +import GHC.Show (Show) + +newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a } + deriving (Generic, Generic1, Monad) + +instance Monad m => Functor (WrappedMonad m) where + fmap f (WrapMonad v) = WrapMonad (liftM f v) + +instance Monad m => Applicative (WrappedMonad m) where + pure = WrapMonad . pure + WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v) + +instance MonadPlus m => Alternative (WrappedMonad m) where + empty = WrapMonad mzero + WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v) + +newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c } + deriving (Generic, Generic1) + +instance Arrow a => Functor (WrappedArrow a b) where + fmap f (WrapArrow a) = WrapArrow (a >>> arr f) + +instance Arrow a => Applicative (WrappedArrow a b) where + pure x = WrapArrow (arr (const x)) + WrapArrow f <*> WrapArrow v = WrapArrow (f &&& v >>> arr (uncurry id)) + +instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where + empty = WrapArrow zeroArrow + WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v) + +-- | Lists, but with an 'Applicative' functor based on zipping, so that +-- +-- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@ +-- +newtype ZipList a = ZipList { getZipList :: [a] } + deriving ( Show, Eq, Ord, Read, Functor + , Foldable, Generic, Generic1) +-- See Data.Traversable for Traversabel instance due to import loops + +instance Applicative ZipList where + pure x = ZipList (repeat x) + ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs) + +-- extra functions + +-- | One or none. +optional :: Alternative f => f a -> f (Maybe a) +optional v = Just <$> v <|> pure Nothing diff --git a/libraries/base/Control/Arrow.hs b/libraries/base/Control/Arrow.hs new file mode 100644 index 0000000..3417f30 --- /dev/null +++ b/libraries/base/Control/Arrow.hs @@ -0,0 +1,374 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} + -- The RULES for the methods of class Arrow may never fire + -- e.g. compose/arr; see Trac #10528 + +----------------------------------------------------------------------------- +-- | +-- 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, + (^>>), (>>^), + (>>>), (<<<), -- reexported + -- ** Right-to-left variants + (<<^), (^<<), + -- * Monoid operations + ArrowZero(..), ArrowPlus(..), + -- * Conditionals + ArrowChoice(..), + -- * Arrow application + ArrowApply(..), ArrowMonad(..), leftApp, + -- * Feedback + ArrowLoop(..) + ) where + +import Data.Tuple ( fst, snd, uncurry ) +import Data.Either +import Control.Monad.Fix +import Control.Category +import GHC.Base hiding ( (.), id ) + +infixr 5 <+> +infixr 3 *** +infixr 3 &&& +infixr 2 +++ +infixr 2 ||| +infixr 1 ^>>, >>^ +infixr 1 ^<<, <<^ + +-- | The basic arrow class. +-- +-- Instances should satisfy the following laws: +-- +-- * @'arr' id = 'id'@ +-- +-- * @'arr' (f >>> g) = 'arr' f >>> 'arr' g@ +-- +-- * @'first' ('arr' f) = 'arr' ('first' f)@ +-- +-- * @'first' (f >>> g) = 'first' f >>> 'first' g@ +-- +-- * @'first' f >>> 'arr' 'fst' = 'arr' 'fst' >>> f@ +-- +-- * @'first' f >>> 'arr' ('id' *** g) = 'arr' ('id' *** g) >>> 'first' f@ +-- +-- * @'first' ('first' f) >>> 'arr' 'assoc' = 'arr' 'assoc' >>> 'first' f@ +-- +-- where +-- +-- > assoc ((a,b),c) = (a,(b,c)) +-- +-- The other combinators have sensible default definitions, +-- which may be overridden for efficiency. + +class Category a => Arrow a where + {-# MINIMAL arr, (first | (***)) #-} + + -- | Lift a function to an arrow. + arr :: (b -> c) -> a b c + + -- | Send the first component of the input through the argument + -- arrow, and copy the rest unchanged to the output. + first :: a b c -> a (b,d) (c,d) + first = (*** id) + + -- | A mirror image of 'first'. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + second :: a b c -> a (d,b) (d,c) + second = (id ***) + + -- | Split the input between the two argument arrows and combine + -- their output. Note that this is in general not a functor. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + (***) :: a b c -> a b' c' -> a (b,b') (c,c') + f *** g = first f >>> arr swap >>> first g >>> arr swap + where swap ~(x,y) = (y,x) + + -- | Fanout: send the input to both argument arrows and combine + -- their output. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + (&&&) :: a b c -> a b c' -> a b (c,c') + f &&& g = arr (\b -> (b,b)) >>> f *** g + +{-# RULES +"compose/arr" forall f g . + (arr f) . (arr g) = arr (f . g) +"first/arr" forall f . + first (arr f) = arr (first f) +"second/arr" forall f . + second (arr f) = arr (second f) +"product/arr" forall f g . + arr f *** arr g = arr (f *** g) +"fanout/arr" forall f g . + arr f &&& arr g = arr (f &&& g) +"compose/first" forall f g . + (first f) . (first g) = first (f . g) +"compose/second" forall f g . + (second f) . (second g) = second (f . g) + #-} + +-- Ordinary functions are arrows. + +instance Arrow (->) where + arr f = f +-- (f *** g) ~(x,y) = (f x, g y) +-- sorry, although the above defn is fully H'98, nhc98 can't parse it. + (***) f g ~(x,y) = (f x, g y) + +-- | Kleisli arrows of a monad. +newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b } + +instance Monad m => Category (Kleisli m) where + id = Kleisli return + (Kleisli f) . (Kleisli g) = Kleisli (\b -> g b >>= f) + +instance Monad m => Arrow (Kleisli m) where + arr f = Kleisli (return . f) + first (Kleisli f) = Kleisli (\ ~(b,d) -> f b >>= \c -> return (c,d)) + second (Kleisli f) = Kleisli (\ ~(d,b) -> f b >>= \c -> return (d,c)) + +-- | The identity arrow, which plays the role of 'return' in arrow notation. +returnA :: Arrow a => a b b +returnA = arr id + +-- | Precomposition with a pure function. +(^>>) :: Arrow a => (b -> c) -> a c d -> a b d +f ^>> a = arr f >>> a + +-- | Postcomposition with a pure function. +(>>^) :: Arrow a => a b c -> (c -> d) -> a b d +a >>^ f = a >>> arr f + +-- | Precomposition with a pure function (right-to-left variant). +(<<^) :: Arrow a => a c d -> (b -> c) -> a b d +a <<^ f = a <<< arr f + +-- | Postcomposition with a pure function (right-to-left variant). +(^<<) :: Arrow a => (c -> d) -> a b c -> a b d +f ^<< a = arr f <<< a + +class Arrow a => ArrowZero a where + zeroArrow :: a b c + +instance MonadPlus m => ArrowZero (Kleisli m) where + zeroArrow = Kleisli (\_ -> mzero) + +-- | A monoid on arrows. +class ArrowZero a => ArrowPlus a where + -- | An associative operation with identity 'zeroArrow'. + (<+>) :: a b c -> a b c -> a b c + +instance MonadPlus m => ArrowPlus (Kleisli m) where + Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x) + +-- | Choice, for arrows that support it. This class underlies the +-- @if@ and @case@ constructs in arrow notation. +-- +-- Instances should satisfy the following laws: +-- +-- * @'left' ('arr' f) = 'arr' ('left' f)@ +-- +-- * @'left' (f >>> g) = 'left' f >>> 'left' g@ +-- +-- * @f >>> 'arr' 'Left' = 'arr' 'Left' >>> 'left' f@ +-- +-- * @'left' f >>> 'arr' ('id' +++ g) = 'arr' ('id' +++ g) >>> 'left' f@ +-- +-- * @'left' ('left' f) >>> 'arr' 'assocsum' = 'arr' 'assocsum' >>> 'left' f@ +-- +-- where +-- +-- > assocsum (Left (Left x)) = Left x +-- > assocsum (Left (Right y)) = Right (Left y) +-- > assocsum (Right z) = Right (Right z) +-- +-- The other combinators have sensible default definitions, which may +-- be overridden for efficiency. + +class Arrow a => ArrowChoice a where + {-# MINIMAL (left | (+++)) #-} + + -- | Feed marked inputs through the argument arrow, passing the + -- rest through unchanged to the output. + left :: a b c -> a (Either b d) (Either c d) + left = (+++ id) + + -- | A mirror image of 'left'. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + right :: a b c -> a (Either d b) (Either d c) + right = (id +++) + + -- | Split the input between the two argument arrows, retagging + -- and merging their outputs. + -- Note that this is in general not a functor. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + (+++) :: a b c -> a b' c' -> a (Either b b') (Either c c') + f +++ g = left f >>> arr mirror >>> left g >>> arr mirror + where + mirror :: Either x y -> Either y x + mirror (Left x) = Right x + mirror (Right y) = Left y + + -- | Fanin: Split the input between the two argument arrows and + -- merge their outputs. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + (|||) :: a b d -> a c d -> a (Either b c) d + f ||| g = f +++ g >>> arr untag + where + untag (Left x) = x + untag (Right y) = y + +{-# RULES +"left/arr" forall f . + left (arr f) = arr (left f) +"right/arr" forall f . + right (arr f) = arr (right f) +"sum/arr" forall f g . + arr f +++ arr g = arr (f +++ g) +"fanin/arr" forall f g . + arr f ||| arr g = arr (f ||| g) +"compose/left" forall f g . + left f . left g = left (f . g) +"compose/right" forall f g . + right f . right g = right (f . g) + #-} + +instance ArrowChoice (->) where + left f = f +++ id + right f = id +++ f + f +++ g = (Left . f) ||| (Right . g) + (|||) = either + +instance Monad m => ArrowChoice (Kleisli m) where + left f = f +++ arr id + right f = arr id +++ f + f +++ g = (f >>> arr Left) ||| (g >>> arr Right) + Kleisli f ||| Kleisli g = Kleisli (either f g) + +-- | Some arrows allow application of arrow inputs to other inputs. +-- Instances should satisfy the following laws: +-- +-- * @'first' ('arr' (\\x -> 'arr' (\\y -> (x,y)))) >>> 'app' = 'id'@ +-- +-- * @'first' ('arr' (g >>>)) >>> 'app' = 'second' g >>> 'app'@ +-- +-- * @'first' ('arr' (>>> h)) >>> 'app' = 'app' >>> h@ +-- +-- Such arrows are equivalent to monads (see 'ArrowMonad'). + +class Arrow a => ArrowApply a where + app :: a (a b c, b) c + +instance ArrowApply (->) where + app (f,x) = f x + +instance Monad m => ArrowApply (Kleisli m) where + app = Kleisli (\(Kleisli f, x) -> f x) + +-- | The 'ArrowApply' class is equivalent to 'Monad': any monad gives rise +-- to a 'Kleisli' arrow, and any instance of 'ArrowApply' defines a monad. + +newtype ArrowMonad a b = ArrowMonad (a () b) + +instance Arrow a => Functor (ArrowMonad a) where + fmap f (ArrowMonad m) = ArrowMonad $ m >>> arr f + +instance Arrow a => Applicative (ArrowMonad a) where + pure x = ArrowMonad (arr (const x)) + ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id)) + +instance ArrowApply a => Monad (ArrowMonad a) where + ArrowMonad m >>= f = ArrowMonad $ + m >>> arr (\x -> let ArrowMonad h = f x in (h, ())) >>> app + +instance ArrowPlus a => Alternative (ArrowMonad a) where + empty = ArrowMonad zeroArrow + ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y) + +instance (ArrowApply a, ArrowPlus a) => MonadPlus (ArrowMonad a) where + mzero = ArrowMonad zeroArrow + ArrowMonad x `mplus` ArrowMonad y = ArrowMonad (x <+> y) + +-- | Any instance of 'ArrowApply' can be made into an instance of +-- 'ArrowChoice' by defining 'left' = 'leftApp'. + +leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d) +leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) ||| + (\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app + +-- | The 'loop' operator expresses computations in which an output value +-- is fed back as input, although the computation occurs only once. +-- It underlies the @rec@ value recursion construct in arrow notation. +-- 'loop' should satisfy the following laws: +-- +-- [/extension/] +-- @'loop' ('arr' f) = 'arr' (\\ b -> 'fst' ('fix' (\\ (c,d) -> f (b,d))))@ +-- +-- [/left tightening/] +-- @'loop' ('first' h >>> f) = h >>> 'loop' f@ +-- +-- [/right tightening/] +-- @'loop' (f >>> 'first' h) = 'loop' f >>> h@ +-- +-- [/sliding/] +-- @'loop' (f >>> 'arr' ('id' *** k)) = 'loop' ('arr' ('id' *** k) >>> f)@ +-- +-- [/vanishing/] +-- @'loop' ('loop' f) = 'loop' ('arr' unassoc >>> f >>> 'arr' assoc)@ +-- +-- [/superposing/] +-- @'second' ('loop' f) = 'loop' ('arr' assoc >>> 'second' f >>> 'arr' unassoc)@ +-- +-- where +-- +-- > assoc ((a,b),c) = (a,(b,c)) +-- > unassoc (a,(b,c)) = ((a,b),c) +-- +class Arrow a => ArrowLoop a where + loop :: a (b,d) (c,d) -> a b c + +instance ArrowLoop (->) where + loop f b = let (c,d) = f (b,d) in c + +-- | Beware that for many monads (those for which the '>>=' operation +-- is strict) this instance will /not/ satisfy the right-tightening law +-- required by the 'ArrowLoop' class. +instance MonadFix m => ArrowLoop (Kleisli m) where + loop (Kleisli f) = Kleisli (liftM fst . mfix . f') + where f' x y = f (x, snd y) diff --git a/libraries/base/Control/Category.hs b/libraries/base/Control/Category.hs new file mode 100644 index 0000000..b638189 --- /dev/null +++ b/libraries/base/Control/Category.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} + -- The RULES for the methods of class Category may never fire + -- e.g. identity/left, identity/right, association; see Trac #10528 + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Category +-- Copyright : (c) Ashley Yakeley 2007 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ashley@semantic.org +-- Stability : experimental +-- Portability : portable + +-- http://ghc.haskell.org/trac/ghc/ticket/1773 + +module Control.Category where + +import qualified GHC.Base (id,(.)) +import Data.Type.Coercion +import Data.Type.Equality +import GHC.Prim (coerce) + +infixr 9 . +infixr 1 >>>, <<< + +-- | A class for categories. +-- id and (.) must form a monoid. +class Category cat where + -- | the identity morphism + id :: cat a a + + -- | morphism composition + (.) :: cat b c -> cat a b -> cat a c + +{-# RULES +"identity/left" forall p . + id . p = p +"identity/right" forall p . + p . id = p +"association" forall p q r . + (p . q) . r = p . (q . r) + #-} + +instance Category (->) where + id = GHC.Base.id + (.) = (GHC.Base..) + +instance Category (:~:) where + id = Refl + Refl . Refl = Refl + +instance Category Coercion where + id = Coercion + (.) Coercion = coerce + +-- | Right-to-left composition +(<<<) :: Category cat => cat b c -> cat a b -> cat a c +(<<<) = (.) + +-- | Left-to-right composition +(>>>) :: Category cat => cat a b -> cat b c -> cat a c +f >>> g = g . f diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs new file mode 100644 index 0000000..376870a --- /dev/null +++ b/libraries/base/Control/Concurrent.hs @@ -0,0 +1,668 @@ +{-# 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 : experimental +-- 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 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 Control.Exception.Base as Exception + +import GHC.Conc hiding (threadWaitRead, threadWaitWrite, + threadWaitReadSTM, threadWaitWriteSTM) +import GHC.IO ( unsafeUnmask, catchException ) +import GHC.IORef ( newIORef, readIORef, writeIORef ) +import GHC.Base + +import System.Posix.Types ( Fd ) +import Foreign.StablePtr +import Foreign.C.Types + +#ifdef mingw32_HOST_OS +import Foreign.C +import System.IO +import Data.Functor ( void ) +#else +import qualified GHC.Conc +#endif + +import 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" library. +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. + +-} + +-- | 'True' if bound threads are supported. +-- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound' +-- will always return 'False' and both 'forkOS' and 'runInBoundThread' will +-- fail. +foreign import ccall rtsSupportsBoundThreads :: Bool + + +{- | +Like 'forkIO', this sparks off a new thread to run the 'IO' +computation passed as the first argument, and returns the 'ThreadId' +of the newly created thread. + +However, 'forkOS' creates a /bound/ thread, which is necessary if you +need to call foreign (non-Haskell) libraries that make use of +thread-local state, such as OpenGL (see "Control.Concurrent#boundthreads"). + +Using 'forkOS' instead of 'forkIO' makes no difference at all to the +scheduling behaviour of the Haskell runtime system. It is a common +misconception that you need to use 'forkOS' instead of 'forkIO' to +avoid blocking all the Haskell threads when making a foreign call; +this isn't the case. To allow foreign calls to be made without +blocking all the Haskell threads (with GHC), it is only necessary to +use the @-threaded@ option when linking your program, and to make sure +the foreign import is not marked @unsafe@. +-} + +forkOS :: IO () -> IO ThreadId + +foreign export ccall forkOS_entry + :: StablePtr (IO ()) -> IO () + +foreign import ccall "forkOS_entry" forkOS_entry_reimported + :: StablePtr (IO ()) -> IO () + +forkOS_entry :: StablePtr (IO ()) -> IO () +forkOS_entry stableAction = do + action <- deRefStablePtr stableAction + action + +foreign import ccall forkOS_createThread + :: StablePtr (IO ()) -> IO CInt + +failNonThreaded :: IO a +failNonThreaded = fail $ "RTS doesn't support multiple OS threads " + ++"(use ghc -threaded when linking)" + +forkOS action0 + | rtsSupportsBoundThreads = do + mv <- newEmptyMVar + b <- Exception.getMaskingState + let + -- async exceptions are masked in the child if they are masked + -- in the parent, as for forkIO (see #1048). forkOS_createThread + -- creates a thread with exceptions masked by default. + action1 = case b of + Unmasked -> unsafeUnmask action0 + MaskedInterruptible -> action0 + MaskedUninterruptible -> uninterruptibleMask_ action0 + + action_plus = catchException action1 childHandler + + entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus) + err <- forkOS_createThread entry + when (err /= 0) $ fail "Cannot create OS thread." + tid <- takeMVar mv + freeStablePtr entry + return tid + | otherwise = failNonThreaded + +-- | Like 'forkIOWithUnmask', but the child thread is a bound thread, +-- as with 'forkOS'. +forkOSWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId +forkOSWithUnmask io = forkOS (io unsafeUnmask) + +-- | Returns 'True' if the calling thread is /bound/, that is, if it is +-- safe to use foreign libraries that rely on thread-local state from the +-- calling thread. +isCurrentThreadBound :: IO Bool +isCurrentThreadBound = IO $ \ s# -> + case isCurrentThreadBound# s# of + (# s2#, flg #) -> (# s2#, isTrue# (flg /=# 0#) #) + + +{- | +Run the 'IO' computation passed as the first argument. If the calling thread +is not /bound/, a bound thread is created temporarily. @runInBoundThread@ +doesn't finish until the 'IO' computation finishes. + +You can wrap a series of foreign function calls that rely on thread-local state +with @runInBoundThread@ so that you can use them without knowing whether the +current thread is /bound/. +-} +runInBoundThread :: IO a -> IO a + +runInBoundThread action + | rtsSupportsBoundThreads = do + bound <- isCurrentThreadBound + if bound + then action + else do + ref <- newIORef undefined + let action_plus = Exception.try action >>= writeIORef ref + bracket (newStablePtr action_plus) + freeStablePtr + (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref) >>= + unsafeResult + | otherwise = failNonThreaded + +{- | +Run the 'IO' computation passed as the first argument. If the calling thread +is /bound/, an unbound thread is created temporarily using 'forkIO'. +@runInBoundThread@ doesn't finish until the 'IO' computation finishes. + +Use this function /only/ in the rare case that you have actually observed a +performance loss due to the use of bound threads. A program that +doesn't need its main thread to be bound and makes /heavy/ use of concurrency +(e.g. a web server), might want to wrap its @main@ action in +@runInUnboundThread@. + +Note that exceptions which are thrown to the current thread are thrown in turn +to the thread that is executing the given computation. This ensures there's +always a way of killing the forked thread. +-} +runInUnboundThread :: IO a -> IO a + +runInUnboundThread action = do + bound <- isCurrentThreadBound + if bound + then do + mv <- newEmptyMVar + mask $ \restore -> do + tid <- forkIO $ Exception.try (restore action) >>= putMVar mv + let wait = takeMVar mv `catchException` \(e :: SomeException) -> + Exception.throwTo tid e >> wait + wait >>= unsafeResult + else action + +unsafeResult :: Either SomeException a -> IO a +unsafeResult = either Exception.throwIO return + +-- --------------------------------------------------------------------------- +-- 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 +#ifdef 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 (waitFd fd 0) + | 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 System.IO.hWaitForInput" +#else + = GHC.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 +#ifdef mingw32_HOST_OS + | threaded = withThread (waitFd fd 1) + | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows" +#else + = GHC.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 +#ifdef mingw32_HOST_OS + | threaded = do v <- newTVarIO Nothing + mask_ $ void $ forkIO $ do result <- try (waitFd fd 0) + 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 + = GHC.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 +#ifdef mingw32_HOST_OS + | threaded = do v <- newTVarIO Nothing + mask_ $ void $ forkIO $ do result <- try (waitFd fd 1) + 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 + = GHC.Conc.threadWaitWriteSTM fd +#endif + +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool + +withThread :: IO a -> IO a +withThread io = do + m <- newEmptyMVar + _ <- mask_ $ forkIO $ try io >>= putMVar m + x <- takeMVar m + case x of + Right a -> return a + Left e -> throwIO (e :: IOException) + +waitFd :: Fd -> CInt -> IO () +waitFd fd write = do + throwErrnoIfMinus1_ "fdReady" $ + fdReady (fromIntegral fd) write iNFINITE 0 + +iNFINITE :: CInt +iNFINITE = 0xFFFFFFFF -- urgh + +foreign import ccall safe "fdReady" + fdReady :: CInt -> CInt -> CInt -> CInt -> 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" library 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" library 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 '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/libraries/base/Control/Concurrent/Chan.hs b/libraries/base/Control/Concurrent/Chan.hs new file mode 100644 index 0000000..ed8e02b --- /dev/null +++ b/libraries/base/Control/Concurrent/Chan.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- Portability : non-portable (concurrency) +-- +-- Unbounded channels. +-- +-- The channels are implemented with @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, + unGetChan, + isEmptyChan, + + -- * Stream interface + getChanContents, + writeList2Chan, + ) where + +import System.IO.Unsafe ( unsafeInterleaveIO ) +import Control.Concurrent.MVar +import 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) + +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 the +-- 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 returns 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'. +readChan :: Chan a -> IO a +readChan (Chan readVar _) = do + modifyMVarMasked readVar $ \read_end -> do -- Note [modifyMVarMasked] + (ChItem val new_read_end) <- readMVar read_end + -- Use readMVar here, not takeMVar, + -- else dupChan doesn't work + return (new_read_end, val) + +-- Note [modifyMVarMasked] +-- This prevents a theoretical deadlock if an asynchronous exception +-- happens during the readMVar while the MVar is empty. In that case +-- the read_end MVar will be left empty, and subsequent readers will +-- deadlock. Using modifyMVarMasked prevents this. The deadlock can +-- be reproduced, but only by expanding readMVar and inserting an +-- artificial yield between its takeMVar and putMVar operations. + + +-- |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) + +-- |Put a data item back onto a channel, where it will be the next item read. +unGetChan :: Chan a -> a -> IO () +unGetChan (Chan readVar _) val = do + new_read_end <- newEmptyMVar + modifyMVar_ readVar $ \read_end -> do + putMVar new_read_end (ChItem val read_end) + return new_read_end +{-# DEPRECATED unGetChan "if you need this operation, use Control.Concurrent.STM.TChan instead. See for details" #-} -- deprecated in 7.0 + +-- |Returns 'True' if the supplied 'Chan' is empty. +isEmptyChan :: Chan a -> IO Bool +isEmptyChan (Chan readVar writeVar) = do + withMVar readVar $ \r -> do + w <- readMVar writeVar + let eq = r == w + eq `seq` return eq +{-# DEPRECATED isEmptyChan "if you need this operation, use Control.Concurrent.STM.TChan instead. See for details" #-} -- deprecated in 7.0 + +-- Operators for interfacing with functional streams. + +-- |Return a lazy list representing the contents of the supplied +-- 'Chan', much like '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/libraries/base/Control/Concurrent/MVar.hs b/libraries/base/Control/Concurrent/MVar.hs new file mode 100644 index 0000000..f76eaeb --- /dev/null +++ b/libraries/base/Control/Concurrent/MVar.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, UnboxedTuples, MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- Portability : non-portable (concurrency) +-- +-- An @'MVar' t@ is 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 +-- +-- 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 'IORef's, but less flexibility +-- than 'STM'. They are appropriate for building synchronization +-- primitives and performing simple interthread communication; however +-- they are very simple and susceptible to race conditions, deadlocks or +-- uncaught exceptions. Do not use them if you need perform larger +-- atomic operations such as reading from multiple variables: use 'STM' +-- instead. +-- +-- In particular, the "bigger" functions in this module ('readMVar', +-- 'swapMVar', 'withMVar', 'modifyMVar_' and 'modifyMVar') are simply +-- the composition of a 'takeMVar' followed by a 'putMVar' with +-- exception safety. +-- These only have atomicity guarantees 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, 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 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 '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.MVar ( MVar(..), newEmptyMVar, newMVar, takeMVar, putMVar, + tryTakeMVar, tryPutMVar, isEmptyMVar, readMVar, + tryReadMVar + ) +import qualified GHC.MVar +import GHC.Weak +import GHC.Base + +import Control.Exception.Base + +{-| + Take a value from an 'MVar', put a new value into the 'MVar' and + return the value taken. This function is atomic only if there are + no other producers for this 'MVar'. +-} +swapMVar :: MVar a -> a -> IO a +swapMVar mvar new = + mask_ $ do + old <- takeMVar mvar + putMVar mvar new + return old + +{-| + 'withMVar' is an exception-safe wrapper for operating on the contents + of an 'MVar'. This operation is exception-safe: it will replace the + original contents of the 'MVar' if an exception is raised (see + "Control.Exception"). However, it is only atomic if there are no + other producers for this 'MVar'. +-} +{-# INLINE withMVar #-} +-- inlining has been reported to have dramatic effects; see +-- http://www.haskell.org//pipermail/haskell/2006-May/017907.html +withMVar :: MVar a -> (a -> IO b) -> IO b +withMVar m io = + mask $ \restore -> do + a <- takeMVar m + b <- restore (io a) `onException` putMVar m a + putMVar m a + return b + +{-| + Like 'withMVar', but the @IO@ action in the second argument is executed + with asynchronous exceptions masked. + + @since 4.7.0.0 +-} +{-# INLINE withMVarMasked #-} +withMVarMasked :: MVar a -> (a -> IO b) -> IO b +withMVarMasked m io = + mask_ $ do + a <- takeMVar m + b <- io a `onException` putMVar m a + putMVar m a + return b + +{-| + An exception-safe wrapper for modifying the contents of an 'MVar'. + Like 'withMVar', 'modifyMVar' will replace the original contents of + the 'MVar' if an exception is raised during the operation. This + function is only atomic if there are no other producers for this + 'MVar'. +-} +{-# INLINE modifyMVar_ #-} +modifyMVar_ :: MVar a -> (a -> IO a) -> IO () +modifyMVar_ m io = + mask $ \restore -> do + a <- takeMVar m + a' <- restore (io a) `onException` putMVar m a + putMVar m a' + +{-| + A slight variation on 'modifyMVar_' that allows a value to be + returned (@b@) in addition to the modified value of the 'MVar'. +-} +{-# INLINE modifyMVar #-} +modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b +modifyMVar m io = + mask $ \restore -> do + a <- takeMVar m + (a',b) <- restore (io a >>= evaluate) `onException` putMVar m a + putMVar m a' + return b + +{-| + Like 'modifyMVar_', but the @IO@ action in the second argument is executed with + asynchronous exceptions masked. + + @since 4.6.0.0 +-} +{-# INLINE modifyMVarMasked_ #-} +modifyMVarMasked_ :: MVar a -> (a -> IO a) -> IO () +modifyMVarMasked_ m io = + mask_ $ do + a <- takeMVar m + a' <- io a `onException` putMVar m a + putMVar m a' + +{-| + Like 'modifyMVar', but the @IO@ action in the second argument is executed with + asynchronous exceptions masked. + + @since 4.6.0.0 +-} +{-# INLINE modifyMVarMasked #-} +modifyMVarMasked :: MVar a -> (a -> IO (a,b)) -> IO b +modifyMVarMasked m io = + mask_ $ do + a <- takeMVar m + (a',b) <- (io a >>= evaluate) `onException` putMVar m a + putMVar m a' + return b + +{-# DEPRECATED addMVarFinalizer "use 'mkWeakMVar' instead" #-} -- deprecated in 7.6 +addMVarFinalizer :: MVar a -> IO () -> IO () +addMVarFinalizer = GHC.MVar.addMVarFinalizer + +-- | Make a 'Weak' pointer to an 'MVar', using the second argument as +-- a finalizer to run when 'MVar' is garbage-collected +-- +-- @since 4.6.0.0 +mkWeakMVar :: MVar a -> IO () -> IO (Weak (MVar a)) +mkWeakMVar m@(MVar m#) (IO f) = IO $ \s -> + case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #) diff --git a/libraries/base/Control/Concurrent/QSem.hs b/libraries/base/Control/Concurrent/QSem.hs new file mode 100644 index 0000000..51624e4 --- /dev/null +++ b/libraries/base/Control/Concurrent/QSem.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- 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 Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar + , putMVar, newMVar, tryPutMVar) +import Control.Exception +import Data.Maybe + +-- | 'QSem' is a quantity semaphore in which the resource is aqcuired +-- 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. +-- +data 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` do + (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/libraries/base/Control/Concurrent/QSemN.hs b/libraries/base/Control/Concurrent/QSemN.hs new file mode 100644 index 0000000..7686d3f --- /dev/null +++ b/libraries/base/Control/Concurrent/QSemN.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE BangPatterns #-} +{-# 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 : experimental +-- 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 Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar + , putMVar, newMVar + , tryPutMVar, isEmptyMVar) +import Control.Exception +import Data.Maybe + +-- | 'QSemN' is a quantity semaphore in which the resource is aqcuired +-- and released in units of one. 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 !(MVar (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; the MVar lock on the +-- semaphore itself resolves race conditions between signalQSemN and a +-- thread attempting to dequeue itself. + +-- |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 <- newMVar (initial, [], []) + return (QSemN sem) + +-- |Wait for the specified quantity to become available +waitQSemN :: QSemN -> Int -> IO () +waitQSemN (QSemN m) sz = + mask_ $ do + (i,b1,b2) <- takeMVar m + let z = i-sz + if z < 0 + then do + b <- newEmptyMVar + putMVar m (i, b1, (sz,b):b2) + wait b + else do + putMVar m (z, b1, b2) + return () + where + wait b = do + takeMVar b `onException` + (uninterruptibleMask_ $ do -- Note [signal uninterruptible] + (i,b1,b2) <- takeMVar m + r <- tryTakeMVar b + r' <- if isJust r + then signal sz (i,b1,b2) + else do putMVar b (); return (i,b1,b2) + putMVar m r') + +-- |Signal that a given quantity is now available from the 'QSemN'. +signalQSemN :: QSemN -> Int -> IO () +signalQSemN (QSemN m) sz = uninterruptibleMask_ $ do + r <- takeMVar m + r' <- signal sz r + putMVar m r' + +signal :: Int + -> (Int,[(Int,MVar ())],[(Int,MVar ())]) + -> IO (Int,[(Int,MVar ())],[(Int,MVar ())]) + +signal sz0 (i,a1,a2) = loop (sz0 + i) a1 a2 + 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/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs new file mode 100644 index 0000000..9c388f4 --- /dev/null +++ b/libraries/base/Control/Exception.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Exception +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- 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 Exception type + SomeException(..), + Exception(..), -- class + IOException, -- instance Eq, Ord, Show, Typeable, Exception + ArithException(..), -- instance Eq, Ord, Show, Typeable, Exception + ArrayException(..), -- instance Eq, Ord, Show, Typeable, Exception + AssertionFailed(..), + SomeAsyncException(..), + AsyncException(..), -- instance Eq, Ord, Show, Typeable, Exception + asyncExceptionToException, asyncExceptionFromException, + + NonTermination(..), + NestedAtomically(..), + BlockedIndefinitelyOnMVar(..), + BlockedIndefinitelyOnSTM(..), + AllocationLimitExceeded(..), + Deadlock(..), + NoMethodError(..), + PatternMatchFail(..), + RecConError(..), + RecSelError(..), + RecUpdError(..), + ErrorCall(..), + TypeError(..), + + -- * Throwing exceptions + throw, + throwIO, + ioError, + throwTo, + + -- * Catching Exceptions + + -- $catching + + -- ** Catching all exceptions + + -- $catchall + + -- ** The @catch@ functions + catch, + catches, Handler(..), + catchJust, + + -- ** The @handle@ functions + handle, + handleJust, + + -- ** The @try@ functions + try, + 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, + + ) where + +import Control.Exception.Base + +import GHC.Base +import GHC.IO (interruptible) + +-- | You need this when using 'catches'. +data Handler a = forall e . Exception e => Handler (e -> IO a) + +instance Functor Handler where + fmap f (Handler h) = Handler (fmap f . h) + +{- | +Sometimes you want to catch two different sorts of exception. You could +do something like + +> f = expr `catch` \ (ex :: ArithException) -> handleArith ex +> `catch` \ (ex :: IOException) -> handleIO ex + +However, there are a couple of problems with this approach. The first is +that having two exception handlers is inefficient. However, the more +serious issue is that the second exception handler will catch exceptions +in the first, e.g. in the example above, if @handleArith@ throws an +@IOException@ then the second exception handler will catch it. + +Instead, we provide a function 'catches', which would be used thus: + +> f = expr `catches` [Handler (\ (ex :: ArithException) -> handleArith ex), +> Handler (\ (ex :: IOException) -> handleIO ex)] +-} +catches :: IO a -> [Handler a] -> IO a +catches io handlers = io `catch` catchesHandler handlers + +catchesHandler :: [Handler a] -> SomeException -> IO a +catchesHandler handlers e = foldr tryHandler (throw e) handlers + where tryHandler (Handler handler) res + = case fromException e of + Just e' -> handler e' + Nothing -> res + +-- ----------------------------------------------------------------------------- +-- Catching exceptions + +{- $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 -> ... + +-} + +-- ----------------------------------------------------------------------------- +-- Asynchronous exceptions + +-- | When invoked inside 'mask', this function allows a masked +-- asynchronous exception to be raised, if one exists. It is +-- equivalent to performing an interruptible operation (see +-- #interruptible), but does not involve any actual blocking. +-- +-- When called outside 'mask', or inside 'uninterruptibleMask', this +-- function has no effect. +-- +-- @since 4.4.0.0 +allowInterrupt :: IO () +allowInterrupt = interruptible $ return () + +{- $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 perfom 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 'IORef' from "Data.IORef" + + * STM transactions that do not use 'retry' + + * everything from the @Foreign@ modules + + * everything from @Control.Exception@ except for 'throwTo' + + * @tryTakeMVar@, @tryPutMVar@, @isEmptyMVar@ + + * @takeMVar@ if the @MVar@ is definitely full, and conversely @putMVar@ if the @MVar@ is definitely empty + + * @newEmptyMVar@, @newMVar@ + + * @forkIO@, @forkIOUnmasked@, @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 occassions 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/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs new file mode 100644 index 0000000..5b3d47c --- /dev/null +++ b/libraries/base/Control/Exception/Base.hs @@ -0,0 +1,422 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- 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(..), + BlockedIndefinitelyOnSTM(..), + AllocationLimitExceeded(..), + Deadlock(..), + NoMethodError(..), + PatternMatchFail(..), + RecConError(..), + RecSelError(..), + RecUpdError(..), + ErrorCall(..), + TypeError(..), -- #10284, custom error type for deferred type errors + + -- * 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, irrefutPatError, runtimeError, + nonExhaustiveGuardsError, patError, noMethodBindingError, + absentError, typeError, + nonTermination, nestedAtomically, + ) where + +import GHC.Base +import GHC.IO hiding (bracket,finally,onException) +import GHC.IO.Exception +import GHC.Exception +import GHC.Show +-- import GHC.Exception hiding ( Exception ) +import GHC.Conc.Sync + +import Data.Either + +----------------------------------------------------------------------------- +-- Catching exceptions + +-- |This is the simplest of the exception-catching functions. It +-- takes a single argument, runs it, and if an exception is raised +-- the \"handler\" is executed, with the value of the exception passed as an +-- argument. Otherwise, the result is returned as normal. For example: +-- +-- > catch (readFile f) +-- > (\e -> do let err = show (e :: IOException) +-- > hPutStr stderr ("Warning: Couldn't open " ++ f ++ ": " ++ err) +-- > return "") +-- +-- Note that we have to give a type signature to @e@, or the program +-- will not typecheck as the type is ambiguous. While it is possible +-- to catch exceptions of any type, see the section \"Catching all +-- exceptions\" (in "Control.Exception") for an explanation of the problems with doing so. +-- +-- For catching exceptions in pure (non-'IO') expressions, see the +-- function 'evaluate'. +-- +-- Note that due to Haskell\'s unspecified evaluation order, an +-- expression may throw one of several possible exceptions: consider +-- the expression @(error \"urk\") + (1 \`div\` 0)@. Does +-- the expression throw +-- @ErrorCall \"urk\"@, or @DivideByZero@? +-- +-- The answer is \"it might throw either\"; the choice is +-- non-deterministic. If you are catching any type of exception then you +-- might catch either. If you are calling @catch@ with type +-- @IO Int -> (ArithException -> IO Int) -> IO Int@ then the handler may +-- get run with @DivideByZero@ as an argument, or an @ErrorCall \"urk\"@ +-- exception may be propogated further up. If you call it again, you +-- might get a the opposite behaviour. This is ok, because 'catch' is an +-- 'IO' computation. +-- +catch :: Exception e + => IO a -- ^ The computation to run + -> (e -> IO a) -- ^ Handler to invoke if an exception is raised + -> IO a +catch act = catchException (lazy act) + +-- | The function 'catchJust' is like 'catch', but it takes an extra +-- argument which is an /exception predicate/, a function which +-- selects which type of exceptions we\'re interested in. +-- +-- > catchJust (\e -> if isDoesNotExistErrorType (ioeGetErrorType e) then Just () else Nothing) +-- > (readFile f) +-- > (\_ -> do hPutStrLn stderr ("No such file: " ++ show f) +-- > return "") +-- +-- Any other exceptions which are not matched by the predicate +-- are re-raised, and may be caught by an enclosing +-- 'catch', 'catchJust', etc. +catchJust + :: Exception e + => (e -> Maybe b) -- ^ Predicate to select exceptions + -> IO a -- ^ Computation to run + -> (b -> IO a) -- ^ Handler + -> IO a +catchJust p a handler = catch a handler' + where handler' e = case p e of + Nothing -> throwIO e + Just b -> handler b + +-- | A version of 'catch' with the arguments swapped around; useful in +-- situations where the code for the handler is shorter. For example: +-- +-- > do handle (\NonTermination -> exitWith (ExitFailure 1)) $ +-- > ... +handle :: Exception e => (e -> IO a) -> IO a -> IO a +handle = flip catch + +-- | A version of 'catchJust' with the arguments swapped around (see +-- 'handle'). +handleJust :: Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a +handleJust p = flip (catchJust p) + +----------------------------------------------------------------------------- +-- 'mapException' + +-- | This function maps one exception into another as proposed in the +-- paper \"A semantics for imprecise exceptions\". + +-- Notice that the usage of 'unsafePerformIO' is safe here. + +mapException :: (Exception e1, Exception e2) => (e1 -> e2) -> a -> a +mapException f v = unsafePerformIO (catch (evaluate v) + (\x -> throwIO (f x))) + +----------------------------------------------------------------------------- +-- 'try' and variations. + +-- | Similar to 'catch', but returns an 'Either' result which is +-- @('Right' a)@ if no exception of type @e@ was raised, or @('Left' ex)@ +-- if an exception of type @e@ was raised and its value is @ex@. +-- If any other type of exception is raised than it will be propogated +-- up to the next enclosing exception handler. +-- +-- > try a = catch (Right `liftM` a) (return . Left) + +try :: Exception e => IO a -> IO (Either e a) +try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e)) + +-- | A variant of 'try' that takes an exception predicate to select +-- which exceptions are caught (c.f. 'catchJust'). If the exception +-- does not match the predicate, it is re-thrown. +tryJust :: Exception e => (e -> Maybe b) -> IO a -> IO (Either b a) +tryJust p a = do + r <- try a + case r of + Right v -> return (Right v) + Left e -> case p e of + Nothing -> throwIO e + Just b -> return (Left b) + +-- | Like 'finally', but only performs the final action if there was an +-- exception raised by the computation. +onException :: IO a -> IO b -> IO a +onException io what = io `catch` \e -> do _ <- what + throwIO (e :: SomeException) + +----------------------------------------------------------------------------- +-- Some Useful Functions + +-- | When you want to acquire a resource, do some work with it, and +-- then release the resource, it is a good idea to use 'bracket', +-- because 'bracket' will install the necessary exception handler to +-- release the resource in the event that an exception is raised +-- during the computation. If an exception is raised, then 'bracket' will +-- re-raise the exception (after performing the release). +-- +-- A common example is opening a file: +-- +-- > bracket +-- > (openFile "filename" ReadMode) +-- > (hClose) +-- > (\fileHandle -> do { ... }) +-- +-- The arguments to 'bracket' are in this order so that we can partially apply +-- it, e.g.: +-- +-- > withFile name mode = bracket (openFile name mode) hClose +-- +bracket + :: IO a -- ^ computation to run first (\"acquire resource\") + -> (a -> IO b) -- ^ computation to run last (\"release resource\") + -> (a -> IO c) -- ^ computation to run in-between + -> IO c -- returns the value from the in-between computation +bracket before after thing = + mask $ \restore -> do + a <- before + r <- restore (thing a) `onException` after a + _ <- after a + return r + +-- | A specialised variant of 'bracket' with just a computation to run +-- afterward. +-- +finally :: IO a -- ^ computation to run first + -> IO b -- ^ computation to run afterward (even if an exception + -- was raised) + -> IO a -- returns the value from the first computation +a `finally` sequel = + mask $ \restore -> do + r <- restore a `onException` sequel + _ <- sequel + return r + +-- | A variant of 'bracket' where the return value from the first computation +-- is not required. +bracket_ :: IO a -> IO b -> IO c -> IO c +bracket_ before after thing = bracket before (const after) (const thing) + +-- | Like 'bracket', but only performs the final action if there was an +-- exception raised by the in-between computation. +bracketOnError + :: IO a -- ^ computation to run first (\"acquire resource\") + -> (a -> IO b) -- ^ computation to run last (\"release resource\") + -> (a -> IO c) -- ^ computation to run in-between + -> IO c -- returns the value from the in-between computation +bracketOnError before after thing = + mask $ \restore -> do + a <- before + restore (thing a) `onException` after a + +----- + +-- |A pattern match failed. The @String@ gives information about the +-- source location of the pattern. +newtype PatternMatchFail = PatternMatchFail String + +instance Show PatternMatchFail where + showsPrec _ (PatternMatchFail err) = showString err + +instance Exception PatternMatchFail + +----- + +-- |A record selector was applied to a constructor without the +-- appropriate field. This can only happen with a datatype with +-- multiple constructors, where some fields are in one constructor +-- but not another. The @String@ gives information about the source +-- location of the record selector. +newtype RecSelError = RecSelError String + +instance Show RecSelError where + showsPrec _ (RecSelError err) = showString err + +instance Exception RecSelError + +----- + +-- |An uninitialised record field was used. The @String@ gives +-- information about the source location where the record was +-- constructed. +newtype RecConError = RecConError String + +instance Show RecConError where + showsPrec _ (RecConError err) = showString err + +instance Exception RecConError + +----- + +-- |A record update was performed on a constructor without the +-- appropriate field. This can only happen with a datatype with +-- multiple constructors, where some fields are in one constructor +-- but not another. The @String@ gives information about the source +-- location of the record update. +newtype RecUpdError = RecUpdError String + +instance Show RecUpdError where + showsPrec _ (RecUpdError err) = showString err + +instance Exception RecUpdError + +----- + +-- |A class method without a definition (neither a default definition, +-- nor a definition in the appropriate instance) was called. The +-- @String@ gives information about which method it was. +newtype NoMethodError = NoMethodError String + +instance Show NoMethodError where + showsPrec _ (NoMethodError err) = showString err + +instance Exception NoMethodError + +----- + +-- |An expression that didn't typecheck during compile time was called. +-- This is only possible with -fdefer-type-errors. The @String@ gives +-- details about the failed type check. +-- +-- @since 4.9.0.0 +newtype TypeError = TypeError String + +instance Show TypeError where + showsPrec _ (TypeError err) = showString err + +instance Exception TypeError + +----- + +-- |Thrown when the runtime system detects that the computation is +-- guaranteed not to terminate. Note that there is no guarantee that +-- the runtime system will notice whether any given computation is +-- guaranteed to terminate or not. +data NonTermination = NonTermination + +instance Show NonTermination where + showsPrec _ NonTermination = showString "<>" + +instance Exception NonTermination + +----- + +-- |Thrown when the program attempts to call @atomically@, from the @stm@ +-- package, inside another call to @atomically@. +data NestedAtomically = NestedAtomically + +instance Show NestedAtomically where + showsPrec _ NestedAtomically = showString "Control.Concurrent.STM.atomically was nested" + +instance Exception NestedAtomically + +----- + +recSelError, recConError, irrefutPatError, runtimeError, + nonExhaustiveGuardsError, patError, noMethodBindingError, + absentError, typeError + :: Addr# -> a -- All take a UTF8-encoded C string + +recSelError s = throw (RecSelError ("No match in record selector " + ++ unpackCStringUtf8# s)) -- No location info unfortunately +runtimeError s = errorWithoutStackTrace (unpackCStringUtf8# s) -- No location info unfortunately +absentError s = errorWithoutStackTrace ("Oops! Entered absent arg " ++ unpackCStringUtf8# s) + +nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in")) +irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern")) +recConError s = throw (RecConError (untangle s "Missing field in record construction")) +noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation")) +patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in")) +typeError s = throw (TypeError (unpackCStringUtf8# s)) + +-- GHC's RTS calls this +nonTermination :: SomeException +nonTermination = toException NonTermination + +-- GHC's RTS calls this +nestedAtomically :: SomeException +nestedAtomically = toException NestedAtomically diff --git a/libraries/base/Control/Monad.hs b/libraries/base/Control/Monad.hs new file mode 100644 index 0000000..a964581 --- /dev/null +++ b/libraries/base/Control/Monad.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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(fmap) + , Monad((>>=), (>>), return, 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 Data.Foldable ( Foldable, sequence_, sequenceA_, msum, mapM_, foldlM, forM_ ) +import Data.Functor ( void, (<$>) ) +import Data.Traversable ( forM, mapM, traverse, sequence, sequenceA ) + +import GHC.Base hiding ( mapM, sequence ) +import GHC.List ( zipWith, unzip ) +import GHC.Num ( (-) ) + +-- ----------------------------------------------------------------------------- +-- Functions mandated by the Prelude + +-- | @'guard' b@ is @'pure' ()@ if @b@ is 'True', +-- and 'empty' if @b@ is 'False'. +guard :: (Alternative f) => Bool -> f () +guard True = pure () +guard False = empty + +-- | This generalizes the list-based 'filter' function. + +{-# INLINE filterM #-} +filterM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] +filterM p = foldr (\ x -> liftA2 (\ flg -> if flg then (x:) else id) (p x)) (pure []) + +infixr 1 <=<, >=> + +-- | Left-to-right Kleisli composition of monads. +(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) +f >=> g = \x -> f x >>= g + +-- | Right-to-left Kleisli composition of monads. @('>=>')@, with the arguments flipped. +-- +-- Note how this operator resembles function composition @('.')@: +-- +-- > (.) :: (b -> c) -> (a -> b) -> a -> c +-- > (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> a -> m c +(<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c) +(<=<) = flip (>=>) + +-- | @'forever' act@ repeats the action infinitely. +forever :: (Applicative f) => f a -> f b +{-# INLINE forever #-} +forever a = let a' = a *> a' in a' +-- Use explicit sharing here, as it is prevents a space leak regardless of +-- optimizations. + +-- ----------------------------------------------------------------------------- +-- Other monad functions + +-- | The 'mapAndUnzipM' function maps its first argument over a list, returning +-- the result as a pair of lists. This function is mainly used with complicated +-- data structures or a state-transforming monad. +mapAndUnzipM :: (Applicative m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) +{-# INLINE mapAndUnzipM #-} +mapAndUnzipM f xs = unzip <$> traverse f xs + +-- | The 'zipWithM' function generalizes 'zipWith' to arbitrary applicative functors. +zipWithM :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m [c] +{-# INLINE zipWithM #-} +zipWithM f xs ys = sequenceA (zipWith f xs ys) + +-- | 'zipWithM_' is the extension of 'zipWithM' which ignores the final result. +zipWithM_ :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m () +{-# INLINE zipWithM_ #-} +zipWithM_ f xs ys = sequenceA_ (zipWith f xs ys) + +{- | The 'foldM' function is analogous to 'foldl', except that its result is +encapsulated in a monad. Note that 'foldM' works from left-to-right over +the list arguments. This could be an issue where @('>>')@ and the `folded +function' are not commutative. + + +> foldM f a1 [x1, x2, ..., xm] + +== + +> do +> a2 <- f a1 x1 +> a3 <- f a2 x2 +> ... +> f am xm + +If right-to-left evaluation is required, the input list should be reversed. + +Note: 'foldM' is the same as 'foldlM' +-} + +foldM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b +{-# INLINEABLE foldM #-} +{-# SPECIALISE foldM :: (a -> b -> IO a) -> a -> [b] -> IO a #-} +{-# SPECIALISE foldM :: (a -> b -> Maybe a) -> a -> [b] -> Maybe a #-} +foldM = foldlM + +-- | Like 'foldM', but discards the result. +foldM_ :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m () +{-# INLINEABLE foldM_ #-} +{-# SPECIALISE foldM_ :: (a -> b -> IO a) -> a -> [b] -> IO () #-} +{-# SPECIALISE foldM_ :: (a -> b -> Maybe a) -> a -> [b] -> Maybe () #-} +foldM_ f a xs = foldlM f a xs >> return () + +{- +Note [Worker/wrapper transform on replicateM/replicateM_ +-------------------------------------------------------- + +The implementations of replicateM and replicateM_ both leverage the +worker/wrapper transform. The simpler implementation of replicateM_, as an +example, would be: + + replicateM_ 0 _ = pure () + replicateM_ n f = f *> replicateM_ (n - 1) f + +However, the self-recrusive nature of this implementation inhibits inlining, +which means we never get to specialise to the action (`f` in the code above). +By contrast, the implementation below with a local loop makes it possible to +inline the entire definition (as hapens for foldr, for example) thereby +specialising for the particular action. + +For further information, see this Trac comment, which includes side-by-side +Core. + +https://ghc.haskell.org/trac/ghc/ticket/11795#comment:6 + +-} + +-- | @'replicateM' n act@ performs the action @n@ times, +-- gathering the results. +replicateM :: (Applicative m) => Int -> m a -> m [a] +{-# INLINEABLE replicateM #-} +{-# SPECIALISE replicateM :: Int -> IO a -> IO [a] #-} +{-# SPECIALISE replicateM :: Int -> Maybe a -> Maybe [a] #-} +replicateM cnt0 f = + loop cnt0 + where + loop cnt + | cnt <= 0 = pure [] + | otherwise = liftA2 (:) f (loop (cnt - 1)) + +-- | Like 'replicateM', but discards the result. +replicateM_ :: (Applicative m) => Int -> m a -> m () +{-# INLINEABLE replicateM_ #-} +{-# SPECIALISE replicateM_ :: Int -> IO a -> IO () #-} +{-# SPECIALISE replicateM_ :: Int -> Maybe a -> Maybe () #-} +replicateM_ cnt0 f = + loop cnt0 + where + loop cnt + | cnt <= 0 = pure () + | otherwise = f *> loop (cnt - 1) + + +-- | The reverse of 'when'. +unless :: (Applicative f) => Bool -> f () -> f () +{-# INLINEABLE unless #-} +{-# SPECIALISE unless :: Bool -> IO () -> IO () #-} +{-# SPECIALISE unless :: Bool -> Maybe () -> Maybe () #-} +unless p s = if p then pure () else s + +infixl 4 <$!> + +-- | Strict version of 'Data.Functor.<$>'. +-- +-- @since 4.8.0.0 +(<$!>) :: Monad m => (a -> b) -> m a -> m b +{-# INLINE (<$!>) #-} +f <$!> m = do + x <- m + let z = f x + z `seq` return z + + +-- ----------------------------------------------------------------------------- +-- Other MonadPlus functions + +-- | Direct 'MonadPlus' equivalent of 'filter' +-- @'filter'@ = @(mfilter:: (a -> Bool) -> [a] -> [a]@ +-- applicable to any 'MonadPlus', for example +-- @mfilter odd (Just 1) == Just 1@ +-- @mfilter odd (Just 2) == Nothing@ + +mfilter :: (MonadPlus m) => (a -> Bool) -> m a -> m a +{-# INLINEABLE mfilter #-} +mfilter p ma = do + a <- ma + if p a then return a else mzero + +{- $naming + +The functions in this library 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: + +> sum :: Num a => [a] -> a +> msum :: MonadPlus m => [m a] -> m a + +-} diff --git a/libraries/base/Control/Monad/Fail.hs b/libraries/base/Control/Monad/Fail.hs new file mode 100644 index 0000000..9c5afbe --- /dev/null +++ b/libraries/base/Control/Monad/Fail.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- 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.Base (String, Monad(), Maybe(Nothing), IO()) +import {-# SOURCE #-} GHC.IO (failIO) + +-- | When a value is bound in @do@-notation, the pattern on the left +-- hand side of @<-@ might not match. In this case, this class +-- provides a function to recover. +-- +-- A 'Monad' without a 'MonadFail' instance may only be used in conjunction +-- with pattern that always match, such as newtypes, tuples, data types with +-- only a single data constructor, and irrefutable patterns (@~pat@). +-- +-- Instances of 'MonadFail' should satisfy the following law: @fail s@ should +-- be a left zero for '>>=', +-- +-- @ +-- fail s >>= f = fail s +-- @ +-- +-- If your 'Monad' is also 'MonadPlus', a popular definition is +-- +-- @ +-- fail _ = mzero +-- @ +-- +-- @since 4.9.0.0 +class Monad m => MonadFail m where + fail :: String -> m a + + +instance MonadFail Maybe where + fail _ = Nothing + +instance MonadFail [] where + {-# INLINE fail #-} + fail _ = [] + +instance MonadFail IO where + fail = failIO diff --git a/libraries/base/Control/Monad/Fix.hs b/libraries/base/Control/Monad/Fix.hs new file mode 100644 index 0000000..4862770 --- /dev/null +++ b/libraries/base/Control/Monad/Fix.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- Portability : portable +-- +-- Monadic fixpoints. +-- +-- For a detailed discussion, see Levent Erkok's thesis, +-- /Value Recursion in Monadic Computations/, Oregon Graduate Institute, 2002. +-- +----------------------------------------------------------------------------- + +module Control.Monad.Fix ( + MonadFix(mfix), + fix + ) where + +import Data.Either +import Data.Function ( fix ) +import Data.Maybe +import Data.Monoid ( Dual(..), Sum(..), Product(..) + , First(..), Last(..), Alt(..) ) +import GHC.Base ( Monad, errorWithoutStackTrace, (.) ) +import GHC.Generics +import GHC.List ( head, tail ) +import GHC.ST +import System.IO + +-- | Monads having fixed points with a \'knot-tying\' semantics. +-- Instances of 'MonadFix' should satisfy the following laws: +-- +-- [/purity/] +-- @'mfix' ('return' . h) = 'return' ('fix' h)@ +-- +-- [/left shrinking/ (or /tightening/)] +-- @'mfix' (\\x -> a >>= \\y -> f x y) = a >>= \\y -> 'mfix' (\\x -> f x y)@ +-- +-- [/sliding/] +-- @'mfix' ('Control.Monad.liftM' h . f) = 'Control.Monad.liftM' h ('mfix' (f . h))@, +-- for strict @h@. +-- +-- [/nesting/] +-- @'mfix' (\\x -> 'mfix' (\\y -> f x y)) = 'mfix' (\\x -> f x x)@ +-- +-- This class is used in the translation of the recursive @do@ notation +-- supported by GHC and Hugs. +class (Monad m) => MonadFix m where + -- | The fixed point of a monadic computation. + -- @'mfix' f@ executes the action @f@ only once, with the eventual + -- output fed back as the input. Hence @f@ should not be strict, + -- for then @'mfix' f@ would diverge. + mfix :: (a -> m a) -> m a + +-- Instances of MonadFix for Prelude monads + +instance MonadFix Maybe where + mfix f = let a = f (unJust a) in a + where unJust (Just x) = x + unJust Nothing = errorWithoutStackTrace "mfix Maybe: Nothing" + +instance MonadFix [] where + mfix f = case fix (f . head) of + [] -> [] + (x:_) -> x : mfix (tail . f) + +instance MonadFix IO where + mfix = fixIO + +instance MonadFix ((->) r) where + mfix f = \ r -> let a = f a r in a + +instance MonadFix (Either e) where + mfix f = let a = f (unRight a) in a + where unRight (Right x) = x + unRight (Left _) = errorWithoutStackTrace "mfix Either: Left" + +instance MonadFix (ST s) where + mfix = fixST + +-- Instances of Data.Monoid wrappers + +instance MonadFix Dual where + mfix f = Dual (fix (getDual . f)) + +instance MonadFix Sum where + mfix f = Sum (fix (getSum . f)) + +instance MonadFix Product where + mfix f = Product (fix (getProduct . f)) + +instance MonadFix First where + mfix f = First (mfix (getFirst . f)) + +instance MonadFix Last where + mfix f = Last (mfix (getLast . f)) + +instance MonadFix f => MonadFix (Alt f) where + mfix f = Alt (mfix (getAlt . f)) + +-- Instances for GHC.Generics +instance MonadFix Par1 where + mfix f = Par1 (fix (unPar1 . f)) + +instance MonadFix f => MonadFix (Rec1 f) where + mfix f = Rec1 (mfix (unRec1 . f)) + +instance MonadFix f => MonadFix (M1 i c f) where + mfix f = M1 (mfix (unM1. f)) + +instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where + mfix f = (mfix (fstP . f)) :*: (mfix (sndP . f)) + where + fstP (a :*: _) = a + sndP (_ :*: b) = b diff --git a/libraries/base/Control/Monad/IO/Class.hs b/libraries/base/Control/Monad/IO/Class.hs new file mode 100644 index 0000000..b2c419c --- /dev/null +++ b/libraries/base/Control/Monad/IO/Class.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- Portability : portable +-- +-- Class of monads based on @IO@. +----------------------------------------------------------------------------- + +module Control.Monad.IO.Class ( + MonadIO(..) + ) where + +-- | Monads in which 'IO' computations may be embedded. +-- Any monad built by applying a sequence of monad transformers to the +-- 'IO' monad will be an instance of this class. +-- +-- Instances should satisfy the following laws, which state that 'liftIO' +-- is a transformer of monads: +-- +-- * @'liftIO' . 'return' = 'return'@ +-- +-- * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@ + +class (Monad m) => MonadIO m where + -- | Lift a computation from the 'IO' monad. + liftIO :: IO a -> m a + +instance MonadIO IO where + liftIO = id diff --git a/libraries/base/Control/Monad/Instances.hs b/libraries/base/Control/Monad/Instances.hs new file mode 100644 index 0000000..7a4fdbe --- /dev/null +++ b/libraries/base/Control/Monad/Instances.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- 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 diff --git a/libraries/base/Control/Monad/ST.hs b/libraries/base/Control/Monad/ST.hs new file mode 100644 index 0000000..8313c2d --- /dev/null +++ b/libraries/base/Control/Monad/ST.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This library 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". + +----------------------------------------------------------------------------- + +module Control.Monad.ST ( + -- * The 'ST' Monad + ST, -- abstract, instance of Functor, Monad, Typeable. + runST, + fixST, + + -- * Converting 'ST' to 'IO' + RealWorld, -- abstract + stToIO, + ) where + +import Control.Monad.ST.Imp + diff --git a/libraries/base/Control/Monad/ST/Imp.hs b/libraries/base/Control/Monad/ST/Imp.hs new file mode 100644 index 0000000..984970f --- /dev/null +++ b/libraries/base/Control/Monad/ST/Imp.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE Unsafe #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.ST.Imp +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This library provides support for /strict/ state threads, as +-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton +-- Jones /Lazy Functional State Threads/. +-- +----------------------------------------------------------------------------- + +module Control.Monad.ST.Imp ( + -- * The 'ST' Monad + ST, -- abstract, instance of Functor, Monad, Typeable. + runST, + fixST, + + -- * Converting 'ST' to 'IO' + RealWorld, -- abstract + stToIO, + + -- * Unsafe operations + unsafeInterleaveST, + unsafeIOToST, + unsafeSTToIO + ) where + +import GHC.ST ( ST, runST, fixST, unsafeInterleaveST ) +import GHC.Base ( RealWorld ) +import GHC.IO ( stToIO, unsafeIOToST, unsafeSTToIO ) diff --git a/libraries/base/Control/Monad/ST/Lazy.hs b/libraries/base/Control/Monad/ST/Lazy.hs new file mode 100644 index 0000000..ef2e648 --- /dev/null +++ b/libraries/base/Control/Monad/ST/Lazy.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- 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 Control.Monad.ST.Lazy.Imp + diff --git a/libraries/base/Control/Monad/ST/Lazy/Imp.hs b/libraries/base/Control/Monad/ST/Lazy/Imp.hs new file mode 100644 index 0000000..51b1d86 --- /dev/null +++ b/libraries/base/Control/Monad/ST/Lazy/Imp.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE MagicHash, UnboxedTuples, RankNTypes #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.ST.Lazy.Imp +-- 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.Imp ( + -- * The 'ST' monad + ST, + runST, + fixST, + + -- * Converting between strict and lazy 'ST' + strictToLazyST, lazyToStrictST, + + -- * Converting 'ST' To 'IO' + RealWorld, + stToIO, + + -- * Unsafe operations + unsafeInterleaveST, + unsafeIOToST + ) where + +import Control.Monad.Fix + +import qualified Control.Monad.ST as ST +import qualified Control.Monad.ST.Unsafe as ST + +import qualified GHC.ST as GHC.ST +import GHC.Base + +-- | The lazy state-transformer monad. +-- A computation of type @'ST' s a@ transforms an internal state indexed +-- by @s@, and returns a value of type @a@. +-- The @s@ parameter is either +-- +-- * an unstantiated type variable (inside invocations of 'runST'), or +-- +-- * 'RealWorld' (inside invocations of 'stToIO'). +-- +-- It serves to keep the internal states of different invocations of +-- 'runST' separate from each other and from invocations of 'stToIO'. +-- +-- The '>>=' and '>>' operations are not strict in the state. For example, +-- +-- @'runST' (writeSTRef _|_ v >>= readSTRef _|_ >> return 2) = 2@ +newtype ST s a = ST (State s -> (a, State s)) +data State s = S# (State# s) + +instance Functor (ST s) where + fmap f m = ST $ \ s -> + let + ST m_a = m + (r,new_s) = m_a s + in + (f r,new_s) + +instance Applicative (ST s) where + pure a = ST $ \ s -> (a,s) + (<*>) = ap + +instance Monad (ST s) where + + fail s = errorWithoutStackTrace s + + (ST m) >>= k + = ST $ \ s -> + let + (r,new_s) = m s + ST k_a = k r + in + k_a new_s + +{-# NOINLINE runST #-} +-- | Return the value computed by a state transformer computation. +-- The @forall@ ensures that the internal state used by the 'ST' +-- computation is inaccessible to the rest of the program. +runST :: (forall s. ST s a) -> a +runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r + +-- | Allow the result of a state transformer computation to be used (lazily) +-- inside the computation. +-- Note that if @f@ is strict, @'fixST' f = _|_@. +fixST :: (a -> ST s a) -> ST s a +fixST m = ST (\ s -> + let + ST m_r = m r + (r,s') = m_r s + in + (r,s')) + +instance MonadFix (ST s) where + mfix = fixST + +-- --------------------------------------------------------------------------- +-- Strict <--> Lazy + +{-| +Convert a strict 'ST' computation into a lazy one. The strict state +thread passed to 'strictToLazyST' is not performed until the result of +the lazy state thread it returns is demanded. +-} +strictToLazyST :: ST.ST s a -> ST s a +strictToLazyST m = ST $ \s -> + let + pr = case s of { S# s# -> GHC.ST.liftST m s# } + r = case pr of { GHC.ST.STret _ v -> v } + s' = case pr of { GHC.ST.STret s2# _ -> S# s2# } + in + (r, s') + +{-| +Convert a lazy 'ST' computation into a strict one. +-} +lazyToStrictST :: ST s a -> ST.ST s a +lazyToStrictST (ST m) = GHC.ST.ST $ \s -> + case (m (S# s)) of (a, S# s') -> (# s', a #) + +-- | A monad transformer embedding lazy state transformers in the 'IO' +-- monad. The 'RealWorld' parameter indicates that the internal state +-- used by the 'ST' computation is a special one supplied by the 'IO' +-- monad, and thus distinct from those used by invocations of 'runST'. +stToIO :: ST RealWorld a -> IO a +stToIO = ST.stToIO . lazyToStrictST + +-- --------------------------------------------------------------------------- +-- Strict <--> Lazy + +unsafeInterleaveST :: ST s a -> ST s a +unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST + +unsafeIOToST :: IO a -> ST s a +unsafeIOToST = strictToLazyST . ST.unsafeIOToST + diff --git a/libraries/base/Control/Monad/ST/Lazy/Safe.hs b/libraries/base/Control/Monad/ST/Lazy/Safe.hs new file mode 100644 index 0000000..9f8e606 --- /dev/null +++ b/libraries/base/Control/Monad/ST/Lazy/Safe.hs @@ -0,0 +1,36 @@ +{-# 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 state 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 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 Control.Monad.ST.Lazy.Imp + diff --git a/libraries/base/Control/Monad/ST/Lazy/Unsafe.hs b/libraries/base/Control/Monad/ST/Lazy/Unsafe.hs new file mode 100644 index 0000000..4a1b8c7 --- /dev/null +++ b/libraries/base/Control/Monad/ST/Lazy/Unsafe.hs @@ -0,0 +1,28 @@ +{-# 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 state operations until +-- a value depending on them is required. +-- +-- Unsafe API. +-- +----------------------------------------------------------------------------- + +module Control.Monad.ST.Lazy.Unsafe ( + -- * Unsafe operations + unsafeInterleaveST, + unsafeIOToST + ) where + +import Control.Monad.ST.Lazy.Imp + diff --git a/libraries/base/Control/Monad/ST/Safe.hs b/libraries/base/Control/Monad/ST/Safe.hs new file mode 100644 index 0000000..d100832 --- /dev/null +++ b/libraries/base/Control/Monad/ST/Safe.hs @@ -0,0 +1,33 @@ +{-# 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 : experimental +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This library 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 Control.Monad.ST instead" #-} ( + -- * The 'ST' Monad + ST, -- abstract + runST, + fixST, + + -- * Converting 'ST' to 'IO' + RealWorld, -- abstract + stToIO, + ) where + +import Control.Monad.ST.Imp + diff --git a/libraries/base/Control/Monad/ST/Strict.hs b/libraries/base/Control/Monad/ST/Strict.hs new file mode 100644 index 0000000..c858548 --- /dev/null +++ b/libraries/base/Control/Monad/ST/Strict.hs @@ -0,0 +1,22 @@ +{-# 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 Control.Monad.ST + ) where + +import Control.Monad.ST + diff --git a/libraries/base/Control/Monad/ST/Unsafe.hs b/libraries/base/Control/Monad/ST/Unsafe.hs new file mode 100644 index 0000000..9fa4b73 --- /dev/null +++ b/libraries/base/Control/Monad/ST/Unsafe.hs @@ -0,0 +1,29 @@ +{-# 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 : experimental +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This library 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, + unsafeIOToST, + unsafeSTToIO + ) where + +import Control.Monad.ST.Imp + diff --git a/libraries/base/Control/Monad/Zip.hs b/libraries/base/Control/Monad/Zip.hs new file mode 100644 index 0000000..fa44438 --- /dev/null +++ b/libraries/base/Control/Monad/Zip.hs @@ -0,0 +1,99 @@ +{-# 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 : experimental +-- Portability : portable +-- +-- Monadic zipping (used for monad comprehensions) +-- +----------------------------------------------------------------------------- + +module Control.Monad.Zip where + +import Control.Monad (liftM, liftM2) +import Data.Monoid +import Data.Proxy +import GHC.Generics + +-- | `MonadZip` type class. Minimal definition: `mzip` or `mzipWith` +-- +-- Instances should satisfy the laws: +-- +-- * Naturality : +-- +-- > liftM (f *** g) (mzip ma mb) = mzip (liftM f ma) (liftM g mb) +-- +-- * Information Preservation: +-- +-- > liftM (const ()) ma = liftM (const ()) mb +-- > ==> +-- > munzip (mzip ma mb) = (ma, mb) +-- +class Monad m => MonadZip m where + {-# MINIMAL mzip | mzipWith #-} + + mzip :: m a -> m b -> m (a,b) + mzip = mzipWith (,) + + mzipWith :: (a -> b -> c) -> m a -> m b -> m c + mzipWith f ma mb = liftM (uncurry f) (mzip ma mb) + + munzip :: m (a,b) -> (m a, m b) + munzip mab = (liftM fst mab, liftM snd mab) + -- munzip is a member of the class because sometimes + -- you can implement it more efficiently than the + -- above default code. See Trac #4370 comment by giorgidze + +instance MonadZip [] where + mzip = zip + mzipWith = zipWith + munzip = unzip + +instance MonadZip Dual where + -- Cannot use coerce, it's unsafe + mzipWith = liftM2 + +instance MonadZip Sum where + mzipWith = liftM2 + +instance MonadZip Product where + mzipWith = liftM2 + +instance MonadZip Maybe where + mzipWith = liftM2 + +instance MonadZip First where + mzipWith = liftM2 + +instance MonadZip Last where + mzipWith = liftM2 + +instance MonadZip f => MonadZip (Alt f) where + mzipWith f (Alt ma) (Alt mb) = Alt (mzipWith f ma mb) + +instance MonadZip Proxy where + mzipWith _ _ _ = Proxy + +-- Instances for GHC.Generics +instance MonadZip U1 where + mzipWith _ _ _ = U1 + +instance MonadZip Par1 where + mzipWith = liftM2 + +instance MonadZip f => MonadZip (Rec1 f) where + mzipWith f (Rec1 fa) (Rec1 fb) = Rec1 (mzipWith f fa fb) + +instance MonadZip f => MonadZip (M1 i c f) where + mzipWith f (M1 fa) (M1 fb) = M1 (mzipWith f fa fb) + +instance (MonadZip f, MonadZip g) => MonadZip (f :*: g) where + mzipWith f (x1 :*: y1) (x2 :*: y2) = mzipWith f x1 x2 :*: mzipWith f y1 y2 diff --git a/libraries/base/Data/Bifunctor.hs b/libraries/base/Data/Bifunctor.hs new file mode 100644 index 0000000..9cc3c1c --- /dev/null +++ b/libraries/base/Data/Bifunctor.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- 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(..) ) + +-- | Formally, the class 'Bifunctor' represents a bifunctor +-- from @Hask@ -> @Hask@. +-- +-- Intuitively it is a bifunctor where both the first and second +-- arguments are covariant. +-- +-- You can define a 'Bifunctor' by either defining 'bimap' or by +-- defining both 'first' and 'second'. +-- +-- 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 Bifunctor p where + {-# MINIMAL bimap | first, second #-} + + -- | Map over both arguments at the same time. + -- + -- @'bimap' f g ≡ 'first' f '.' 'second' g@ + 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'@ + first :: (a -> b) -> p a c -> p b c + first f = bimap f id + + -- | Map covariantly over the second argument. + -- + -- @'second' ≡ 'bimap' 'id'@ + second :: (b -> c) -> p a b -> p a c + second = bimap id + + +instance Bifunctor (,) where + bimap f g ~(a, b) = (f a, g b) + +instance Bifunctor ((,,) x1) where + bimap f g ~(x1, a, b) = (x1, f a, g b) + +instance Bifunctor ((,,,) x1 x2) where + bimap f g ~(x1, x2, a, b) = (x1, x2, f a, g b) + +instance Bifunctor ((,,,,) x1 x2 x3) where + bimap f g ~(x1, x2, x3, a, b) = (x1, x2, x3, f a, g b) + +instance Bifunctor ((,,,,,) x1 x2 x3 x4) where + bimap f g ~(x1, x2, x3, x4, a, b) = (x1, x2, x3, x4, f a, g b) + +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) + + +instance Bifunctor Either where + bimap f _ (Left a) = Left (f a) + bimap _ g (Right b) = Right (g b) + +instance Bifunctor Const where + bimap f _ (Const a) = Const (f a) + +instance Bifunctor (K1 i) where + bimap f _ (K1 c) = K1 (f c) diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs new file mode 100644 index 0000000..3c31999 --- /dev/null +++ b/libraries/base/Data/Bits.hs @@ -0,0 +1,659 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Bits +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- 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 ( + 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 + +-- Defines the @Bits@ class containing bit-based operations. +-- See library document for details on the semantics of the +-- individual operations. + +#include "MachDeps.h" + +#ifdef MIN_VERSION_integer_gmp +# define HAVE_INTEGER_GMP1 MIN_VERSION_integer_gmp(1,0,0) +#endif + +import Data.Maybe +import GHC.Enum +import GHC.Num +import GHC.Base +import GHC.Real + +#if HAVE_INTEGER_GMP1 +import GHC.Integer.GMP.Internals (bitInteger, popCountInteger) +#endif + +infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR` +infixl 7 .&. +infixl 6 `xor` +infixl 5 .|. + +{-# DEPRECATED bitSize "Use 'bitSizeMaybe' or 'finiteBitSize' instead" #-} -- deprecated in 7.8 + +-- | The 'Bits' class defines bitwise operations over integral types. +-- +-- * Bits are numbered from 0 with bit 0 being the least +-- significant bit. +class Eq a => Bits a where + {-# MINIMAL (.&.), (.|.), xor, complement, + (shift | (shiftL, shiftR)), + (rotate | (rotateL, rotateR)), + bitSize, bitSizeMaybe, isSigned, testBit, bit, popCount #-} + + -- | Bitwise \"and\" + (.&.) :: a -> a -> a + + -- | Bitwise \"or\" + (.|.) :: a -> a -> a + + -- | Bitwise \"xor\" + xor :: a -> a -> a + + {-| Reverse all the bits in the argument -} + complement :: a -> a + + {-| @'shift' x i@ shifts @x@ left by @i@ bits if @i@ is positive, + or right by @-i@ bits otherwise. + Right shifts perform sign extension on signed number types; + i.e. they fill the top bits with 1 if the @x@ is negative + and with 0 otherwise. + + An instance can define either this unified 'shift' or 'shiftL' and + 'shiftR', depending on which is more convenient for the type in + question. -} + shift :: a -> Int -> a + + x `shift` i | i<0 = x `shiftR` (-i) + | i>0 = x `shiftL` i + | otherwise = x + + {-| @'rotate' x i@ rotates @x@ left by @i@ bits if @i@ is positive, + or right by @-i@ bits otherwise. + + For unbounded types like 'Integer', 'rotate' is equivalent to 'shift'. + + An instance can define either this unified 'rotate' or 'rotateL' and + 'rotateR', depending on which is more convenient for the type in + question. -} + rotate :: a -> Int -> a + + x `rotate` i | i<0 = x `rotateR` (-i) + | i>0 = x `rotateL` i + | otherwise = x + + {- + -- Rotation can be implemented in terms of two shifts, but care is + -- needed for negative values. This suggested implementation assumes + -- 2's-complement arithmetic. It is commented out because it would + -- require an extra context (Ord a) on the signature of 'rotate'. + x `rotate` i | i<0 && isSigned x && x<0 + = let left = i+bitSize x in + ((x `shift` i) .&. complement ((-1) `shift` left)) + .|. (x `shift` left) + | i<0 = (x `shift` i) .|. (x `shift` (i+bitSize x)) + | i==0 = x + | i>0 = (x `shift` i) .|. (x `shift` (i-bitSize x)) + -} + + -- | 'zeroBits' is the value with all bits unset. + -- + -- The following laws ought to hold (for all valid bit indices @/n/@): + -- + -- * @'clearBit' 'zeroBits' /n/ == 'zeroBits'@ + -- * @'setBit' 'zeroBits' /n/ == 'bit' /n/@ + -- * @'testBit' 'zeroBits' /n/ == False@ + -- * @'popCount' 'zeroBits' == 0@ + -- + -- This method uses @'clearBit' ('bit' 0) 0@ as its default + -- implementation (which ought to be equivalent to 'zeroBits' for + -- types which possess a 0th bit). + -- + -- @since 4.7.0.0 + zeroBits :: a + zeroBits = clearBit (bit 0) 0 + + -- | @bit /i/@ is a value with the @/i/@th bit set and all other bits clear. + -- + -- Can be implemented using `bitDefault' if @a@ is also an + -- instance of 'Num'. + -- + -- See also 'zeroBits'. + bit :: Int -> a + + -- | @x \`setBit\` i@ is the same as @x .|. bit i@ + setBit :: a -> Int -> a + + -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@ + clearBit :: a -> Int -> a + + -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@ + complementBit :: a -> Int -> a + + -- | Return 'True' if the @n@th bit of the argument is 1 + -- + -- Can be implemented using `testBitDefault' if @a@ is also an + -- instance of 'Num'. + testBit :: a -> Int -> Bool + + {-| Return the number of bits in the type of the argument. The actual + value of the argument is ignored. Returns Nothing + for types that do not have a fixed bitsize, like 'Integer'. + + @since 4.7.0.0 + -} + bitSizeMaybe :: a -> Maybe Int + + {-| Return the number of bits in the type of the argument. The actual + value of the argument is ignored. The function 'bitSize' is + undefined for types that do not have a fixed bitsize, like 'Integer'. + -} + bitSize :: a -> Int + + {-| Return 'True' if the argument is a signed type. The actual + value of the argument is ignored -} + isSigned :: a -> Bool + + {-# INLINE setBit #-} + {-# INLINE clearBit #-} + {-# INLINE complementBit #-} + x `setBit` i = x .|. bit i + x `clearBit` i = x .&. complement (bit i) + x `complementBit` i = x `xor` bit i + + {-| Shift the argument left by the specified number of bits + (which must be non-negative). + + An instance can define either this and 'shiftR' or the unified + 'shift', depending on which is more convenient for the type in + question. -} + shiftL :: a -> Int -> a + {-# INLINE shiftL #-} + x `shiftL` i = x `shift` i + + {-| Shift the argument left by the specified number of bits. The + result is undefined for negative shift amounts and shift amounts + greater or equal to the 'bitSize'. + + Defaults to 'shiftL' unless defined explicitly by an instance. + + @since 4.5.0.0 -} + unsafeShiftL :: a -> Int -> a + {-# INLINE unsafeShiftL #-} + x `unsafeShiftL` i = x `shiftL` i + + {-| Shift the first argument right by the specified number of bits. The + result is undefined for negative shift amounts and shift amounts + greater or equal to the 'bitSize'. + + Right shifts perform sign extension on signed number types; + i.e. they fill the top bits with 1 if the @x@ is negative + and with 0 otherwise. + + An instance can define either this and 'shiftL' or the unified + 'shift', depending on which is more convenient for the type in + question. -} + shiftR :: a -> Int -> a + {-# INLINE shiftR #-} + x `shiftR` i = x `shift` (-i) + + {-| Shift the first argument right by the specified number of bits, which + must be non-negative an smaller than the number of bits in the type. + + Right shifts perform sign extension on signed number types; + i.e. they fill the top bits with 1 if the @x@ is negative + and with 0 otherwise. + + Defaults to 'shiftR' unless defined explicitly by an instance. + + @since 4.5.0.0 -} + unsafeShiftR :: a -> Int -> a + {-# INLINE unsafeShiftR #-} + x `unsafeShiftR` i = x `shiftR` i + + {-| Rotate the argument left by the specified number of bits + (which must be non-negative). + + An instance can define either this and 'rotateR' or the unified + 'rotate', depending on which is more convenient for the type in + question. -} + rotateL :: a -> Int -> a + {-# INLINE rotateL #-} + x `rotateL` i = x `rotate` i + + {-| Rotate the argument right by the specified number of bits + (which must be non-negative). + + An instance can define either this and 'rotateL' or the unified + 'rotate', depending on which is more convenient for the type in + question. -} + rotateR :: a -> Int -> a + {-# INLINE rotateR #-} + x `rotateR` i = x `rotate` (-i) + + {-| Return the number of set bits in the argument. This number is + known as the population count or the Hamming weight. + + Can be implemented using `popCountDefault' if @a@ is also an + instance of 'Num'. + + @since 4.5.0.0 -} + popCount :: a -> Int + +-- |The 'FiniteBits' class denotes types with a finite, fixed number of bits. +-- +-- @since 4.7.0.0 +class Bits b => FiniteBits b where + -- | Return the number of bits in the type of the argument. + -- The actual value of the argument is ignored. Moreover, 'finiteBitSize' + -- is total, in contrast to the deprecated 'bitSize' function it replaces. + -- + -- @ + -- 'finiteBitSize' = 'bitSize' + -- 'bitSizeMaybe' = 'Just' . 'finiteBitSize' + -- @ + -- + -- @since 4.7.0.0 + finiteBitSize :: b -> Int + + -- | Count number of zero bits preceding the most significant set bit. + -- + -- @ + -- 'countLeadingZeros' ('zeroBits' :: a) = finiteBitSize ('zeroBits' :: a) + -- @ + -- + -- 'countLeadingZeros' can be used to compute log base 2 via + -- + -- @ + -- logBase2 x = 'finiteBitSize' x - 1 - 'countLeadingZeros' x + -- @ + -- + -- Note: The default implementation for this method is intentionally + -- naive. However, the instances provided for the primitive + -- integral types are implemented using CPU specific machine + -- instructions. + -- + -- @since 4.8.0.0 + countLeadingZeros :: b -> Int + countLeadingZeros x = (w-1) - go (w-1) + where + go i | i < 0 = i -- no bit set + | testBit x i = i + | otherwise = go (i-1) + + w = finiteBitSize x + + -- | Count number of zero bits following the least significant set bit. + -- + -- @ + -- 'countTrailingZeros' ('zeroBits' :: a) = finiteBitSize ('zeroBits' :: a) + -- 'countTrailingZeros' . 'negate' = 'countTrailingZeros' + -- @ + -- + -- The related + -- + -- can be expressed in terms of 'countTrailingZeros' as follows + -- + -- @ + -- findFirstSet x = 1 + 'countTrailingZeros' x + -- @ + -- + -- Note: The default implementation for this method is intentionally + -- naive. However, the instances provided for the primitive + -- integral types are implemented using CPU specific machine + -- instructions. + -- + -- @since 4.8.0.0 + countTrailingZeros :: b -> Int + countTrailingZeros x = go 0 + where + go i | i >= w = i + | testBit x i = i + | otherwise = go (i+1) + + w = finiteBitSize x + + +-- The defaults below are written with lambdas so that e.g. +-- bit = bitDefault +-- is fully applied, so inlining will happen + +-- | Default implementation for 'bit'. +-- +-- Note that: @bitDefault i = 1 `shiftL` i@ +-- +-- @since 4.6.0.0 +bitDefault :: (Bits a, Num a) => Int -> a +bitDefault = \i -> 1 `shiftL` i +{-# INLINE bitDefault #-} + +-- | Default implementation for 'testBit'. +-- +-- Note that: @testBitDefault x i = (x .&. bit i) /= 0@ +-- +-- @since 4.6.0.0 +testBitDefault :: (Bits a, Num a) => a -> Int -> Bool +testBitDefault = \x i -> (x .&. bit i) /= 0 +{-# INLINE testBitDefault #-} + +-- | Default implementation for 'popCount'. +-- +-- This implementation is intentionally naive. Instances are expected to provide +-- an optimized implementation for their size. +-- +-- @since 4.6.0.0 +popCountDefault :: (Bits a, Num a) => a -> Int +popCountDefault = go 0 + where + go !c 0 = c + go c w = go (c+1) (w .&. (w - 1)) -- clear the least significant +{-# INLINABLE popCountDefault #-} + + +-- Interpret 'Bool' as 1-bit bit-field; @since 4.7.0.0 +instance Bits Bool where + (.&.) = (&&) + + (.|.) = (||) + + xor = (/=) + + complement = not + + shift x 0 = x + shift _ _ = False + + rotate x _ = x + + bit 0 = True + bit _ = False + + testBit x 0 = x + testBit _ _ = False + + bitSizeMaybe _ = Just 1 + + bitSize _ = 1 + + isSigned _ = False + + popCount False = 0 + popCount True = 1 + +instance FiniteBits Bool where + finiteBitSize _ = 1 + countTrailingZeros x = if x then 0 else 1 + countLeadingZeros x = if x then 0 else 1 + +instance Bits Int where + {-# INLINE shift #-} + {-# INLINE bit #-} + {-# INLINE testBit #-} + + zeroBits = 0 + + bit = bitDefault + + testBit = testBitDefault + + (I# x#) .&. (I# y#) = I# (x# `andI#` y#) + (I# x#) .|. (I# y#) = I# (x# `orI#` y#) + (I# x#) `xor` (I# y#) = I# (x# `xorI#` y#) + complement (I# x#) = I# (notI# x#) + (I# x#) `shift` (I# i#) + | isTrue# (i# >=# 0#) = I# (x# `iShiftL#` i#) + | otherwise = I# (x# `iShiftRA#` negateInt# i#) + (I# x#) `shiftL` (I# i#) = I# (x# `iShiftL#` i#) + (I# x#) `unsafeShiftL` (I# i#) = I# (x# `uncheckedIShiftL#` i#) + (I# x#) `shiftR` (I# i#) = I# (x# `iShiftRA#` i#) + (I# x#) `unsafeShiftR` (I# i#) = I# (x# `uncheckedIShiftRA#` i#) + + {-# INLINE rotate #-} -- See Note [Constant folding for rotate] + (I# x#) `rotate` (I# i#) = + I# ((x# `uncheckedIShiftL#` i'#) `orI#` (x# `uncheckedIShiftRL#` (wsib -# i'#))) + where + !i'# = i# `andI#` (wsib -# 1#) + !wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} + bitSizeMaybe i = Just (finiteBitSize i) + bitSize i = finiteBitSize i + + popCount (I# x#) = I# (word2Int# (popCnt# (int2Word# x#))) + + isSigned _ = True + +instance FiniteBits Int where + finiteBitSize _ = WORD_SIZE_IN_BITS + countLeadingZeros (I# x#) = I# (word2Int# (clz# (int2Word# x#))) + countTrailingZeros (I# x#) = I# (word2Int# (ctz# (int2Word# x#))) + +instance Bits Word where + {-# INLINE shift #-} + {-# INLINE bit #-} + {-# INLINE testBit #-} + + (W# x#) .&. (W# y#) = W# (x# `and#` y#) + (W# x#) .|. (W# y#) = W# (x# `or#` y#) + (W# x#) `xor` (W# y#) = W# (x# `xor#` y#) + complement (W# x#) = W# (x# `xor#` mb#) + where !(W# mb#) = maxBound + (W# x#) `shift` (I# i#) + | isTrue# (i# >=# 0#) = W# (x# `shiftL#` i#) + | otherwise = W# (x# `shiftRL#` negateInt# i#) + (W# x#) `shiftL` (I# i#) = W# (x# `shiftL#` i#) + (W# x#) `unsafeShiftL` (I# i#) = W# (x# `uncheckedShiftL#` i#) + (W# x#) `shiftR` (I# i#) = W# (x# `shiftRL#` i#) + (W# x#) `unsafeShiftR` (I# i#) = W# (x# `uncheckedShiftRL#` i#) + (W# x#) `rotate` (I# i#) + | isTrue# (i'# ==# 0#) = W# x# + | otherwise = W# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (wsib -# i'#))) + where + !i'# = i# `andI#` (wsib -# 1#) + !wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} + bitSizeMaybe i = Just (finiteBitSize i) + bitSize i = finiteBitSize i + isSigned _ = False + popCount (W# x#) = I# (word2Int# (popCnt# x#)) + bit = bitDefault + testBit = testBitDefault + +instance FiniteBits Word where + finiteBitSize _ = WORD_SIZE_IN_BITS + countLeadingZeros (W# x#) = I# (word2Int# (clz# x#)) + countTrailingZeros (W# x#) = I# (word2Int# (ctz# x#)) + +instance Bits Integer where + (.&.) = andInteger + (.|.) = orInteger + xor = xorInteger + complement = complementInteger + shift x i@(I# i#) | i >= 0 = shiftLInteger x i# + | otherwise = shiftRInteger x (negateInt# i#) + testBit x (I# i) = testBitInteger x i + zeroBits = 0 + +#if HAVE_INTEGER_GMP1 + bit (I# i#) = bitInteger i# + popCount x = I# (popCountInteger x) +#else + bit = bitDefault + popCount = popCountDefault +#endif + + rotate x i = shift x i -- since an Integer never wraps around + + bitSizeMaybe _ = Nothing + bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Integer)" + isSigned _ = True + +----------------------------------------------------------------------------- + +-- | Attempt to convert an 'Integral' type @a@ to an 'Integral' type @b@ using +-- the size of the types as measured by 'Bits' methods. +-- +-- A simpler version of this function is: +-- +-- > toIntegral :: (Integral a, Integral b) => a -> Maybe b +-- > toIntegral x +-- > | toInteger x == y = Just (fromInteger y) +-- > | otherwise = Nothing +-- > where +-- > y = toInteger x +-- +-- This version requires going through 'Integer', which can be inefficient. +-- However, @toIntegralSized@ is optimized to allow GHC to statically determine +-- the relative type sizes (as measured by 'bitSizeMaybe' and 'isSigned') and +-- avoid going through 'Integer' for many types. (The implementation uses +-- 'fromIntegral', which is itself optimized with rules for @base@ types but may +-- go through 'Integer' for some type pairs.) +-- +-- @since 4.8.0.0 + +toIntegralSized :: (Integral a, Integral b, Bits a, Bits b) => a -> Maybe b +toIntegralSized x -- See Note [toIntegralSized optimization] + | maybe True (<= x) yMinBound + , maybe True (x <=) yMaxBound = Just y + | otherwise = Nothing + where + y = fromIntegral x + + xWidth = bitSizeMaybe x + yWidth = bitSizeMaybe y + + yMinBound + | isBitSubType x y = Nothing + | isSigned x, not (isSigned y) = Just 0 + | isSigned x, isSigned y + , Just yW <- yWidth = Just (negate $ bit (yW-1)) -- Assumes sub-type + | otherwise = Nothing + + yMaxBound + | isBitSubType x y = Nothing + | isSigned x, not (isSigned y) + , Just xW <- xWidth, Just yW <- yWidth + , xW <= yW+1 = Nothing -- Max bound beyond a's domain + | Just yW <- yWidth = if isSigned y + then Just (bit (yW-1)-1) + else Just (bit yW-1) + | otherwise = Nothing +{-# INLINEABLE toIntegralSized #-} + +-- | 'True' if the size of @a@ is @<=@ the size of @b@, where size is measured +-- by 'bitSizeMaybe' and 'isSigned'. +isBitSubType :: (Bits a, Bits b) => a -> b -> Bool +isBitSubType x y + -- Reflexive + | xWidth == yWidth, xSigned == ySigned = True + + -- Every integer is a subset of 'Integer' + | ySigned, Nothing == yWidth = True + | not xSigned, not ySigned, Nothing == yWidth = True + + -- Sub-type relations between fixed-with types + | xSigned == ySigned, Just xW <- xWidth, Just yW <- yWidth = xW <= yW + | not xSigned, ySigned, Just xW <- xWidth, Just yW <- yWidth = xW < yW + + | otherwise = False + where + xWidth = bitSizeMaybe x + xSigned = isSigned x + + yWidth = bitSizeMaybe y + ySigned = isSigned y +{-# INLINE isBitSubType #-} + +{- Note [Constant folding for rotate] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The INLINE on the Int instance of rotate enables it to be constant +folded. For example: + sumU . mapU (`rotate` 3) . replicateU 10000000 $ (7 :: Int) +goes to: + Main.$wfold = + \ (ww_sO7 :: Int#) (ww1_sOb :: Int#) -> + case ww1_sOb of wild_XM { + __DEFAULT -> Main.$wfold (+# ww_sO7 56) (+# wild_XM 1); + 10000000 -> ww_sO7 +whereas before it was left as a call to $wrotate. + +All other Bits instances seem to inline well enough on their +own to enable constant folding; for example 'shift': + sumU . mapU (`shift` 3) . replicateU 10000000 $ (7 :: Int) + goes to: + Main.$wfold = + \ (ww_sOb :: Int#) (ww1_sOf :: Int#) -> + case ww1_sOf of wild_XM { + __DEFAULT -> Main.$wfold (+# ww_sOb 56) (+# wild_XM 1); + 10000000 -> ww_sOb + } +-} + +-- Note [toIntegralSized optimization] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The code in 'toIntegralSized' relies on GHC optimizing away statically +-- decidable branches. +-- +-- If both integral types are statically known, GHC will be able optimize the +-- code significantly (for @-O1@ and better). +-- +-- For instance (as of GHC 7.8.1) the following definitions: +-- +-- > w16_to_i32 = toIntegralSized :: Word16 -> Maybe Int32 +-- > +-- > i16_to_w16 = toIntegralSized :: Int16 -> Maybe Word16 +-- +-- are translated into the following (simplified) /GHC Core/ language: +-- +-- > w16_to_i32 = \x -> Just (case x of _ { W16# x# -> I32# (word2Int# x#) }) +-- > +-- > i16_to_w16 = \x -> case eta of _ +-- > { I16# b1 -> case tagToEnum# (<=# 0 b1) of _ +-- > { False -> Nothing +-- > ; True -> Just (W16# (narrow16Word# (int2Word# b1))) +-- > } +-- > } diff --git a/libraries/base/Data/Bool.hs b/libraries/base/Data/Bool.hs new file mode 100644 index 0000000..3e812d4 --- /dev/null +++ b/libraries/base/Data/Bool.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Bool +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- The 'Bool' type and related functions. +-- +----------------------------------------------------------------------------- + +module Data.Bool ( + -- * Booleans + Bool(..), + -- ** Operations + (&&), + (||), + not, + otherwise, + bool, + ) where + +import GHC.Base + +-- | Case analysis for the 'Bool' type. @'bool' x y p@ evaluates to @x@ +-- when @p@ is 'False', and evaluates to @y@ when @p@ is 'True'. +-- +-- This is equivalent to @if p then y else x@; that is, one can +-- think of it as an if-then-else construct with its arguments +-- reordered. +-- +-- @since 4.7.0.0 +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> bool "foo" "bar" True +-- "bar" +-- >>> bool "foo" "bar" False +-- "foo" +-- +-- Confirm that @'bool' x y p@ and @if p then y else x@ are +-- equivalent: +-- +-- >>> let p = True; x = "bar"; y = "foo" +-- >>> bool x y p == if p then y else x +-- True +-- >>> let p = False +-- >>> bool x y p == if p then y else x +-- True +-- +bool :: a -> a -> Bool -> a +bool f _ False = f +bool _ t True = t diff --git a/libraries/base/Data/Char.hs b/libraries/base/Data/Char.hs new file mode 100644 index 0000000..69e4db7 --- /dev/null +++ b/libraries/base/Data/Char.hs @@ -0,0 +1,290 @@ +{-# 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, isUpper, 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.Base +import GHC.Char +import GHC.Real (fromIntegral) +import GHC.Show +import GHC.Read (readLitChar, lexLitChar) +import GHC.Unicode +import GHC.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 '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/libraries/base/Data/Coerce.hs b/libraries/base/Data/Coerce.hs new file mode 100644 index 0000000..bb98393 --- /dev/null +++ b/libraries/base/Data/Coerce.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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.Prim (coerce) +import GHC.Types (Coercible) + +import GHC.Base () -- for build ordering; see Notes in GHC.Base for more info diff --git a/libraries/base/Data/Complex.hs b/libraries/base/Data/Complex.hs new file mode 100644 index 0000000..dd831bb --- /dev/null +++ b/libraries/base/Data/Complex.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# 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 GHC.Generics (Generic, Generic1) +import GHC.Float (Floating(..)) +import Data.Data (Data) +import Foreign (Storable, castPtr, peek, poke, pokeElemOff, peekElemOff, sizeOf, + alignment) + +infix 6 :+ + +-- ----------------------------------------------------------------------------- +-- The Complex type + +-- | Complex numbers are an algebraic type. +-- +-- 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. +-- +-- The 'Foldable' and 'Traversable' instances traverse the real part first. +data Complex a + = !a :+ !a -- ^ forms a complex number from its real and imaginary + -- rectangular components. + deriving (Eq, Show, Read, Data, Generic, Generic1 + , Functor, Foldable, Traversable) + +-- ----------------------------------------------------------------------------- +-- Functions over Complex + +-- | Extracts the real part of a complex number. +realPart :: Complex a -> a +realPart (x :+ _) = x + +-- | Extracts the imaginary part of a complex number. +imagPart :: Complex a -> a +imagPart (_ :+ y) = y + +-- | The conjugate of a complex number. +{-# 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. +{-# 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'@). +{-# 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 nonnegative, and the phase in the range @(-'pi', 'pi']@; +-- if the magnitude is zero, then so is the phase. +{-# SPECIALISE polar :: Complex Double -> (Double,Double) #-} +polar :: (RealFloat a) => Complex a -> (a,a) +polar z = (magnitude z, phase z) + +-- | The nonnegative magnitude of a complex number. +{-# 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. +{-# 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 + +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 + +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 + +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)) + acosh z = log (z + (z+1) * sqrt ((z-1)/(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 #-} + +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 + +instance Applicative Complex where + pure a = a :+ a + f :+ g <*> a :+ b = f a :+ g b + +instance Monad Complex where + a :+ b >>= f = realPart (f a) :+ imagPart (f b) diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs new file mode 100644 index 0000000..fd189ed --- /dev/null +++ b/libraries/base/Data/Data.hs @@ -0,0 +1,1818 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables, PolyKinds, StandaloneDeriving, + TypeOperators, GADTs, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- Portability : non-portable (local universal quantification) +-- +-- \"Scrap your boilerplate\" --- Generic programming in Haskell. See +-- . +-- 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. +-- +-- For more information, please visit the new +-- SYB wiki: . +-- +----------------------------------------------------------------------------- + +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, + 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 Data.Either +import Data.Eq +import Data.Maybe +import Data.Monoid +import Data.Ord +import Data.Typeable +import Data.Version( Version(..) ) +import GHC.Base hiding (Any, IntRep, FloatRep) +import GHC.List +import GHC.Num +import GHC.Read +import GHC.Show +import Text.Read( reads ) + +-- Imports for the instances +import Data.Int -- So we can give Data instance for Int8, ... +import Data.Type.Coercion +import Data.Word -- So we can give Data instance for Word8, ... +import GHC.Real -- So we can give Data instance for Ratio +--import GHC.IOBase -- So we can give Data instance for IO, Handle +import GHC.Ptr -- So we can give Data instance for Ptr +import GHC.ForeignPtr -- So we can give Data instance for ForeignPtr +--import GHC.Stable -- So we can give Data instance for StablePtr +--import GHC.ST -- So we can give Data instance for ST +--import GHC.Conc -- So we can give Data instance for MVar & Co. +import GHC.Arr -- So we can give Data instance for Array +import qualified GHC.Generics as Generics (Fixity(..)) +import GHC.Generics hiding (Fixity(..)) + -- So we can give Data instance for U1, V1, ... + +------------------------------------------------------------------------------ +-- +-- The Data class +-- +------------------------------------------------------------------------------ + +{- | +The 'Data' class comprehends a fundamental primitive 'gfoldl' for +folding over constructor applications, say terms. This primitive can +be instantiated in several ways to map over the immediate subterms +of a term; see the @gmap@ combinators later in this class. Indeed, a +generic programmer does not necessarily need to use the ingenious gfoldl +primitive but rather the intuitive @gmap@ combinators. The 'gfoldl' +primitive is completed by means to query top-level constructors, to +turn constructor representations into proper terms, and to list all +possible datatype constructors. This completion allows us to serve +generic programming scenarios like read, show, equality, term generation. + +The combinators 'gmapT', 'gmapQ', 'gmapM', etc are all provided with +default definitions in terms of 'gfoldl', leaving open the opportunity +to provide datatype-specific definitions. +(The inclusion of the @gmap@ combinators as members of class 'Data' +allows the programmer or the compiler to derive specialised, and maybe +more efficient code per datatype. /Note/: 'gfoldl' is more higher-order +than the @gmap@ combinators. This is subject to ongoing benchmarking +experiments. It might turn out that the @gmap@ combinators will be +moved out of the class 'Data'.) + +Conceptually, the definition of the @gmap@ combinators in terms of the +primitive 'gfoldl' requires the identification of the 'gfoldl' function +arguments. Technically, we also need to identify the type constructor +@c@ for the construction of the result type from the folded term type. + +In the definition of @gmapQ@/x/ combinators, we use phantom type +constructors for the @c@ in the type of 'gfoldl' because the result type +of a query does not involve the (polymorphic) type of the term argument. +In the definition of 'gmapQl' we simply use the plain constant type +constructor because 'gfoldl' is left-associative anyway and so it is +readily suited to fold a left-associative binary operation over the +immediate subterms. In the definition of gmapQr, extra effort is +needed. We use a higher-order accumulation trick to mediate between +left-associative constructor application vs. right-associative binary +operation (e.g., @(:)@). When the query is meant to compute a value +of type @r@, then the result type withing generic folding is @r -> r@. +So the result of folding is a function to which we finally pass the +right unit. + +With the @-XDeriveDataTypeable@ option, GHC can generate instances of the +'Data' class automatically. For example, given the declaration + +> data T a b = C1 a b | C2 deriving (Typeable, Data) + +GHC will generate an instance that is equivalent to + +> instance (Data a, Data b) => Data (T a b) where +> gfoldl k z (C1 a b) = z C1 `k` a `k` b +> gfoldl k z C2 = z C2 +> +> gunfold k z c = case constrIndex c of +> 1 -> k (k (z C1)) +> 2 -> z C2 +> +> toConstr (C1 _ _) = con_C1 +> toConstr C2 = con_C2 +> +> dataTypeOf _ = ty_T +> +> con_C1 = mkConstr ty_T "C1" [] Prefix +> con_C2 = mkConstr ty_T "C2" [] Prefix +> ty_T = mkDataType "Module.T" [con_C1, con_C2] + +This is suitable for datatypes that are exported transparently. + +-} + +class Typeable a => Data a where + + -- | Left-associative fold operation for constructor applications. + -- + -- The type of 'gfoldl' is a headache, but operationally it is a simple + -- generalisation of a list fold. + -- + -- The default definition for 'gfoldl' is @'const' 'id'@, which is + -- suitable for abstract datatypes with no substructures. + gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b) + -- ^ defines how nonempty constructor applications are + -- folded. It takes the folded tail of the constructor + -- application and its head, i.e., an immediate subterm, + -- and combines them in some way. + -> (forall g. g -> c g) + -- ^ defines how the empty constructor application is + -- folded, like the neutral \/ start element for list + -- folding. + -> a + -- ^ structure to be folded. + -> c a + -- ^ result, with a type defined in terms of @a@, but + -- variability is achieved by means of type constructor + -- @c@ for the construction of the actual result type. + + -- See the 'Data' instances in this file for an illustration of 'gfoldl'. + + gfoldl _ z = z + + -- | Unfolding constructor applications + gunfold :: (forall b r. Data b => c (b -> r) -> c r) + -> (forall r. r -> c r) + -> Constr + -> c a + + -- | Obtaining the constructor from a given datum. + -- For proper terms, this is meant to be the top-level constructor. + -- Primitive datatypes are here viewed as potentially infinite sets of + -- values (i.e., constructors). + toConstr :: a -> Constr + + + -- | The outer type constructor of the type + dataTypeOf :: a -> DataType + + + +------------------------------------------------------------------------------ +-- +-- Mediate types and type constructors +-- +------------------------------------------------------------------------------ + + -- | Mediate types and unary type constructors. + -- In 'Data' instances of the form @T a@, 'dataCast1' should be defined + -- as 'gcast1'. + -- + -- The default definition is @'const' 'Nothing'@, which is appropriate + -- for non-unary type constructors. + dataCast1 :: Typeable t + => (forall d. Data d => c (t d)) + -> Maybe (c a) + dataCast1 _ = Nothing + + -- | Mediate types and binary type constructors. + -- In 'Data' instances of the form @T a b@, 'dataCast2' should be + -- defined as 'gcast2'. + -- + -- The default definition is @'const' 'Nothing'@, which is appropriate + -- for non-binary type constructors. + dataCast2 :: Typeable t + => (forall d e. (Data d, Data e) => c (t d e)) + -> Maybe (c a) + dataCast2 _ = Nothing + + + +------------------------------------------------------------------------------ +-- +-- Typical generic maps defined in terms of gfoldl +-- +------------------------------------------------------------------------------ + + + -- | A generic transformation that maps over the immediate subterms + -- + -- The default definition instantiates the type constructor @c@ in the + -- type of 'gfoldl' to an identity datatype constructor, using the + -- isomorphism pair as injection and projection. + gmapT :: (forall b. Data b => b -> b) -> a -> a + + -- Use an identity datatype constructor ID (see below) + -- to instantiate the type constructor c in the type of gfoldl, + -- and perform injections ID and projections unID accordingly. + -- + gmapT f x0 = unID (gfoldl k ID x0) + where + k :: Data d => ID (d->b) -> d -> ID b + k (ID c) x = ID (c (f x)) + + + -- | A generic query with a left-associative binary operator + gmapQl :: forall r r'. (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r + gmapQl o r f = unCONST . gfoldl k z + where + k :: Data d => CONST r (d->b) -> d -> CONST r b + k c x = CONST $ (unCONST c) `o` f x + z :: g -> CONST r g + z _ = CONST r + + -- | A generic query with a right-associative binary operator + gmapQr :: forall r r'. (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r + gmapQr o r0 f x0 = unQr (gfoldl k (const (Qr id)) x0) r0 + where + k :: Data d => Qr r (d->b) -> d -> Qr r b + k (Qr c) x = Qr (\r -> c (f x `o` r)) + + + -- | A generic query that processes the immediate subterms and returns a list + -- of results. The list is given in the same order as originally specified + -- in the declaration of the data constructors. + gmapQ :: (forall d. Data d => d -> u) -> a -> [u] + gmapQ f = gmapQr (:) [] f + + + -- | A generic query that processes one child by index (zero-based) + gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> a -> u + gmapQi i f x = case gfoldl k z x of { Qi _ q -> fromJust q } + where + k :: Data d => Qi u (d -> b) -> d -> Qi u b + k (Qi i' q) a = Qi (i'+1) (if i==i' then Just (f a) else q) + z :: g -> Qi q g + z _ = Qi 0 Nothing + + + -- | A generic monadic transformation that maps over the immediate subterms + -- + -- The default definition instantiates the type constructor @c@ in + -- the type of 'gfoldl' to the monad datatype constructor, defining + -- injection and projection using 'return' and '>>='. + gmapM :: forall m. Monad m => (forall d. Data d => d -> m d) -> a -> m a + + -- Use immediately the monad datatype constructor + -- to instantiate the type constructor c in the type of gfoldl, + -- so injection and projection is done by return and >>=. + -- + gmapM f = gfoldl k return + where + k :: Data d => m (d -> b) -> d -> m b + k c x = do c' <- c + x' <- f x + return (c' x') + + + -- | Transformation of at least one immediate subterm does not fail + gmapMp :: forall m. MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a + +{- + +The type constructor that we use here simply keeps track of the fact +if we already succeeded for an immediate subterm; see Mp below. To +this end, we couple the monadic computation with a Boolean. + +-} + + gmapMp f x = unMp (gfoldl k z x) >>= \(x',b) -> + if b then return x' else mzero + where + z :: g -> Mp m g + z g = Mp (return (g,False)) + k :: Data d => Mp m (d -> b) -> d -> Mp m b + k (Mp c) y + = Mp ( c >>= \(h, b) -> + (f y >>= \y' -> return (h y', True)) + `mplus` return (h y, b) + ) + + -- | Transformation of one immediate subterm with success + gmapMo :: forall m. MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a + +{- + +We use the same pairing trick as for gmapMp, +i.e., we use an extra Bool component to keep track of the +fact whether an immediate subterm was processed successfully. +However, we cut of mapping over subterms once a first subterm +was transformed successfully. + +-} + + gmapMo f x = unMp (gfoldl k z x) >>= \(x',b) -> + if b then return x' else mzero + where + z :: g -> Mp m g + z g = Mp (return (g,False)) + k :: Data d => Mp m (d -> b) -> d -> Mp m b + k (Mp c) y + = Mp ( c >>= \(h,b) -> if b + then return (h y, b) + else (f y >>= \y' -> return (h y',True)) + `mplus` return (h y, b) + ) + + +-- | The identity type constructor needed for the definition of gmapT +newtype ID x = ID { unID :: x } + + +-- | The constant type constructor needed for the definition of gmapQl +newtype CONST c a = CONST { unCONST :: c } + + +-- | Type constructor for adding counters to queries +data Qi q a = Qi Int (Maybe q) + + +-- | The type constructor used in definition of gmapQr +newtype Qr r a = Qr { unQr :: r -> r } + + +-- | The type constructor used in definition of gmapMp +newtype Mp m x = Mp { unMp :: m (x, Bool) } + + + +------------------------------------------------------------------------------ +-- +-- Generic unfolding +-- +------------------------------------------------------------------------------ + + +-- | Build a term skeleton +fromConstr :: Data a => Constr -> a +fromConstr = fromConstrB (errorWithoutStackTrace "Data.Data.fromConstr") + + +-- | Build a term and use a generic function for subterms +fromConstrB :: Data a + => (forall d. Data d => d) + -> Constr + -> a +fromConstrB f = unID . gunfold k z + where + k :: forall b r. Data b => ID (b -> r) -> ID r + k c = ID (unID c f) + + z :: forall r. r -> ID r + z = ID + + +-- | Monadic variation on 'fromConstrB' +fromConstrM :: forall m a. (Monad m, Data a) + => (forall d. Data d => m d) + -> Constr + -> m a +fromConstrM f = gunfold k z + where + k :: forall b r. Data b => m (b -> r) -> m r + k c = do { c' <- c; b <- f; return (c' b) } + + z :: forall r. r -> m r + z = return + + + +------------------------------------------------------------------------------ +-- +-- Datatype and constructor representations +-- +------------------------------------------------------------------------------ + + +-- +-- | Representation of datatypes. +-- A package of constructor representations with names of type and module. +-- +data DataType = DataType + { tycon :: String + , datarep :: DataRep + } + + deriving Show + +-- | Representation of constructors. Note that equality on constructors +-- with different types may not work -- i.e. the constructors for 'False' and +-- 'Nothing' may compare equal. +data Constr = Constr + { conrep :: ConstrRep + , constring :: String + , confields :: [String] -- for AlgRep only + , confixity :: Fixity -- for AlgRep only + , datatype :: DataType + } + +instance Show Constr where + show = constring + + +-- | Equality of constructors +instance Eq Constr where + c == c' = constrRep c == constrRep c' + + +-- | Public representation of datatypes +data DataRep = AlgRep [Constr] + | IntRep + | FloatRep + | CharRep + | NoRep + + deriving (Eq,Show) +-- The list of constructors could be an array, a balanced tree, or others. + + +-- | Public representation of constructors +data ConstrRep = AlgConstr ConIndex + | IntConstr Integer + | FloatConstr Rational + | CharConstr Char + + deriving (Eq,Show) + + +-- | Unique index for datatype constructors, +-- counting from 1 in the order they are given in the program text. +type ConIndex = Int + + +-- | Fixity of constructors +data Fixity = Prefix + | Infix -- Later: add associativity and precedence + + deriving (Eq,Show) + + +------------------------------------------------------------------------------ +-- +-- Observers for datatype representations +-- +------------------------------------------------------------------------------ + + +-- | Gets the type constructor including the module +dataTypeName :: DataType -> String +dataTypeName = tycon + + + +-- | Gets the public presentation of a datatype +dataTypeRep :: DataType -> DataRep +dataTypeRep = datarep + + +-- | Gets the datatype of a constructor +constrType :: Constr -> DataType +constrType = datatype + + +-- | Gets the public presentation of constructors +constrRep :: Constr -> ConstrRep +constrRep = conrep + + +-- | Look up a constructor by its representation +repConstr :: DataType -> ConstrRep -> Constr +repConstr dt cr = + case (dataTypeRep dt, cr) of + (AlgRep cs, AlgConstr i) -> cs !! (i-1) + (IntRep, IntConstr i) -> mkIntegralConstr dt i + (FloatRep, FloatConstr f) -> mkRealConstr dt f + (CharRep, CharConstr c) -> mkCharConstr dt c + _ -> errorWithoutStackTrace "Data.Data.repConstr: The given ConstrRep does not fit to the given DataType." + + + +------------------------------------------------------------------------------ +-- +-- Representations of algebraic data types +-- +------------------------------------------------------------------------------ + + +-- | Constructs an algebraic datatype +mkDataType :: String -> [Constr] -> DataType +mkDataType str cs = DataType + { tycon = str + , datarep = AlgRep cs + } + + +-- | Constructs a constructor +mkConstr :: DataType -> String -> [String] -> Fixity -> Constr +mkConstr dt str fields fix = + Constr + { conrep = AlgConstr idx + , constring = str + , confields = fields + , confixity = fix + , datatype = dt + } + where + idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..], + showConstr c == str ] + + +-- | Gets the constructors of an algebraic datatype +dataTypeConstrs :: DataType -> [Constr] +dataTypeConstrs dt = case datarep dt of + (AlgRep cons) -> cons + _ -> errorWithoutStackTrace $ "Data.Data.dataTypeConstrs is not supported for " + ++ dataTypeName dt ++ + ", as it is not an algebraic data type." + + +-- | Gets the field labels of a constructor. The list of labels +-- is returned in the same order as they were given in the original +-- constructor declaration. +constrFields :: Constr -> [String] +constrFields = confields + + +-- | Gets the fixity of a constructor +constrFixity :: Constr -> Fixity +constrFixity = confixity + + + +------------------------------------------------------------------------------ +-- +-- From strings to constr's and vice versa: all data types +-- +------------------------------------------------------------------------------ + + +-- | Gets the string for a constructor +showConstr :: Constr -> String +showConstr = constring + + +-- | Lookup a constructor via a string +readConstr :: DataType -> String -> Maybe Constr +readConstr dt str = + case dataTypeRep dt of + AlgRep cons -> idx cons + IntRep -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i))) + FloatRep -> mkReadCon ffloat + CharRep -> mkReadCon (\c -> (mkPrimCon dt str (CharConstr c))) + NoRep -> Nothing + where + + -- Read a value and build a constructor + mkReadCon :: Read t => (t -> Constr) -> Maybe Constr + mkReadCon f = case (reads str) of + [(t,"")] -> Just (f t) + _ -> Nothing + + -- Traverse list of algebraic datatype constructors + idx :: [Constr] -> Maybe Constr + idx cons = let fit = filter ((==) str . showConstr) cons + in if fit == [] + then Nothing + else Just (head fit) + + ffloat :: Double -> Constr + ffloat = mkPrimCon dt str . FloatConstr . toRational + +------------------------------------------------------------------------------ +-- +-- Convenience funtions: algebraic data types +-- +------------------------------------------------------------------------------ + + +-- | Test for an algebraic type +isAlgType :: DataType -> Bool +isAlgType dt = case datarep dt of + (AlgRep _) -> True + _ -> False + + +-- | Gets the constructor for an index (algebraic datatypes only) +indexConstr :: DataType -> ConIndex -> Constr +indexConstr dt idx = case datarep dt of + (AlgRep cs) -> cs !! (idx-1) + _ -> errorWithoutStackTrace $ "Data.Data.indexConstr is not supported for " + ++ dataTypeName dt ++ + ", as it is not an algebraic data type." + + +-- | Gets the index of a constructor (algebraic datatypes only) +constrIndex :: Constr -> ConIndex +constrIndex con = case constrRep con of + (AlgConstr idx) -> idx + _ -> errorWithoutStackTrace $ "Data.Data.constrIndex is not supported for " + ++ dataTypeName (constrType con) ++ + ", as it is not an algebraic data type." + + +-- | Gets the maximum constructor index of an algebraic datatype +maxConstrIndex :: DataType -> ConIndex +maxConstrIndex dt = case dataTypeRep dt of + AlgRep cs -> length cs + _ -> errorWithoutStackTrace $ "Data.Data.maxConstrIndex is not supported for " + ++ dataTypeName dt ++ + ", as it is not an algebraic data type." + + + +------------------------------------------------------------------------------ +-- +-- Representation of primitive types +-- +------------------------------------------------------------------------------ + + +-- | Constructs the 'Int' type +mkIntType :: String -> DataType +mkIntType = mkPrimType IntRep + + +-- | Constructs the 'Float' type +mkFloatType :: String -> DataType +mkFloatType = mkPrimType FloatRep + + +-- | Constructs the 'Char' type +mkCharType :: String -> DataType +mkCharType = mkPrimType CharRep + + +-- | Helper for 'mkIntType', 'mkFloatType' +mkPrimType :: DataRep -> String -> DataType +mkPrimType dr str = DataType + { tycon = str + , datarep = dr + } + + +-- Makes a constructor for primitive types +mkPrimCon :: DataType -> String -> ConstrRep -> Constr +mkPrimCon dt str cr = Constr + { datatype = dt + , conrep = cr + , constring = str + , confields = errorWithoutStackTrace "Data.Data.confields" + , confixity = errorWithoutStackTrace "Data.Data.confixity" + } + +mkIntegralConstr :: (Integral a, Show a) => DataType -> a -> Constr +mkIntegralConstr dt i = case datarep dt of + IntRep -> mkPrimCon dt (show i) (IntConstr (toInteger i)) + _ -> errorWithoutStackTrace $ "Data.Data.mkIntegralConstr is not supported for " + ++ dataTypeName dt ++ + ", as it is not an Integral data type." + +mkRealConstr :: (Real a, Show a) => DataType -> a -> Constr +mkRealConstr dt f = case datarep dt of + FloatRep -> mkPrimCon dt (show f) (FloatConstr (toRational f)) + _ -> errorWithoutStackTrace $ "Data.Data.mkRealConstr is not supported for " + ++ dataTypeName dt ++ + ", as it is not an Real data type." + +-- | Makes a constructor for 'Char'. +mkCharConstr :: DataType -> Char -> Constr +mkCharConstr dt c = case datarep dt of + CharRep -> mkPrimCon dt (show c) (CharConstr c) + _ -> errorWithoutStackTrace $ "Data.Data.mkCharConstr is not supported for " + ++ dataTypeName dt ++ + ", as it is not an Char data type." + + +------------------------------------------------------------------------------ +-- +-- Non-representations for non-representable types +-- +------------------------------------------------------------------------------ + + +-- | Constructs a non-representation for a non-representable type +mkNoRepType :: String -> DataType +mkNoRepType str = DataType + { tycon = str + , datarep = NoRep + } + +-- | Test for a non-representable type +isNorepType :: DataType -> Bool +isNorepType dt = case datarep dt of + NoRep -> True + _ -> False + + + +------------------------------------------------------------------------------ +-- +-- Convenience for qualified type constructors +-- +------------------------------------------------------------------------------ + + +-- | Gets the unqualified type constructor: +-- drop *.*.*... before name +-- +tyconUQname :: String -> String +tyconUQname x = let x' = dropWhile (not . (==) '.') x + in if x' == [] then x else tyconUQname (tail x') + + +-- | Gets the module of a type constructor: +-- take *.*.*... before name +tyconModule :: String -> String +tyconModule x = let (a,b) = break ((==) '.') x + in if b == "" + then b + else a ++ tyconModule' (tail b) + where + tyconModule' y = let y' = tyconModule y + in if y' == "" then "" else ('.':y') + + + + +------------------------------------------------------------------------------ +------------------------------------------------------------------------------ +-- +-- Instances of the Data class for Prelude-like types. +-- We define top-level definitions for representations. +-- +------------------------------------------------------------------------------ + + +falseConstr :: Constr +falseConstr = mkConstr boolDataType "False" [] Prefix +trueConstr :: Constr +trueConstr = mkConstr boolDataType "True" [] Prefix + +boolDataType :: DataType +boolDataType = mkDataType "Prelude.Bool" [falseConstr,trueConstr] + +instance Data Bool where + toConstr False = falseConstr + toConstr True = trueConstr + gunfold _ z c = case constrIndex c of + 1 -> z False + 2 -> z True + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " + ++ show c + ++ " is not of type Bool." + dataTypeOf _ = boolDataType + + +------------------------------------------------------------------------------ + +charType :: DataType +charType = mkCharType "Prelude.Char" + +instance Data Char where + toConstr x = mkCharConstr charType x + gunfold _ z c = case constrRep c of + (CharConstr x) -> z x + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Char." + dataTypeOf _ = charType + + +------------------------------------------------------------------------------ + +floatType :: DataType +floatType = mkFloatType "Prelude.Float" + +instance Data Float where + toConstr = mkRealConstr floatType + gunfold _ z c = case constrRep c of + (FloatConstr x) -> z (realToFrac x) + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Float." + dataTypeOf _ = floatType + + +------------------------------------------------------------------------------ + +doubleType :: DataType +doubleType = mkFloatType "Prelude.Double" + +instance Data Double where + toConstr = mkRealConstr doubleType + gunfold _ z c = case constrRep c of + (FloatConstr x) -> z (realToFrac x) + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Double." + dataTypeOf _ = doubleType + + +------------------------------------------------------------------------------ + +intType :: DataType +intType = mkIntType "Prelude.Int" + +instance Data Int where + toConstr x = mkIntegralConstr intType x + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Int." + dataTypeOf _ = intType + + +------------------------------------------------------------------------------ + +integerType :: DataType +integerType = mkIntType "Prelude.Integer" + +instance Data Integer where + toConstr = mkIntegralConstr integerType + gunfold _ z c = case constrRep c of + (IntConstr x) -> z x + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Integer." + dataTypeOf _ = integerType + + +------------------------------------------------------------------------------ + +int8Type :: DataType +int8Type = mkIntType "Data.Int.Int8" + +instance Data Int8 where + toConstr x = mkIntegralConstr int8Type x + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Int8." + dataTypeOf _ = int8Type + + +------------------------------------------------------------------------------ + +int16Type :: DataType +int16Type = mkIntType "Data.Int.Int16" + +instance Data Int16 where + toConstr x = mkIntegralConstr int16Type x + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Int16." + dataTypeOf _ = int16Type + + +------------------------------------------------------------------------------ + +int32Type :: DataType +int32Type = mkIntType "Data.Int.Int32" + +instance Data Int32 where + toConstr x = mkIntegralConstr int32Type x + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Int32." + dataTypeOf _ = int32Type + + +------------------------------------------------------------------------------ + +int64Type :: DataType +int64Type = mkIntType "Data.Int.Int64" + +instance Data Int64 where + toConstr x = mkIntegralConstr int64Type x + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Int64." + dataTypeOf _ = int64Type + + +------------------------------------------------------------------------------ + +wordType :: DataType +wordType = mkIntType "Data.Word.Word" + +instance Data Word where + toConstr x = mkIntegralConstr wordType x + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Word" + dataTypeOf _ = wordType + + +------------------------------------------------------------------------------ + +word8Type :: DataType +word8Type = mkIntType "Data.Word.Word8" + +instance Data Word8 where + toConstr x = mkIntegralConstr word8Type x + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Word8." + dataTypeOf _ = word8Type + + +------------------------------------------------------------------------------ + +word16Type :: DataType +word16Type = mkIntType "Data.Word.Word16" + +instance Data Word16 where + toConstr x = mkIntegralConstr word16Type x + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Word16." + dataTypeOf _ = word16Type + + +------------------------------------------------------------------------------ + +word32Type :: DataType +word32Type = mkIntType "Data.Word.Word32" + +instance Data Word32 where + toConstr x = mkIntegralConstr word32Type x + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Word32." + dataTypeOf _ = word32Type + + +------------------------------------------------------------------------------ + +word64Type :: DataType +word64Type = mkIntType "Data.Word.Word64" + +instance Data Word64 where + toConstr x = mkIntegralConstr word64Type x + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Word64." + dataTypeOf _ = word64Type + + +------------------------------------------------------------------------------ + +ratioConstr :: Constr +ratioConstr = mkConstr ratioDataType ":%" [] Infix + +ratioDataType :: DataType +ratioDataType = mkDataType "GHC.Real.Ratio" [ratioConstr] + +instance (Data a, Integral a) => Data (Ratio a) where + gfoldl k z (a :% b) = z (%) `k` a `k` b + toConstr _ = ratioConstr + gunfold k z c | constrIndex c == 1 = k (k (z (%))) + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(Ratio)" + dataTypeOf _ = ratioDataType + + +------------------------------------------------------------------------------ + +nilConstr :: Constr +nilConstr = mkConstr listDataType "[]" [] Prefix +consConstr :: Constr +consConstr = mkConstr listDataType "(:)" [] Infix + +listDataType :: DataType +listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr] + +instance Data a => Data [a] where + gfoldl _ z [] = z [] + gfoldl f z (x:xs) = z (:) `f` x `f` xs + toConstr [] = nilConstr + toConstr (_:_) = consConstr + gunfold k z c = case constrIndex c of + 1 -> z [] + 2 -> k (k (z (:))) + _ -> errorWithoutStackTrace "Data.Data.gunfold(List)" + dataTypeOf _ = listDataType + dataCast1 f = gcast1 f + +-- +-- The gmaps are given as an illustration. +-- This shows that the gmaps for lists are different from list maps. +-- + gmapT _ [] = [] + gmapT f (x:xs) = (f x:f xs) + gmapQ _ [] = [] + gmapQ f (x:xs) = [f x,f xs] + gmapM _ [] = return [] + gmapM f (x:xs) = f x >>= \x' -> f xs >>= \xs' -> return (x':xs') + + +------------------------------------------------------------------------------ + +nothingConstr :: Constr +nothingConstr = mkConstr maybeDataType "Nothing" [] Prefix +justConstr :: Constr +justConstr = mkConstr maybeDataType "Just" [] Prefix + +maybeDataType :: DataType +maybeDataType = mkDataType "Prelude.Maybe" [nothingConstr,justConstr] + +instance Data a => Data (Maybe a) where + gfoldl _ z Nothing = z Nothing + gfoldl f z (Just x) = z Just `f` x + toConstr Nothing = nothingConstr + toConstr (Just _) = justConstr + gunfold k z c = case constrIndex c of + 1 -> z Nothing + 2 -> k (z Just) + _ -> errorWithoutStackTrace "Data.Data.gunfold(Maybe)" + dataTypeOf _ = maybeDataType + dataCast1 f = gcast1 f + + +------------------------------------------------------------------------------ + +ltConstr :: Constr +ltConstr = mkConstr orderingDataType "LT" [] Prefix +eqConstr :: Constr +eqConstr = mkConstr orderingDataType "EQ" [] Prefix +gtConstr :: Constr +gtConstr = mkConstr orderingDataType "GT" [] Prefix + +orderingDataType :: DataType +orderingDataType = mkDataType "Prelude.Ordering" [ltConstr,eqConstr,gtConstr] + +instance Data Ordering where + gfoldl _ z LT = z LT + gfoldl _ z EQ = z EQ + gfoldl _ z GT = z GT + toConstr LT = ltConstr + toConstr EQ = eqConstr + toConstr GT = gtConstr + gunfold _ z c = case constrIndex c of + 1 -> z LT + 2 -> z EQ + 3 -> z GT + _ -> errorWithoutStackTrace "Data.Data.gunfold(Ordering)" + dataTypeOf _ = orderingDataType + + +------------------------------------------------------------------------------ + +leftConstr :: Constr +leftConstr = mkConstr eitherDataType "Left" [] Prefix + +rightConstr :: Constr +rightConstr = mkConstr eitherDataType "Right" [] Prefix + +eitherDataType :: DataType +eitherDataType = mkDataType "Prelude.Either" [leftConstr,rightConstr] + +instance (Data a, Data b) => Data (Either a b) where + gfoldl f z (Left a) = z Left `f` a + gfoldl f z (Right a) = z Right `f` a + toConstr (Left _) = leftConstr + toConstr (Right _) = rightConstr + gunfold k z c = case constrIndex c of + 1 -> k (z Left) + 2 -> k (z Right) + _ -> errorWithoutStackTrace "Data.Data.gunfold(Either)" + dataTypeOf _ = eitherDataType + dataCast2 f = gcast2 f + + +------------------------------------------------------------------------------ + +tuple0Constr :: Constr +tuple0Constr = mkConstr tuple0DataType "()" [] Prefix + +tuple0DataType :: DataType +tuple0DataType = mkDataType "Prelude.()" [tuple0Constr] + +instance Data () where + toConstr () = tuple0Constr + gunfold _ z c | constrIndex c == 1 = z () + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(unit)" + dataTypeOf _ = tuple0DataType + + +------------------------------------------------------------------------------ + +tuple2Constr :: Constr +tuple2Constr = mkConstr tuple2DataType "(,)" [] Infix + +tuple2DataType :: DataType +tuple2DataType = mkDataType "Prelude.(,)" [tuple2Constr] + +instance (Data a, Data b) => Data (a,b) where + gfoldl f z (a,b) = z (,) `f` a `f` b + toConstr (_,_) = tuple2Constr + gunfold k z c | constrIndex c == 1 = k (k (z (,))) + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(tup2)" + dataTypeOf _ = tuple2DataType + dataCast2 f = gcast2 f + + +------------------------------------------------------------------------------ + +tuple3Constr :: Constr +tuple3Constr = mkConstr tuple3DataType "(,,)" [] Infix + +tuple3DataType :: DataType +tuple3DataType = mkDataType "Prelude.(,,)" [tuple3Constr] + +instance (Data a, Data b, Data c) => Data (a,b,c) where + gfoldl f z (a,b,c) = z (,,) `f` a `f` b `f` c + toConstr (_,_,_) = tuple3Constr + gunfold k z c | constrIndex c == 1 = k (k (k (z (,,)))) + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(tup3)" + dataTypeOf _ = tuple3DataType + + +------------------------------------------------------------------------------ + +tuple4Constr :: Constr +tuple4Constr = mkConstr tuple4DataType "(,,,)" [] Infix + +tuple4DataType :: DataType +tuple4DataType = mkDataType "Prelude.(,,,)" [tuple4Constr] + +instance (Data a, Data b, Data c, Data d) + => Data (a,b,c,d) where + gfoldl f z (a,b,c,d) = z (,,,) `f` a `f` b `f` c `f` d + toConstr (_,_,_,_) = tuple4Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (k (k (z (,,,))))) + _ -> errorWithoutStackTrace "Data.Data.gunfold(tup4)" + dataTypeOf _ = tuple4DataType + + +------------------------------------------------------------------------------ + +tuple5Constr :: Constr +tuple5Constr = mkConstr tuple5DataType "(,,,,)" [] Infix + +tuple5DataType :: DataType +tuple5DataType = mkDataType "Prelude.(,,,,)" [tuple5Constr] + +instance (Data a, Data b, Data c, Data d, Data e) + => Data (a,b,c,d,e) where + gfoldl f z (a,b,c,d,e) = z (,,,,) `f` a `f` b `f` c `f` d `f` e + toConstr (_,_,_,_,_) = tuple5Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (k (k (k (z (,,,,)))))) + _ -> errorWithoutStackTrace "Data.Data.gunfold(tup5)" + dataTypeOf _ = tuple5DataType + + +------------------------------------------------------------------------------ + +tuple6Constr :: Constr +tuple6Constr = mkConstr tuple6DataType "(,,,,,)" [] Infix + +tuple6DataType :: DataType +tuple6DataType = mkDataType "Prelude.(,,,,,)" [tuple6Constr] + +instance (Data a, Data b, Data c, Data d, Data e, Data f) + => Data (a,b,c,d,e,f) where + gfoldl f z (a,b,c,d,e,f') = z (,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f' + toConstr (_,_,_,_,_,_) = tuple6Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (k (k (k (k (z (,,,,,))))))) + _ -> errorWithoutStackTrace "Data.Data.gunfold(tup6)" + dataTypeOf _ = tuple6DataType + + +------------------------------------------------------------------------------ + +tuple7Constr :: Constr +tuple7Constr = mkConstr tuple7DataType "(,,,,,,)" [] Infix + +tuple7DataType :: DataType +tuple7DataType = mkDataType "Prelude.(,,,,,,)" [tuple7Constr] + +instance (Data a, Data b, Data c, Data d, Data e, Data f, Data g) + => Data (a,b,c,d,e,f,g) where + gfoldl f z (a,b,c,d,e,f',g) = + z (,,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f' `f` g + toConstr (_,_,_,_,_,_,_) = tuple7Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (k (k (k (k (k (z (,,,,,,)))))))) + _ -> errorWithoutStackTrace "Data.Data.gunfold(tup7)" + dataTypeOf _ = tuple7DataType + + +------------------------------------------------------------------------------ + +instance Data a => Data (Ptr a) where + toConstr _ = errorWithoutStackTrace "Data.Data.toConstr(Ptr)" + gunfold _ _ = errorWithoutStackTrace "Data.Data.gunfold(Ptr)" + dataTypeOf _ = mkNoRepType "GHC.Ptr.Ptr" + dataCast1 x = gcast1 x + +------------------------------------------------------------------------------ + +instance Data a => Data (ForeignPtr a) where + toConstr _ = errorWithoutStackTrace "Data.Data.toConstr(ForeignPtr)" + gunfold _ _ = errorWithoutStackTrace "Data.Data.gunfold(ForeignPtr)" + dataTypeOf _ = mkNoRepType "GHC.ForeignPtr.ForeignPtr" + dataCast1 x = gcast1 x + +------------------------------------------------------------------------------ +-- The Data instance for Array preserves data abstraction at the cost of +-- inefficiency. We omit reflection services for the sake of data abstraction. +instance (Data a, Data b, Ix a) => Data (Array a b) + where + gfoldl f z a = z (listArray (bounds a)) `f` (elems a) + toConstr _ = errorWithoutStackTrace "Data.Data.toConstr(Array)" + gunfold _ _ = errorWithoutStackTrace "Data.Data.gunfold(Array)" + dataTypeOf _ = mkNoRepType "Data.Array.Array" + dataCast2 x = gcast2 x + +---------------------------------------------------------------------------- +-- Data instance for Proxy + +proxyConstr :: Constr +proxyConstr = mkConstr proxyDataType "Proxy" [] Prefix + +proxyDataType :: DataType +proxyDataType = mkDataType "Data.Proxy.Proxy" [proxyConstr] + +instance (Data t) => Data (Proxy t) where + gfoldl _ z Proxy = z Proxy + toConstr Proxy = proxyConstr + gunfold _ z c = case constrIndex c of + 1 -> z Proxy + _ -> errorWithoutStackTrace "Data.Data.gunfold(Proxy)" + dataTypeOf _ = proxyDataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- +-- instance for (:~:) + +reflConstr :: Constr +reflConstr = mkConstr equalityDataType "Refl" [] Prefix + +equalityDataType :: DataType +equalityDataType = mkDataType "Data.Type.Equality.(:~:)" [reflConstr] + +instance (a ~ b, Data a) => Data (a :~: b) where + gfoldl _ z Refl = z Refl + toConstr Refl = reflConstr + gunfold _ z c = case constrIndex c of + 1 -> z Refl + _ -> errorWithoutStackTrace "Data.Data.gunfold(:~:)" + dataTypeOf _ = equalityDataType + dataCast2 f = gcast2 f + +----------------------------------------------------------------------- +-- instance for Coercion + +coercionConstr :: Constr +coercionConstr = mkConstr equalityDataType "Coercion" [] Prefix + +coercionDataType :: DataType +coercionDataType = mkDataType "Data.Type.Coercion.Coercion" [coercionConstr] + +instance (Coercible a b, Data a, Data b) => Data (Coercion a b) where + gfoldl _ z Coercion = z Coercion + toConstr Coercion = coercionConstr + gunfold _ z c = case constrIndex c of + 1 -> z Coercion + _ -> errorWithoutStackTrace "Data.Data.gunfold(Coercion)" + dataTypeOf _ = coercionDataType + dataCast2 f = gcast2 f + +----------------------------------------------------------------------- +-- instance for Data.Version + +versionConstr :: Constr +versionConstr = mkConstr versionDataType "Version" ["versionBranch","versionTags"] Prefix + +versionDataType :: DataType +versionDataType = mkDataType "Data.Version.Version" [versionConstr] + +instance Data Version where + gfoldl k z (Version bs ts) = z Version `k` bs `k` ts + toConstr (Version _ _) = versionConstr + gunfold k z c = case constrIndex c of + 1 -> k (k (z Version)) + _ -> errorWithoutStackTrace "Data.Data.gunfold(Version)" + dataTypeOf _ = versionDataType + +----------------------------------------------------------------------- +-- instances for Data.Monoid wrappers + +dualConstr :: Constr +dualConstr = mkConstr dualDataType "Dual" ["getDual"] Prefix + +dualDataType :: DataType +dualDataType = mkDataType "Data.Monoid.Dual" [dualConstr] + +instance Data a => Data (Dual a) where + gfoldl f z (Dual x) = z Dual `f` x + gunfold k z _ = k (z Dual) + toConstr (Dual _) = dualConstr + dataTypeOf _ = dualDataType + dataCast1 f = gcast1 f + +allConstr :: Constr +allConstr = mkConstr allDataType "All" ["getAll"] Prefix + +allDataType :: DataType +allDataType = mkDataType "All" [allConstr] + +instance Data All where + gfoldl f z (All x) = (z All `f` x) + gunfold k z _ = k (z All) + toConstr (All _) = allConstr + dataTypeOf _ = allDataType + +anyConstr :: Constr +anyConstr = mkConstr anyDataType "Any" ["getAny"] Prefix + +anyDataType :: DataType +anyDataType = mkDataType "Any" [anyConstr] + +instance Data Any where + gfoldl f z (Any x) = (z Any `f` x) + gunfold k z _ = k (z Any) + toConstr (Any _) = anyConstr + dataTypeOf _ = anyDataType + + +sumConstr :: Constr +sumConstr = mkConstr sumDataType "Sum" ["getSum"] Prefix + +sumDataType :: DataType +sumDataType = mkDataType "Data.Monoid.Sum" [sumConstr] + +instance Data a => Data (Sum a) where + gfoldl f z (Sum x) = z Sum `f` x + gunfold k z _ = k (z Sum) + toConstr (Sum _) = sumConstr + dataTypeOf _ = sumDataType + dataCast1 f = gcast1 f + + +productConstr :: Constr +productConstr = mkConstr productDataType "Product" ["getProduct"] Prefix + +productDataType :: DataType +productDataType = mkDataType "Data.Monoid.Product" [productConstr] + +instance Data a => Data (Product a) where + gfoldl f z (Product x) = z Product `f` x + gunfold k z _ = k (z Product) + toConstr (Product _) = productConstr + dataTypeOf _ = productDataType + dataCast1 f = gcast1 f + + +firstConstr :: Constr +firstConstr = mkConstr firstDataType "First" ["getFirst"] Prefix + +firstDataType :: DataType +firstDataType = mkDataType "Data.Monoid.First" [firstConstr] + +instance Data a => Data (First a) where + gfoldl f z (First x) = (z First `f` x) + gunfold k z _ = k (z First) + toConstr (First _) = firstConstr + dataTypeOf _ = firstDataType + dataCast1 f = gcast1 f + + +lastConstr :: Constr +lastConstr = mkConstr lastDataType "Last" ["getLast"] Prefix + +lastDataType :: DataType +lastDataType = mkDataType "Data.Monoid.Last" [lastConstr] + +instance Data a => Data (Last a) where + gfoldl f z (Last x) = (z Last `f` x) + gunfold k z _ = k (z Last) + toConstr (Last _) = lastConstr + dataTypeOf _ = lastDataType + dataCast1 f = gcast1 f + + +altConstr :: Constr +altConstr = mkConstr altDataType "Alt" ["getAlt"] Prefix + +altDataType :: DataType +altDataType = mkDataType "Alt" [altConstr] + +instance (Data (f a), Data a, Typeable f) => Data (Alt f a) where + gfoldl f z (Alt x) = (z Alt `f` x) + gunfold k z _ = k (z Alt) + toConstr (Alt _) = altConstr + dataTypeOf _ = altDataType + +----------------------------------------------------------------------- +-- instances for GHC.Generics + +u1Constr :: Constr +u1Constr = mkConstr u1DataType "U1" [] Prefix + +u1DataType :: DataType +u1DataType = mkDataType "GHC.Generics.U1" [u1Constr] + +instance Data p => Data (U1 p) where + gfoldl _ z U1 = z U1 + toConstr U1 = u1Constr + gunfold _ z c = case constrIndex c of + 1 -> z U1 + _ -> errorWithoutStackTrace "Data.Data.gunfold(U1)" + dataTypeOf _ = u1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +par1Constr :: Constr +par1Constr = mkConstr par1DataType "Par1" [] Prefix + +par1DataType :: DataType +par1DataType = mkDataType "GHC.Generics.Par1" [par1Constr] + +instance Data p => Data (Par1 p) where + gfoldl k z (Par1 p) = z Par1 `k` p + toConstr (Par1 _) = par1Constr + gunfold k z c = case constrIndex c of + 1 -> k (z Par1) + _ -> errorWithoutStackTrace "Data.Data.gunfold(Par1)" + dataTypeOf _ = par1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +rec1Constr :: Constr +rec1Constr = mkConstr rec1DataType "Rec1" [] Prefix + +rec1DataType :: DataType +rec1DataType = mkDataType "GHC.Generics.Rec1" [rec1Constr] + +instance (Data (f p), Typeable f, Data p) => Data (Rec1 f p) where + gfoldl k z (Rec1 p) = z Rec1 `k` p + toConstr (Rec1 _) = rec1Constr + gunfold k z c = case constrIndex c of + 1 -> k (z Rec1) + _ -> errorWithoutStackTrace "Data.Data.gunfold(Rec1)" + dataTypeOf _ = rec1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +k1Constr :: Constr +k1Constr = mkConstr k1DataType "K1" [] Prefix + +k1DataType :: DataType +k1DataType = mkDataType "GHC.Generics.K1" [k1Constr] + +instance (Typeable i, Data p, Data c) => Data (K1 i c p) where + gfoldl k z (K1 p) = z K1 `k` p + toConstr (K1 _) = k1Constr + gunfold k z c = case constrIndex c of + 1 -> k (z K1) + _ -> errorWithoutStackTrace "Data.Data.gunfold(K1)" + dataTypeOf _ = k1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +m1Constr :: Constr +m1Constr = mkConstr m1DataType "M1" [] Prefix + +m1DataType :: DataType +m1DataType = mkDataType "GHC.Generics.M1" [m1Constr] + +instance (Data p, Data (f p), Typeable c, Typeable i, Typeable f) + => Data (M1 i c f p) where + gfoldl k z (M1 p) = z M1 `k` p + toConstr (M1 _) = m1Constr + gunfold k z c = case constrIndex c of + 1 -> k (z M1) + _ -> errorWithoutStackTrace "Data.Data.gunfold(M1)" + dataTypeOf _ = m1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +sum1DataType :: DataType +sum1DataType = mkDataType "GHC.Generics.:+:" [l1Constr, r1Constr] + +l1Constr :: Constr +l1Constr = mkConstr sum1DataType "L1" [] Prefix + +r1Constr :: Constr +r1Constr = mkConstr sum1DataType "R1" [] Prefix + +instance (Typeable f, Typeable g, Data p, Data (f p), Data (g p)) + => Data ((f :+: g) p) where + gfoldl k z (L1 a) = z L1 `k` a + gfoldl k z (R1 a) = z R1 `k` a + toConstr L1{} = l1Constr + toConstr R1{} = r1Constr + gunfold k z c = case constrIndex c of + 1 -> k (z L1) + 2 -> k (z R1) + _ -> errorWithoutStackTrace "Data.Data.gunfold(:+:)" + dataTypeOf _ = sum1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +comp1Constr :: Constr +comp1Constr = mkConstr comp1DataType "Comp1" [] Prefix + +comp1DataType :: DataType +comp1DataType = mkDataType "GHC.Generics.:.:" [comp1Constr] + +instance (Typeable f, Typeable g, Data p, Data (f (g p))) + => Data ((f :.: g) p) where + gfoldl k z (Comp1 c) = z Comp1 `k` c + toConstr (Comp1 _) = m1Constr + gunfold k z c = case constrIndex c of + 1 -> k (z Comp1) + _ -> errorWithoutStackTrace "Data.Data.gunfold(:.:)" + dataTypeOf _ = comp1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +v1DataType :: DataType +v1DataType = mkDataType "GHC.Generics.V1" [] + +instance Data p => Data (V1 p) where + gfoldl _ _ !_ = undefined + toConstr !_ = undefined + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(V1)" + dataTypeOf _ = v1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +prod1DataType :: DataType +prod1DataType = mkDataType "GHC.Generics.:*:" [prod1Constr] + +prod1Constr :: Constr +prod1Constr = mkConstr prod1DataType "Prod1" [] Infix + +instance (Typeable f, Typeable g, Data p, Data (f p), Data (g p)) + => Data ((f :*: g) p) where + gfoldl k z (l :*: r) = z (:*:) `k` l `k` r + toConstr _ = prod1Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (z (:*:))) + _ -> errorWithoutStackTrace "Data.Data.gunfold(:*:)" + dataCast1 f = gcast1 f + dataTypeOf _ = prod1DataType + +----------------------------------------------------------------------- + +prefixConstr :: Constr +prefixConstr = mkConstr fixityDataType "Prefix" [] Prefix +infixConstr :: Constr +infixConstr = mkConstr fixityDataType "Infix" [] Prefix + +fixityDataType :: DataType +fixityDataType = mkDataType "GHC.Generics.Fixity" [prefixConstr,infixConstr] + +instance Data Generics.Fixity where + gfoldl _ z Generics.Prefix = z Generics.Prefix + gfoldl f z (Generics.Infix a i) = z Generics.Infix `f` a `f` i + toConstr Generics.Prefix = prefixConstr + toConstr Generics.Infix{} = infixConstr + gunfold k z c = case constrIndex c of + 1 -> z Generics.Prefix + 2 -> k (k (z Generics.Infix)) + _ -> errorWithoutStackTrace "Data.Data.gunfold(Fixity)" + dataTypeOf _ = fixityDataType + +----------------------------------------------------------------------- + +leftAssociativeConstr :: Constr +leftAssociativeConstr + = mkConstr associativityDataType "LeftAssociative" [] Prefix +rightAssociativeConstr :: Constr +rightAssociativeConstr + = mkConstr associativityDataType "RightAssociative" [] Prefix +notAssociativeConstr :: Constr +notAssociativeConstr + = mkConstr associativityDataType "NotAssociative" [] Prefix + +associativityDataType :: DataType +associativityDataType = mkDataType "GHC.Generics.Associativity" + [leftAssociativeConstr,rightAssociativeConstr,notAssociativeConstr] + +instance Data Associativity where + gfoldl _ z LeftAssociative = z LeftAssociative + gfoldl _ z RightAssociative = z RightAssociative + gfoldl _ z NotAssociative = z NotAssociative + toConstr LeftAssociative = leftAssociativeConstr + toConstr RightAssociative = rightAssociativeConstr + toConstr NotAssociative = notAssociativeConstr + gunfold _ z c = case constrIndex c of + 1 -> z LeftAssociative + 2 -> z RightAssociative + 3 -> z NotAssociative + _ -> errorWithoutStackTrace + "Data.Data.gunfold(Associativity)" + dataTypeOf _ = associativityDataType + +----------------------------------------------------------------------- + +noSourceUnpackednessConstr :: Constr +noSourceUnpackednessConstr + = mkConstr sourceUnpackednessDataType "NoSourceUnpackedness" [] Prefix +sourceNoUnpackConstr :: Constr +sourceNoUnpackConstr + = mkConstr sourceUnpackednessDataType "SourceNoUnpack" [] Prefix +sourceUnpackConstr :: Constr +sourceUnpackConstr + = mkConstr sourceUnpackednessDataType "SourceUnpack" [] Prefix + +sourceUnpackednessDataType :: DataType +sourceUnpackednessDataType = mkDataType "GHC.Generics.SourceUnpackedness" + [noSourceUnpackednessConstr,sourceNoUnpackConstr,sourceUnpackConstr] + +instance Data SourceUnpackedness where + gfoldl _ z NoSourceUnpackedness = z NoSourceUnpackedness + gfoldl _ z SourceNoUnpack = z SourceNoUnpack + gfoldl _ z SourceUnpack = z SourceUnpack + toConstr NoSourceUnpackedness = noSourceUnpackednessConstr + toConstr SourceNoUnpack = sourceNoUnpackConstr + toConstr SourceUnpack = sourceUnpackConstr + gunfold _ z c = case constrIndex c of + 1 -> z NoSourceUnpackedness + 2 -> z SourceNoUnpack + 3 -> z SourceUnpack + _ -> errorWithoutStackTrace + "Data.Data.gunfold(SourceUnpackedness)" + dataTypeOf _ = sourceUnpackednessDataType + +----------------------------------------------------------------------- + +noSourceStrictnessConstr :: Constr +noSourceStrictnessConstr + = mkConstr sourceStrictnessDataType "NoSourceStrictness" [] Prefix +sourceLazyConstr :: Constr +sourceLazyConstr + = mkConstr sourceStrictnessDataType "SourceLazy" [] Prefix +sourceStrictConstr :: Constr +sourceStrictConstr + = mkConstr sourceStrictnessDataType "SourceStrict" [] Prefix + +sourceStrictnessDataType :: DataType +sourceStrictnessDataType = mkDataType "GHC.Generics.SourceStrictness" + [noSourceStrictnessConstr,sourceLazyConstr,sourceStrictConstr] + +instance Data SourceStrictness where + gfoldl _ z NoSourceStrictness = z NoSourceStrictness + gfoldl _ z SourceLazy = z SourceLazy + gfoldl _ z SourceStrict = z SourceStrict + toConstr NoSourceStrictness = noSourceStrictnessConstr + toConstr SourceLazy = sourceLazyConstr + toConstr SourceStrict = sourceStrictConstr + gunfold _ z c = case constrIndex c of + 1 -> z NoSourceStrictness + 2 -> z SourceLazy + 3 -> z SourceStrict + _ -> errorWithoutStackTrace + "Data.Data.gunfold(SourceStrictness)" + dataTypeOf _ = sourceStrictnessDataType + +----------------------------------------------------------------------- + +decidedLazyConstr :: Constr +decidedLazyConstr + = mkConstr decidedStrictnessDataType "DecidedLazy" [] Prefix +decidedStrictConstr :: Constr +decidedStrictConstr + = mkConstr decidedStrictnessDataType "DecidedStrict" [] Prefix +decidedUnpackConstr :: Constr +decidedUnpackConstr + = mkConstr decidedStrictnessDataType "DecidedUnpack" [] Prefix + +decidedStrictnessDataType :: DataType +decidedStrictnessDataType = mkDataType "GHC.Generics.DecidedStrictness" + [decidedLazyConstr,decidedStrictConstr,decidedUnpackConstr] + +instance Data DecidedStrictness where + gfoldl _ z DecidedLazy = z DecidedLazy + gfoldl _ z DecidedStrict = z DecidedStrict + gfoldl _ z DecidedUnpack = z DecidedUnpack + toConstr DecidedLazy = decidedLazyConstr + toConstr DecidedStrict = decidedStrictConstr + toConstr DecidedUnpack = decidedUnpackConstr + gunfold _ z c = case constrIndex c of + 1 -> z DecidedLazy + 2 -> z DecidedStrict + 3 -> z DecidedUnpack + _ -> errorWithoutStackTrace + "Data.Data.gunfold(DecidedStrictness)" + dataTypeOf _ = decidedStrictnessDataType diff --git a/libraries/base/Data/Dynamic.hs b/libraries/base/Data/Dynamic.hs new file mode 100644 index 0000000..55082ff --- /dev/null +++ b/libraries/base/Data/Dynamic.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Dynamic +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- 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 + ( + + -- Module Data.Typeable re-exported for convenience + module Data.Typeable, + + -- * The @Dynamic@ type + Dynamic, -- abstract, instance of: Show, Typeable + + -- * Converting to and from @Dynamic@ + toDyn, + fromDyn, + fromDynamic, + + -- * Applying functions of dynamic type + dynApply, + dynApp, + dynTypeRep + + ) where + + +import Data.Typeable +import Data.Maybe +import Unsafe.Coerce + +import GHC.Base +import GHC.Show +import GHC.Exception + +------------------------------------------------------------- +-- +-- The type Dynamic +-- +------------------------------------------------------------- + +{-| + A value of type 'Dynamic' is an object encapsulated together with its type. + + A 'Dynamic' may only represent a monomorphic value; an attempt to + create a value of type 'Dynamic' from a polymorphically-typed + expression will result in an ambiguity error (see 'toDyn'). + + 'Show'ing a value of type 'Dynamic' returns a pretty-printed representation + of the object\'s type; useful for debugging. +-} +data Dynamic = Dynamic TypeRep Obj + +instance Show Dynamic where + -- the instance just prints the type representation. + showsPrec _ (Dynamic t _) = + showString "<<" . + showsPrec 0 t . + showString ">>" + +-- here so that it isn't an orphan: +instance Exception Dynamic + +type Obj = Any + -- Use GHC's primitive 'Any' type to hold the dynamically typed value. + -- + -- In GHC's new eval/apply execution model this type must not look + -- like a data type. If it did, GHC would use the constructor convention + -- when evaluating it, and this will go wrong if the object is really a + -- function. Using Any forces GHC to use + -- a fallback convention for evaluating it that works for all types. + +-- | Converts an arbitrary value into an object of type 'Dynamic'. +-- +-- The type of the object must be an instance of 'Typeable', which +-- ensures that only monomorphically-typed objects may be converted to +-- 'Dynamic'. To convert a polymorphic object into 'Dynamic', give it +-- a monomorphic type signature. For example: +-- +-- > toDyn (id :: Int -> Int) +-- +toDyn :: Typeable a => a -> Dynamic +toDyn v = Dynamic (typeOf v) (unsafeCoerce v) + +-- | Converts a 'Dynamic' object back into an ordinary Haskell value of +-- the correct type. See also 'fromDynamic'. +fromDyn :: Typeable a + => Dynamic -- ^ the dynamically-typed object + -> a -- ^ a default value + -> a -- ^ returns: the value of the first argument, if + -- it has the correct type, otherwise the value of + -- the second argument. +fromDyn (Dynamic t v) def + | typeOf def == t = unsafeCoerce v + | otherwise = def + +-- | Converts a 'Dynamic' object back into an ordinary Haskell value of +-- the correct type. See also 'fromDyn'. +fromDynamic + :: Typeable a + => Dynamic -- ^ the dynamically-typed object + -> Maybe a -- ^ returns: @'Just' a@, if the dynamically-typed + -- object has the correct type (and @a@ is its value), + -- or 'Nothing' otherwise. +fromDynamic (Dynamic t v) = + case unsafeCoerce v of + r | t == typeOf r -> Just r + | otherwise -> Nothing + +-- (f::(a->b)) `dynApply` (x::a) = (f a)::b +dynApply :: Dynamic -> Dynamic -> Maybe Dynamic +dynApply (Dynamic t1 f) (Dynamic t2 x) = + case funResultTy t1 t2 of + Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x)) + Nothing -> Nothing + +dynApp :: Dynamic -> Dynamic -> Dynamic +dynApp f x = case dynApply f x of + Just r -> r + Nothing -> errorWithoutStackTrace ("Type error in dynamic application.\n" ++ + "Can't apply function " ++ show f ++ + " to argument " ++ show x) + +dynTypeRep :: Dynamic -> TypeRep +dynTypeRep (Dynamic tr _) = tr + diff --git a/libraries/base/Data/Either.hs b/libraries/base/Data/Either.hs new file mode 100644 index 0000000..db34092 --- /dev/null +++ b/libraries/base/Data/Either.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, TypeOperators, UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Either +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- The Either type, and associated operations. +-- +----------------------------------------------------------------------------- + +module Data.Either ( + Either(..), + either, + lefts, + rights, + isLeft, + isRight, + partitionEithers, + ) where + +import GHC.Base +import GHC.Show +import GHC.Read + +import Data.Type.Equality + +-- $setup +-- Allow the use of some Prelude functions in doctests. +-- >>> import Prelude ( (+), (*), length, putStrLn ) + +{- +-- just for testing +import Test.QuickCheck +-} + +{-| + +The 'Either' type represents values with two possibilities: a value of +type @'Either' a b@ is either @'Left' a@ or @'Right' b@. + +The 'Either' type is sometimes used to represent a value which is +either correct or an error; by convention, the 'Left' constructor is +used to hold an error value and the 'Right' constructor is used to +hold a correct value (mnemonic: \"right\" also means \"correct\"). + +==== __Examples__ + +The type @'Either' 'String' 'Int'@ is the type of values which can be either +a 'String' or an 'Int'. The 'Left' constructor can be used only on +'String's, and the 'Right' constructor can be used only on 'Int's: + +>>> let s = Left "foo" :: Either String Int +>>> s +Left "foo" +>>> let n = Right 3 :: Either String Int +>>> n +Right 3 +>>> :type s +s :: Either String Int +>>> :type n +n :: Either String Int + +The 'fmap' from our 'Functor' instance will ignore 'Left' values, but +will apply the supplied function to values contained in a 'Right': + +>>> let s = Left "foo" :: Either String Int +>>> let n = Right 3 :: Either String Int +>>> fmap (*2) s +Left "foo" +>>> fmap (*2) n +Right 6 + +The 'Monad' instance for 'Either' allows us to chain together multiple +actions which may fail, and fail overall if any of the individual +steps failed. First we'll write a function that can either parse an +'Int' from a 'Char', or fail. + +>>> import Data.Char ( digitToInt, isDigit ) +>>> :{ + let parseEither :: Char -> Either String Int + parseEither c + | isDigit c = Right (digitToInt c) + | otherwise = Left "parse error" +>>> :} + +The following should work, since both @\'1\'@ and @\'2\'@ can be +parsed as 'Int's. + +>>> :{ + let parseMultiple :: Either String Int + parseMultiple = do + x <- parseEither '1' + y <- parseEither '2' + return (x + y) +>>> :} + +>>> parseMultiple +Right 3 + +But the following should fail overall, since the first operation where +we attempt to parse @\'m\'@ as an 'Int' will fail: + +>>> :{ + let parseMultiple :: Either String Int + parseMultiple = do + x <- parseEither 'm' + y <- parseEither '2' + return (x + y) +>>> :} + +>>> parseMultiple +Left "parse error" + +-} +data Either a b = Left a | Right b + deriving (Eq, Ord, Read, Show) + +instance Functor (Either a) where + fmap _ (Left x) = Left x + fmap f (Right y) = Right (f y) + +instance Applicative (Either e) where + pure = Right + Left e <*> _ = Left e + Right f <*> r = fmap f r + +instance Monad (Either e) where + Left l >>= _ = Left l + Right r >>= k = k r + +-- | Case analysis for the 'Either' type. +-- If the value is @'Left' a@, apply the first function to @a@; +-- if it is @'Right' b@, apply the second function to @b@. +-- +-- ==== __Examples__ +-- +-- We create two values of type @'Either' 'String' 'Int'@, one using the +-- 'Left' constructor and another using the 'Right' constructor. Then +-- we apply \"either\" the 'length' function (if we have a 'String') +-- or the \"times-two\" function (if we have an 'Int'): +-- +-- >>> let s = Left "foo" :: Either String Int +-- >>> let n = Right 3 :: Either String Int +-- >>> either length (*2) s +-- 3 +-- >>> either length (*2) n +-- 6 +-- +either :: (a -> c) -> (b -> c) -> Either a b -> c +either f _ (Left x) = f x +either _ g (Right y) = g y + + +-- | Extracts from a list of 'Either' all the 'Left' elements. +-- All the 'Left' elements are extracted in order. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> let list = [ Left "foo", Right 3, Left "bar", Right 7, Left "baz" ] +-- >>> lefts list +-- ["foo","bar","baz"] +-- +lefts :: [Either a b] -> [a] +lefts x = [a | Left a <- x] + +-- | Extracts from a list of 'Either' all the 'Right' elements. +-- All the 'Right' elements are extracted in order. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> let list = [ Left "foo", Right 3, Left "bar", Right 7, Left "baz" ] +-- >>> rights list +-- [3,7] +-- +rights :: [Either a b] -> [b] +rights x = [a | Right a <- x] + +-- | Partitions a list of 'Either' into two lists. +-- All the 'Left' elements are extracted, in order, to the first +-- component of the output. Similarly the 'Right' elements are extracted +-- to the second component of the output. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> let list = [ Left "foo", Right 3, Left "bar", Right 7, Left "baz" ] +-- >>> partitionEithers list +-- (["foo","bar","baz"],[3,7]) +-- +-- The pair returned by @'partitionEithers' x@ should be the same +-- pair as @('lefts' x, 'rights' x)@: +-- +-- >>> let list = [ Left "foo", Right 3, Left "bar", Right 7, Left "baz" ] +-- >>> partitionEithers list == (lefts list, rights list) +-- True +-- +partitionEithers :: [Either a b] -> ([a],[b]) +partitionEithers = foldr (either left right) ([],[]) + where + left a ~(l, r) = (a:l, r) + right a ~(l, r) = (l, a:r) + +-- | Return `True` if the given value is a `Left`-value, `False` otherwise. +-- +-- @since 4.7.0.0 +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> isLeft (Left "foo") +-- True +-- >>> isLeft (Right 3) +-- False +-- +-- Assuming a 'Left' value signifies some sort of error, we can use +-- 'isLeft' to write a very simple error-reporting function that does +-- absolutely nothing in the case of success, and outputs \"ERROR\" if +-- any error occurred. +-- +-- This example shows how 'isLeft' might be used to avoid pattern +-- matching when one does not care about the value contained in the +-- constructor: +-- +-- >>> import Control.Monad ( when ) +-- >>> let report e = when (isLeft e) $ putStrLn "ERROR" +-- >>> report (Right 1) +-- >>> report (Left "parse error") +-- ERROR +-- +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft (Right _) = False + +-- | Return `True` if the given value is a `Right`-value, `False` otherwise. +-- +-- @since 4.7.0.0 +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> isRight (Left "foo") +-- False +-- >>> isRight (Right 3) +-- True +-- +-- Assuming a 'Left' value signifies some sort of error, we can use +-- 'isRight' to write a very simple reporting function that only +-- outputs \"SUCCESS\" when a computation has succeeded. +-- +-- This example shows how 'isRight' might be used to avoid pattern +-- matching when one does not care about the value contained in the +-- constructor: +-- +-- >>> import Control.Monad ( when ) +-- >>> let report e = when (isRight e) $ putStrLn "SUCCESS" +-- >>> report (Left "parse error") +-- >>> report (Right 1) +-- SUCCESS +-- +isRight :: Either a b -> Bool +isRight (Left _) = False +isRight (Right _) = True + +-- instance for the == Boolean type-level equality operator +type family EqEither a b where + EqEither ('Left x) ('Left y) = x == y + EqEither ('Right x) ('Right y) = x == y + EqEither a b = 'False +type instance a == b = EqEither a b + +{- +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} +prop_partitionEithers :: [Either Int Int] -> Bool +prop_partitionEithers x = + partitionEithers x == (lefts x, rights x) +-} + diff --git a/libraries/base/Data/Eq.hs b/libraries/base/Data/Eq.hs new file mode 100644 index 0000000..fe487bf --- /dev/null +++ b/libraries/base/Data/Eq.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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.Base diff --git a/libraries/base/Data/Fixed.hs b/libraries/base/Data/Fixed.hs new file mode 100644 index 0000000..150afb8 --- /dev/null +++ b/libraries/base/Data/Fixed.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Fixed +-- Copyright : (c) Ashley Yakeley 2005, 2006, 2009 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Ashley Yakeley +-- Stability : experimental +-- Portability : portable +-- +-- This module defines a \"Fixed\" type for fixed-precision arithmetic. +-- The parameter to Fixed is any type that's an instance of HasResolution. +-- HasResolution has a single method that gives the resolution of the Fixed type. +-- +-- This module also contains generalisations of div, mod, and divmod to work +-- with any Real instance. +-- +----------------------------------------------------------------------------- + +module Data.Fixed +( + div',mod',divMod', + + Fixed(..), HasResolution(..), + showFixed, + E0,Uni, + E1,Deci, + E2,Centi, + E3,Milli, + E6,Micro, + E9,Nano, + E12,Pico +) where + +import Data.Data +import GHC.Read +import Text.ParserCombinators.ReadPrec +import Text.Read.Lex + +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 parameter should be an instance of 'HasResolution'. +newtype Fixed a = MkFixed Integer -- ^ @since 4.7.0.0 + deriving (Eq,Ord) + +-- 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 +instance (Typeable a) => Data (Fixed a) where + gfoldl k z (MkFixed a) = k (z MkFixed) a + gunfold k z _ = k (z MkFixed) + dataTypeOf _ = tyFixed + toConstr _ = conMkFixed + +class HasResolution a where + resolution :: p a -> Integer + +withType :: (p a -> f a) -> f a +withType foo = foo undefined + +withResolution :: (HasResolution a) => (Integer -> f a) -> f a +withResolution foo = withType (foo . resolution) + +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) + +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)) + +instance (HasResolution a) => Real (Fixed a) where + toRational fa@(MkFixed a) = (toRational a) / (toRational (resolution fa)) + +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)))) + +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 +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 + +instance (HasResolution a) => Show (Fixed a) where + show = showFixed False + +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 (undefined :: Fixed 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 + +data E0 +instance HasResolution E0 where + resolution _ = 1 +-- | resolution of 1, this works the same as Integer +type Uni = Fixed E0 + +data E1 +instance HasResolution E1 where + resolution _ = 10 +-- | resolution of 10^-1 = .1 +type Deci = Fixed E1 + +data E2 +instance HasResolution E2 where + resolution _ = 100 +-- | resolution of 10^-2 = .01, useful for many monetary currencies +type Centi = Fixed E2 + +data E3 +instance HasResolution E3 where + resolution _ = 1000 +-- | resolution of 10^-3 = .001 +type Milli = Fixed E3 + +data E6 +instance HasResolution E6 where + resolution _ = 1000000 +-- | resolution of 10^-6 = .000001 +type Micro = Fixed E6 + +data E9 +instance HasResolution E9 where + resolution _ = 1000000000 +-- | resolution of 10^-9 = .000000001 +type Nano = Fixed E9 + +data E12 +instance HasResolution E12 where + resolution _ = 1000000000000 +-- | resolution of 10^-12 = .000000000001 +type Pico = Fixed E12 diff --git a/libraries/base/Data/Foldable.hs b/libraries/base/Data/Foldable.hs new file mode 100644 index 0000000..0defe6c --- /dev/null +++ b/libraries/base/Data/Foldable.hs @@ -0,0 +1,623 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Foldable +-- Copyright : Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Class of data structures that can be folded to a summary value. +-- +----------------------------------------------------------------------------- + +module Data.Foldable ( + -- * Folds + 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 + ) where + +import Data.Bool +import Data.Either +import Data.Eq +import qualified GHC.List as List +import Data.Maybe +import Data.Monoid +import Data.Ord +import Data.Proxy + +import GHC.Arr ( Array(..), elems, numElements, + foldlElems, foldrElems, + foldlElems', foldrElems', + foldl1Elems, foldr1Elems) +import GHC.Base hiding ( foldr ) +import GHC.Generics +import GHC.Num ( Num(..) ) + +infix 4 `elem`, `notElem` + +-- | Data structures that can be folded. +-- +-- For example, given a data type +-- +-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) +-- +-- a suitable instance would be +-- +-- > instance Foldable Tree where +-- > foldMap f Empty = mempty +-- > foldMap f (Leaf x) = f x +-- > foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r +-- +-- This is suitable even for abstract types, as the monoid is assumed +-- to satisfy the monoid laws. Alternatively, one could define @foldr@: +-- +-- > 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 +-- +-- @Foldable@ instances are expected to satisfy the following laws: +-- +-- > foldr f z t = appEndo (foldMap (Endo . f) t ) z +-- +-- > foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z +-- +-- > fold = foldMap id +-- +-- @sum@, @product@, @maximum@, and @minimum@ should all be essentially +-- equivalent to @foldMap@ forms, such as +-- +-- > sum = getSum . foldMap Sum +-- +-- but may be less defined. +-- +-- If the type is also a 'Functor' instance, it should satisfy +-- +-- > foldMap f = fold . fmap f +-- +-- which implies that +-- +-- > foldMap f . fmap g = foldMap (f . g) + +class Foldable t where + {-# MINIMAL foldMap | foldr #-} + + -- | Combine the elements of a structure using a monoid. + fold :: Monoid m => t m -> m + fold = foldMap id + + -- | Map each element of the structure to a monoid, + -- and combine the results. + foldMap :: Monoid m => (a -> m) -> t a -> m + {-# INLINE foldMap #-} + -- This INLINE allows more list functions to fuse. See Trac #9848. + foldMap f = foldr (mappend . f) mempty + + -- | Right-associative fold of a structure. + -- + -- In the case of lists, 'foldr', when applied to a binary operator, a + -- starting value (typically the right-identity of the operator), and a + -- list, reduces the list using the binary operator, from right to left: + -- + -- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...) + -- + -- Note that, since the head of the resulting expression is produced by + -- an application of the operator to the first element of the list, + -- 'foldr' can produce a terminating expression from an infinite list. + -- + -- For a general 'Foldable' structure this should be semantically identical + -- to, + -- + -- @foldr f z = 'List.foldr' f z . 'toList'@ + -- + foldr :: (a -> b -> b) -> b -> t a -> b + foldr f z t = appEndo (foldMap (Endo #. f) t) z + + -- | Right-associative fold of a structure, but with strict application of + -- the operator. + -- + foldr' :: (a -> b -> b) -> b -> t a -> b + foldr' f z0 xs = foldl f' id xs z0 + where f' k x z = k $! f x z + + -- | Left-associative fold of a structure. + -- + -- In the case of lists, 'foldl', when applied to a binary + -- operator, a starting value (typically the left-identity of the operator), + -- and a list, reduces the list using the binary operator, from left to + -- right: + -- + -- > foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn + -- + -- Note that to produce the outermost application of the operator the + -- entire input list must be traversed. This means that 'foldl'' will + -- diverge if given an infinite list. + -- + -- Also note that if you want an efficient left-fold, you probably want to + -- use 'foldl'' instead of 'foldl'. The reason for this is that latter does + -- not force the "inner" results (e.g. @z `f` x1@ in the above example) + -- before applying them to the operator (e.g. to @(`f` x2)@). This results + -- in a thunk chain @O(n)@ elements long, which then must be evaluated from + -- the outside-in. + -- + -- For a general 'Foldable' structure this should be semantically identical + -- to, + -- + -- @foldl f z = 'List.foldl' f z . 'toList'@ + -- + foldl :: (b -> a -> b) -> b -> t a -> b + foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z + -- There's no point mucking around with coercions here, + -- because flip forces us to build a new function anyway. + + -- | 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 + -- list to a single, monolithic result (e.g. 'length'). + -- + -- For a general 'Foldable' structure this should be semantically identical + -- to, + -- + -- @foldl f z = 'List.foldl'' f z . 'toList'@ + -- + foldl' :: (b -> a -> b) -> b -> t a -> b + foldl' f z0 xs = foldr f' id xs z0 + where f' x k z = k $! f z x + + -- | A variant of 'foldr' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldr1' f = 'List.foldr1' f . 'toList'@ + foldr1 :: (a -> a -> a) -> t a -> a + foldr1 f xs = fromMaybe (errorWithoutStackTrace "foldr1: empty structure") + (foldr mf Nothing xs) + where + mf x m = Just (case m of + Nothing -> x + Just y -> f x y) + + -- | A variant of 'foldl' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldl1' f = 'List.foldl1' f . 'toList'@ + foldl1 :: (a -> a -> a) -> t a -> a + foldl1 f xs = fromMaybe (errorWithoutStackTrace "foldl1: empty structure") + (foldl mf Nothing xs) + where + mf m y = Just (case m of + Nothing -> y + Just x -> f x y) + + -- | List of elements of a structure, from left to right. + toList :: t a -> [a] + {-# INLINE toList #-} + toList t = build (\ c n -> foldr c n t) + + -- | Test whether the structure is empty. The default implementation is + -- optimized for structures that are similar to cons-lists, because there + -- is no general way to do better. + null :: t a -> Bool + null = foldr (\_ _ -> False) True + + -- | Returns the size/length of a finite structure as an 'Int'. The + -- default implementation is optimized for structures that are similar to + -- cons-lists, because there is no general way to do better. + length :: t a -> Int + length = foldl' (\c _ -> c+1) 0 + + -- | Does the element occur in the structure? + elem :: Eq a => a -> t a -> Bool + elem = any . (==) + + -- | The largest element of a non-empty structure. + maximum :: forall a . Ord a => t a -> a + maximum = fromMaybe (errorWithoutStackTrace "maximum: empty structure") . + getMax . foldMap (Max #. (Just :: a -> Maybe a)) + + -- | The least element of a non-empty structure. + minimum :: forall a . Ord a => t a -> a + minimum = fromMaybe (errorWithoutStackTrace "minimum: empty structure") . + getMin . foldMap (Min #. (Just :: a -> Maybe a)) + + -- | The 'sum' function computes the sum of the numbers of a structure. + sum :: Num a => t a -> a + sum = getSum #. foldMap Sum + + -- | The 'product' function computes the product of the numbers of a + -- structure. + product :: Num a => t a -> a + product = getProduct #. foldMap Product + +-- instances for Prelude types + +instance Foldable Maybe where + foldr _ z Nothing = z + foldr f z (Just x) = f x z + + foldl _ z Nothing = z + foldl f z (Just x) = f z x + +instance Foldable [] where + elem = List.elem + foldl = List.foldl + foldl' = List.foldl' + foldl1 = List.foldl1 + foldr = List.foldr + foldr1 = List.foldr1 + length = List.length + maximum = List.maximum + minimum = List.minimum + null = List.null + product = List.product + sum = List.sum + toList = id + +instance Foldable (Either a) where + foldMap _ (Left _) = mempty + foldMap f (Right y) = f y + + foldr _ z (Left _) = z + foldr f z (Right y) = f y z + + length (Left _) = 0 + length (Right _) = 1 + + null = isLeft + +instance Foldable ((,) a) where + foldMap f (_, y) = f y + + foldr f z (_, y) = f y z + +instance Foldable (Array i) where + foldr = foldrElems + foldl = foldlElems + foldl' = foldlElems' + foldr' = foldrElems' + foldl1 = foldl1Elems + foldr1 = foldr1Elems + toList = elems + length = numElements + null a = numElements a == 0 + +instance Foldable Proxy where + foldMap _ _ = mempty + {-# INLINE foldMap #-} + fold _ = mempty + {-# INLINE fold #-} + foldr _ z _ = z + {-# INLINE foldr #-} + foldl _ z _ = z + {-# INLINE foldl #-} + foldl1 _ _ = errorWithoutStackTrace "foldl1: Proxy" + foldr1 _ _ = errorWithoutStackTrace "foldr1: Proxy" + length _ = 0 + null _ = True + elem _ _ = False + sum _ = 0 + product _ = 1 + +instance Foldable Dual where + foldMap = coerce + + elem = (. getDual) #. (==) + foldl = coerce + foldl' = coerce + foldl1 _ = getDual + foldr f z (Dual x) = f x z + foldr' = foldr + foldr1 _ = getDual + length _ = 1 + maximum = getDual + minimum = getDual + null _ = False + product = getDual + sum = getDual + toList (Dual x) = [x] + +instance Foldable Sum where + foldMap = coerce + + elem = (. getSum) #. (==) + foldl = coerce + foldl' = coerce + foldl1 _ = getSum + foldr f z (Sum x) = f x z + foldr' = foldr + foldr1 _ = getSum + length _ = 1 + maximum = getSum + minimum = getSum + null _ = False + product = getSum + sum = getSum + toList (Sum x) = [x] + +instance Foldable Product where + foldMap = coerce + + elem = (. getProduct) #. (==) + foldl = coerce + foldl' = coerce + foldl1 _ = getProduct + foldr f z (Product x) = f x z + foldr' = foldr + foldr1 _ = getProduct + length _ = 1 + maximum = getProduct + minimum = getProduct + null _ = False + product = getProduct + sum = getProduct + toList (Product x) = [x] + +instance Foldable First where + foldMap f = foldMap f . getFirst + +instance Foldable Last where + foldMap f = foldMap f . getLast + +-- We don't export Max and Min because, as Edward Kmett pointed out to me, +-- there are two reasonable ways to define them. One way is to use Maybe, as we +-- do here; the other way is to impose a Bounded constraint on the Monoid +-- instance. We may eventually want to add both versions, but we don't want to +-- trample on anyone's toes by imposing Max = MaxMaybe. + +newtype Max a = Max {getMax :: Maybe a} +newtype Min a = Min {getMin :: Maybe a} + +instance Ord a => Monoid (Max a) where + mempty = Max Nothing + + {-# INLINE mappend #-} + m `mappend` Max Nothing = m + Max Nothing `mappend` n = n + (Max m@(Just x)) `mappend` (Max n@(Just y)) + | x >= y = Max m + | otherwise = Max n + +instance Ord a => Monoid (Min a) where + mempty = Min Nothing + + {-# INLINE mappend #-} + m `mappend` Min Nothing = m + Min Nothing `mappend` n = n + (Min m@(Just x)) `mappend` (Min n@(Just y)) + | x <= y = Min m + | otherwise = Min n + +-- Instances for GHC.Generics +instance Foldable U1 where + foldMap _ _ = mempty + {-# INLINE foldMap #-} + fold _ = mempty + {-# INLINE fold #-} + foldr _ z _ = z + {-# INLINE foldr #-} + foldl _ z _ = z + {-# INLINE foldl #-} + foldl1 _ _ = errorWithoutStackTrace "foldl1: U1" + foldr1 _ _ = errorWithoutStackTrace "foldr1: U1" + length _ = 0 + null _ = True + elem _ _ = False + sum _ = 0 + product _ = 1 + +deriving instance Foldable V1 +deriving instance Foldable Par1 +deriving instance Foldable f => Foldable (Rec1 f) +deriving instance Foldable (K1 i c) +deriving instance Foldable f => Foldable (M1 i c f) +deriving instance (Foldable f, Foldable g) => Foldable (f :+: g) +deriving instance (Foldable f, Foldable g) => Foldable (f :*: g) +deriving instance (Foldable f, Foldable g) => Foldable (f :.: g) +deriving instance Foldable UAddr +deriving instance Foldable UChar +deriving instance Foldable UDouble +deriving instance Foldable UFloat +deriving instance Foldable UInt +deriving instance Foldable UWord + +-- | Monadic fold over the elements of a structure, +-- associating to the right, i.e. from right to left. +foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b +foldrM f z0 xs = foldl f' return xs z0 + where f' k x z = f x z >>= k + +-- | Monadic fold over the elements of a structure, +-- associating to the left, i.e. from left to right. +foldlM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b +foldlM f z0 xs = foldr f' return xs z0 + where f' x k z = f z x >>= k + +-- | Map each element of a structure to an action, evaluate these +-- actions from left to right, and ignore the results. For a version +-- that doesn't ignore the results see 'Data.Traversable.traverse'. +traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () +traverse_ f = foldr ((*>) . f) (pure ()) + +-- | 'for_' is 'traverse_' with its arguments flipped. For a version +-- that doesn't ignore the results see 'Data.Traversable.for'. +-- +-- >>> for_ [1..4] print +-- 1 +-- 2 +-- 3 +-- 4 +for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f () +{-# INLINE for_ #-} +for_ = flip traverse_ + +-- | Map each element of a structure to a monadic action, evaluate +-- these actions from left to right, and ignore the results. For a +-- version that doesn't ignore the results see +-- 'Data.Traversable.mapM'. +-- +-- As of base 4.8.0.0, 'mapM_' is just 'traverse_', specialized to +-- 'Monad'. +mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () +mapM_ f= foldr ((>>) . f) (return ()) + +-- | 'forM_' is 'mapM_' with its arguments flipped. For a version that +-- doesn't ignore the results see 'Data.Traversable.forM'. +-- +-- As of base 4.8.0.0, 'forM_' is just 'for_', specialized to 'Monad'. +forM_ :: (Foldable t, Monad m) => t a -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ = flip mapM_ + +-- | 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.Traversable.sequenceA'. +sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f () +sequenceA_ = foldr (*>) (pure ()) + +-- | Evaluate each monadic action in the structure from left to right, +-- and ignore the results. For a version that doesn't ignore the +-- results see 'Data.Traversable.sequence'. +-- +-- As of base 4.8.0.0, 'sequence_' is just 'sequenceA_', specialized +-- to 'Monad'. +sequence_ :: (Foldable t, Monad m) => t (m a) -> m () +sequence_ = foldr (>>) (return ()) + +-- | The sum of a collection of actions, generalizing 'concat'. +asum :: (Foldable t, Alternative f) => t (f a) -> f a +{-# INLINE asum #-} +asum = foldr (<|>) empty + +-- | The sum of a collection of actions, generalizing 'concat'. +-- As of base 4.8.0.0, 'msum' is just 'asum', specialized to 'MonadPlus'. +msum :: (Foldable t, MonadPlus m) => t (m a) -> m a +{-# INLINE msum #-} +msum = asum + +-- | The concatenation of all the elements of a container of lists. +concat :: Foldable t => t [a] -> [a] +concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs) +{-# INLINE concat #-} + +-- | Map a function over all the elements of a container and concatenate +-- the resulting lists. +concatMap :: Foldable t => (a -> [b]) -> t a -> [b] +concatMap f xs = build (\c n -> foldr (\x b -> foldr c b (f x)) n xs) +{-# INLINE concatMap #-} + +-- These use foldr rather than foldMap to avoid repeated concatenation. + +-- | 'and' 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. +and :: Foldable t => t Bool -> Bool +and = getAll #. foldMap All + +-- | 'or' 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. +or :: Foldable t => t Bool -> Bool +or = getAny #. foldMap Any + +-- | Determines whether any element of the structure satisfies the predicate. +any :: Foldable t => (a -> Bool) -> t a -> Bool +any p = getAny #. foldMap (Any #. p) + +-- | Determines whether all elements of the structure satisfy the predicate. +all :: Foldable t => (a -> Bool) -> t a -> Bool +all p = getAll #. foldMap (All #. p) + +-- | The largest element of a non-empty structure with respect to the +-- given comparison function. +maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a +maximumBy cmp = foldr1 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. +minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a +minimumBy cmp = foldr1 min' + where min' x y = case cmp x y of + GT -> y + _ -> x + +-- | 'notElem' is the negation of 'elem'. +notElem :: (Foldable t, Eq a) => a -> t a -> Bool +notElem x = not . elem x + +-- | The 'find' 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. +find :: Foldable t => (a -> Bool) -> t a -> Maybe a +find p = getFirst . foldMap (\ x -> First (if p x then Just x else Nothing)) + +-- See Note [Function coercion] +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) +(#.) _f = coerce +{-# INLINE (#.) #-} + +{- +Note [Function coercion] +~~~~~~~~~~~~~~~~~~~~~~~~ + +Several functions here use (#.) instead of (.) to avoid potential efficiency +problems relating to #7542. The problem, in a nutshell: + +If N is a newtype constructor, then N x will always have the same +representation as x (something similar applies for a newtype deconstructor). +However, if f is a function, + +N . f = \x -> N (f x) + +This looks almost the same as f, but the eta expansion lifts it--the lhs could +be _|_, but the rhs never is. This can lead to very inefficient code. Thus we +steal a technique from Shachaf and Edward Kmett and adapt it to the current +(rather clean) setting. Instead of using N . f, we use N .## f, which is +just + +coerce f `asTypeOf` (N . f) + +That is, we just *pretend* that f has the right type, and thanks to the safety +of coerce, the type checker guarantees that nothing really goes wrong. We still +have to be a bit careful, though: remember that #. completely ignores the +*value* of its left operand. +-} diff --git a/libraries/base/Data/Function.hs b/libraries/base/Data/Function.hs new file mode 100644 index 0000000..c5ded4c --- /dev/null +++ b/libraries/base/Data/Function.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- Portability : portable +-- +-- Simple combinators working solely on and with functions. +-- +----------------------------------------------------------------------------- + +module Data.Function + ( -- * "Prelude" re-exports + id, const, (.), flip, ($) + -- * Other combinators + , (&) + , fix + , on + ) where + +import GHC.Base ( ($), (.), id, const, flip ) + +infixl 0 `on` +infixl 1 & + +-- | @'fix' f@ is the least fixed point of the function @f@, +-- i.e. the least defined @x@ such that @f x = x@. +fix :: (a -> a) -> a +fix f = let x = f x in x + +-- | @(*) \`on\` f = \\x y -> f x * f y@. +-- +-- Typical usage: @'Data.List.sortBy' ('compare' \`on\` 'fst')@. +-- +-- Algebraic properties: +-- +-- * @(*) \`on\` 'id' = (*)@ (if @(*) ∉ {⊥, 'const' ⊥}@) +-- +-- * @((*) \`on\` f) \`on\` g = (*) \`on\` (f . g)@ +-- +-- * @'flip' on f . 'flip' on g = 'flip' on (g . f)@ + +-- Proofs (so that I don't have to edit the test-suite): + +-- (*) `on` id +-- = +-- \x y -> id x * id y +-- = +-- \x y -> x * y +-- = { If (*) /= _|_ or const _|_. } +-- (*) + +-- (*) `on` f `on` g +-- = +-- ((*) `on` f) `on` g +-- = +-- \x y -> ((*) `on` f) (g x) (g y) +-- = +-- \x y -> (\x y -> f x * f y) (g x) (g y) +-- = +-- \x y -> f (g x) * f (g y) +-- = +-- \x y -> (f . g) x * (f . g) y +-- = +-- (*) `on` (f . g) +-- = +-- (*) `on` f . g + +-- flip on f . flip on g +-- = +-- (\h (*) -> (*) `on` h) f . (\h (*) -> (*) `on` h) g +-- = +-- (\(*) -> (*) `on` f) . (\(*) -> (*) `on` g) +-- = +-- \(*) -> (*) `on` g `on` f +-- = { See above. } +-- \(*) -> (*) `on` g . f +-- = +-- (\h (*) -> (*) `on` h) (g . f) +-- = +-- flip on (g . f) + +on :: (b -> b -> c) -> (a -> b) -> a -> a -> c +(.*.) `on` f = \x y -> f x .*. f y + + +-- | '&' is a reverse application operator. This provides notational +-- convenience. Its precedence is one higher than that of the forward +-- application operator '$', which allows '&' to be nested in '$'. +-- +-- @since 4.8.0.0 +(&) :: a -> (a -> b) -> b +x & f = f x diff --git a/libraries/base/Data/Functor.hs b/libraries/base/Data/Functor.hs new file mode 100644 index 0000000..8eba29e --- /dev/null +++ b/libraries/base/Data/Functor.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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 +-- +-- Functors: uniform action over a parameterized type, generalizing the +-- 'Data.List.map' function on lists. + +module Data.Functor + ( + Functor(fmap), + (<$), + ($>), + (<$>), + void, + ) where + +import GHC.Base ( Functor(..), flip ) + +-- $setup +-- Allow the use of Prelude in doctests. +-- >>> import Prelude + +infixl 4 <$> + +-- | An infix synonym for 'fmap'. +-- +-- The name of this operator is an allusion to '$'. +-- Note the similarities between their types: +-- +-- > ($) :: (a -> b) -> a -> b +-- > (<$>) :: Functor f => (a -> b) -> f a -> f b +-- +-- Whereas '$' is function application, '<$>' is function +-- application lifted over a 'Functor'. +-- +-- ==== __Examples__ +-- +-- Convert from a @'Maybe' 'Int'@ to a @'Maybe' 'String'@ using 'show': +-- +-- >>> show <$> Nothing +-- Nothing +-- >>> show <$> Just 3 +-- Just "3" +-- +-- Convert from an @'Either' 'Int' 'Int'@ to an @'Either' 'Int'@ +-- 'String' using 'show': +-- +-- >>> show <$> Left 17 +-- Left 17 +-- >>> show <$> Right 17 +-- Right "17" +-- +-- Double each element of a list: +-- +-- >>> (*2) <$> [1,2,3] +-- [2,4,6] +-- +-- Apply 'even' to the second element of a pair: +-- +-- >>> even <$> (2,2) +-- (2,True) +-- +(<$>) :: Functor f => (a -> b) -> f a -> f b +(<$>) = fmap + +infixl 4 $> + +-- | Flipped version of '<$'. +-- +-- @since 4.7.0.0 +-- +-- ==== __Examples__ +-- +-- Replace the contents of a @'Maybe' 'Int'@ with a constant 'String': +-- +-- >>> Nothing $> "foo" +-- Nothing +-- >>> Just 90210 $> "foo" +-- Just "foo" +-- +-- Replace the contents of an @'Either' 'Int' 'Int'@ with a constant +-- 'String', resulting in an @'Either' 'Int' 'String'@: +-- +-- >>> Left 8675309 $> "foo" +-- Left 8675309 +-- >>> Right 8675309 $> "foo" +-- Right "foo" +-- +-- Replace each element of a list with a constant 'String': +-- +-- >>> [1,2,3] $> "foo" +-- ["foo","foo","foo"] +-- +-- Replace the second element of a pair with a constant 'String': +-- +-- >>> (1,2) $> "foo" +-- (1,"foo") +-- +($>) :: Functor f => f a -> b -> f b +($>) = flip (<$) + +-- | @'void' value@ discards or ignores the result of evaluation, such +-- as the return value of an 'System.IO.IO' action. +-- +-- ==== __Examples__ +-- +-- Replace the contents of a @'Maybe' 'Int'@ with unit: +-- +-- >>> void Nothing +-- Nothing +-- >>> void (Just 3) +-- Just () +-- +-- Replace the contents of an @'Either' 'Int' 'Int'@ with unit, +-- resulting in an @'Either' 'Int' '()'@: +-- +-- >>> void (Left 8675309) +-- Left 8675309 +-- >>> void (Right 8675309) +-- Right () +-- +-- Replace every element of a list with unit: +-- +-- >>> void [1,2,3] +-- [(),(),()] +-- +-- Replace the second element of a pair with unit: +-- +-- >>> void (1,2) +-- (1,()) +-- +-- Discard the result of an 'System.IO.IO' action: +-- +-- >>> mapM print [1,2] +-- 1 +-- 2 +-- [(),()] +-- >>> void $ mapM print [1,2] +-- 1 +-- 2 +-- +void :: Functor f => f a -> f () +void x = () <$ x diff --git a/libraries/base/Data/Functor/Classes.hs b/libraries/base/Data/Functor/Classes.hs new file mode 100644 index 0000000..ce84af0 --- /dev/null +++ b/libraries/base/Data/Functor/Classes.hs @@ -0,0 +1,490 @@ +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Classes +-- Copyright : (c) Ross Paterson 2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- 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 readsPrec = readsPrec1 +-- > 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, + Show1(..), showsPrec1, + -- ** For binary constructors + Eq2(..), eq2, + Ord2(..), compare2, + Read2(..), readsPrec2, + Show2(..), showsPrec2, + -- * Helper functions + -- $example + readsData, + readsUnaryWith, + readsBinaryWith, + showsUnaryWith, + showsBinaryWith, + -- ** Obsolete helpers + readsUnary, + readsUnary1, + readsBinary1, + showsUnary, + showsUnary1, + showsBinary1, + ) where + +import Control.Applicative (Const(Const)) +import Data.Functor.Identity (Identity(Identity)) +import Data.Proxy (Proxy(Proxy)) +import Data.Monoid (mappend) +import Text.Show (showListWith) + +-- | Lifting of the 'Eq' class to unary type constructors. +class 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. + liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool + +-- | Lift the standard @('==')@ function through the type constructor. +eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool +eq1 = liftEq (==) + +-- | Lifting of the 'Ord' class to unary type constructors. +class (Eq1 f) => 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. + liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering + +-- | Lift the standard 'compare' function through the type constructor. +compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering +compare1 = liftCompare compare + +-- | Lifting of the 'Read' class to unary type constructors. +class Read1 f where + -- | 'readsPrec' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument type. + liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) + + -- | '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. + liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a] + liftReadList rp rl = readListWith (liftReadsPrec rp rl 0) + +-- | Read a list (using square brackets and commas), given a function +-- for reading elements. +readListWith :: ReadS a -> ReadS [a] +readListWith rp = + readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) + where + readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t] + readl' s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u] + +-- | Lift the standard 'readsPrec' and 'readList' functions through the +-- type constructor. +readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a) +readsPrec1 = liftReadsPrec readsPrec readList + +-- | Lifting of the 'Show' class to unary type constructors. +class Show1 f where + -- | 'showsPrec' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument type. + liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + Int -> f a -> ShowS + + -- | '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. + 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. +showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS +showsPrec1 = liftShowsPrec showsPrec showList + +-- | Lifting of the 'Eq' class to binary type constructors. +class 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. + liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool + +-- | Lift the standard @('==')@ function through the type constructor. +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. +class (Eq2 f) => 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. + liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) -> + f a c -> f b d -> Ordering + +-- | Lift the standard 'compare' function through the type constructor. +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. +class Read2 f where + -- | 'readsPrec' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument types. + liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] -> + (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b) + + -- | '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. + liftReadList2 :: (Int -> ReadS a) -> ReadS [a] -> + (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b] + liftReadList2 rp1 rl1 rp2 rl2 = + readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0) + +-- | Lift the standard 'readsPrec' function through the type constructor. +readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b) +readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList + +-- | Lifting of the 'Show' class to binary type constructors. +class Show2 f where + -- | 'showsPrec' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument types. + 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. + 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. +showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS +showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList + +-- Instances for Prelude type constructors + +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 + +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 + +instance Read1 Maybe where + liftReadsPrec rp _ d = + readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r]) + `mappend` + readsData (readsUnaryWith rp "Just" Just) d + +instance Show1 Maybe where + liftShowsPrec _ _ _ Nothing = showString "Nothing" + liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x + +instance Eq1 [] where + liftEq _ [] [] = True + liftEq _ [] (_:_) = False + liftEq _ (_:_) [] = False + liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys + +instance Ord1 [] where + liftCompare _ [] [] = EQ + liftCompare _ [] (_:_) = LT + liftCompare _ (_:_) [] = GT + liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys + +instance Read1 [] where + liftReadsPrec _ rl _ = rl + +instance Show1 [] where + liftShowsPrec _ sl _ = sl + +instance Eq2 (,) where + liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2 + +instance Ord2 (,) where + liftCompare2 comp1 comp2 (x1, y1) (x2, y2) = + comp1 x1 x2 `mappend` comp2 y1 y2 + +instance Read2 (,) where + liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r -> + [((x,y), w) | ("(",s) <- lex r, + (x,t) <- rp1 0 s, + (",",u) <- lex t, + (y,v) <- rp2 0 u, + (")",w) <- lex v] + +instance Show2 (,) where + liftShowsPrec2 sp1 _ sp2 _ _ (x, y) = + showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')' + +instance (Eq a) => Eq1 ((,) a) where + liftEq = liftEq2 (==) + +instance (Ord a) => Ord1 ((,) a) where + liftCompare = liftCompare2 compare + +instance (Read a) => Read1 ((,) a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance (Show a) => Show1 ((,) a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +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 + +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 + +instance Read2 Either where + liftReadsPrec2 rp1 _ rp2 _ = readsData $ + readsUnaryWith rp1 "Left" Left `mappend` + readsUnaryWith rp2 "Right" Right + +instance Show2 Either where + liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x + liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x + +instance (Eq a) => Eq1 (Either a) where + liftEq = liftEq2 (==) + +instance (Ord a) => Ord1 (Either a) where + liftCompare = liftCompare2 compare + +instance (Read a) => Read1 (Either a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance (Show a) => Show1 (Either a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +-- Instances for other functors defined in the base package + +instance Eq1 Identity where + liftEq eq (Identity x) (Identity y) = eq x y + +instance Ord1 Identity where + liftCompare comp (Identity x) (Identity y) = comp x y + +instance Read1 Identity where + liftReadsPrec rp _ = readsData $ + readsUnaryWith rp "Identity" Identity + +instance Show1 Identity where + liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x + +instance Eq2 Const where + liftEq2 eq _ (Const x) (Const y) = eq x y + +instance Ord2 Const where + liftCompare2 comp _ (Const x) (Const y) = comp x y + +instance Read2 Const where + liftReadsPrec2 rp _ _ _ = readsData $ + readsUnaryWith rp "Const" Const + +instance Show2 Const where + liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x + +instance (Eq a) => Eq1 (Const a) where + liftEq = liftEq2 (==) +instance (Ord a) => Ord1 (Const a) where + liftCompare = liftCompare2 compare +instance (Read a) => Read1 (Const a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList +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 + liftReadsPrec _ _ d = + readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) + +-- 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. +readsData :: (String -> ReadS a) -> Int -> ReadS a +readsData reader d = + readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s] + +-- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor +-- and then parses its argument using @rp@. +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] + +-- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary +-- data constructor and then parses its arguments using @rp1@ and @rp2@ +-- respectively. +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] + +-- | @'showsUnaryWith' sp n d x@ produces the string representation of a +-- unary data constructor with name @n@ and argument @x@, in precedence +-- context @d@. +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@. +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'. +{-# 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'. +{-# 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'. +{-# 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@. +{-# 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@. +{-# 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@. +{-# 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 +> liftReadsPrec rp rl = readsData $ +> readsUnaryWith rp "Zero" Zero `mappend` +> readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend` +> readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two + +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 + +-} diff --git a/libraries/base/Data/Functor/Compose.hs b/libraries/base/Data/Functor/Compose.hs new file mode 100644 index 0000000..d548836 --- /dev/null +++ b/libraries/base/Data/Functor/Compose.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Compose +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Composition of functors. +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Functor.Compose ( + Compose(..), + ) where + +import Data.Functor.Classes + +import Control.Applicative +import Data.Data (Data) +import Data.Foldable (Foldable(foldMap)) +import Data.Traversable (Traversable(traverse)) +import GHC.Generics (Generic, Generic1) + +infixr 9 `Compose` + +-- | Right-to-left composition of functors. +-- The composition of applicative functors is always applicative, +-- but the composition of monads is not always a monad. +newtype Compose f g a = Compose { getCompose :: f (g a) } + deriving (Data, Generic, Generic1) + +-- Instances of lifted Prelude classes + +instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where + liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y + +instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where + liftCompare comp (Compose x) (Compose y) = + liftCompare (liftCompare comp) x y + +instance (Read1 f, Read1 g) => Read1 (Compose f g) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance (Show1 f, Show1 g) => Show1 (Compose f g) where + liftShowsPrec sp sl d (Compose x) = + showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +-- Instances of Prelude classes + +instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where + (==) = eq1 + +instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where + compare = compare1 + +instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where + readsPrec = readsPrec1 + +instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where + showsPrec = showsPrec1 + +-- Functor instances + +instance (Functor f, Functor g) => Functor (Compose f g) where + fmap f (Compose x) = Compose (fmap (fmap f) x) + +instance (Foldable f, Foldable g) => Foldable (Compose f g) where + foldMap f (Compose t) = foldMap (foldMap f) t + +instance (Traversable f, Traversable g) => Traversable (Compose f g) where + traverse f (Compose t) = Compose <$> traverse (traverse f) t + +instance (Applicative f, Applicative g) => Applicative (Compose f g) where + pure x = Compose (pure (pure x)) + Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) + +instance (Alternative f, Applicative g) => Alternative (Compose f g) where + empty = Compose empty + Compose x <|> Compose y = Compose (x <|> y) diff --git a/libraries/base/Data/Functor/Const.hs b/libraries/base/Data/Functor/Const.hs new file mode 100644 index 0000000..9f2db7f --- /dev/null +++ b/libraries/base/Data/Functor/Const.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- Portability : portable + +-- The 'Const' functor. +-- +-- @since 4.9.0.0 + +module Data.Functor.Const (Const(..)) where + +import Data.Bits (Bits, FiniteBits) +import Data.Foldable (Foldable(foldMap)) +import Foreign.Storable (Storable) + +import GHC.Arr (Ix) +import GHC.Base +import GHC.Enum (Bounded, Enum) +import GHC.Float (Floating, RealFloat) +import GHC.Generics (Generic, Generic1) +import GHC.Num (Num) +import GHC.Real (Fractional, Integral, Real, RealFrac) +import GHC.Read (Read(readsPrec), readParen, lex) +import GHC.Show (Show(showsPrec), showParen, showString) + +-- | The 'Const' functor. +newtype Const a b = Const { getConst :: a } + deriving ( Bits, Bounded, Enum, Eq, FiniteBits, Floating, Fractional + , Generic, Generic1, Integral, Ix, Monoid, Num, Ord, Real + , RealFrac, RealFloat , Storable) + +-- | This instance would be equivalent to the derived instances of the +-- 'Const' newtype if the 'runConst' field were removed +instance Read a => Read (Const a b) where + readsPrec d = readParen (d > 10) + $ \r -> [(Const x,t) | ("Const", s) <- lex r, (x, t) <- readsPrec 11 s] + +-- | This instance would be equivalent to the derived instances of the +-- 'Const' newtype if the 'runConst' field were removed +instance Show a => Show (Const a b) where + showsPrec d (Const x) = showParen (d > 10) $ + showString "Const " . showsPrec 11 x + +instance Foldable (Const m) where + foldMap _ _ = mempty + +instance Functor (Const m) where + fmap _ (Const v) = Const v + +instance Monoid m => Applicative (Const m) where + pure _ = Const mempty + (<*>) = coerce (mappend :: m -> m -> m) +-- This is pretty much the same as +-- Const f <*> Const v = Const (f `mappend` v) +-- but guarantees that mappend for Const a b will have the same arity +-- as the one for a; it won't create a closure to raise the arity +-- to 2. diff --git a/libraries/base/Data/Functor/Identity.hs b/libraries/base/Data/Functor/Identity.hs new file mode 100644 index 0000000..4e6646a --- /dev/null +++ b/libraries/base/Data/Functor/Identity.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- 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 Control.Monad.Fix +import Control.Monad.Zip +import Data.Bits (Bits, FiniteBits) +import Data.Coerce +import Data.Data (Data) +import Data.Foldable +import Data.Ix (Ix) +import Data.Semigroup (Semigroup) +import Data.String (IsString) +import Foreign.Storable (Storable) +import GHC.Generics (Generic, Generic1) + +-- | Identity functor and monad. (a non-strict monad) +-- +-- @since 4.8.0.0 +newtype Identity a = Identity { runIdentity :: a } + deriving ( Bits, Bounded, Data, Enum, Eq, FiniteBits, Floating, Fractional + , Generic, Generic1, Integral, IsString, Ix, Monoid, Num, Ord + , Real, RealFrac, RealFloat , Semigroup, Storable, Traversable) + +-- | This instance would be equivalent to the derived instances of the +-- 'Identity' newtype if the 'runIdentity' field were removed +instance (Read a) => Read (Identity a) where + readsPrec d = readParen (d > 10) $ \ r -> + [(Identity x,t) | ("Identity",s) <- lex r, (x,t) <- readsPrec 11 s] + +-- | This instance would be equivalent to the derived instances of the +-- 'Identity' newtype if the 'runIdentity' field were removed +instance (Show a) => Show (Identity a) where + showsPrec d (Identity x) = showParen (d > 10) $ + showString "Identity " . showsPrec 11 x + +-- --------------------------------------------------------------------------- +-- Identity instances for Functor and Monad + +instance Foldable Identity where + foldMap = coerce + + elem = (. runIdentity) #. (==) + foldl = coerce + foldl' = coerce + foldl1 _ = runIdentity + foldr f z (Identity x) = f x z + foldr' = foldr + foldr1 _ = runIdentity + length _ = 1 + maximum = runIdentity + minimum = runIdentity + null _ = False + product = runIdentity + sum = runIdentity + toList (Identity x) = [x] + +instance Functor Identity where + fmap = coerce + +instance Applicative Identity where + pure = Identity + (<*>) = coerce + +instance Monad Identity where + m >>= k = k (runIdentity m) + +instance MonadFix Identity where + mfix f = Identity (fix (runIdentity . f)) + +instance MonadZip Identity where + mzipWith = coerce + munzip = coerce + +-- | Internal (non-exported) 'Coercible' helper for 'elem' +-- +-- See Note [Function coercion] in "Data.Foldable" for more details. +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c +(#.) _f = coerce diff --git a/libraries/base/Data/Functor/Product.hs b/libraries/base/Data/Functor/Product.hs new file mode 100644 index 0000000..9d6d6a6 --- /dev/null +++ b/libraries/base/Data/Functor/Product.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Product +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Products, lifted to functors. +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Functor.Product ( + Product(..), + ) where + +import Control.Applicative +import Control.Monad (MonadPlus(..)) +import Control.Monad.Fix (MonadFix(..)) +import Control.Monad.Zip (MonadZip(mzipWith)) +import Data.Data (Data) +import Data.Foldable (Foldable(foldMap)) +import Data.Functor.Classes +import Data.Monoid (mappend) +import Data.Traversable (Traversable(traverse)) +import GHC.Generics (Generic, Generic1) + +-- | Lifted product of functors. +data Product f g a = Pair (f a) (g a) + deriving (Data, Generic, Generic1) + +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 + +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 + +instance (Read1 f, Read1 g) => Read1 (Product f g) where + liftReadsPrec rp rl = readsData $ + readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair + +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 + +instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a) + where (==) = eq1 +instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where + compare = compare1 +instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where + readsPrec = readsPrec1 +instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where + showsPrec = showsPrec1 + +instance (Functor f, Functor g) => Functor (Product f g) where + fmap f (Pair x y) = Pair (fmap f x) (fmap f y) + +instance (Foldable f, Foldable g) => Foldable (Product f g) where + foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y + +instance (Traversable f, Traversable g) => Traversable (Product f g) where + traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y + +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) + +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) + +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 + +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) + +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 + +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) diff --git a/libraries/base/Data/Functor/Sum.hs b/libraries/base/Data/Functor/Sum.hs new file mode 100644 index 0000000..f5bee11 --- /dev/null +++ b/libraries/base/Data/Functor/Sum.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Sum +-- Copyright : (c) Ross Paterson 2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Sums, lifted to functors. +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Functor.Sum ( + Sum(..), + ) where + +import Data.Data (Data) +import Data.Foldable (Foldable(foldMap)) +import Data.Functor.Classes +import Data.Monoid (mappend) +import Data.Traversable (Traversable(traverse)) +import GHC.Generics (Generic, Generic1) + +-- | Lifted sum of functors. +data Sum f g a = InL (f a) | InR (g a) + deriving (Data, Generic, Generic1) + +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 + +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 + +instance (Read1 f, Read1 g) => Read1 (Sum f g) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend` + readsUnaryWith (liftReadsPrec rp rl) "InR" InR + +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 + +instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where + (==) = eq1 +instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where + compare = compare1 +instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where + readsPrec = readsPrec1 +instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where + showsPrec = showsPrec1 + +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) + +instance (Foldable f, Foldable g) => Foldable (Sum f g) where + foldMap f (InL x) = foldMap f x + foldMap f (InR y) = foldMap f y + +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/libraries/base/Data/IORef.hs b/libraries/base/Data/IORef.hs new file mode 100644 index 0000000..c6275f5 --- /dev/null +++ b/libraries/base/Data/IORef.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.IORef +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Mutable references in the IO monad. +-- +----------------------------------------------------------------------------- + +module Data.IORef + ( + -- * IORefs + IORef, -- abstract, instance of: Eq, Typeable + newIORef, + readIORef, + writeIORef, + modifyIORef, + modifyIORef', + atomicModifyIORef, + atomicModifyIORef', + atomicWriteIORef, + mkWeakIORef, + -- ** Memory Model + + -- $memmodel + + ) where + +import GHC.Base +import GHC.STRef +import GHC.IORef hiding (atomicModifyIORef) +import qualified GHC.IORef +import GHC.Weak + +-- |Make a 'Weak' pointer to an 'IORef', using the second argument as a finalizer +-- to run when 'IORef' is garbage-collected +mkWeakIORef :: IORef a -> IO () -> IO (Weak (IORef a)) +mkWeakIORef r@(IORef (STRef r#)) (IO finalizer) = IO $ \s -> + case mkWeak# r# r finalizer s of (# s1, w #) -> (# s1, Weak w #) + +-- |Mutate the contents of an 'IORef'. +-- +-- Be warned that 'modifyIORef' does not apply the function strictly. This +-- means if the program calls 'modifyIORef' many times, but seldomly uses the +-- value, thunks will pile up in memory resulting in a space leak. This is a +-- common mistake made when using an IORef as a counter. For example, the +-- following will likely produce a stack overflow: +-- +-- >ref <- newIORef 0 +-- >replicateM_ 1000000 $ modifyIORef ref (+1) +-- >readIORef ref >>= print +-- +-- To avoid this problem, use 'modifyIORef'' instead. +modifyIORef :: IORef a -> (a -> a) -> IO () +modifyIORef ref f = readIORef ref >>= writeIORef ref . f + +-- |Strict version of 'modifyIORef' +-- +-- @since 4.6.0.0 +modifyIORef' :: IORef a -> (a -> a) -> IO () +modifyIORef' ref f = do + x <- readIORef ref + let x' = f x + x' `seq` writeIORef ref x' + +-- |Atomically modifies the contents of an 'IORef'. +-- +-- This function is useful for using 'IORef' in a safe way in a multithreaded +-- program. If you only have one 'IORef', then using 'atomicModifyIORef' to +-- access and modify it will prevent race conditions. +-- +-- Extending the atomicity to multiple 'IORef's is problematic, so it +-- is recommended that if you need to do anything more complicated +-- then using 'Control.Concurrent.MVar.MVar' instead is a good idea. +-- +-- 'atomicModifyIORef' does not apply the function strictly. This is important +-- to know even if all you are doing is replacing the value. For example, this +-- will leak memory: +-- +-- >ref <- newIORef '1' +-- >forever $ atomicModifyIORef ref (\_ -> ('2', ())) +-- +-- Use 'atomicModifyIORef'' or 'atomicWriteIORef' to avoid this problem. +-- +atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b +atomicModifyIORef = GHC.IORef.atomicModifyIORef + +-- | Strict version of 'atomicModifyIORef'. This forces both the value stored +-- in the 'IORef' as well as the value returned. +-- +-- @since 4.6.0.0 +atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b +atomicModifyIORef' ref f = do + b <- atomicModifyIORef ref $ \a -> + case f a of + v@(a',_) -> a' `seq` v + b `seq` return b + +-- | Variant of 'writeIORef' with the \"barrier to reordering\" property that +-- 'atomicModifyIORef' has. +-- +-- @since 4.6.0.0 +atomicWriteIORef :: IORef a -> a -> IO () +atomicWriteIORef ref a = do + x <- atomicModifyIORef ref (\_ -> (a, ())) + x `seq` return () + +{- $memmodel + + In a concurrent program, 'IORef' operations may appear out-of-order + to another thread, depending on the memory model of the underlying + processor architecture. For example, on x86, loads can move ahead + of stores, so in the following example: + +> 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 + allows 'readIORef' to happen before the earlier 'writeIORef'. + + 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. + + 'atomicModifyIORef' acts as a barrier to reordering. Multiple + 'atomicModifyIORef' operations occur in strict program order. An + 'atomicModifyIORef' is never observed to take place ahead of any + earlier (in program order) 'IORef' operations, or after any later + 'IORef' operations. + +-} + diff --git a/libraries/base/Data/Int.hs b/libraries/base/Data/Int.hs new file mode 100644 index 0000000..8ca8221 --- /dev/null +++ b/libraries/base/Data/Int.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Int +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Signed integer types +-- +----------------------------------------------------------------------------- + +module Data.Int + ( + -- * Signed integer types + Int, + Int8, Int16, Int32, Int64, + + -- * Notes + + -- $notes + ) where + +import GHC.Base ( Int ) +import GHC.Int ( Int8, Int16, Int32, Int64 ) + +{- $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/libraries/base/Data/Ix.hs b/libraries/base/Data/Ix.hs new file mode 100644 index 0000000..0171431 --- /dev/null +++ b/libraries/base/Data/Ix.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- 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 + ) + -- Ix instances: + -- + -- Ix Char + -- Ix Int + -- Ix Integer + -- Ix Bool + -- Ix Ordering + -- Ix () + -- (Ix a, Ix b) => Ix (a, b) + -- ... + + -- * 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.Arr diff --git a/libraries/base/Data/Kind.hs b/libraries/base/Data/Kind.hs new file mode 100644 index 0000000..3483013 --- /dev/null +++ b/libraries/base/Data/Kind.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Trustworthy, ExplicitNamespaces #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Kind +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : not portable +-- +-- Basic kinds +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Kind ( Type, Constraint, type (*), type (★) ) where + +import GHC.Types diff --git a/libraries/base/Data/List.hs b/libraries/base/Data/List.hs new file mode 100644 index 0000000..693c0dd --- /dev/null +++ b/libraries/base/Data/List.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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 + ( + -- * Basic functions + + (++) + , head + , last + , tail + , init + , uncons + , null + , length + + -- * 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 + , repeat + , replicate + , cycle + + -- ** Unfolding + , unfoldr + + -- * Sublists + + -- ** Extracting sublists + , take + , drop + , splitAt + + , takeWhile + , dropWhile + , dropWhileEnd + , span + , break + + , stripPrefix + + , group + + , inits + , tails + + -- ** 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 a 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' ('compare' + -- \`on\` '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 Data.Foldable +import Data.Traversable + +import Data.OldList hiding ( all, and, any, concat, concatMap, elem, find, + foldl, foldl1, foldl', foldr, foldr1, mapAccumL, + mapAccumR, maximum, maximumBy, minimum, minimumBy, + length, notElem, null, or, product, sum ) + +import GHC.Base ( Bool(..), Eq((==)), otherwise ) + +-- | The 'isSubsequenceOf' function takes two lists and returns 'True' if all +-- the elements of the first list occur, in order, in the second. The +-- elements do not have to occur consecutively. +-- +-- @'isSubsequenceOf' x y@ is equivalent to @'elem' x ('subsequences' y)@. +-- +-- @since 4.8.0.0 +-- +-- ==== __Examples__ +-- +-- >>> isSubsequenceOf "GHC" "The Glorious Haskell Compiler" +-- True +-- >>> isSubsequenceOf ['a','d'..'z'] ['a'..'z'] +-- True +-- >>> isSubsequenceOf [1..10] [10,9..0] +-- False +isSubsequenceOf :: (Eq a) => [a] -> [a] -> Bool +isSubsequenceOf [] _ = True +isSubsequenceOf _ [] = False +isSubsequenceOf a@(x:a') (y:b) | x == y = isSubsequenceOf a' b + | otherwise = isSubsequenceOf a b diff --git a/libraries/base/Data/List/NonEmpty.hs b/libraries/base/Data/List/NonEmpty.hs new file mode 100644 index 0000000..2218fc8 --- /dev/null +++ b/libraries/base/Data/List/NonEmpty.hs @@ -0,0 +1,490 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# 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 +---------------------------------------------------------------------------- + +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 + , head -- :: NonEmpty a -> a + , tail -- :: NonEmpty a -> [a] + , last -- :: NonEmpty a -> a + , init -- :: NonEmpty a -> [a] + , (<|), cons -- :: a -> NonEmpty a -> NonEmpty a + , uncons -- :: NonEmpty a -> (a, Maybe (NonEmpty a)) + , unfoldr -- :: (a -> (b, Maybe a)) -> a -> NonEmpty b + , sort -- :: NonEmpty a -> NonEmpty a + , reverse -- :: NonEmpty a -> NonEmpty a + , inits -- :: Foldable f => f a -> NonEmpty a + , tails -- :: Foldable f => f 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 -- :: Int -> NonEmpty a -> [a] + , dropWhile -- :: Int -> NonEmpty a -> [a] + , span -- :: Int -> NonEmpty a -> ([a],[a]) + , break -- :: Int -> 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 -- :: (Foldable f, Ord b) => (a -> b) -> f a -> [NonEmpty a] + , group1 -- :: Eq a => NonEmpty a -> NonEmpty (NonEmpty a) + , groupBy1 -- :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a) + , groupWith1 -- :: (Foldable f, Eq b) => (a -> b) -> f a -> NonEmpty (NonEmpty a) + , groupAllWith1 -- :: (Foldable f, Ord b) => (a -> b) -> f a -> NonEmpty (NonEmpty a) + -- * Sublist predicates + , isPrefixOf -- :: Foldable f => f 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 -- :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b) + -- * Converting to and from a list + , fromList -- :: [a] -> NonEmpty a + , toList -- :: NonEmpty a -> [a] + , nonEmpty -- :: [a] -> Maybe (NonEmpty a) + , xor -- :: NonEmpty a -> 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, (!!)) +import qualified Prelude + +import Control.Applicative (Alternative, many) +import Control.Monad (ap) +import Control.Monad.Fix +import Control.Monad.Zip (MonadZip(..)) +import Data.Data (Data) +import Data.Foldable hiding (length, toList) +import qualified Data.Foldable as Foldable +import Data.Function (on) +import qualified Data.List as List +import Data.Ord (comparing) +import qualified GHC.Exts as Exts (IsList(..)) +import GHC.Generics (Generic, Generic1) + +infixr 5 :|, <| + +-- | Non-empty (and non-strict) list type. +-- +-- @since 4.9.0.0 +data NonEmpty a = a :| [a] + deriving ( Eq, Ord, Show, Read, Data, Generic, Generic1 ) + +instance Exts.IsList (NonEmpty a) where + type Item (NonEmpty a) = a + fromList = fromList + toList = toList + +instance MonadFix NonEmpty where + mfix f = case fix (f . head) of + ~(x :| _) -> x :| mfix (tail . f) + +instance MonadZip NonEmpty where + mzip = zip + mzipWith = zipWith + munzip = unzip + +-- | Number of elements in 'NonEmpty' list. +length :: NonEmpty a -> Int +length (_ :| xs) = 1 + Prelude.length xs + +-- | 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 + +-- | '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 +-- '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 + +instance Functor NonEmpty where + fmap f ~(a :| as) = f a :| fmap f as + b <$ ~(_ :| as) = b :| (b <$ as) + +instance Applicative NonEmpty where + pure a = a :| [] + (<*>) = ap + +instance Monad NonEmpty where + ~(a :| as) >>= f = b :| (bs ++ bs') + where b :| bs = f a + bs' = as >>= toList . f + +instance Traversable NonEmpty where + traverse f ~(a :| as) = (:|) <$> f a <*> traverse f as + +instance Foldable NonEmpty where + foldr f z ~(a :| as) = f a (foldr f z as) + foldl f z ~(a :| as) = foldl f (f z a) as + foldl1 f ~(a :| as) = foldl f a as + foldMap f ~(a :| as) = f a `mappend` foldMap f as + fold ~(m :| ms) = m `mappend` fold ms + +-- | 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 :| as) = List.last (a : as) + +-- | Extract everything except the last element of the stream. +init :: NonEmpty a -> [a] +init ~(a :| as) = List.init (a : as) + +-- | Prepend an element to the stream. +(<|) :: a -> NonEmpty a -> NonEmpty a +a <| ~(b :| bs) = a :| b : bs + +-- | Synonym for '<|'. +cons :: a -> NonEmpty a -> NonEmpty a +cons = (<|) + +-- | Sort a stream. +sort :: Ord a => NonEmpty a -> NonEmpty a +sort = lift List.sort + +-- | Converts a normal list to a 'NonEmpty' stream. +-- +-- Raises an error if given an empty list. +fromList :: [a] -> NonEmpty a +fromList (a:as) = a :| as +fromList [] = errorWithoutStackTrace "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 + +-- | Map a function over a 'NonEmpty' stream. +map :: (a -> b) -> NonEmpty a -> NonEmpty b +map f ~(a :| as) = f a :| fmap f as + +-- | The 'inits' function takes a stream @xs@ and returns all the +-- finite prefixes of @xs@. +inits :: Foldable f => f a -> NonEmpty [a] +inits = fromList . List.inits . Foldable.toList + +-- | The 'tails' function takes a stream @xs@ and returns all the +-- suffixes of @xs@. +tails :: Foldable f => f a -> NonEmpty [a] +tails = fromList . List.tails . Foldable.toList + +-- | @'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 = (:|) <$> 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. For example, in list notation: +-- +-- > 'group' $ 'cycle' "Mississippi" +-- > = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "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 'isPrefix' 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. +(!!) :: NonEmpty a -> Int -> a +(!!) ~(x :| xs) n + | n == 0 = x + | n > 0 = xs List.!! (n - 1) + | otherwise = errorWithoutStackTrace "NonEmpty.!! negative argument" + +-- | The 'zip' function takes two streams and returns a stream of +-- corresponding pairs. +zip :: NonEmpty a -> NonEmpty b -> NonEmpty (a,b) +zip ~(x :| xs) ~(y :| ys) = (x, y) :| List.zip xs ys + +-- | The 'zipWith' function generalizes 'zip'. Rather than tupling +-- the elements, the elements are combined using the function +-- passed as the first argument. +zipWith :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c +zipWith f ~(x :| xs) ~(y :| ys) = f x y :| List.zipWith f xs ys + +-- | The 'unzip' function is the inverse of the 'zip' function. +unzip :: Functor f => f (a,b) -> (f a, f b) +unzip xs = (fst <$> xs, snd <$> xs) + +-- | The 'nub' function removes duplicate elements from a list. In +-- particular, it keeps only the first occurence 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 '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 . Foldable.toList + . fmap Foldable.toList + +-- | 'sortBy' for 'NonEmpty', behaves the same as '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 diff --git a/libraries/base/Data/Maybe.hs b/libraries/base/Data/Maybe.hs new file mode 100644 index 0000000..e81cdf7 --- /dev/null +++ b/libraries/base/Data/Maybe.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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.Base + +-- $setup +-- Allow the use of some Prelude functions in doctests. +-- >>> import Prelude ( (*), odd, show, sum ) + +-- --------------------------------------------------------------------------- +-- Functions over Maybe + +-- | The 'maybe' function takes a default value, a function, and a 'Maybe' +-- value. If the 'Maybe' value is 'Nothing', the function returns the +-- default value. Otherwise, it applies the function to the value inside +-- the 'Just' and returns the result. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> maybe False odd (Just 3) +-- True +-- +-- >>> maybe False odd Nothing +-- False +-- +-- Read an integer from a string using 'readMaybe'. If we succeed, +-- return twice the integer; that is, apply @(*2)@ to it. If instead +-- we fail to parse an integer, return @0@ by default: +-- +-- >>> import Text.Read ( readMaybe ) +-- >>> maybe 0 (*2) (readMaybe "5") +-- 10 +-- >>> maybe 0 (*2) (readMaybe "") +-- 0 +-- +-- Apply 'show' to a @Maybe Int@. If we have @Just n@, we want to show +-- the underlying 'Int' @n@. But if we have 'Nothing', we return the +-- empty string instead of (for example) \"Nothing\": +-- +-- >>> maybe "" show (Just 5) +-- "5" +-- >>> maybe "" show Nothing +-- "" +-- +maybe :: b -> (a -> b) -> Maybe a -> b +maybe n _ Nothing = n +maybe _ f (Just x) = f x + +-- | The 'isJust' function returns 'True' iff its argument is of the +-- form @Just _@. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> isJust (Just 3) +-- True +-- +-- >>> isJust (Just ()) +-- True +-- +-- >>> isJust Nothing +-- False +-- +-- Only the outer constructor is taken into consideration: +-- +-- >>> isJust (Just Nothing) +-- True +-- +isJust :: Maybe a -> Bool +isJust Nothing = False +isJust _ = True + +-- | The 'isNothing' function returns 'True' iff its argument is 'Nothing'. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> isNothing (Just 3) +-- False +-- +-- >>> isNothing (Just ()) +-- False +-- +-- >>> isNothing Nothing +-- True +-- +-- Only the outer constructor is taken into consideration: +-- +-- >>> isNothing (Just Nothing) +-- False +-- +isNothing :: Maybe a -> Bool +isNothing Nothing = True +isNothing _ = False + +-- | The 'fromJust' function extracts the element out of a 'Just' and +-- throws an error if its argument is 'Nothing'. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> fromJust (Just 1) +-- 1 +-- +-- >>> 2 * (fromJust (Just 10)) +-- 20 +-- +-- >>> 2 * (fromJust Nothing) +-- *** Exception: Maybe.fromJust: Nothing +-- +fromJust :: Maybe a -> a +fromJust Nothing = errorWithoutStackTrace "Maybe.fromJust: Nothing" -- yuck +fromJust (Just x) = x + +-- | The 'fromMaybe' function takes a default value and and 'Maybe' +-- value. If the 'Maybe' is 'Nothing', it returns the default values; +-- otherwise, it returns the value contained in the 'Maybe'. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> fromMaybe "" (Just "Hello, World!") +-- "Hello, World!" +-- +-- >>> fromMaybe "" Nothing +-- "" +-- +-- Read an integer from a string using 'readMaybe'. If we fail to +-- parse an integer, we want to return @0@ by default: +-- +-- >>> import Text.Read ( readMaybe ) +-- >>> fromMaybe 0 (readMaybe "5") +-- 5 +-- >>> fromMaybe 0 (readMaybe "") +-- 0 +-- +fromMaybe :: a -> Maybe a -> a +fromMaybe d x = case x of {Nothing -> d;Just v -> v} + +-- | The 'maybeToList' function returns an empty list when given +-- 'Nothing' or a singleton list when not given 'Nothing'. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> maybeToList (Just 7) +-- [7] +-- +-- >>> maybeToList Nothing +-- [] +-- +-- One can use 'maybeToList' to avoid pattern matching when combined +-- with a function that (safely) works on lists: +-- +-- >>> import Text.Read ( readMaybe ) +-- >>> sum $ maybeToList (readMaybe "3") +-- 3 +-- >>> sum $ maybeToList (readMaybe "") +-- 0 +-- +maybeToList :: Maybe a -> [a] +maybeToList Nothing = [] +maybeToList (Just x) = [x] + +-- | The 'listToMaybe' function returns 'Nothing' on an empty list +-- or @'Just' a@ where @a@ is the first element of the list. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> listToMaybe [] +-- Nothing +-- +-- >>> listToMaybe [9] +-- Just 9 +-- +-- >>> listToMaybe [1,2,3] +-- Just 1 +-- +-- Composing 'maybeToList' with 'listToMaybe' should be the identity +-- on singleton/empty lists: +-- +-- >>> maybeToList $ listToMaybe [5] +-- [5] +-- >>> maybeToList $ listToMaybe [] +-- [] +-- +-- But not on lists with more than one element: +-- +-- >>> maybeToList $ listToMaybe [1,2,3] +-- [1] +-- +listToMaybe :: [a] -> Maybe a +listToMaybe [] = Nothing +listToMaybe (a:_) = Just a + +-- | The 'catMaybes' function takes a list of 'Maybe's and returns +-- a list of all the 'Just' values. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> catMaybes [Just 1, Nothing, Just 3] +-- [1,3] +-- +-- When constructing a list of 'Maybe' values, 'catMaybes' can be used +-- to return all of the \"success\" results (if the list is the result +-- of a 'map', then 'mapMaybe' would be more appropriate): +-- +-- >>> import Text.Read ( readMaybe ) +-- >>> [readMaybe x :: Maybe Int | x <- ["1", "Foo", "3"] ] +-- [Just 1,Nothing,Just 3] +-- >>> catMaybes $ [readMaybe x :: Maybe Int | x <- ["1", "Foo", "3"] ] +-- [1,3] +-- +catMaybes :: [Maybe a] -> [a] +catMaybes ls = [x | Just x <- ls] + +-- | The 'mapMaybe' function is a version of 'map' which can throw +-- out elements. In particular, the functional argument returns +-- something of type @'Maybe' b@. If this is 'Nothing', no element +-- is added on to the result list. If it is @'Just' b@, then @b@ is +-- included in the result list. +-- +-- ==== __Examples__ +-- +-- Using @'mapMaybe' f x@ is a shortcut for @'catMaybes' $ 'map' f x@ +-- in most cases: +-- +-- >>> import Text.Read ( readMaybe ) +-- >>> let readMaybeInt = readMaybe :: String -> Maybe Int +-- >>> mapMaybe readMaybeInt ["1", "Foo", "3"] +-- [1,3] +-- >>> catMaybes $ map readMaybeInt ["1", "Foo", "3"] +-- [1,3] +-- +-- If we map the 'Just' constructor, the entire list should be returned: +-- +-- >>> mapMaybe Just [1,2,3] +-- [1,2,3] +-- +mapMaybe :: (a -> Maybe b) -> [a] -> [b] +mapMaybe _ [] = [] +mapMaybe f (x:xs) = + let rs = mapMaybe f xs in + case f x of + Nothing -> rs + Just r -> r:rs +{-# NOINLINE [1] mapMaybe #-} + +{-# RULES +"mapMaybe" [~1] forall f xs. mapMaybe f xs + = build (\c n -> foldr (mapMaybeFB c f) n xs) +"mapMaybeList" [1] forall f. foldr (mapMaybeFB (:) f) [] = mapMaybe f + #-} + +{-# NOINLINE [0] mapMaybeFB #-} +mapMaybeFB :: (b -> r -> r) -> (a -> Maybe b) -> a -> r -> r +mapMaybeFB cons f x next = case f x of + Nothing -> next + Just r -> cons r next diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs new file mode 100644 index 0000000..0a33c27 --- /dev/null +++ b/libraries/base/Data/Monoid.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- Portability : portable +-- +-- A class for monoids (types with an associative binary operation that +-- has an identity) with various general-purpose instances. +-- +----------------------------------------------------------------------------- + +module Data.Monoid ( + -- * 'Monoid' typeclass + Monoid(..), + (<>), + Dual(..), + Endo(..), + -- * 'Bool' wrappers + All(..), + Any(..), + -- * 'Num' wrappers + Sum(..), + Product(..), + -- * 'Maybe' wrappers + -- $MaybeExamples + First(..), + Last(..), + -- * 'Alternative' wrapper + Alt (..) + ) where + +-- Push down the module in the dependency hierarchy. +import GHC.Base hiding (Any) +import GHC.Enum +import GHC.Num +import GHC.Read +import GHC.Show +import GHC.Generics + +{- +-- just for testing +import Data.Maybe +import Test.QuickCheck +-- -} + +infixr 6 <> + +-- | An infix synonym for 'mappend'. +-- +-- @since 4.5.0.0 +(<>) :: Monoid m => m -> m -> m +(<>) = mappend +{-# INLINE (<>) #-} + +-- Monoid instances. + +-- | The dual of a 'Monoid', obtained by swapping the arguments of 'mappend'. +newtype Dual a = Dual { getDual :: a } + deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1) + +instance Monoid a => Monoid (Dual a) where + mempty = Dual mempty + Dual x `mappend` Dual y = Dual (y `mappend` x) + +instance Functor Dual where + fmap = coerce + +instance Applicative Dual where + pure = Dual + (<*>) = coerce + +instance Monad Dual where + m >>= k = k (getDual m) + +-- | The monoid of endomorphisms under composition. +newtype Endo a = Endo { appEndo :: a -> a } + deriving (Generic) + +instance Monoid (Endo a) where + mempty = Endo id + Endo f `mappend` Endo g = Endo (f . g) + +-- | Boolean monoid under conjunction ('&&'). +newtype All = All { getAll :: Bool } + deriving (Eq, Ord, Read, Show, Bounded, Generic) + +instance Monoid All where + mempty = All True + All x `mappend` All y = All (x && y) + +-- | Boolean monoid under disjunction ('||'). +newtype Any = Any { getAny :: Bool } + deriving (Eq, Ord, Read, Show, Bounded, Generic) + +instance Monoid Any where + mempty = Any False + Any x `mappend` Any y = Any (x || y) + +-- | Monoid under addition. +newtype Sum a = Sum { getSum :: a } + deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num) + +instance Num a => Monoid (Sum a) where + mempty = Sum 0 + mappend = coerce ((+) :: a -> a -> a) +-- Sum x `mappend` Sum y = Sum (x + y) + +instance Functor Sum where + fmap = coerce + +instance Applicative Sum where + pure = Sum + (<*>) = coerce + +instance Monad Sum where + m >>= k = k (getSum m) + +-- | Monoid under multiplication. +newtype Product a = Product { getProduct :: a } + deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num) + +instance Num a => Monoid (Product a) where + mempty = Product 1 + mappend = coerce ((*) :: a -> a -> a) +-- Product x `mappend` Product y = Product (x * y) + +instance Functor Product where + fmap = coerce + +instance Applicative Product where + pure = Product + (<*>) = coerce + +instance Monad Product where + m >>= k = k (getProduct m) + +-- $MaybeExamples +-- To implement @find@ or @findLast@ on any 'Foldable': +-- +-- @ +-- findLast :: Foldable t => (a -> Bool) -> t a -> Maybe a +-- findLast pred = getLast . foldMap (\x -> if pred x +-- then Last (Just x) +-- else Last Nothing) +-- @ +-- +-- Much of Data.Map's interface can be implemented with +-- Data.Map.alter. Some of the rest can be implemented with a new +-- @alterA@ function and either 'First' or 'Last': +-- +-- > alterA :: (Applicative f, Ord k) => +-- > (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a) +-- > +-- > instance Monoid a => Applicative ((,) a) -- from Control.Applicative +-- +-- @ +-- insertLookupWithKey :: Ord k => (k -> v -> v -> v) -> k -> v +-- -> Map k v -> (Maybe v, Map k v) +-- insertLookupWithKey combine key value = +-- Arrow.first getFirst . alterA doChange key +-- where +-- doChange Nothing = (First Nothing, Just value) +-- doChange (Just oldValue) = +-- (First (Just oldValue), +-- Just (combine key value oldValue)) +-- @ + + +-- | Maybe monoid returning the leftmost non-Nothing value. +-- +-- @'First' a@ is isomorphic to @'Alt' 'Maybe' a@, but precedes it +-- historically. +newtype First a = First { getFirst :: Maybe a } + deriving (Eq, Ord, Read, Show, Generic, Generic1, + Functor, Applicative, Monad) + +instance Monoid (First a) where + mempty = First Nothing + First Nothing `mappend` r = r + l `mappend` _ = l + +-- | Maybe monoid returning the rightmost non-Nothing value. +-- +-- @'Last' a@ is isomorphic to @'Dual' ('First' a)@, and thus to +-- @'Dual' ('Alt' 'Maybe' a)@ +newtype Last a = Last { getLast :: Maybe a } + deriving (Eq, Ord, Read, Show, Generic, Generic1, + Functor, Applicative, Monad) + +instance Monoid (Last a) where + mempty = Last Nothing + l `mappend` Last Nothing = l + _ `mappend` r = r + +-- | Monoid under '<|>'. +-- +-- @since 4.8.0.0 +newtype Alt f a = Alt {getAlt :: f a} + deriving (Generic, Generic1, Read, Show, Eq, Ord, Num, Enum, + Monad, MonadPlus, Applicative, Alternative, Functor) + +instance Alternative f => Monoid (Alt f a) where + mempty = Alt empty + mappend = coerce ((<|>) :: f a -> f a -> f a) + +{- +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} +instance Arbitrary a => Arbitrary (Maybe a) where + arbitrary = oneof [return Nothing, Just `fmap` arbitrary] + +prop_mconcatMaybe :: [Maybe [Int]] -> Bool +prop_mconcatMaybe x = + fromMaybe [] (mconcat x) == mconcat (catMaybes x) + +prop_mconcatFirst :: [Maybe Int] -> Bool +prop_mconcatFirst x = + getFirst (mconcat (map First x)) == listToMaybe (catMaybes x) +prop_mconcatLast :: [Maybe Int] -> Bool +prop_mconcatLast x = + getLast (mconcat (map Last x)) == listLastToMaybe (catMaybes x) + where listLastToMaybe [] = Nothing + listLastToMaybe lst = Just (last lst) +-- -} diff --git a/libraries/base/Data/OldList.hs b/libraries/base/Data/OldList.hs new file mode 100644 index 0000000..1846182 --- /dev/null +++ b/libraries/base/Data/OldList.hs @@ -0,0 +1,1193 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables, MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- 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.OldList + ( + -- * Basic functions + + (++) + , head + , last + , tail + , init + , uncons + , null + , length + + -- * 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 + , repeat + , replicate + , cycle + + -- ** Unfolding + , unfoldr + + -- * Sublists + + -- ** Extracting sublists + , take + , drop + , splitAt + + , takeWhile + , dropWhile + , dropWhileEnd + , span + , break + + , stripPrefix + + , group + + , inits + , tails + + -- ** Predicates + , isPrefixOf + , isSuffixOf + , isInfixOf + + -- * Searching lists + + -- ** Searching by equality + , elem + , notElem + , lookup + + -- ** Searching with a predicate + , find + , filter + , partition + + -- * Indexing lists + -- | These functions treat a list @xs@ as a 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' ('compare' + -- \`on\` '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 Data.Maybe +import Data.Bits ( (.&.) ) +import Data.Char ( isSpace ) +import Data.Ord ( comparing ) +import Data.Tuple ( fst, snd ) + +import GHC.Num +import GHC.Real +import GHC.List +import GHC.Base + +infix 5 \\ -- comment to fool cpp: https://www.haskell.org/ghc/docs/latest/html/users_guide/options-phases.html#cpp-string-gaps + +-- ----------------------------------------------------------------------------- +-- List functions + +-- | The 'dropWhileEnd' function drops the largest suffix of a list +-- in which the given predicate holds for all elements. For example: +-- +-- > dropWhileEnd isSpace "foo\n" == "foo" +-- > dropWhileEnd isSpace "foo bar" == "foo bar" +-- > dropWhileEnd isSpace ("foo\n" ++ undefined) == "foo" ++ undefined +-- +-- @since 4.5.0.0 +dropWhileEnd :: (a -> Bool) -> [a] -> [a] +dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] + +-- | The 'stripPrefix' function drops the given prefix from a list. +-- It returns 'Nothing' if the list did not start with the prefix +-- given, or 'Just' the list after the prefix, if it does. +-- +-- > stripPrefix "foo" "foobar" == Just "bar" +-- > stripPrefix "foo" "foo" == Just "" +-- > stripPrefix "foo" "barfoo" == Nothing +-- > stripPrefix "foo" "barfoobaz" == Nothing +stripPrefix :: Eq a => [a] -> [a] -> Maybe [a] +stripPrefix [] ys = Just ys +stripPrefix (x:xs) (y:ys) + | x == y = stripPrefix xs ys +stripPrefix _ _ = Nothing + +-- | The 'elemIndex' function returns the index of the first element +-- in the given list which is equal (by '==') to the query element, +-- or 'Nothing' if there is no such element. +elemIndex :: Eq a => a -> [a] -> Maybe Int +elemIndex x = findIndex (x==) + +-- | The 'elemIndices' function extends 'elemIndex', by returning the +-- indices of all elements equal to the query element, in ascending order. +elemIndices :: Eq a => a -> [a] -> [Int] +elemIndices x = findIndices (x==) + +-- | The 'find' function takes a predicate and a list and returns the +-- first element in the list matching the predicate, or 'Nothing' if +-- there is no such element. +find :: (a -> Bool) -> [a] -> Maybe a +find p = listToMaybe . filter p + +-- | The 'findIndex' function takes a predicate and a list and returns +-- the index of the first element in the list satisfying the predicate, +-- or 'Nothing' if there is no such element. +findIndex :: (a -> Bool) -> [a] -> Maybe Int +findIndex p = listToMaybe . findIndices p + +-- | The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +findIndices :: (a -> Bool) -> [a] -> [Int] +#ifdef USE_REPORT_PRELUDE +findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] +#else +-- Efficient definition, adapted from Data.Sequence +{-# INLINE findIndices #-} +findIndices p ls = build $ \c n -> + let go x r k | p x = I# k `c` r (k +# 1#) + | otherwise = r (k +# 1#) + in foldr go (\_ -> n) ls 0# +#endif /* USE_REPORT_PRELUDE */ + +-- | The 'isPrefixOf' function takes two lists and returns 'True' +-- iff the first list is a prefix of the second. +isPrefixOf :: (Eq a) => [a] -> [a] -> Bool +isPrefixOf [] _ = True +isPrefixOf _ [] = False +isPrefixOf (x:xs) (y:ys)= x == y && isPrefixOf xs ys + +-- | The 'isSuffixOf' function takes two lists and returns 'True' iff +-- the first list is a suffix of the second. The second list must be +-- finite. +isSuffixOf :: (Eq a) => [a] -> [a] -> Bool +ns `isSuffixOf` hs = maybe False id $ do + delta <- dropLengthMaybe ns hs + return $ ns == dropLength delta hs + -- Since dropLengthMaybe ns hs succeeded, we know that (if hs is finite) + -- length ns + length delta = length hs + -- so dropping the length of delta from hs will yield a suffix exactly + -- the length of ns. + +-- A version of drop that drops the length of the first argument from the +-- second argument. If xs is longer than ys, xs will not be traversed in its +-- entirety. dropLength is also generally faster than (drop . length) +-- Both this and dropLengthMaybe could be written as folds over their first +-- arguments, but this reduces clarity with no benefit to isSuffixOf. +dropLength :: [a] -> [b] -> [b] +dropLength [] y = y +dropLength _ [] = [] +dropLength (_:x') (_:y') = dropLength x' y' + +-- A version of dropLength that returns Nothing if the second list runs out of +-- elements before the first. +dropLengthMaybe :: [a] -> [b] -> Maybe [b] +dropLengthMaybe [] y = Just y +dropLengthMaybe _ [] = Nothing +dropLengthMaybe (_:x') (_:y') = dropLengthMaybe x' y' + +-- | The 'isInfixOf' function takes two lists and returns 'True' +-- iff the first list is contained, wholly and intact, +-- anywhere within the second. +-- +-- Example: +-- +-- >isInfixOf "Haskell" "I really like Haskell." == True +-- >isInfixOf "Ial" "I really like Haskell." == False +isInfixOf :: (Eq a) => [a] -> [a] -> Bool +isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) + +-- | /O(n^2)/. 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 equality test. +nub :: (Eq a) => [a] -> [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) -> [a] -> [a] +#ifdef USE_REPORT_PRELUDE +nubBy eq [] = [] +nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs) +#else +-- stolen from HBC +nubBy eq l = nubBy' l [] + where + nubBy' [] _ = [] + nubBy' (y:ys) xs + | elem_by eq y xs = nubBy' ys xs + | otherwise = y : nubBy' ys (y:xs) + +-- Not exported: +-- Note that we keep the call to `eq` with arguments in the +-- same order as in the reference (prelude) implementation, +-- and that this order is different from how `elem` calls (==). +-- See #2528, #3280 and #7913. +-- 'xs' is the list of things we've seen so far, +-- 'y' is the potential new element +elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool +elem_by _ _ [] = False +elem_by eq y (x:xs) = x `eq` y || elem_by eq y xs +#endif + + +-- | 'delete' @x@ removes the first occurrence of @x@ from its list argument. +-- For example, +-- +-- > delete 'a' "banana" == "bnana" +-- +-- It is a special case of 'deleteBy', which allows the programmer to +-- supply their own equality test. + +delete :: (Eq a) => a -> [a] -> [a] +delete = deleteBy (==) + +-- | The 'deleteBy' function behaves like 'delete', but takes a +-- user-supplied equality predicate. +deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] +deleteBy _ _ [] = [] +deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys + +-- | The '\\' function is list difference (non-associative). +-- In the result of @xs@ '\\' @ys@, the first occurrence of each element of +-- @ys@ in turn (if any) has been removed from @xs@. Thus +-- +-- > (xs ++ ys) \\ xs == ys. +-- +-- It is a special case of 'deleteFirstsBy', which allows the programmer +-- to supply their own equality test. + +(\\) :: (Eq a) => [a] -> [a] -> [a] +(\\) = foldl (flip delete) + +-- | The 'union' function returns the list union of the two lists. +-- For example, +-- +-- > "dog" `union` "cow" == "dogcw" +-- +-- Duplicates, and elements of the first list, are removed from the +-- the second list, but if the first list contains duplicates, so will +-- the result. +-- It is a special case of 'unionBy', which allows the programmer to supply +-- their own equality test. + +union :: (Eq a) => [a] -> [a] -> [a] +union = unionBy (==) + +-- | The 'unionBy' function is the non-overloaded version of 'union'. +unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs + +-- | The 'intersect' function takes the list intersection of two lists. +-- For example, +-- +-- > [1,2,3,4] `intersect` [2,4,6,8] == [2,4] +-- +-- If the first list contains duplicates, so will the result. +-- +-- > [1,2,2,3,4] `intersect` [6,4,4,2] == [2,2,4] +-- +-- It is a special case of 'intersectBy', which allows the programmer to +-- supply their own equality test. If the element is found in both the first +-- and the second list, the element from the first list will be used. + +intersect :: (Eq a) => [a] -> [a] -> [a] +intersect = intersectBy (==) + +-- | The 'intersectBy' function is the non-overloaded version of 'intersect'. +intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +intersectBy _ [] _ = [] +intersectBy _ _ [] = [] +intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] + +-- | The 'intersperse' function takes an element and a list and +-- \`intersperses\' that element between the elements of the list. +-- For example, +-- +-- > intersperse ',' "abcde" == "a,b,c,d,e" + +intersperse :: a -> [a] -> [a] +intersperse _ [] = [] +intersperse sep (x:xs) = x : prependToAll sep xs + + +-- Not exported: +-- We want to make every element in the 'intersperse'd list available +-- as soon as possible to avoid space leaks. Experiments suggested that +-- a separate top-level helper is more efficient than a local worker. +prependToAll :: a -> [a] -> [a] +prependToAll _ [] = [] +prependToAll sep (x:xs) = sep : x : prependToAll sep xs + +-- | 'intercalate' @xs xss@ is equivalent to @('concat' ('intersperse' xs xss))@. +-- It inserts the list @xs@ in between the lists in @xss@ and concatenates the +-- result. +intercalate :: [a] -> [[a]] -> [a] +intercalate xs xss = concat (intersperse xs xss) + +-- | The 'transpose' function transposes the rows and columns of its argument. +-- For example, +-- +-- > transpose [[1,2,3],[4,5,6]] == [[1,4],[2,5],[3,6]] +-- +-- If some of the rows are shorter than the following rows, their elements are skipped: +-- +-- > transpose [[10,11],[20],[],[30,31,32]] == [[10,20,30],[11,31],[32]] + +transpose :: [[a]] -> [[a]] +transpose [] = [] +transpose ([] : xss) = transpose xss +transpose ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (xs : [ t | (_:t) <- xss]) + + +-- | The 'partition' function takes a predicate a list and returns +-- the pair of lists of elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p xs == (filter p xs, filter (not . p) xs) + +partition :: (a -> Bool) -> [a] -> ([a],[a]) +{-# INLINE partition #-} +partition p xs = foldr (select p) ([],[]) xs + +select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a]) +select p x ~(ts,fs) | p x = (x:ts,fs) + | otherwise = (ts, x:fs) + +-- | The 'mapAccumL' function behaves like a combination of 'map' and +-- 'foldl'; it applies a function to each element of a list, passing +-- an accumulating parameter from left to right, and returning a final +-- value of this accumulator together with the new list. +mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list +{-# NOINLINE [1] mapAccumL #-} +mapAccumL _ s [] = (s, []) +mapAccumL f s (x:xs) = (s'',y:ys) + where (s', y ) = f s x + (s'',ys) = mapAccumL f s' xs + +{-# RULES +"mapAccumL" [~1] forall f s xs . mapAccumL f s xs = foldr (mapAccumLF f) pairWithNil xs s +"mapAccumLList" [1] forall f s xs . foldr (mapAccumLF f) pairWithNil xs s = mapAccumL f s xs + #-} + +pairWithNil :: acc -> (acc, [y]) +{-# INLINE [0] pairWithNil #-} +pairWithNil x = (x, []) + +mapAccumLF :: (acc -> x -> (acc, y)) -> x -> (acc -> (acc, [y])) -> acc -> (acc, [y]) +{-# INLINE [0] mapAccumLF #-} +mapAccumLF f = \x r -> oneShot (\s -> + let (s', y) = f s x + (s'', ys) = r s' + in (s'', y:ys)) + -- See Note [Left folds via right fold] + + +-- | The 'mapAccumR' function behaves like a combination of 'map' and +-- 'foldr'; it applies a function to each element of a list, passing +-- an accumulating parameter from right to left, and returning a final +-- value of this accumulator together with the new list. +mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list +mapAccumR _ s [] = (s, []) +mapAccumR f s (x:xs) = (s'', y:ys) + where (s'',y ) = f s' x + (s', ys) = mapAccumR f s xs + +-- | The 'insert' function takes an element and a list and inserts the +-- element into the list at the first position where it is less +-- than or equal to the next element. In particular, if the list +-- is sorted before the call, the result will also be sorted. +-- It is a special case of 'insertBy', which allows the programmer to +-- supply their own comparison function. +insert :: Ord a => a -> [a] -> [a] +insert e ls = insertBy (compare) e ls + +-- | The non-overloaded version of 'insert'. +insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a] +insertBy _ x [] = [x] +insertBy cmp x ys@(y:ys') + = case cmp x y of + GT -> y : insertBy cmp x ys' + _ -> x : ys + +-- | The 'maximumBy' function takes a comparison function and a list +-- and returns the greatest element of the list by the comparison function. +-- The list must be finite and non-empty. +maximumBy :: (a -> a -> Ordering) -> [a] -> a +maximumBy _ [] = errorWithoutStackTrace "List.maximumBy: empty list" +maximumBy cmp xs = foldl1 maxBy xs + where + maxBy x y = case cmp x y of + GT -> x + _ -> y + +-- | The 'minimumBy' function takes a comparison function and a list +-- and returns the least element of the list by the comparison function. +-- The list must be finite and non-empty. +minimumBy :: (a -> a -> Ordering) -> [a] -> a +minimumBy _ [] = errorWithoutStackTrace "List.minimumBy: empty list" +minimumBy cmp xs = foldl1 minBy xs + where + minBy x y = case cmp x y of + GT -> y + _ -> x + +-- | The 'genericLength' function is an overloaded version of 'length'. In +-- particular, instead of returning an 'Int', it returns any type which is +-- an instance of 'Num'. It is, however, less efficient than 'length'. +genericLength :: (Num i) => [a] -> i +{-# NOINLINE [1] genericLength #-} +genericLength [] = 0 +genericLength (_:l) = 1 + genericLength l + +{-# RULES + "genericLengthInt" genericLength = (strictGenericLength :: [a] -> Int); + "genericLengthInteger" genericLength = (strictGenericLength :: [a] -> Integer); + #-} + +strictGenericLength :: (Num i) => [b] -> i +strictGenericLength l = gl l 0 + where + gl [] a = a + gl (_:xs) a = let a' = a + 1 in a' `seq` gl xs a' + +-- | The 'genericTake' function is an overloaded version of 'take', which +-- accepts any 'Integral' value as the number of elements to take. +genericTake :: (Integral i) => i -> [a] -> [a] +genericTake n _ | n <= 0 = [] +genericTake _ [] = [] +genericTake n (x:xs) = x : genericTake (n-1) xs + +-- | The 'genericDrop' function is an overloaded version of 'drop', which +-- accepts any 'Integral' value as the number of elements to drop. +genericDrop :: (Integral i) => i -> [a] -> [a] +genericDrop n xs | n <= 0 = xs +genericDrop _ [] = [] +genericDrop n (_:xs) = genericDrop (n-1) xs + + +-- | The 'genericSplitAt' function is an overloaded version of 'splitAt', which +-- accepts any 'Integral' value as the position at which to split. +genericSplitAt :: (Integral i) => i -> [a] -> ([a], [a]) +genericSplitAt n xs | n <= 0 = ([],xs) +genericSplitAt _ [] = ([],[]) +genericSplitAt n (x:xs) = (x:xs',xs'') where + (xs',xs'') = genericSplitAt (n-1) xs + +-- | The 'genericIndex' function is an overloaded version of '!!', which +-- accepts any 'Integral' value as the index. +genericIndex :: (Integral i) => [a] -> i -> a +genericIndex (x:_) 0 = x +genericIndex (_:xs) n + | n > 0 = genericIndex xs (n-1) + | otherwise = errorWithoutStackTrace "List.genericIndex: negative argument." +genericIndex _ _ = errorWithoutStackTrace "List.genericIndex: index too large." + +-- | The 'genericReplicate' function is an overloaded version of 'replicate', +-- which accepts any 'Integral' value as the number of repetitions to make. +genericReplicate :: (Integral i) => i -> a -> [a] +genericReplicate n x = genericTake n (repeat x) + +-- | The 'zip4' function takes four lists and returns a list of +-- quadruples, analogous to 'zip'. +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] +zip4 = zipWith4 (,,,) + +-- | The 'zip5' function takes five lists and returns a list of +-- five-tuples, analogous to 'zip'. +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] +zip5 = zipWith5 (,,,,) + +-- | The 'zip6' function takes six lists and returns a list of six-tuples, +-- analogous to 'zip'. +zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> + [(a,b,c,d,e,f)] +zip6 = zipWith6 (,,,,,) + +-- | The 'zip7' function takes seven lists and returns a list of +-- seven-tuples, analogous to 'zip'. +zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> + [g] -> [(a,b,c,d,e,f,g)] +zip7 = zipWith7 (,,,,,,) + +-- | The 'zipWith4' function takes a function which combines four +-- elements, as well as four lists and returns a list of their point-wise +-- combination, analogous to 'zipWith'. +zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4 z as bs cs ds +zipWith4 _ _ _ _ _ = [] + +-- | The 'zipWith5' function takes a function which combines five +-- elements, as well as five lists and returns a list of their point-wise +-- combination, analogous to 'zipWith'. +zipWith5 :: (a->b->c->d->e->f) -> + [a]->[b]->[c]->[d]->[e]->[f] +zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) + = z a b c d e : zipWith5 z as bs cs ds es +zipWith5 _ _ _ _ _ _ = [] + +-- | The 'zipWith6' function takes a function which combines six +-- elements, as well as six lists and returns a list of their point-wise +-- combination, analogous to 'zipWith'. +zipWith6 :: (a->b->c->d->e->f->g) -> + [a]->[b]->[c]->[d]->[e]->[f]->[g] +zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) + = z a b c d e f : zipWith6 z as bs cs ds es fs +zipWith6 _ _ _ _ _ _ _ = [] + +-- | The 'zipWith7' function takes a function which combines seven +-- elements, as well as seven lists and returns a list of their point-wise +-- combination, analogous to 'zipWith'. +zipWith7 :: (a->b->c->d->e->f->g->h) -> + [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h] +zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) + = z a b c d e f g : zipWith7 z as bs cs ds es fs gs +zipWith7 _ _ _ _ _ _ _ _ = [] + +-- | The 'unzip4' function takes a list of quadruples and returns four +-- lists, analogous to 'unzip'. +unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d]) +unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) -> + (a:as,b:bs,c:cs,d:ds)) + ([],[],[],[]) + +-- | The 'unzip5' function takes a list of five-tuples and returns five +-- lists, analogous to 'unzip'. +unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e]) +unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) -> + (a:as,b:bs,c:cs,d:ds,e:es)) + ([],[],[],[],[]) + +-- | The 'unzip6' function takes a list of six-tuples and returns six +-- lists, analogous to 'unzip'. +unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f]) +unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs)) + ([],[],[],[],[],[]) + +-- | The 'unzip7' function takes a list of seven-tuples and returns +-- seven lists, analogous to 'unzip'. +unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g]) +unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) + ([],[],[],[],[],[],[]) + + +-- | The 'deleteFirstsBy' function takes a predicate and two lists and +-- returns the first list with the first occurrence of each element of +-- the second list removed. +deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +deleteFirstsBy eq = foldl (flip (deleteBy eq)) + +-- | The 'group' function takes a list and returns a list of lists such +-- that the concatenation of the result is equal to the argument. Moreover, +-- each sublist in the result contains only equal elements. For example, +-- +-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] +-- +-- It is a special case of 'groupBy', which allows the programmer to supply +-- their own equality test. +group :: Eq a => [a] -> [[a]] +group = groupBy (==) + +-- | The 'groupBy' function is the non-overloaded version of 'group'. +groupBy :: (a -> a -> Bool) -> [a] -> [[a]] +groupBy _ [] = [] +groupBy eq (x:xs) = (x:ys) : groupBy eq zs + where (ys,zs) = span (eq x) xs + +-- | The 'inits' function returns all initial segments of the argument, +-- shortest first. For example, +-- +-- > inits "abc" == ["","a","ab","abc"] +-- +-- Note that 'inits' has the following strictness property: +-- @inits (xs ++ _|_) = inits xs ++ _|_@ +-- +-- In particular, +-- @inits _|_ = [] : _|_@ +inits :: [a] -> [[a]] +inits = map toListSB . scanl' snocSB emptySB +{-# NOINLINE inits #-} + +-- We do not allow inits to inline, because it plays havoc with Call Arity +-- if it fuses with a consumer, and it would generally lead to serious +-- loss of sharing if allowed to fuse with a producer. + +-- | The 'tails' function returns all final segments of the argument, +-- longest first. For example, +-- +-- > tails "abc" == ["abc", "bc", "c",""] +-- +-- Note that 'tails' has the following strictness property: +-- @tails _|_ = _|_ : _|_@ +tails :: [a] -> [[a]] +{-# INLINABLE tails #-} +tails lst = build (\c n -> + let tailsGo xs = xs `c` case xs of + [] -> n + _ : xs' -> tailsGo xs' + in tailsGo lst) + +-- | The 'subsequences' function returns the list of all subsequences of the argument. +-- +-- > subsequences "abc" == ["","a","b","ab","c","ac","bc","abc"] +subsequences :: [a] -> [[a]] +subsequences xs = [] : nonEmptySubsequences xs + +-- | The 'nonEmptySubsequences' function returns the list of all subsequences of the argument, +-- except for the empty list. +-- +-- > nonEmptySubsequences "abc" == ["a","b","ab","c","ac","bc","abc"] +nonEmptySubsequences :: [a] -> [[a]] +nonEmptySubsequences [] = [] +nonEmptySubsequences (x:xs) = [x] : foldr f [] (nonEmptySubsequences xs) + where f ys r = ys : (x : ys) : r + + +-- | The 'permutations' function returns the list of all permutations of the argument. +-- +-- > permutations "abc" == ["abc","bac","cba","bca","cab","acb"] +permutations :: [a] -> [[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) + + +------------------------------------------------------------------------------ +-- Quick Sort algorithm taken from HBC's QSort library. + +-- | The 'sort' function implements a stable sorting algorithm. +-- It is a special case of 'sortBy', which allows the programmer to supply +-- their own comparison function. +sort :: (Ord a) => [a] -> [a] + +-- | The 'sortBy' function is the non-overloaded version of 'sort'. +sortBy :: (a -> a -> Ordering) -> [a] -> [a] + +#ifdef USE_REPORT_PRELUDE +sort = sortBy compare +sortBy cmp = foldr (insertBy cmp) [] +#else + +{- +GHC's mergesort replaced by a better implementation, 24/12/2009. +This code originally contributed to the nhc12 compiler by Thomas Nordin +in 2002. Rumoured to have been based on code by Lennart Augustsson, e.g. + http://www.mail-archive.com/haskell@haskell.org/msg01822.html +and possibly to bear similarities to a 1982 paper by Richard O'Keefe: +"A smooth applicative merge sort". + +Benchmarks show it to be often 2x the speed of the previous implementation. +Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/2143 +-} + +sort = sortBy compare +sortBy cmp = mergeAll . sequences + where + sequences (a:b:xs) + | a `cmp` b == GT = descending b [a] xs + | otherwise = ascending b (a:) xs + sequences xs = [xs] + + descending a as (b:bs) + | a `cmp` b == GT = descending b (a:as) bs + descending a as bs = (a:as): sequences bs + + ascending a as (b:bs) + | a `cmp` b /= GT = ascending b (\ys -> as (a:ys)) bs + ascending a as bs = as [a]: sequences bs + + mergeAll [x] = x + mergeAll xs = mergeAll (mergePairs xs) + + mergePairs (a:b:xs) = merge a b: mergePairs xs + mergePairs xs = xs + + merge as@(a:as') bs@(b:bs') + | a `cmp` b == GT = b:merge as bs' + | otherwise = a:merge as' bs + merge [] bs = bs + merge as [] = as + +{- +sortBy cmp l = mergesort cmp l +sort l = mergesort compare l + +Quicksort replaced by mergesort, 14/5/2002. + +From: Ian Lynagh + +I am curious as to why the List.sort implementation in GHC is a +quicksort algorithm rather than an algorithm that guarantees n log n +time in the worst case? I have attached a mergesort implementation along +with a few scripts to time it's performance, the results of which are +shown below (* means it didn't finish successfully - in all cases this +was due to a stack overflow). + +If I heap profile the random_list case with only 10000 then I see +random_list peaks at using about 2.5M of memory, whereas in the same +program using List.sort it uses only 100k. + +Input style Input length Sort data Sort alg User time +stdin 10000 random_list sort 2.82 +stdin 10000 random_list mergesort 2.96 +stdin 10000 sorted sort 31.37 +stdin 10000 sorted mergesort 1.90 +stdin 10000 revsorted sort 31.21 +stdin 10000 revsorted mergesort 1.88 +stdin 100000 random_list sort * +stdin 100000 random_list mergesort * +stdin 100000 sorted sort * +stdin 100000 sorted mergesort * +stdin 100000 revsorted sort * +stdin 100000 revsorted mergesort * +func 10000 random_list sort 0.31 +func 10000 random_list mergesort 0.91 +func 10000 sorted sort 19.09 +func 10000 sorted mergesort 0.15 +func 10000 revsorted sort 19.17 +func 10000 revsorted mergesort 0.16 +func 100000 random_list sort 3.85 +func 100000 random_list mergesort * +func 100000 sorted sort 5831.47 +func 100000 sorted mergesort 2.23 +func 100000 revsorted sort 5872.34 +func 100000 revsorted mergesort 2.24 + +mergesort :: (a -> a -> Ordering) -> [a] -> [a] +mergesort cmp = mergesort' cmp . map wrap + +mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a] +mergesort' _ [] = [] +mergesort' _ [xs] = xs +mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss) + +merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]] +merge_pairs _ [] = [] +merge_pairs _ [xs] = [xs] +merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss + +merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +merge _ [] ys = ys +merge _ xs [] = xs +merge cmp (x:xs) (y:ys) + = case x `cmp` y of + GT -> y : merge cmp (x:xs) ys + _ -> x : merge cmp xs (y:ys) + +wrap :: a -> [a] +wrap x = [x] + + + +OLDER: qsort version + +-- qsort is stable and does not concatenate. +qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +qsort _ [] r = r +qsort _ [x] r = x:r +qsort cmp (x:xs) r = qpart cmp x xs [] [] r + +-- qpart partitions and sorts the sublists +qpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a] +qpart cmp x [] rlt rge r = + -- rlt and rge are in reverse order and must be sorted with an + -- anti-stable sorting + rqsort cmp rlt (x:rqsort cmp rge r) +qpart cmp x (y:ys) rlt rge r = + case cmp x y of + GT -> qpart cmp x ys (y:rlt) rge r + _ -> qpart cmp x ys rlt (y:rge) r + +-- rqsort is as qsort but anti-stable, i.e. reverses equal elements +rqsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +rqsort _ [] r = r +rqsort _ [x] r = x:r +rqsort cmp (x:xs) r = rqpart cmp x xs [] [] r + +rqpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a] +rqpart cmp x [] rle rgt r = + qsort cmp rle (x:qsort cmp rgt r) +rqpart cmp x (y:ys) rle rgt r = + case cmp y x of + GT -> rqpart cmp x ys rle (y:rgt) r + _ -> rqpart cmp x ys (y:rle) rgt r +-} + +#endif /* USE_REPORT_PRELUDE */ + +-- | Sort a list by comparing the results of a key function applied to each +-- element. @sortOn f@ is equivalent to @sortBy (comparing f)@, but has the +-- performance advantage of only evaluating @f@ once for each element in the +-- input list. This is called the decorate-sort-undecorate paradigm, or +-- Schwartzian transform. +-- +-- @since 4.8.0.0 +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn f = + map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) + +-- | The 'unfoldr' function is a \`dual\' to 'foldr': while 'foldr' +-- reduces a list to a summary value, 'unfoldr' builds a list from +-- a seed value. The function takes the element and returns 'Nothing' +-- if it is done producing the list or returns 'Just' @(a,b)@, in which +-- case, @a@ is a prepended to the list and @b@ is used as the next +-- element in a recursive call. For example, +-- +-- > iterate f == unfoldr (\x -> Just (x, f x)) +-- +-- In some cases, 'unfoldr' can undo a 'foldr' operation: +-- +-- > unfoldr f' (foldr f z xs) == xs +-- +-- if the following holds: +-- +-- > f' (f x y) = Just (x,y) +-- > f' z = Nothing +-- +-- A simple use of unfoldr: +-- +-- > unfoldr (\b -> if b == 0 then Nothing else Just (b, b-1)) 10 +-- > [10,9,8,7,6,5,4,3,2,1] +-- + +-- Note [INLINE unfoldr] +-- We treat unfoldr a little differently from some other forms for list fusion +-- for two reasons: +-- +-- 1. We don't want to use a rule to rewrite a basic form to a fusible +-- form because this would inline before constant floating. As Simon Peyton- +-- Jones and others have pointed out, this could reduce sharing in some cases +-- where sharing is beneficial. Thus we simply INLINE it, which is, for +-- example, how enumFromTo::Int becomes eftInt. Unfortunately, we don't seem +-- to get enough of an inlining discount to get a version of eftInt based on +-- unfoldr to inline as readily as the usual one. We know that all the Maybe +-- nonsense will go away, but the compiler does not. +-- +-- 2. The benefit of inlining unfoldr is likely to be huge in many common cases, +-- even apart from list fusion. In particular, inlining unfoldr often +-- allows GHC to erase all the Maybes. This appears to be critical if unfoldr +-- is to be used in high-performance code. A small increase in code size +-- in the relatively rare cases when this does not happen looks like a very +-- small price to pay. +-- +-- Doing a back-and-forth dance doesn't seem to accomplish anything if the +-- final form has to be inlined in any case. + +unfoldr :: (b -> Maybe (a, b)) -> b -> [a] + +{-# INLINE unfoldr #-} -- See Note [INLINE unfoldr] +unfoldr f b0 = build (\c n -> + let go b = case f b of + Just (a, new_b) -> a `c` go new_b + Nothing -> n + in go b0) + +-- ----------------------------------------------------------------------------- +-- Functions on strings + +-- | 'lines' breaks a string up into a list of strings at newline +-- characters. The resulting strings do not contain newlines. +-- +-- Note that after splitting the string at newline characters, the +-- last part of the string is considered a line even if it doesn't end +-- with a newline. For example, +-- +-- > lines "" == [] +-- > lines "\n" == [""] +-- > lines "one" == ["one"] +-- > lines "one\n" == ["one"] +-- > lines "one\n\n" == ["one",""] +-- > lines "one\ntwo" == ["one","two"] +-- > lines "one\ntwo\n" == ["one","two"] +-- +-- Thus @'lines' s@ contains at least as many elements as newlines in @s@. +lines :: String -> [String] +lines "" = [] +-- Somehow GHC doesn't detect the selector thunks in the below code, +-- so s' keeps a reference to the first line via the pair and we have +-- a space leak (cf. #4334). +-- So we need to make GHC see the selector thunks with a trick. +lines s = cons (case break (== '\n') s of + (l, s') -> (l, case s' of + [] -> [] + _:s'' -> lines s'')) + where + cons ~(h, t) = h : t + +-- | 'unlines' is an inverse operation to 'lines'. +-- It joins lines, after appending a terminating newline to each. +unlines :: [String] -> String +#ifdef USE_REPORT_PRELUDE +unlines = concatMap (++ "\n") +#else +-- HBC version (stolen) +-- here's a more efficient version +unlines [] = [] +unlines (l:ls) = l ++ '\n' : unlines ls +#endif + +-- | 'words' breaks a string up into a list of words, which were delimited +-- by white space. +words :: String -> [String] +{-# NOINLINE [1] words #-} +words s = case dropWhile {-partain:Char.-}isSpace s of + "" -> [] + s' -> w : words s'' + where (w, s'') = + break {-partain:Char.-}isSpace s' + +{-# RULES +"words" [~1] forall s . words s = build (\c n -> wordsFB c n s) +"wordsList" [1] wordsFB (:) [] = words + #-} +wordsFB :: ([Char] -> b -> b) -> b -> String -> b +{-# NOINLINE [0] wordsFB #-} +wordsFB c n = go + where + go s = case dropWhile isSpace s of + "" -> n + s' -> w `c` go s'' + where (w, s'') = break isSpace s' + +-- | 'unwords' is an inverse operation to 'words'. +-- It joins words with separating spaces. +unwords :: [String] -> String +#ifdef USE_REPORT_PRELUDE +unwords [] = "" +unwords ws = foldr1 (\w s -> w ++ ' ':s) ws +#else +-- Here's a lazier version that can get the last element of a +-- _|_-terminated list. +{-# NOINLINE [1] unwords #-} +unwords [] = "" +unwords (w:ws) = w ++ go ws + where + go [] = "" + go (v:vs) = ' ' : (v ++ go vs) + +-- In general, the foldr-based version is probably slightly worse +-- than the HBC version, because it adds an extra space and then takes +-- it back off again. But when it fuses, it reduces allocation. How much +-- depends entirely on the average word length--it's most effective when +-- the words are on the short side. +{-# RULES +"unwords" [~1] forall ws . + unwords ws = tailUnwords (foldr unwordsFB "" ws) +"unwordsList" [1] forall ws . + tailUnwords (foldr unwordsFB "" ws) = unwords ws + #-} + +{-# INLINE [0] tailUnwords #-} +tailUnwords :: String -> String +tailUnwords [] = [] +tailUnwords (_:xs) = xs + +{-# INLINE [0] unwordsFB #-} +unwordsFB :: String -> String -> String +unwordsFB w r = ' ' : w ++ r +#endif + +{- A "SnocBuilder" is a version of Chris Okasaki's banker's queue that supports +toListSB instead of uncons. In single-threaded use, its performance +characteristics are similar to John Hughes's functional difference lists, but +likely somewhat worse. In heavily persistent settings, however, it does much +better, because it takes advantage of sharing. The banker's queue guarantees +(amortized) O(1) snoc and O(1) uncons, meaning that we can think of toListSB as +an O(1) conversion to a list-like structure a constant factor slower than +normal lists--we pay the O(n) cost incrementally as we consume the list. Using +functional difference lists, on the other hand, we would have to pay the whole +cost up front for each output list. -} + +{- We store a front list, a rear list, and the length of the queue. Because we +only snoc onto the queue and never uncons, we know it's time to rotate when the +length of the queue plus 1 is a power of 2. Note that we rely on the value of +the length field only for performance. In the unlikely event of overflow, the +performance will suffer but the semantics will remain correct. -} + +data SnocBuilder a = SnocBuilder {-# UNPACK #-} !Word [a] [a] + +{- Smart constructor that rotates the builder when lp is one minus a power of +2. Does not rotate very small builders because doing so is not worth the +trouble. The lp < 255 test goes first because the power-of-2 test gives awful +branch prediction for very small n (there are 5 powers of 2 between 1 and +16). Putting the well-predicted lp < 255 test first avoids branching on the +power-of-2 test until powers of 2 have become sufficiently rare to be predicted +well. -} + +{-# INLINE sb #-} +sb :: Word -> [a] -> [a] -> SnocBuilder a +sb lp f r + | lp < 255 || (lp .&. (lp + 1)) /= 0 = SnocBuilder lp f r + | otherwise = SnocBuilder lp (f ++ reverse r) [] + +-- The empty builder + +emptySB :: SnocBuilder a +emptySB = SnocBuilder 0 [] [] + +-- Add an element to the end of a queue. + +snocSB :: SnocBuilder a -> a -> SnocBuilder a +snocSB (SnocBuilder lp f r) x = sb (lp + 1) f (x:r) + +-- Convert a builder to a list + +toListSB :: SnocBuilder a -> [a] +toListSB (SnocBuilder _ f r) = f ++ reverse r diff --git a/libraries/base/Data/Ord.hs b/libraries/base/Data/Ord.hs new file mode 100644 index 0000000..809f148 --- /dev/null +++ b/libraries/base/Data/Ord.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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, + ) where + +import GHC.Base +import GHC.Show +import GHC.Read + +-- | +-- > comparing p x y = compare (p x) (p y) +-- +-- Useful combinator for use in conjunction with the @xxxBy@ family +-- of functions from "Data.List", for example: +-- +-- > ... sortBy (comparing fst) ... +comparing :: (Ord a) => (b -> a) -> b -> b -> Ordering +comparing p x y = compare (p x) (p y) + +-- | The 'Down' type allows you to reverse sort order conveniently. A value of type +-- @'Down' a@ contains a value of type @a@ (represented as @'Down' a@). +-- If @a@ has an @'Ord'@ instance associated with it then comparing two +-- values thus wrapped will give you the opposite of their normal sort order. +-- This is particularly useful when sorting in generalised list comprehensions, +-- as in: @then sortWith by 'Down' x@ +-- +-- Provides 'Show' and 'Read' instances (/since: 4.7.0.0/). +-- +-- @since 4.6.0.0 +newtype Down a = Down a deriving (Eq, Show, Read) + +instance Ord a => Ord (Down a) where + compare (Down x) (Down y) = y `compare` x diff --git a/libraries/base/Data/Proxy.hs b/libraries/base/Data/Proxy.hs new file mode 100644 index 0000000..f0760e8 --- /dev/null +++ b/libraries/base/Data/Proxy.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Proxy +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- 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.Base +import GHC.Show +import GHC.Read +import GHC.Enum +import GHC.Arr + +-- | A concrete, poly-kinded proxy type +data Proxy t = Proxy + +-- | A concrete, promotable proxy type, for use at the kind level +-- There are no instances for this because it is intended at the kind level only +data KProxy (t :: *) = KProxy + +-- It's common to use (undefined :: Proxy t) and (Proxy :: Proxy t) +-- interchangeably, so all of these instances are hand-written to be +-- lazy in Proxy arguments. + +instance Eq (Proxy s) where + _ == _ = True + +instance Ord (Proxy s) where + compare _ _ = EQ + +instance Show (Proxy s) where + showsPrec _ _ = showString "Proxy" + +instance Read (Proxy s) where + readsPrec d = readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) + +instance Enum (Proxy s) where + succ _ = errorWithoutStackTrace "Proxy.succ" + pred _ = errorWithoutStackTrace "Proxy.pred" + fromEnum _ = 0 + toEnum 0 = Proxy + toEnum _ = errorWithoutStackTrace "Proxy.toEnum: 0 expected" + enumFrom _ = [Proxy] + enumFromThen _ _ = [Proxy] + enumFromThenTo _ _ _ = [Proxy] + enumFromTo _ _ = [Proxy] + +instance Ix (Proxy s) where + range _ = [Proxy] + index _ _ = 0 + inRange _ _ = True + rangeSize _ = 1 + unsafeIndex _ _ = 0 + unsafeRangeSize _ = 1 + +instance Bounded (Proxy s) where + minBound = Proxy + maxBound = Proxy + +instance Monoid (Proxy s) where + mempty = Proxy + mappend _ _ = Proxy + mconcat _ = Proxy + +instance Functor Proxy where + fmap _ _ = Proxy + {-# INLINE fmap #-} + +instance Applicative Proxy where + pure _ = Proxy + {-# INLINE pure #-} + _ <*> _ = Proxy + {-# INLINE (<*>) #-} + +instance Alternative Proxy where + empty = Proxy + {-# INLINE empty #-} + _ <|> _ = Proxy + {-# INLINE (<|>) #-} + +instance Monad Proxy where + _ >>= _ = Proxy + {-# INLINE (>>=) #-} + +instance MonadPlus Proxy + +-- | 'asProxyTypeOf' is a type-restricted version of 'const'. +-- It is usually used as an infix operator, and its typing forces its first +-- argument (which is usually overloaded) to have the same type as the tag +-- of the second. +asProxyTypeOf :: a -> Proxy a -> a +asProxyTypeOf = const +{-# INLINE asProxyTypeOf #-} diff --git a/libraries/base/Data/Ratio.hs b/libraries/base/Data/Ratio.hs new file mode 100644 index 0000000..8517e48 --- /dev/null +++ b/libraries/base/Data/Ratio.hs @@ -0,0 +1,73 @@ +{-# 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.Real -- The basic defns for Ratio + +-- ----------------------------------------------------------------------------- +-- 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 = simplest (rat-eps) (rat+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/libraries/base/Data/STRef.hs b/libraries/base/Data/STRef.hs new file mode 100644 index 0000000..60bccf5 --- /dev/null +++ b/libraries/base/Data/STRef.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.STRef +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (uses Control.Monad.ST) +-- +-- Mutable references in the (strict) ST monad. +-- +----------------------------------------------------------------------------- + +module Data.STRef ( + -- * STRefs + STRef, -- abstract + newSTRef, + readSTRef, + writeSTRef, + modifySTRef, + modifySTRef' + ) where + +import GHC.ST +import GHC.STRef + +-- | Mutate the contents of an 'STRef'. +-- +-- Be warned that 'modifySTRef' does not apply the function strictly. This +-- means if the program calls 'modifySTRef' many times, but seldomly uses the +-- value, thunks will pile up in memory resulting in a space leak. This is a +-- common mistake made when using an STRef as a counter. For example, the +-- following will leak memory and likely produce a stack overflow: +-- +-- >print $ runST $ do +-- > ref <- newSTRef 0 +-- > replicateM_ 1000000 $ modifySTRef ref (+1) +-- > readSTRef ref +-- +-- To avoid this problem, use 'modifySTRef'' instead. +modifySTRef :: STRef s a -> (a -> a) -> ST s () +modifySTRef ref f = writeSTRef ref . f =<< readSTRef ref + +-- | Strict version of 'modifySTRef' +-- +-- @since 4.6.0.0 +modifySTRef' :: STRef s a -> (a -> a) -> ST s () +modifySTRef' ref f = do + x <- readSTRef ref + let x' = f x + x' `seq` writeSTRef ref x' diff --git a/libraries/base/Data/STRef/Lazy.hs b/libraries/base/Data/STRef/Lazy.hs new file mode 100644 index 0000000..c7c3291 --- /dev/null +++ b/libraries/base/Data/STRef/Lazy.hs @@ -0,0 +1,38 @@ +{-# 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 : experimental +-- 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 Control.Monad.ST.Lazy +import qualified 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/libraries/base/Data/STRef/Strict.hs b/libraries/base/Data/STRef/Strict.hs new file mode 100644 index 0000000..ead6683 --- /dev/null +++ b/libraries/base/Data/STRef/Strict.hs @@ -0,0 +1,22 @@ +{-# 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/libraries/base/Data/Semigroup.hs b/libraries/base/Data/Semigroup.hs new file mode 100644 index 0000000..6fa0cd8 --- /dev/null +++ b/libraries/base/Data/Semigroup.hs @@ -0,0 +1,634 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Semigroup +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- In mathematics, a semigroup is an algebraic structure consisting of a +-- set together with an associative binary operation. A semigroup +-- generalizes a monoid in that there might not exist an identity +-- element. It also (originally) generalized a group (a monoid with all +-- inverses) to a type where every element did not have to have an inverse, +-- thus the name semigroup. +-- +-- 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 from Data.Monoid + , Monoid(..) + , Dual(..) + , Endo(..) + , All(..) + , Any(..) + , Sum(..) + , Product(..) + -- * A better monoid for Maybe + , Option(..) + , option + -- * Difference lists of a semigroup + , diff + , cycle1 + -- * ArgMin, ArgMax + , Arg(..) + , ArgMin + , ArgMax + ) where + +import Prelude hiding (foldr1) + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Data.Bifunctor +import Data.Coerce +import Data.Data +import Data.List.NonEmpty +import Data.Monoid (All (..), Any (..), Dual (..), Endo (..), + Product (..), Sum (..)) +import Data.Monoid (Alt (..)) +import qualified Data.Monoid as Monoid +import Data.Void +import GHC.Generics + +infixr 6 <> + +-- | The class of semigroups (types with an associative binary operation). +-- +-- @since 4.9.0.0 +class Semigroup a where + -- | An associative operation. + -- + -- @ + -- (a '<>' b) '<>' c = a '<>' (b '<>' c) + -- @ + -- + -- If @a@ is also a 'Monoid' we further require + -- + -- @ + -- ('<>') = 'mappend' + -- @ + (<>) :: a -> a -> a + + default (<>) :: Monoid a => a -> a -> a + (<>) = mappend + + -- | Reduce a non-empty list with @\<\>@ + -- + -- The default definition should be sufficient, but this can be + -- overridden for efficiency. + -- + sconcat :: NonEmpty a -> a + sconcat (a :| as) = go a as where + go b (c:cs) = b <> go c cs + go b [] = b + + -- | Repeat a value @n@ times. + -- + -- Given that this works on a 'Semigroup' it is allowed to fail if + -- you request 0 or fewer repetitions, and the default definition + -- will do so. + -- + -- By making this a member of the class, idempotent semigroups and monoids can + -- upgrade this to execute in /O(1)/ by picking + -- @stimes = stimesIdempotent@ or @stimes = stimesIdempotentMonoid@ + -- respectively. + stimes :: Integral b => b -> a -> a + stimes y0 x0 + | y0 <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected" + | otherwise = f x0 y0 + where + f x y + | even y = f (x <> x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x <> x) (pred y `quot` 2) x + g x y z + | even y = g (x <> x) (y `quot` 2) z + | y == 1 = x <> z + | otherwise = g (x <> x) (pred y `quot` 2) (x <> z) + +-- | A generalization of 'Data.List.cycle' to an arbitrary 'Semigroup'. +-- May fail to terminate for some values in some semigroups. +cycle1 :: Semigroup m => m -> m +cycle1 xs = xs' where xs' = xs <> xs' + +instance Semigroup () where + _ <> _ = () + sconcat _ = () + stimes _ _ = () + +instance Semigroup b => Semigroup (a -> b) where + f <> g = \a -> f a <> g a + stimes n f e = stimes n (f e) + +instance Semigroup [a] where + (<>) = (++) + stimes n x + | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier" + | otherwise = rep n + where + rep 0 = [] + rep i = x ++ rep (i - 1) + +instance Semigroup a => Semigroup (Maybe a) where + Nothing <> b = b + a <> Nothing = a + Just a <> Just b = Just (a <> b) + stimes _ Nothing = Nothing + stimes n (Just a) = case compare n 0 of + LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier" + EQ -> Nothing + GT -> Just (stimes n a) + +instance Semigroup (Either a b) where + Left _ <> b = b + a <> _ = a + stimes = stimesIdempotent + +instance (Semigroup a, Semigroup b) => Semigroup (a, b) where + (a,b) <> (a',b') = (a<>a',b<>b') + stimes n (a,b) = (stimes n a, stimes n b) + +instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where + (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c') + stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c) + +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) + => Semigroup (a, b, c, d) where + (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d') + stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d) + +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) + => Semigroup (a, b, c, d, e) where + (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e') + stimes n (a,b,c,d,e) = + (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e) + +instance Semigroup Ordering where + LT <> _ = LT + EQ <> y = y + GT <> _ = GT + stimes = stimesIdempotentMonoid + +instance Semigroup a => Semigroup (Dual a) where + Dual a <> Dual b = Dual (b <> a) + stimes n (Dual a) = Dual (stimes n a) + +instance Semigroup (Endo a) where + (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a)) + stimes = stimesMonoid + +instance Semigroup All where + (<>) = coerce (&&) + stimes = stimesIdempotentMonoid + +instance Semigroup Any where + (<>) = coerce (||) + stimes = stimesIdempotentMonoid + + +instance Num a => Semigroup (Sum a) where + (<>) = coerce ((+) :: a -> a -> a) + stimes n (Sum a) = Sum (fromIntegral n * a) + +instance Num a => Semigroup (Product a) where + (<>) = coerce ((*) :: a -> a -> a) + stimes n (Product a) = Product (a ^ n) + +-- | This is a valid definition of 'stimes' for a 'Monoid'. +-- +-- Unlike the default definition of 'stimes', it is defined for 0 +-- and so it should be preferred where possible. +stimesMonoid :: (Integral b, Monoid a) => b -> a -> a +stimesMonoid n x0 = case compare n 0 of + LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier" + EQ -> mempty + GT -> f x0 n + where + f x y + | even y = f (x `mappend` x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x `mappend` x) (pred y `quot` 2) x + g x y z + | even y = g (x `mappend` x) (y `quot` 2) z + | y == 1 = x `mappend` z + | otherwise = g (x `mappend` x) (pred y `quot` 2) (x `mappend` z) + +-- | This is a valid definition of 'stimes' for an idempotent 'Monoid'. +-- +-- When @mappend x x = x@, this definition should be preferred, because it +-- works in /O(1)/ rather than /O(log n)/ +stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a +stimesIdempotentMonoid n x = case compare n 0 of + LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier" + EQ -> mempty + GT -> x + +-- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'. +-- +-- When @x <> x = x@, this definition should be preferred, because it +-- works in /O(1)/ rather than /O(log n)/. +stimesIdempotent :: Integral b => b -> a -> a +stimesIdempotent n x + | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected" + | otherwise = x + +instance Semigroup a => Semigroup (Const a b) where + (<>) = coerce ((<>) :: a -> a -> a) + stimes n (Const a) = Const (stimes n a) + +instance Semigroup (Monoid.First a) where + Monoid.First Nothing <> b = b + a <> _ = a + stimes = stimesIdempotentMonoid + +instance Semigroup (Monoid.Last a) where + a <> Monoid.Last Nothing = a + _ <> b = b + stimes = stimesIdempotentMonoid + +instance Alternative f => Semigroup (Alt f a) where + (<>) = coerce ((<|>) :: f a -> f a -> f a) + stimes = stimesMonoid + +instance Semigroup Void where + a <> _ = a + stimes = stimesIdempotent + +instance Semigroup (NonEmpty a) where + (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs) + + +newtype Min a = Min { getMin :: a } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Bounded a => Bounded (Min a) where + minBound = Min minBound + maxBound = Min maxBound + +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 <$> enumFrom a + enumFromThen (Min a) (Min b) = Min <$> enumFromThen a b + enumFromTo (Min a) (Min b) = Min <$> enumFromTo a b + enumFromThenTo (Min a) (Min b) (Min c) = Min <$> enumFromThenTo a b c + + +instance Ord a => Semigroup (Min a) where + (<>) = coerce (min :: a -> a -> a) + stimes = stimesIdempotent + +instance (Ord a, Bounded a) => Monoid (Min a) where + mempty = maxBound + mappend = (<>) + +instance Functor Min where + fmap f (Min x) = Min (f x) + +instance Foldable Min where + foldMap f (Min a) = f a + +instance Traversable Min where + traverse f (Min a) = Min <$> f a + +instance Applicative Min where + pure = Min + a <* _ = a + _ *> a = a + Min f <*> Min x = Min (f x) + +instance Monad Min where + (>>) = (*>) + Min a >>= f = f a + +instance MonadFix Min where + mfix f = fix (f . getMin) + +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 + +newtype Max a = Max { getMax :: a } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Bounded a => Bounded (Max a) where + minBound = Max minBound + maxBound = Max maxBound + +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 <$> enumFrom a + enumFromThen (Max a) (Max b) = Max <$> enumFromThen a b + enumFromTo (Max a) (Max b) = Max <$> enumFromTo a b + enumFromThenTo (Max a) (Max b) (Max c) = Max <$> enumFromThenTo a b c + +instance Ord a => Semigroup (Max a) where + (<>) = coerce (max :: a -> a -> a) + stimes = stimesIdempotent + +instance (Ord a, Bounded a) => Monoid (Max a) where + mempty = minBound + mappend = (<>) + +instance Functor Max where + fmap f (Max x) = Max (f x) + +instance Foldable Max where + foldMap f (Max a) = f a + +instance Traversable Max where + traverse f (Max a) = Max <$> f a + +instance Applicative Max where + pure = Max + a <* _ = a + _ *> a = a + Max f <*> Max x = Max (f x) + +instance Monad Max where + (>>) = (*>) + Max a >>= f = f a + +instance MonadFix Max where + mfix f = fix (f . getMax) + +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. +data Arg a b = Arg a b deriving + (Show, Read, Data, Typeable, Generic, Generic1) + +type ArgMin a b = Min (Arg a b) +type ArgMax a b = Max (Arg a b) + +instance Functor (Arg a) where + fmap f (Arg x a) = Arg x (f a) + +instance Foldable (Arg a) where + foldMap f (Arg _ a) = f a + +instance Traversable (Arg a) where + traverse f (Arg x a) = Arg x <$> f a + +instance Eq a => Eq (Arg a b) where + Arg a _ == Arg b _ = a == b + +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 + +instance Bifunctor Arg where + bimap f g (Arg a b) = Arg (f a) (g b) + +-- | Use @'Option' ('First' a)@ to get the behavior of +-- 'Data.Monoid.First' from "Data.Monoid". +newtype First a = First { getFirst :: a } deriving + (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Bounded a => Bounded (First a) where + minBound = First minBound + maxBound = First maxBound + +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 <$> enumFrom a + enumFromThen (First a) (First b) = First <$> enumFromThen a b + enumFromTo (First a) (First b) = First <$> enumFromTo a b + enumFromThenTo (First a) (First b) (First c) = First <$> enumFromThenTo a b c + +instance Semigroup (First a) where + a <> _ = a + stimes = stimesIdempotent + +instance Functor First where + fmap f (First x) = First (f x) + +instance Foldable First where + foldMap f (First a) = f a + +instance Traversable First where + traverse f (First a) = First <$> f a + +instance Applicative First where + pure x = First x + a <* _ = a + _ *> a = a + First f <*> First x = First (f x) + +instance Monad First where + (>>) = (*>) + First a >>= f = f a + +instance MonadFix First where + mfix f = fix (f . getFirst) + +-- | Use @'Option' ('Last' a)@ to get the behavior of +-- 'Data.Monoid.Last' from "Data.Monoid" +newtype Last a = Last { getLast :: a } deriving + (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Bounded a => Bounded (Last a) where + minBound = Last minBound + maxBound = Last maxBound + +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 <$> enumFrom a + enumFromThen (Last a) (Last b) = Last <$> enumFromThen a b + enumFromTo (Last a) (Last b) = Last <$> enumFromTo a b + enumFromThenTo (Last a) (Last b) (Last c) = Last <$> enumFromThenTo a b c + +instance Semigroup (Last a) where + _ <> b = b + stimes = stimesIdempotent + +instance Functor Last where + fmap f (Last x) = Last (f x) + a <$ _ = Last a + +instance Foldable Last where + foldMap f (Last a) = f a + +instance Traversable Last where + traverse f (Last a) = Last <$> f a + +instance Applicative Last where + pure = Last + a <* _ = a + _ *> a = a + Last f <*> Last x = Last (f x) + +instance Monad Last where + (>>) = (*>) + Last a >>= f = f a + +instance MonadFix Last where + mfix f = fix (f . getLast) + +-- | Provide a Semigroup for an arbitrary Monoid. +newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Monoid m => Semigroup (WrappedMonoid m) where + (<>) = coerce (mappend :: m -> m -> m) + +instance Monoid m => Monoid (WrappedMonoid m) where + mempty = WrapMonoid mempty + mappend = (<>) + +instance Bounded a => Bounded (WrappedMonoid a) where + minBound = WrapMonoid minBound + maxBound = WrapMonoid maxBound + +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 <$> enumFrom a + enumFromThen (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromThen a b + enumFromTo (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromTo a b + enumFromThenTo (WrapMonoid a) (WrapMonoid b) (WrapMonoid c) = + WrapMonoid <$> enumFromThenTo a b c + +-- | Repeat a value @n@ times. +-- +-- > mtimesDefault n a = a <> a <> ... <> a -- using <> (n-1) times +-- +-- Implemented using 'stimes' and 'mempty'. +-- +-- This is a suitable definition for an 'mtimes' member of 'Monoid'. +mtimesDefault :: (Integral b, Monoid a) => b -> a -> a +mtimesDefault n x + | n == 0 = mempty + | otherwise = unwrapMonoid (stimes n (WrapMonoid x)) + +-- | 'Option' is effectively 'Maybe' with a better instance of +-- 'Monoid', built off of an underlying 'Semigroup' instead of an +-- underlying 'Monoid'. +-- +-- Ideally, this type would not exist at all and we would just fix the +-- 'Monoid' instance of 'Maybe' +newtype Option a = Option { getOption :: Maybe a } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Functor Option where + fmap f (Option a) = Option (fmap f a) + +instance Applicative Option where + pure a = Option (Just a) + Option a <*> Option b = Option (a <*> b) + + Option Nothing *> _ = Option Nothing + _ *> b = b + +instance Monad Option where + Option (Just a) >>= k = k a + _ >>= _ = Option Nothing + (>>) = (*>) + +instance Alternative Option where + empty = Option Nothing + Option Nothing <|> b = b + a <|> _ = a + +instance MonadPlus Option where + mzero = Option Nothing + mplus = (<|>) + +instance MonadFix Option where + mfix f = Option (mfix (getOption . f)) + +instance Foldable Option where + foldMap f (Option (Just m)) = f m + foldMap _ (Option Nothing) = mempty + +instance Traversable Option where + traverse f (Option (Just a)) = Option . Just <$> f a + traverse _ (Option Nothing) = pure (Option Nothing) + +-- | Fold an 'Option' case-wise, just like 'maybe'. +option :: b -> (a -> b) -> Option a -> b +option n j (Option m) = maybe n j m + +instance Semigroup a => Semigroup (Option a) where + (<>) = coerce ((<>) :: Maybe a -> Maybe a -> Maybe a) + + stimes _ (Option Nothing) = Option Nothing + stimes n (Option (Just a)) = case compare n 0 of + LT -> errorWithoutStackTrace "stimes: Option, negative multiplier" + EQ -> Option Nothing + GT -> Option (Just (stimes n a)) + +instance Semigroup a => Monoid (Option a) where + mempty = Option Nothing + mappend = (<>) + +-- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'. +diff :: Semigroup m => m -> Endo m +diff = Endo . (<>) + +instance Semigroup (Proxy s) where + _ <> _ = Proxy + sconcat _ = Proxy + stimes _ _ = Proxy diff --git a/libraries/base/Data/String.hs b/libraries/base/Data/String.hs new file mode 100644 index 0000000..f341ff2 --- /dev/null +++ b/libraries/base/Data/String.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.String +-- Copyright : (c) The University of Glasgow 2007 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- The @String@ type and associated operations. +-- +----------------------------------------------------------------------------- + +module Data.String ( + String + , IsString(..) + + -- * Functions on strings + , lines + , words + , unlines + , unwords + ) where + +import GHC.Base +import Data.Functor.Const (Const (Const)) +import Data.List (lines, words, unlines, unwords) + +-- | Class for string-like datastructures; used by the overloaded string +-- extension (-XOverloadedStrings in GHC). +class IsString a where + fromString :: String -> a + +{- Note [IsString String] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, the IsString instance that covered String was a flexible +instance for [Char]. This is in some sense the most accurate choice, +but there are cases where it can lead to an ambiguity, for instance: + + show $ "foo" ++ "bar" + +The use of (++) ensures that "foo" and "bar" must have type [t] for +some t, but a flexible instance for [Char] will _only_ match if +something further determines t to be Char, and nothing in the above +example actually does. + +So, the above example generates an error about the ambiguity of t, +and what's worse, the above behavior can be generated by simply +typing: + + "foo" ++ "bar" + +into GHCi with the OverloadedStrings extension enabled. + +The new instance fixes this by defining an instance that matches all +[a], and forces a to be Char. This instance, of course, overlaps +with things that the [Char] flexible instance doesn't, but this was +judged to be an acceptable cost, for the gain of providing a less +confusing experience for people experimenting with overloaded strings. + +It may be possible to fix this via (extended) defaulting. Currently, +the rules are not able to default t to Char in the above example. If +a more flexible system that enabled this defaulting were put in place, +then it would probably make sense to revert to the flexible [Char] +instance, since extended defaulting is enabled in GHCi. However, it +is not clear at the time of this note exactly what such a system +would be, and it certainly hasn't been implemented. + +A test case (should_run/overloadedstringsrun01.hs) has been added to +ensure the good behavior of the above example remains in the future. +-} + +instance (a ~ Char) => IsString [a] where + -- See Note [IsString String] + fromString xs = xs + +instance IsString a => IsString (Const a b) where + fromString = Const . fromString diff --git a/libraries/base/Data/Traversable.hs b/libraries/base/Data/Traversable.hs new file mode 100644 index 0000000..b903b1d --- /dev/null +++ b/libraries/base/Data/Traversable.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- 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 : experimental +-- Portability : portable +-- +-- Class of data structures that can be traversed from left to right, +-- performing an action on each element. +-- +-- See also +-- +-- * \"Applicative Programming with Effects\", +-- by Conor McBride and Ross Paterson, +-- /Journal of Functional Programming/ 18:1 (2008) 1-13, online at +-- . +-- +-- * \"The Essence of the Iterator Pattern\", +-- by Jeremy Gibbons and Bruno Oliveira, +-- in /Mathematically-Structured Functional Programming/, 2006, online at +-- . +-- +-- * \"An Investigation of the Laws of Traversals\", +-- by Mauro Jaskelioff and Ondrej Rypacek, +-- in /Mathematically-Structured Functional Programming/, 2012, online at +-- . +-- +----------------------------------------------------------------------------- + +module Data.Traversable ( + -- * The 'Traversable' class + Traversable(..), + -- * Utility functions + for, + forM, + mapAccumL, + mapAccumR, + -- * General definitions for superclass methods + fmapDefault, + foldMapDefault, + ) where + +-- It is convenient to use 'Const' here but this means we must +-- define a few instances here which really belong in Control.Applicative +import Control.Applicative ( Const(..), ZipList(..) ) +import Data.Either ( Either(..) ) +import Data.Foldable ( Foldable ) +import Data.Functor +import Data.Monoid ( Dual(..), Sum(..), Product(..), First(..), Last(..) ) +import Data.Proxy ( Proxy(..) ) + +import GHC.Arr +import GHC.Base ( Applicative(..), Monad(..), Monoid, Maybe(..), + ($), (.), id, flip ) +import GHC.Generics +import qualified GHC.List as List ( foldr ) + +-- | Functors representing data structures that can be traversed from +-- left to right. +-- +-- 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' (Compose . 'fmap' g . f) = 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' 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 (x '<*>' y) = t x '<*>' t y@ +-- +-- and the identity functor @Identity@ and composition of functors @Compose@ +-- are defined as +-- +-- > newtype Identity a = Identity a +-- > +-- > instance Functor Identity where +-- > fmap f (Identity x) = Identity (f x) +-- > +-- > instance Applicative Identity where +-- > pure x = Identity x +-- > Identity f <*> Identity x = Identity (f x) +-- > +-- > newtype Compose f g a = Compose (f (g a)) +-- > +-- > instance (Functor f, Functor g) => Functor (Compose f g) where +-- > fmap f (Compose x) = Compose (fmap (fmap f) x) +-- > +-- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where +-- > pure x = Compose (pure (pure x)) +-- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) +-- +-- (The naturality law is implied by parametricity.) +-- +-- Instances are similar to 'Functor', e.g. given a data type +-- +-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) +-- +-- a suitable instance would be +-- +-- > instance Traversable Tree where +-- > traverse f Empty = pure Empty +-- > traverse f (Leaf x) = Leaf <$> f x +-- > traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r +-- +-- This is suitable even for abstract types, as the laws for '<*>' +-- imply a form of associativity. +-- +-- 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'). +-- +class (Functor t, Foldable t) => Traversable t where + {-# MINIMAL traverse | sequenceA #-} + + -- | Map each element of a structure to an action, evaluate these actions + -- from left to right, and collect the results. For a version that ignores + -- the results see 'Data.Foldable.traverse_'. + traverse :: Applicative f => (a -> f b) -> t a -> f (t b) + traverse f = sequenceA . fmap f + + -- | Evaluate each action in the structure from left to right, and + -- and collect the results. For a version that ignores the results + -- see 'Data.Foldable.sequenceA_'. + sequenceA :: Applicative f => t (f a) -> f (t a) + sequenceA = traverse id + + -- | Map each element of a structure to a monadic action, evaluate + -- these actions from left to right, and collect the results. For + -- a version that ignores the results see 'Data.Foldable.mapM_'. + mapM :: Monad m => (a -> m b) -> t a -> m (t b) + mapM = traverse + + -- | Evaluate each monadic action in the structure from left to + -- right, and collect the results. For a version that ignores the + -- results see 'Data.Foldable.sequence_'. + sequence :: Monad m => t (m a) -> m (t a) + sequence = sequenceA + +-- instances for Prelude types + +instance Traversable Maybe where + traverse _ Nothing = pure Nothing + traverse f (Just x) = Just <$> f x + +instance Traversable [] where + {-# INLINE traverse #-} -- so that traverse can fuse + traverse f = List.foldr cons_f (pure []) + where cons_f x ys = (:) <$> f x <*> ys + +instance Traversable (Either a) where + traverse _ (Left x) = pure (Left x) + traverse f (Right y) = Right <$> f y + +instance Traversable ((,) a) where + traverse f (x, y) = (,) x <$> f y + +instance Ix i => Traversable (Array i) where + traverse f arr = listArray (bounds arr) `fmap` traverse f (elems arr) + +instance Traversable Proxy where + traverse _ _ = pure Proxy + {-# INLINE traverse #-} + sequenceA _ = pure Proxy + {-# INLINE sequenceA #-} + mapM _ _ = pure Proxy + {-# INLINE mapM #-} + sequence _ = pure Proxy + {-# INLINE sequence #-} + +instance Traversable (Const m) where + traverse _ (Const m) = pure $ Const m + +instance Traversable Dual where + traverse f (Dual x) = Dual <$> f x + +instance Traversable Sum where + traverse f (Sum x) = Sum <$> f x + +instance Traversable Product where + traverse f (Product x) = Product <$> f x + +instance Traversable First where + traverse f (First x) = First <$> traverse f x + +instance Traversable Last where + traverse f (Last x) = Last <$> traverse f x + +instance Traversable ZipList where + traverse f (ZipList x) = ZipList <$> traverse f x + +-- Instances for GHC.Generics +instance Traversable U1 where + traverse _ _ = pure U1 + {-# INLINE traverse #-} + sequenceA _ = pure U1 + {-# INLINE sequenceA #-} + mapM _ _ = pure U1 + {-# INLINE mapM #-} + sequence _ = pure U1 + {-# INLINE sequence #-} + +deriving instance Traversable V1 +deriving instance Traversable Par1 +deriving instance Traversable f => Traversable (Rec1 f) +deriving instance Traversable (K1 i c) +deriving instance Traversable f => Traversable (M1 i c f) +deriving instance (Traversable f, Traversable g) => Traversable (f :+: g) +deriving instance (Traversable f, Traversable g) => Traversable (f :*: g) +deriving instance (Traversable f, Traversable g) => Traversable (f :.: g) +deriving instance Traversable UAddr +deriving instance Traversable UChar +deriving instance Traversable UDouble +deriving instance Traversable UFloat +deriving instance Traversable UInt +deriving instance Traversable UWord + +-- general functions + +-- | 'for' is 'traverse' with its arguments flipped. For a version +-- that ignores the results see 'Data.Foldable.for_'. +for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b) +{-# INLINE for #-} +for = flip traverse + +-- | 'forM' is 'mapM' with its arguments flipped. For a version that +-- ignores the results see 'Data.Foldable.forM_'. +forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) +{-# INLINE forM #-} +forM = flip mapM + +-- left-to-right state transformer +newtype StateL s a = StateL { runStateL :: s -> (s, a) } + +instance Functor (StateL s) where + fmap f (StateL k) = StateL $ \ s -> let (s', v) = k s in (s', f v) + +instance Applicative (StateL s) where + pure x = StateL (\ s -> (s, x)) + StateL kf <*> StateL kv = StateL $ \ s -> + let (s', f) = kf s + (s'', v) = kv s' + in (s'', f v) + +-- |The 'mapAccumL' function behaves like a combination of 'fmap' +-- and 'foldl'; it applies a function to each element of a structure, +-- passing an accumulating parameter from left to right, and returning +-- a final value of this accumulator together with the new structure. +mapAccumL :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) +mapAccumL f s t = runStateL (traverse (StateL . flip f) t) s + +-- right-to-left state transformer +newtype StateR s a = StateR { runStateR :: s -> (s, a) } + +instance Functor (StateR s) where + fmap f (StateR k) = StateR $ \ s -> let (s', v) = k s in (s', f v) + +instance Applicative (StateR s) where + pure x = StateR (\ s -> (s, x)) + StateR kf <*> StateR kv = StateR $ \ s -> + let (s', v) = kv s + (s'', f) = kf s' + in (s'', f v) + +-- |The 'mapAccumR' function behaves like a combination of 'fmap' +-- and 'foldr'; it applies a function to each element of a structure, +-- passing an accumulating parameter from right to left, and returning +-- a final value of this accumulator together with the new structure. +mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) +mapAccumR f s t = runStateR (traverse (StateR . flip f) t) s + +-- | This function may be used as a value for `fmap` in a `Functor` +-- instance, provided that 'traverse' is defined. (Using +-- `fmapDefault` with a `Traversable` instance defined only by +-- 'sequenceA' will result in infinite recursion.) +fmapDefault :: Traversable t => (a -> b) -> t a -> t b +{-# INLINE fmapDefault #-} +fmapDefault f = getId . traverse (Id . f) + +-- | This function may be used as a value for `Data.Foldable.foldMap` +-- in a `Foldable` instance. +foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m +foldMapDefault f = getConst . traverse (Const . f) + +-- local instances + +newtype Id a = Id { getId :: a } + +instance Functor Id where + fmap f (Id x) = Id (f x) + +instance Applicative Id where + pure = Id + Id f <*> Id x = Id (f x) + diff --git a/libraries/base/Data/Tuple.hs b/libraries/base/Data/Tuple.hs new file mode 100644 index 0000000..d8bccf3 --- /dev/null +++ b/libraries/base/Data/Tuple.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tuple +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- The tuple data types, and associated functions. +-- +----------------------------------------------------------------------------- + +module Data.Tuple + ( fst + , snd + , curry + , uncurry + , swap + ) where + +import GHC.Base () -- Note [Depend on GHC.Tuple] + +default () -- Double isn't available yet + +-- --------------------------------------------------------------------------- +-- Standard functions over tuples + +-- | Extract the first component of a pair. +fst :: (a,b) -> a +fst (x,_) = x + +-- | Extract the second component of a pair. +snd :: (a,b) -> b +snd (_,y) = y + +-- | 'curry' converts an uncurried function to a curried function. +curry :: ((a, b) -> c) -> a -> b -> c +curry f x y = f (x, y) + +-- | 'uncurry' converts a curried function to a function on pairs. +uncurry :: (a -> b -> c) -> ((a, b) -> c) +uncurry f p = f (fst p) (snd p) + +-- | Swap the components of a pair. +swap :: (a,b) -> (b,a) +swap (a,b) = (b,a) diff --git a/libraries/base/Data/Type/Bool.hs b/libraries/base/Data/Type/Bool.hs new file mode 100644 index 0000000..cfd4bfa --- /dev/null +++ b/libraries/base/Data/Type/Bool.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies, TypeOperators, DataKinds, NoImplicitPrelude, + PolyKinds #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Type.Bool +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : not portable +-- +-- Basic operations on type-level Booleans. +-- +-- @since 4.7.0.0 +----------------------------------------------------------------------------- + +module Data.Type.Bool ( + If, type (&&), type (||), Not + ) where + +import Data.Bool + +-- This needs to be in base because (&&) is used in Data.Type.Equality. +-- The other functions do not need to be in base, but seemed to be appropriate +-- here. + +-- | Type-level "If". @If True a b@ ==> @a@; @If False a b@ ==> @b@ +type family If cond tru fls where + If 'True tru fls = tru + If 'False tru fls = fls + +-- | Type-level "and" +type family a && b where + 'False && a = 'False + 'True && a = a + a && 'False = 'False + a && 'True = a + a && a = a +infixr 3 && + +-- | Type-level "or" +type family a || b where + 'False || a = a + 'True || a = 'True + a || 'False = a + a || 'True = 'True + a || a = a +infixr 2 || + +-- | Type-level "not" +type family Not a where + Not 'False = 'True + Not 'True = 'False diff --git a/libraries/base/Data/Type/Coercion.hs b/libraries/base/Data/Type/Coercion.hs new file mode 100644 index 0000000..cc34683 --- /dev/null +++ b/libraries/base/Data/Type/Coercion.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Type.Coercion +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : not portable +-- +-- Definition of representational equality ('Coercion'). +-- +-- @since 4.7.0.0 +----------------------------------------------------------------------------- + +module Data.Type.Coercion + ( Coercion(..) + , coerceWith + , sym + , trans + , repr + , TestCoercion(..) + ) where + +import qualified Data.Type.Equality as Eq +import Data.Maybe +import GHC.Enum +import GHC.Show +import GHC.Read +import GHC.Base + +-- | Representational equality. If @Coercion a b@ is inhabited by some terminating +-- value, then the type @a@ has the same underlying representation as the type @b@. +-- +-- To use this equality in practice, pattern-match on the @Coercion a b@ to get out +-- the @Coercible a b@ instance, and then use 'coerce' to apply it. +-- +-- @since 4.7.0.0 +data Coercion a b where + Coercion :: Coercible a b => Coercion a b + +-- with credit to Conal Elliott for 'ty', Erik Hesselink & Martijn van +-- Steenbergen for 'type-equality', Edward Kmett for 'eq', and Gabor Greif +-- for 'type-eq' + +-- | Type-safe cast, using representational equality +coerceWith :: Coercion a b -> a -> b +coerceWith Coercion x = coerce x + +-- | Symmetry of representational equality +sym :: Coercion a b -> Coercion b a +sym Coercion = Coercion + +-- | Transitivity of representational equality +trans :: Coercion a b -> Coercion b c -> Coercion a c +trans Coercion Coercion = Coercion + +-- | Convert propositional (nominal) equality to representational equality +repr :: (a Eq.:~: b) -> Coercion a b +repr Eq.Refl = Coercion + +deriving instance Eq (Coercion a b) +deriving instance Show (Coercion a b) +deriving instance Ord (Coercion a b) + +instance Coercible a b => Read (Coercion a b) where + readsPrec d = readParen (d > 10) (\r -> [(Coercion, s) | ("Coercion",s) <- lex r ]) + +instance Coercible a b => Enum (Coercion a b) where + toEnum 0 = Coercion + toEnum _ = errorWithoutStackTrace "Data.Type.Coercion.toEnum: bad argument" + + fromEnum Coercion = 0 + +instance Coercible a b => Bounded (Coercion a b) where + minBound = Coercion + maxBound = Coercion + +-- | This class contains types where you can learn the equality of two types +-- from information contained in /terms/. Typically, only singleton types should +-- inhabit this class. +class TestCoercion f where + -- | Conditionally prove the representational equality of @a@ and @b@. + testCoercion :: f a -> f b -> Maybe (Coercion a b) + +instance TestCoercion ((Eq.:~:) a) where + testCoercion Eq.Refl Eq.Refl = Just Coercion + +instance TestCoercion (Coercion a) where + testCoercion Coercion Coercion = Just Coercion diff --git a/libraries/base/Data/Type/Equality.hs b/libraries/base/Data/Type/Equality.hs new file mode 100644 index 0000000..a57b65e --- /dev/null +++ b/libraries/base/Data/Type/Equality.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Type.Equality +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- 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 (~~), + + -- * Working with equality + sym, trans, castWith, gcastWith, apply, inner, outer, + + -- * Inferring equality from other types + TestEquality(..), + + -- * Boolean type-level equality + type (==) + ) where + +import Data.Maybe +import GHC.Enum +import GHC.Show +import GHC.Read +import GHC.Base +import Data.Type.Bool + +-- | Lifted, homogeneous equality. By lifted, we mean that it can be +-- bogus (deferred type error). By homogeneous, the two types @a@ +-- and @b@ must have the same kind. +class a ~~ b => (a :: k) ~ (b :: k) | a -> b, b -> a + -- See Note [The equality types story] in TysPrim + -- NB: All this class does is to wrap its superclass, which is + -- the "real", inhomogeneous equality; this is needed when + -- we have a Given (a~b), and we want to prove things from it + -- NB: Not exported, as (~) is magical syntax. That's also why there's + -- no fixity. + +instance {-# INCOHERENT #-} a ~~ b => a ~ b + -- See Note [The equality types story] in TysPrim + -- If we have a Wanted (t1 ~ t2), we want to immediately + -- simplify it to (t1 ~~ t2) and solve that instead + -- + -- INCOHERENT because we want to use this instance eagerly, even when + -- the tyvars are partially unknown. + +infix 4 :~: + +-- | Propositional equality. If @a :~: b@ is inhabited by some terminating +-- value, then the type @a@ is the same as the type @b@. To use this equality +-- in practice, pattern-match on the @a :~: b@ to get out the @Refl@ constructor; +-- in the body of the pattern-match, the compiler knows that @a ~ b@. +-- +-- @since 4.7.0.0 +data a :~: b where -- See Note [The equality types story] in TysPrim + Refl :: a :~: a + +-- with credit to Conal Elliott for 'ty', Erik Hesselink & Martijn van +-- Steenbergen for 'type-equality', Edward Kmett for 'eq', and Gabor Greif +-- for 'type-eq' + +-- | Symmetry of equality +sym :: (a :~: b) -> (b :~: a) +sym Refl = Refl + +-- | Transitivity of equality +trans :: (a :~: b) -> (b :~: c) -> (a :~: c) +trans Refl Refl = Refl + +-- | Type-safe cast, using propositional equality +castWith :: (a :~: b) -> a -> b +castWith Refl x = x + +-- | Generalized form of type-safe cast using propositional equality +gcastWith :: (a :~: b) -> ((a ~ b) => r) -> r +gcastWith Refl x = x + +-- | Apply one equality to another, respectively +apply :: (f :~: g) -> (a :~: b) -> (f a :~: g b) +apply Refl Refl = Refl + +-- | Extract equality of the arguments from an equality of a applied types +inner :: (f a :~: g b) -> (a :~: b) +inner Refl = Refl + +-- | Extract equality of type constructors from an equality of applied types +outer :: (f a :~: g b) -> (f :~: g) +outer Refl = Refl + +deriving instance Eq (a :~: b) +deriving instance Show (a :~: b) +deriving instance Ord (a :~: b) + +instance a ~ b => Read (a :~: b) where + readsPrec d = readParen (d > 10) (\r -> [(Refl, s) | ("Refl",s) <- lex r ]) + +instance a ~ b => Enum (a :~: b) where + toEnum 0 = Refl + toEnum _ = errorWithoutStackTrace "Data.Type.Equality.toEnum: bad argument" + + fromEnum Refl = 0 + +instance a ~ b => Bounded (a :~: b) where + minBound = Refl + maxBound = Refl + +-- | This class contains types where you can learn the equality of two types +-- from information contained in /terms/. Typically, only singleton types should +-- inhabit this class. +class TestEquality f where + -- | Conditionally prove the equality of @a@ and @b@. + testEquality :: f a -> f b -> Maybe (a :~: b) + +instance TestEquality ((:~:) a) where + testEquality Refl Refl = Just Refl + +-- | A type family to compute Boolean equality. Instances are provided +-- only for /open/ kinds, such as @*@ and function kinds. Instances are +-- also provided for datatypes exported from base. A poly-kinded instance +-- is /not/ provided, as a recursive definition for algebraic kinds is +-- generally more useful. +type family (a :: k) == (b :: k) :: Bool +infix 4 == + +{- +This comment explains more about why a poly-kinded instance for (==) is +not provided. To be concrete, here would be the poly-kinded instance: + +type family EqPoly (a :: k) (b :: k) where + EqPoly a a = True + EqPoly a b = False +type instance (a :: k) == (b :: k) = EqPoly a b + +Note that this overlaps with every other instance -- if this were defined, +it would be the only instance for (==). + +Now, consider +data Nat = Zero | Succ Nat + +Suppose I want +foo :: (Succ n == Succ m) ~ True => ((n == m) :~: True) +foo = Refl + +This would not type-check with the poly-kinded instance. `Succ n == Succ m` +quickly becomes `EqPoly (Succ n) (Succ m)` but then is stuck. We don't know +enough about `n` and `m` to reduce further. + +On the other hand, consider this: + +type family EqNat (a :: Nat) (b :: Nat) where + EqNat Zero Zero = True + EqNat (Succ n) (Succ m) = EqNat n m + EqNat n m = False +type instance (a :: Nat) == (b :: Nat) = EqNat a b + +With this instance, `foo` type-checks fine. `Succ n == Succ m` becomes `EqNat +(Succ n) (Succ m)` which becomes `EqNat n m`. Thus, we can conclude `(n == m) +~ True` as desired. + +So, the Nat-specific instance allows strictly more reductions, and is thus +preferable to the poly-kinded instance. But, if we introduce the poly-kinded +instance, we are barred from writing the Nat-specific instance, due to +overlap. + +Even better than the current instance for * would be one that does this sort +of recursion for all datatypes, something like this: + +type family EqStar (a :: *) (b :: *) where + EqStar Bool Bool = True + EqStar (a,b) (c,d) = a == c && b == d + EqStar (Maybe a) (Maybe b) = a == b + ... + EqStar a b = False + +The problem is the (...) is extensible -- we would want to add new cases for +all datatypes in scope. This is not currently possible for closed type +families. +-} + +-- all of the following closed type families are local to this module +type family EqStar (a :: *) (b :: *) where + EqStar a a = 'True + EqStar a b = 'False + +-- This looks dangerous, but it isn't. This allows == to be defined +-- over arbitrary type constructors. +type family EqArrow (a :: k1 -> k2) (b :: k1 -> k2) where + EqArrow a a = 'True + EqArrow a b = 'False + +type family EqBool a b where + EqBool 'True 'True = 'True + EqBool 'False 'False = 'True + EqBool a b = 'False + +type family EqOrdering a b where + EqOrdering 'LT 'LT = 'True + EqOrdering 'EQ 'EQ = 'True + EqOrdering 'GT 'GT = 'True + EqOrdering a b = 'False + +type EqUnit (a :: ()) (b :: ()) = 'True + +type family EqList a b where + EqList '[] '[] = 'True + EqList (h1 ': t1) (h2 ': t2) = (h1 == h2) && (t1 == t2) + EqList a b = 'False + +type family EqMaybe a b where + EqMaybe 'Nothing 'Nothing = 'True + EqMaybe ('Just x) ('Just y) = x == y + EqMaybe a b = 'False + +type family Eq2 a b where + Eq2 '(a1, b1) '(a2, b2) = a1 == a2 && b1 == b2 + +type family Eq3 a b where + Eq3 '(a1, b1, c1) '(a2, b2, c2) = a1 == a2 && b1 == b2 && c1 == c2 + +type family Eq4 a b where + Eq4 '(a1, b1, c1, d1) '(a2, b2, c2, d2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 + +type family Eq5 a b where + Eq5 '(a1, b1, c1, d1, e1) '(a2, b2, c2, d2, e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 + +type family Eq6 a b where + Eq6 '(a1, b1, c1, d1, e1, f1) '(a2, b2, c2, d2, e2, f2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 + +type family Eq7 a b where + Eq7 '(a1, b1, c1, d1, e1, f1, g1) '(a2, b2, c2, d2, e2, f2, g2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 + +type family Eq8 a b where + Eq8 '(a1, b1, c1, d1, e1, f1, g1, h1) '(a2, b2, c2, d2, e2, f2, g2, h2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 + +type family Eq9 a b where + Eq9 '(a1, b1, c1, d1, e1, f1, g1, h1, i1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 + +type family Eq10 a b where + Eq10 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 + +type family Eq11 a b where + Eq11 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 + +type family Eq12 a b where + Eq12 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 + +type family Eq13 a b where + Eq13 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2 + +type family Eq14 a b where + Eq14 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2 && n1 == n2 + +type family Eq15 a b where + Eq15 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2 && n1 == n2 && o1 == o2 + +-- these all look to be overlapping, but they are differentiated by their kinds +type instance a == b = EqStar a b +type instance a == b = EqArrow a b +type instance a == b = EqBool a b +type instance a == b = EqOrdering a b +type instance a == b = EqUnit a b +type instance a == b = EqList a b +type instance a == b = EqMaybe a b +type instance a == b = Eq2 a b +type instance a == b = Eq3 a b +type instance a == b = Eq4 a b +type instance a == b = Eq5 a b +type instance a == b = Eq6 a b +type instance a == b = Eq7 a b +type instance a == b = Eq8 a b +type instance a == b = Eq9 a b +type instance a == b = Eq10 a b +type instance a == b = Eq11 a b +type instance a == b = Eq12 a b +type instance a == b = Eq13 a b +type instance a == b = Eq14 a b +type instance a == b = Eq15 a b diff --git a/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs new file mode 100644 index 0000000..1afc6a9 --- /dev/null +++ b/libraries/base/Data/Typeable.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Typeable +-- Copyright : (c) The University of Glasgow, CWI 2001--2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- The 'Typeable' class reifies types to some extent by associating type +-- representations to types. These type representations can be compared, +-- and one can in turn define a type-safe cast operation. To this end, +-- an unsafe cast is guarded by a test for type (representation) +-- equivalence. The module "Data.Dynamic" uses Typeable for an +-- implementation of dynamics. The module "Data.Data" uses Typeable +-- and type-safe cast (but not dynamics) to support the \"Scrap your +-- boilerplate\" style of generic programming. +-- +-- == Compatibility Notes +-- +-- Since GHC 7.8, 'Typeable' is poly-kinded. The changes required for this might +-- break some old programs involving 'Typeable'. More details on this, including +-- how to fix your code, can be found on the +-- +-- +----------------------------------------------------------------------------- + +module Data.Typeable + ( + -- * The Typeable class + Typeable, + typeRep, + + -- * Propositional equality + (:~:)(Refl), + + -- * For backwards compatibility + typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7, + Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, + Typeable7, + + -- * Type-safe cast + cast, + eqT, + gcast, -- a generalisation of cast + + -- * Generalized casts for higher-order kinds + gcast1, -- :: ... => c (t a) -> Maybe (c (t' a)) + gcast2, -- :: ... => c (t a b) -> Maybe (c (t' a b)) + + -- * A canonical proxy type + Proxy (..), + + -- * Type representations + TypeRep, -- abstract, instance of: Eq, Show, Typeable + typeRepFingerprint, + rnfTypeRep, + showsTypeRep, + + TyCon, -- abstract, instance of: Eq, Show, Typeable + -- For now don't export Module, to avoid name clashes + tyConFingerprint, + tyConString, + tyConPackage, + tyConModule, + tyConName, + rnfTyCon, + + -- * Construction of type representations + -- mkTyCon, -- :: String -> TyCon + mkTyCon3, -- :: String -> String -> String -> TyCon + mkTyConApp, -- :: TyCon -> [TypeRep] -> TypeRep + mkAppTy, -- :: TypeRep -> TypeRep -> TypeRep + mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep + + -- * Observation of type representations + splitTyConApp, -- :: TypeRep -> (TyCon, [TypeRep]) + funResultTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep + typeRepTyCon, -- :: TypeRep -> TyCon + typeRepArgs, -- :: TypeRep -> [TypeRep] + ) where + +import Data.Typeable.Internal +import Data.Type.Equality + +import Unsafe.Coerce +import Data.Maybe +import GHC.Base + +------------------------------------------------------------- +-- +-- Type-safe cast +-- +------------------------------------------------------------- + +-- | The type-safe cast operation +cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b +cast x = if typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy b) + then Just $ unsafeCoerce x + else Nothing + +-- | Extract a witness of equality of two types +-- +-- @since 4.7.0.0 +eqT :: forall a b. (Typeable a, Typeable b) => Maybe (a :~: b) +eqT = if typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy b) + then Just $ unsafeCoerce Refl + else Nothing + +-- | A flexible variation parameterised in a type constructor +gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b) +gcast x = fmap (\Refl -> x) (eqT :: Maybe (a :~: b)) + +-- | Cast over @k1 -> k2@ +gcast1 :: forall c t t' a. (Typeable t, Typeable t') + => c (t a) -> Maybe (c (t' a)) +gcast1 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t')) + +-- | Cast over @k1 -> k2 -> k3@ +gcast2 :: forall c t t' a b. (Typeable t, Typeable t') + => c (t a b) -> Maybe (c (t' a b)) +gcast2 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t')) + diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs new file mode 100644 index 0000000..dfc089f --- /dev/null +++ b/libraries/base/Data/Typeable/Internal.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Typeable.Internal +-- Copyright : (c) The University of Glasgow, CWI 2001--2011 +-- 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 a TyCon. +-- +----------------------------------------------------------------------------- + +module Data.Typeable.Internal ( + Proxy (..), + Fingerprint(..), + + -- * Typeable class + typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7, + Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, Typeable7, + + -- * Module + Module, -- Abstract + moduleName, modulePackage, + + -- * TyCon + TyCon, -- Abstract + tyConPackage, tyConModule, tyConName, tyConString, tyConFingerprint, + mkTyCon3, mkTyCon3#, + rnfTyCon, + + -- * TypeRep + TypeRep(..), KindRep, + typeRep, + mkTyConApp, + mkPolyTyConApp, + mkAppTy, + typeRepTyCon, + Typeable(..), + mkFunTy, + splitTyConApp, + splitPolyTyConApp, + funResultTy, + typeRepArgs, + typeRepFingerprint, + rnfTypeRep, + showsTypeRep, + typeRepKinds, + typeSymbolTypeRep, typeNatTypeRep + ) where + +import GHC.Base +import GHC.Types (TYPE) +import GHC.Word +import GHC.Show +import Data.Proxy +import GHC.TypeLits( KnownNat, KnownSymbol, natVal', symbolVal' ) + +import GHC.Fingerprint.Type +import {-# SOURCE #-} GHC.Fingerprint + -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable + -- Better to break the loop here, because we want non-SOURCE imports + -- of Data.Typeable as much as possible so we can optimise the derived + -- instances. + +#include "MachDeps.h" + +{- ********************************************************************* +* * + The TyCon type +* * +********************************************************************* -} + +modulePackage :: Module -> String +modulePackage (Module p _) = trNameString p + +moduleName :: Module -> String +moduleName (Module _ m) = trNameString m + +tyConPackage :: TyCon -> String +tyConPackage (TyCon _ _ m _) = modulePackage m + +tyConModule :: TyCon -> String +tyConModule (TyCon _ _ m _) = moduleName m + +tyConName :: TyCon -> String +tyConName (TyCon _ _ _ n) = trNameString n + +trNameString :: TrName -> String +trNameString (TrNameS s) = unpackCString# s +trNameString (TrNameD s) = s + +-- | Observe string encoding of a type representation +{-# DEPRECATED tyConString "renamed to 'tyConName'; 'tyConModule' and 'tyConPackage' are also available." #-} +-- deprecated in 7.4 +tyConString :: TyCon -> String +tyConString = tyConName + +tyConFingerprint :: TyCon -> Fingerprint +tyConFingerprint (TyCon hi lo _ _) + = Fingerprint (W64# hi) (W64# lo) + +mkTyCon3# :: Addr# -- ^ package name + -> Addr# -- ^ module name + -> Addr# -- ^ the name of the type constructor + -> TyCon -- ^ A unique 'TyCon' object +mkTyCon3# pkg modl name + | Fingerprint (W64# hi) (W64# lo) <- fingerprint + = TyCon hi lo (Module (TrNameS pkg) (TrNameS modl)) (TrNameS name) + where + fingerprint :: Fingerprint + fingerprint = fingerprintString (unpackCString# pkg + ++ (' ': unpackCString# modl) + ++ (' ' : unpackCString# name)) + +mkTyCon3 :: String -- ^ package name + -> String -- ^ module name + -> String -- ^ the name of the type constructor + -> TyCon -- ^ A unique 'TyCon' object +-- Used when the strings are dynamically allocated, +-- eg from binary deserialisation +mkTyCon3 pkg modl name + | Fingerprint (W64# hi) (W64# lo) <- fingerprint + = TyCon hi lo (Module (TrNameD pkg) (TrNameD modl)) (TrNameD name) + where + fingerprint :: Fingerprint + fingerprint = fingerprintString (pkg ++ (' ':modl) ++ (' ':name)) + +isTupleTyCon :: TyCon -> Bool +isTupleTyCon tc + | ('(':',':_) <- tyConName tc = True + | otherwise = False + +-- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation +-- +-- @since 4.8.0.0 +rnfModule :: Module -> () +rnfModule (Module p m) = rnfTrName p `seq` rnfTrName m + +rnfTrName :: TrName -> () +rnfTrName (TrNameS _) = () +rnfTrName (TrNameD n) = rnfString n + +rnfTyCon :: TyCon -> () +rnfTyCon (TyCon _ _ m n) = rnfModule m `seq` rnfTrName n + +rnfString :: [Char] -> () +rnfString [] = () +rnfString (c:cs) = c `seq` rnfString cs + + +{- ********************************************************************* +* * + The TypeRep type +* * +********************************************************************* -} + +-- | A concrete representation of a (monomorphic) type. +-- 'TypeRep' supports reasonably efficient equality. +data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [KindRep] [TypeRep] + -- NB: For now I've made this lazy so that it's easy to + -- optimise code that constructs and deconstructs TypeReps + -- perf/should_run/T9203 is a good example + -- Also note that mkAppTy does discards the fingerprint, + -- so it's a waste to compute it + +type KindRep = TypeRep + +-- Compare keys for equality +instance Eq TypeRep where + TypeRep x _ _ _ == TypeRep y _ _ _ = x == y + +instance Ord TypeRep where + TypeRep x _ _ _ <= TypeRep y _ _ _ = x <= y + +-- | Observe the 'Fingerprint' of a type representation +-- +-- @since 4.8.0.0 +typeRepFingerprint :: TypeRep -> Fingerprint +typeRepFingerprint (TypeRep fpr _ _ _) = fpr + +-- | Applies a kind-polymorphic type constructor to a sequence of kinds and +-- types +mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep +{-# INLINE mkPolyTyConApp #-} +mkPolyTyConApp tc kinds types + = TypeRep (fingerprintFingerprints sub_fps) tc kinds types + where + !kt_fps = typeRepFingerprints kinds types + sub_fps = tyConFingerprint tc : kt_fps + +typeRepFingerprints :: [KindRep] -> [TypeRep] -> [Fingerprint] +-- Builds no thunks +typeRepFingerprints kinds types + = go1 [] kinds + where + go1 acc [] = go2 acc types + go1 acc (k:ks) = let !fp = typeRepFingerprint k + in go1 (fp:acc) ks + go2 acc [] = acc + go2 acc (t:ts) = let !fp = typeRepFingerprint t + in go2 (fp:acc) ts + +-- | Applies a kind-monomorphic type constructor to a sequence of types +mkTyConApp :: TyCon -> [TypeRep] -> TypeRep +mkTyConApp tc = mkPolyTyConApp tc [] + +-- | A special case of 'mkTyConApp', which applies the function +-- type constructor to a pair of types. +mkFunTy :: TypeRep -> TypeRep -> TypeRep +mkFunTy f a = mkTyConApp tcFun [f,a] + +-- | Splits a type constructor application. +-- Note that if the type constructor is polymorphic, this will +-- not return the kinds that were used. +-- See 'splitPolyTyConApp' if you need all parts. +splitTyConApp :: TypeRep -> (TyCon,[TypeRep]) +splitTyConApp (TypeRep _ tc _ trs) = (tc,trs) + +-- | Split a type constructor application +splitPolyTyConApp :: TypeRep -> (TyCon,[KindRep],[TypeRep]) +splitPolyTyConApp (TypeRep _ tc ks trs) = (tc,ks,trs) + +-- | Applies a type to a function type. Returns: @'Just' u@ if the +-- first argument represents a function of type @t -> u@ and the +-- second argument represents a function of type @t@. Otherwise, +-- returns 'Nothing'. +funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep +funResultTy trFun trArg + = case splitTyConApp trFun of + (tc, [t1,t2]) | tc == tcFun && t1 == trArg -> Just t2 + _ -> Nothing + +tyConOf :: Typeable a => Proxy a -> TyCon +tyConOf = typeRepTyCon . typeRep + +tcFun :: TyCon +tcFun = tyConOf (Proxy :: Proxy (Int -> Int)) + +-- | Adds a TypeRep argument to a TypeRep. +mkAppTy :: TypeRep -> TypeRep -> TypeRep +{-# INLINE mkAppTy #-} +mkAppTy (TypeRep _ tc ks trs) arg_tr = mkPolyTyConApp tc ks (trs ++ [arg_tr]) + -- Notice that we call mkTyConApp to construct the fingerprint from tc and + -- the arg fingerprints. Simply combining the current fingerprint with + -- the new one won't give the same answer, but of course we want to + -- ensure that a TypeRep of the same shape has the same fingerprint! + -- See Trac #5962 + +----------------- Observation --------------------- + +-- | Observe the type constructor of a type representation +typeRepTyCon :: TypeRep -> TyCon +typeRepTyCon (TypeRep _ tc _ _) = tc + +-- | Observe the argument types of a type representation +typeRepArgs :: TypeRep -> [TypeRep] +typeRepArgs (TypeRep _ _ _ tys) = tys + +-- | Observe the argument kinds of a type representation +typeRepKinds :: TypeRep -> [KindRep] +typeRepKinds (TypeRep _ _ ks _) = ks + + +{- ********************************************************************* +* * + The Typeable class +* * +********************************************************************* -} + +------------------------------------------------------------- +-- +-- The Typeable class and friends +-- +------------------------------------------------------------- + +-- | The class 'Typeable' allows a concrete representation of a type to +-- be calculated. +class Typeable a where + typeRep# :: Proxy# a -> TypeRep + +-- | Takes a value of type @a@ and returns a concrete representation +-- of that type. +-- +-- @since 4.7.0.0 +typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep +typeRep _ = typeRep# (proxy# :: Proxy# a) +{-# INLINE typeRep #-} + +-- Keeping backwards-compatibility +typeOf :: forall a. Typeable a => a -> TypeRep +typeOf _ = typeRep (Proxy :: Proxy a) + +typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep +typeOf1 _ = typeRep (Proxy :: Proxy t) + +typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep +typeOf2 _ = typeRep (Proxy :: Proxy t) + +typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t + => t a b c -> TypeRep +typeOf3 _ = typeRep (Proxy :: Proxy t) + +typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t + => t a b c d -> TypeRep +typeOf4 _ = typeRep (Proxy :: Proxy t) + +typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t + => t a b c d e -> TypeRep +typeOf5 _ = typeRep (Proxy :: Proxy t) + +typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *). + Typeable t => t a b c d e f -> TypeRep +typeOf6 _ = typeRep (Proxy :: Proxy t) + +typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *) + (g :: *). Typeable t => t a b c d e f g -> TypeRep +typeOf7 _ = typeRep (Proxy :: Proxy t) + +type Typeable1 (a :: * -> *) = Typeable a +type Typeable2 (a :: * -> * -> *) = Typeable a +type Typeable3 (a :: * -> * -> * -> *) = Typeable a +type Typeable4 (a :: * -> * -> * -> * -> *) = Typeable a +type Typeable5 (a :: * -> * -> * -> * -> * -> *) = Typeable a +type Typeable6 (a :: * -> * -> * -> * -> * -> * -> *) = Typeable a +type Typeable7 (a :: * -> * -> * -> * -> * -> * -> * -> *) = Typeable a + +{-# DEPRECATED Typeable1 "renamed to 'Typeable'" #-} -- deprecated in 7.8 +{-# DEPRECATED Typeable2 "renamed to 'Typeable'" #-} -- deprecated in 7.8 +{-# DEPRECATED Typeable3 "renamed to 'Typeable'" #-} -- deprecated in 7.8 +{-# DEPRECATED Typeable4 "renamed to 'Typeable'" #-} -- deprecated in 7.8 +{-# DEPRECATED Typeable5 "renamed to 'Typeable'" #-} -- deprecated in 7.8 +{-# DEPRECATED Typeable6 "renamed to 'Typeable'" #-} -- deprecated in 7.8 +{-# DEPRECATED Typeable7 "renamed to 'Typeable'" #-} -- deprecated in 7.8 + + +----------------- Showing TypeReps -------------------- + +instance Show TypeRep where + showsPrec p (TypeRep _ tycon kinds tys) = + case tys of + [] -> showsPrec p tycon + [x] + | tycon == tcList -> showChar '[' . shows x . showChar ']' + where + tcList = tyConOf @[] Proxy + [TypeRep _ ptrRepCon _ []] + | tycon == tcTYPE && ptrRepCon == tc'PtrRepLifted + -> showChar '*' + | tycon == tcTYPE && ptrRepCon == tc'PtrRepUnlifted + -> showChar '#' + where + tcTYPE = tyConOf @TYPE Proxy + tc'PtrRepLifted = tyConOf @'PtrRepLifted Proxy + tc'PtrRepUnlifted = tyConOf @'PtrRepUnlifted Proxy + [a,r] | tycon == tcFun -> showParen (p > 8) $ + showsPrec 9 a . + showString " -> " . + showsPrec 8 r + xs | isTupleTyCon tycon -> showTuple xs + | otherwise -> + showParen (p > 9) $ + showsPrec p tycon . + showChar ' ' . + showArgs (showChar ' ') (kinds ++ tys) + +showsTypeRep :: TypeRep -> ShowS +showsTypeRep = shows + +-- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation +-- +-- @since 4.8.0.0 +rnfTypeRep :: TypeRep -> () +rnfTypeRep (TypeRep _ tyc krs tyrs) = rnfTyCon tyc `seq` go krs `seq` go tyrs + where + go [] = () + go (x:xs) = rnfTypeRep x `seq` go xs + +-- Some (Show.TypeRep) helpers: + +showArgs :: Show a => ShowS -> [a] -> ShowS +showArgs _ [] = id +showArgs _ [a] = showsPrec 10 a +showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as + +showTuple :: [TypeRep] -> ShowS +showTuple args = showChar '(' + . showArgs (showChar ',') args + . showChar ')' + +{- ********************************************************* +* * +* TyCon/TypeRep definitions for type literals * +* (Symbol and Nat) * +* * +********************************************************* -} + + +mkTypeLitTyCon :: String -> TyCon +mkTypeLitTyCon name = mkTyCon3 "base" "GHC.TypeLits" name + +-- | Used to make `'Typeable' instance for things of kind Nat +typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep +typeNatTypeRep p = typeLitTypeRep (show (natVal' p)) + +-- | Used to make `'Typeable' instance for things of kind Symbol +typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep +typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p)) + +-- | An internal function, to make representations for type literals. +typeLitTypeRep :: String -> TypeRep +typeLitTypeRep nm = mkTyConApp (mkTypeLitTyCon nm) [] diff --git a/libraries/base/Data/Unique.hs b/libraries/base/Data/Unique.hs new file mode 100644 index 0000000..2db9247 --- /dev/null +++ b/libraries/base/Data/Unique.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Unique +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- An abstract interface to a unique symbol generator. +-- +----------------------------------------------------------------------------- + +module Data.Unique ( + -- * Unique objects + Unique, + newUnique, + hashUnique + ) where + +import System.IO.Unsafe (unsafePerformIO) + +import GHC.Base +import GHC.Num +import Data.IORef + +-- | An abstract unique object. Objects of type 'Unique' may be +-- compared for equality and ordering and hashed into 'Int'. +newtype Unique = Unique Integer deriving (Eq,Ord) + +uniqSource :: IORef Integer +uniqSource = unsafePerformIO (newIORef 0) +{-# NOINLINE uniqSource #-} + +-- | Creates a new object of type 'Unique'. The value returned will +-- not compare equal to any other value of type 'Unique' returned by +-- previous calls to 'newUnique'. There is no limit on the number of +-- times 'newUnique' may be called. +newUnique :: IO Unique +newUnique = do + r <- atomicModifyIORef' uniqSource $ \x -> let z = x+1 in (z,z) + return (Unique r) + +-- SDM (18/3/2010): changed from MVar to STM. This fixes +-- 1. there was no async exception protection +-- 2. there was a space leak (now new value is strict) +-- 3. using atomicModifyIORef would be slightly quicker, but can +-- suffer from adverse scheduling issues (see #3838) +-- 4. also, the STM version is faster. + +-- SDM (30/4/2012): changed to IORef using atomicModifyIORef. Reasons: +-- 1. STM version could not be used inside unsafePerformIO, if it +-- happened to be poked inside an STM transaction. +-- 2. IORef version can be used with unsafeIOToSTM inside STM, +-- because if the transaction retries then we just get a new +-- Unique. +-- 3. IORef version is very slightly faster. + +-- IGL (08/06/2013): changed to using atomicModifyIORef' instead. +-- This feels a little safer, from the point of view of not leaking +-- memory, but the resulting core is identical. + +-- | Hashes a 'Unique' into an 'Int'. Two 'Unique's may hash to the +-- same value, although in practice this is unlikely. The 'Int' +-- returned makes a good hash key. +hashUnique :: Unique -> Int +hashUnique (Unique i) = I# (hashInteger i) diff --git a/libraries/base/Data/Version.hs b/libraries/base/Data/Version.hs new file mode 100644 index 0000000..6738ca8 --- /dev/null +++ b/libraries/base/Data/Version.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Version +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (local universal quantification in ReadP) +-- +-- A general library 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 Data.Functor ( Functor(..) ) +import Control.Applicative ( Applicative(..) ) +import Data.Bool ( (&&) ) +import Data.Char ( isDigit, isAlphaNum ) +import Data.Eq +import Data.Int ( Int ) +import Data.List +import Data.Ord +import Data.String ( String ) +import GHC.Generics +import GHC.Read +import GHC.Show +import Text.ParserCombinators.ReadP +import Text.Read ( read ) + +{- | +A 'Version' represents the version of a software entity. + +An instance of 'Eq' is provided, which implements exact equality +modulo reordering of the tags in the 'versionTags' field. + +An instance of 'Ord' is also provided, which gives lexicographic +ordering on the 'versionBranch' fields (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2, +etc.). This is expected to be sufficient for many uses, but note that +you may need to use a more specific ordering for your versioning +scheme. For example, some versioning schemes may include pre-releases +which have tags @\"pre1\"@, @\"pre2\"@, and so on, and these would need to +be taken into account when determining ordering. In some cases, date +ordering may be more appropriate, so the application would have to +look for @date@ tags in the 'versionTags' field and compare those. +The bottom line is, don't always assume that 'compare' and other 'Ord' +operations are the right thing for every 'Version'. + +Similarly, concrete representations of versions may differ. One +possible concrete representation is provided (see 'showVersion' and +'parseVersion'), but depending on the application a different concrete +representation may be more appropriate. +-} +data Version = + Version { versionBranch :: [Int], + -- ^ The numeric branch for this version. This reflects the + -- fact that most software versions are tree-structured; there + -- is a main trunk which is tagged with versions at various + -- points (1,2,3...), and the first branch off the trunk after + -- version 3 is 3.1, the second branch off the trunk after + -- version 3 is 3.2, and so on. The tree can be branched + -- arbitrarily, just by adding more digits. + -- + -- We represent the branch as a list of 'Int', so + -- version 3.2.1 becomes [3,2,1]. Lexicographic ordering + -- (i.e. the default instance of 'Ord' for @[Int]@) gives + -- the natural ordering of branches. + + versionTags :: [String] -- really a bag + -- ^ A version can be tagged with an arbitrary list of strings. + -- The interpretation of the list of tags is entirely dependent + -- on the entity that this version applies to. + } + deriving (Read,Show,Generic) +{-# DEPRECATED versionTags "See GHC ticket #2496" #-} +-- TODO. Remove all references to versionTags in GHC 8.0 release. + +instance Eq Version where + v1 == v2 = versionBranch v1 == versionBranch v2 + && sort (versionTags v1) == sort (versionTags v2) + -- tags may be in any order + +instance Ord Version where + v1 `compare` v2 = versionBranch v1 `compare` versionBranch v2 + +-- ----------------------------------------------------------------------------- +-- A concrete representation of 'Version' + +-- | Provides one possible concrete representation for 'Version'. For +-- a version with 'versionBranch' @= [1,2,3]@ and 'versionTags' +-- @= [\"tag1\",\"tag2\"]@, the output will be @1.2.3-tag1-tag2@. +-- +showVersion :: Version -> String +showVersion (Version branch tags) + = concat (intersperse "." (map show branch)) ++ + concatMap ('-':) tags + +-- | A parser for versions in the format produced by 'showVersion'. +-- +parseVersion :: ReadP Version +parseVersion = do branch <- sepBy1 (fmap read (munch1 isDigit)) (char '.') + tags <- many (char '-' *> munch1 isAlphaNum) + pure Version{versionBranch=branch, versionTags=tags} + +-- | Construct tag-less 'Version' +-- +-- @since 4.8.0.0 +makeVersion :: [Int] -> Version +makeVersion b = Version b [] diff --git a/libraries/base/Data/Void.hs b/libraries/base/Data/Void.hs new file mode 100644 index 0000000..55ebd7e --- /dev/null +++ b/libraries/base/Data/Void.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- 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 Control.Exception +import Data.Data +import Data.Ix +import GHC.Generics + +-- | Uninhabited data type +-- +-- @since 4.8.0.0 +data Void deriving (Generic) + +deriving instance Data Void + +instance Eq Void where + _ == _ = True + +instance Ord Void where + compare _ _ = EQ + +-- | Reading a 'Void' value is always a parse error, considering +-- 'Void' as a data type with no constructors. +instance Read Void where + readsPrec _ _ = [] + +instance Show Void where + showsPrec _ = absurd + +instance Ix Void where + range _ = [] + index _ = absurd + inRange _ = absurd + rangeSize _ = 0 + +instance Exception Void + +-- | Since 'Void' values logically don't exist, this witnesses the +-- logical reasoning tool of \"ex falso quodlibet\". +-- +-- @since 4.8.0.0 +absurd :: Void -> a +absurd a = case a of {} + +-- | If 'Void' is uninhabited then any 'Functor' that holds only +-- values of type 'Void' is holding no values. +-- +-- @since 4.8.0.0 +vacuous :: Functor f => f Void -> f a +vacuous = fmap absurd diff --git a/libraries/base/Data/Word.hs b/libraries/base/Data/Word.hs new file mode 100644 index 0000000..f20844f --- /dev/null +++ b/libraries/base/Data/Word.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Word +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Unsigned integer types. +-- +----------------------------------------------------------------------------- + +module Data.Word + ( + -- * Unsigned integral types + + Word, + Word8, Word16, Word32, Word64, + + -- * byte swapping + byteSwap16, byteSwap32, byteSwap64, + + -- * Notes + + -- $notes + ) where + +import GHC.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/libraries/base/Debug/Trace.hs b/libraries/base/Debug/Trace.hs new file mode 100644 index 0000000..40475d3 --- /dev/null +++ b/libraries/base/Debug/Trace.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE UnboxedTuples #-} + +----------------------------------------------------------------------------- +-- | +-- 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, + traceStack, + traceIO, + traceM, + traceShowM, + putTraceMsg, + + -- * Eventlog tracing + -- $eventlog_tracing + traceEvent, + traceEventIO, + + -- * Execution phase markers + -- $markers + traceMarker, + traceMarkerIO, + ) where + +import System.IO.Unsafe + +import Foreign.C.String +import GHC.Base +import qualified GHC.Foreign +import GHC.IO.Encoding +import GHC.Ptr +import GHC.Show +import GHC.Stack +import Data.List + +-- $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 '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. + +-- | The 'traceIO' function outputs the trace message from the IO monad. +-- This sequences the output with respect to other IO actions. +-- +-- @since 4.5.0.0 +traceIO :: String -> IO () +traceIO msg = do + withCString "%s\n" $ \cfmt -> do + -- NB: debugBelch can't deal with null bytes, so filter them + -- out so we don't accidentally truncate the message. See Trac #9395 + let (nulls, msg') = partition (=='\0') msg + withCString msg' $ \cmsg -> + debugBelch cfmt cmsg + when (not (null nulls)) $ + withCString "WARNING: previous trace message had null bytes" $ \cmsg -> + debugBelch cfmt cmsg + +-- don't use debugBelch() directly, because we cannot call varargs functions +-- using the FFI. +foreign import ccall unsafe "HsBase.h debugBelch2" + debugBelch :: CString -> CString -> IO () + +-- | +putTraceMsg :: String -> IO () +putTraceMsg = traceIO +{-# DEPRECATED putTraceMsg "Use 'Debug.Trace.traceIO'" #-} -- deprecated in 7.4 + + +{-# NOINLINE trace #-} +{-| +The 'trace' function outputs the trace message given as its first argument, +before returning the second argument as its result. + +For example, this returns the value of @f x@ but first outputs the message. + +> trace ("calling f with x = " ++ show x) (f x) + +The 'trace' function should /only/ be used for debugging, or for monitoring +execution. The function is not referentially transparent: its type indicates +that it is a pure function but it has the side effect of outputting the +trace message. +-} +trace :: String -> a -> a +trace string expr = unsafePerformIO $ do + traceIO string + return expr + +{-| +Like 'trace' but returns the message instead of a third value. + +@since 4.7.0.0 +-} +traceId :: String -> String +traceId a = trace a a + +{-| +Like 'trace', but uses 'show' on the argument to convert it to a 'String'. + +This makes it convenient for printing the values of interesting variables or +expressions inside a function. For example here we print the value of the +variables @x@ and @z@: + +> f x y = +> traceShow (x, z) $ result +> where +> z = ... +> ... +-} +traceShow :: (Show a) => a -> b -> b +traceShow = trace . show + +{-| +Like 'traceShow' but returns the shown value instead of a third value. + +@since 4.7.0.0 +-} +traceShowId :: (Show a) => a -> a +traceShowId a = trace (show a) a + +{-| +Like 'trace' but returning unit in an arbitrary 'Applicative' context. Allows +for convenient use in do-notation. + +Note that the application of 'traceM' is not an action in the 'Applicative' +context, as 'traceIO' is in the 'IO' type. While the fresh bindings in the +following example will force the 'traceM' expressions to be reduced every time +the @do@-block is executed, @traceM "not crashed"@ would only be reduced once, +and the message would only be printed once. If your monad is in 'MonadIO', +@liftIO . traceIO@ may be a better option. + +> ... = do +> x <- ... +> traceM $ "x: " ++ show x +> y <- ... +> traceM $ "y: " ++ show y + +@since 4.7.0.0 +-} +traceM :: (Applicative f) => String -> f () +traceM string = trace string $ pure () + +{-| +Like 'traceM', but uses 'show' on the argument to convert it to a 'String'. + +> ... = do +> x <- ... +> traceShowM $ x +> y <- ... +> traceShowM $ x + y + +@since 4.7.0.0 +-} +traceShowM :: (Show a, Applicative f) => a -> f () +traceShowM = traceM . show + +-- | like 'trace', but additionally prints a call stack if one is +-- available. +-- +-- In the current GHC implementation, the call stack is only +-- available if the program was compiled with @-prof@; otherwise +-- 'traceStack' behaves exactly like 'trace'. Entries in the call +-- stack correspond to @SCC@ annotations, so it is a good idea to use +-- @-fprof-auto@ or @-fprof-auto-calls@ to add SCC annotations automatically. +-- +-- @since 4.5.0.0 +traceStack :: String -> a -> a +traceStack str expr = unsafePerformIO $ do + traceIO str + stack <- currentCallStack + when (not (null stack)) $ traceIO (renderStack stack) + return expr + + +-- $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. + +{-# NOINLINE traceEvent #-} +-- | The 'traceEvent' function behaves like 'trace' with the difference that +-- the message is emitted to the eventlog, if eventlog profiling is available +-- and enabled at runtime. +-- +-- It is suitable for use in pure code. In an IO context use 'traceEventIO' +-- instead. +-- +-- Note that when using GHC's SMP runtime, it is possible (but rare) to get +-- duplicate events emitted if two CPUs simultaneously evaluate the same thunk +-- that uses 'traceEvent'. +-- +-- @since 4.5.0.0 +traceEvent :: String -> a -> a +traceEvent msg expr = unsafeDupablePerformIO $ do + traceEventIO msg + return expr + +-- | The 'traceEventIO' function emits a message to the eventlog, if eventlog +-- profiling is available and enabled at runtime. +-- +-- Compared to 'traceEvent', 'traceEventIO' sequences the event with respect to +-- other IO actions. +-- +-- @since 4.5.0.0 +traceEventIO :: String -> IO () +traceEventIO msg = + GHC.Foreign.withCString utf8 msg $ \(Ptr p) -> IO $ \s -> + case traceEvent# p s of s' -> (# s', () #) + +-- $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. + +{-# NOINLINE traceMarker #-} +-- | The 'traceMarker' function emits a marker to the eventlog, if eventlog +-- profiling is available and enabled at runtime. The @String@ is the name of +-- the marker. The name is just used in the profiling tools to help you keep +-- clear which marker is which. +-- +-- This function is suitable for use in pure code. In an IO context use +-- 'traceMarkerIO' instead. +-- +-- Note that when using GHC's SMP runtime, it is possible (but rare) to get +-- duplicate events emitted if two CPUs simultaneously evaluate the same thunk +-- that uses 'traceMarker'. +-- +-- @since 4.7.0.0 +traceMarker :: String -> a -> a +traceMarker msg expr = unsafeDupablePerformIO $ do + traceMarkerIO msg + return expr + +-- | The 'traceMarkerIO' function emits a marker to the eventlog, if eventlog +-- profiling is available and enabled at runtime. +-- +-- Compared to 'traceMarker', 'traceMarkerIO' sequences the event with respect to +-- other IO actions. +-- +-- @since 4.7.0.0 +traceMarkerIO :: String -> IO () +traceMarkerIO msg = + GHC.Foreign.withCString utf8 msg $ \(Ptr p) -> IO $ \s -> + case traceMarker# p s of s' -> (# s', () #) diff --git a/libraries/base/Foreign.hs b/libraries/base/Foreign.hs new file mode 100644 index 0000000..b25e456 --- /dev/null +++ b/libraries/base/Foreign.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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/libraries/base/Foreign/C.hs b/libraries/base/Foreign/C.hs new file mode 100644 index 0000000..83ab6b8 --- /dev/null +++ b/libraries/base/Foreign/C.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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/libraries/base/Foreign/C/Error.hs b/libraries/base/Foreign/C/Error.hs new file mode 100644 index 0000000..7614351 --- /dev/null +++ b/libraries/base/Foreign/C/Error.hs @@ -0,0 +1,575 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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, + + -- access to the current thread's "errno" value + -- + getErrno, + resetErrno, + + -- conversion of an "errno" value into IO error + -- + errnoToIOError, + + -- throw current "errno" value + -- + 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 + + +-- this is were we get the CONST_XXX definitions from that configure +-- calculated for us +-- +#include "HsBaseConfig.h" + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String +import Data.Functor ( void ) +import Data.Maybe + +import GHC.IO +import GHC.IO.Exception +import GHC.IO.Handle.Types +import GHC.Num +import GHC.Base + +-- "errno" type +-- ------------ + +-- | Haskell representation for @errno@ values. +-- The implementation is deliberately exposed, to allow users to add +-- their own definitions of 'Errno' values. + +newtype Errno = Errno CInt + +instance Eq Errno where + errno1@(Errno no1) == errno2@(Errno no2) + | isValidErrno errno1 && isValidErrno errno2 = no1 == no2 + | otherwise = False + +-- common "errno" symbols +-- +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 +-- +-- the cCONST_XXX identifiers are cpp symbols whose value is computed by +-- configure +-- +eOK = Errno 0 +e2BIG = Errno (CONST_E2BIG) +eACCES = Errno (CONST_EACCES) +eADDRINUSE = Errno (CONST_EADDRINUSE) +eADDRNOTAVAIL = Errno (CONST_EADDRNOTAVAIL) +eADV = Errno (CONST_EADV) +eAFNOSUPPORT = Errno (CONST_EAFNOSUPPORT) +eAGAIN = Errno (CONST_EAGAIN) +eALREADY = Errno (CONST_EALREADY) +eBADF = Errno (CONST_EBADF) +eBADMSG = Errno (CONST_EBADMSG) +eBADRPC = Errno (CONST_EBADRPC) +eBUSY = Errno (CONST_EBUSY) +eCHILD = Errno (CONST_ECHILD) +eCOMM = Errno (CONST_ECOMM) +eCONNABORTED = Errno (CONST_ECONNABORTED) +eCONNREFUSED = Errno (CONST_ECONNREFUSED) +eCONNRESET = Errno (CONST_ECONNRESET) +eDEADLK = Errno (CONST_EDEADLK) +eDESTADDRREQ = Errno (CONST_EDESTADDRREQ) +eDIRTY = Errno (CONST_EDIRTY) +eDOM = Errno (CONST_EDOM) +eDQUOT = Errno (CONST_EDQUOT) +eEXIST = Errno (CONST_EEXIST) +eFAULT = Errno (CONST_EFAULT) +eFBIG = Errno (CONST_EFBIG) +eFTYPE = Errno (CONST_EFTYPE) +eHOSTDOWN = Errno (CONST_EHOSTDOWN) +eHOSTUNREACH = Errno (CONST_EHOSTUNREACH) +eIDRM = Errno (CONST_EIDRM) +eILSEQ = Errno (CONST_EILSEQ) +eINPROGRESS = Errno (CONST_EINPROGRESS) +eINTR = Errno (CONST_EINTR) +eINVAL = Errno (CONST_EINVAL) +eIO = Errno (CONST_EIO) +eISCONN = Errno (CONST_EISCONN) +eISDIR = Errno (CONST_EISDIR) +eLOOP = Errno (CONST_ELOOP) +eMFILE = Errno (CONST_EMFILE) +eMLINK = Errno (CONST_EMLINK) +eMSGSIZE = Errno (CONST_EMSGSIZE) +eMULTIHOP = Errno (CONST_EMULTIHOP) +eNAMETOOLONG = Errno (CONST_ENAMETOOLONG) +eNETDOWN = Errno (CONST_ENETDOWN) +eNETRESET = Errno (CONST_ENETRESET) +eNETUNREACH = Errno (CONST_ENETUNREACH) +eNFILE = Errno (CONST_ENFILE) +eNOBUFS = Errno (CONST_ENOBUFS) +eNODATA = Errno (CONST_ENODATA) +eNODEV = Errno (CONST_ENODEV) +eNOENT = Errno (CONST_ENOENT) +eNOEXEC = Errno (CONST_ENOEXEC) +eNOLCK = Errno (CONST_ENOLCK) +eNOLINK = Errno (CONST_ENOLINK) +eNOMEM = Errno (CONST_ENOMEM) +eNOMSG = Errno (CONST_ENOMSG) +eNONET = Errno (CONST_ENONET) +eNOPROTOOPT = Errno (CONST_ENOPROTOOPT) +eNOSPC = Errno (CONST_ENOSPC) +eNOSR = Errno (CONST_ENOSR) +eNOSTR = Errno (CONST_ENOSTR) +eNOSYS = Errno (CONST_ENOSYS) +eNOTBLK = Errno (CONST_ENOTBLK) +eNOTCONN = Errno (CONST_ENOTCONN) +eNOTDIR = Errno (CONST_ENOTDIR) +eNOTEMPTY = Errno (CONST_ENOTEMPTY) +eNOTSOCK = Errno (CONST_ENOTSOCK) +eNOTSUP = Errno (CONST_ENOTSUP) +-- ^ @since 4.7.0.0 +eNOTTY = Errno (CONST_ENOTTY) +eNXIO = Errno (CONST_ENXIO) +eOPNOTSUPP = Errno (CONST_EOPNOTSUPP) +ePERM = Errno (CONST_EPERM) +ePFNOSUPPORT = Errno (CONST_EPFNOSUPPORT) +ePIPE = Errno (CONST_EPIPE) +ePROCLIM = Errno (CONST_EPROCLIM) +ePROCUNAVAIL = Errno (CONST_EPROCUNAVAIL) +ePROGMISMATCH = Errno (CONST_EPROGMISMATCH) +ePROGUNAVAIL = Errno (CONST_EPROGUNAVAIL) +ePROTO = Errno (CONST_EPROTO) +ePROTONOSUPPORT = Errno (CONST_EPROTONOSUPPORT) +ePROTOTYPE = Errno (CONST_EPROTOTYPE) +eRANGE = Errno (CONST_ERANGE) +eREMCHG = Errno (CONST_EREMCHG) +eREMOTE = Errno (CONST_EREMOTE) +eROFS = Errno (CONST_EROFS) +eRPCMISMATCH = Errno (CONST_ERPCMISMATCH) +eRREMOTE = Errno (CONST_ERREMOTE) +eSHUTDOWN = Errno (CONST_ESHUTDOWN) +eSOCKTNOSUPPORT = Errno (CONST_ESOCKTNOSUPPORT) +eSPIPE = Errno (CONST_ESPIPE) +eSRCH = Errno (CONST_ESRCH) +eSRMNT = Errno (CONST_ESRMNT) +eSTALE = Errno (CONST_ESTALE) +eTIME = Errno (CONST_ETIME) +eTIMEDOUT = Errno (CONST_ETIMEDOUT) +eTOOMANYREFS = Errno (CONST_ETOOMANYREFS) +eTXTBSY = Errno (CONST_ETXTBSY) +eUSERS = Errno (CONST_EUSERS) +eWOULDBLOCK = Errno (CONST_EWOULDBLOCK) +eXDEV = Errno (CONST_EXDEV) + +-- | Yield 'True' if the given 'Errno' value is valid on the system. +-- This implies that the 'Eq' instance of 'Errno' is also system dependent +-- as it is only defined for valid values of 'Errno'. +-- +isValidErrno :: Errno -> Bool +-- +-- the configure script sets all invalid "errno"s to -1 +-- +isValidErrno (Errno errno) = errno /= -1 + + +-- access to the current thread's "errno" value +-- -------------------------------------------- + +-- | Get the current value of @errno@ in the current thread. +-- +getErrno :: IO Errno + +-- We must call a C function to get the value of errno in general. On +-- threaded systems, errno is hidden behind a C macro so that each OS +-- thread gets its own copy. +getErrno = do e <- get_errno; return (Errno e) +foreign import ccall unsafe "HsBase.h __hscore_get_errno" get_errno :: IO CInt + +-- | Reset the current thread\'s @errno@ value to 'eOK'. +-- +resetErrno :: IO () + +-- Again, setting errno has to be done via a C function. +resetErrno = set_errno 0 +foreign import ccall unsafe "HsBase.h __hscore_set_errno" set_errno :: CInt -> IO () + +-- throw current "errno" value +-- --------------------------- + +-- | Throw an 'IOError' corresponding to the current value of 'getErrno'. +-- +throwErrno :: String -- ^ textual description of the error location + -> IO a +throwErrno loc = + do + errno <- getErrno + ioError (errnoToIOError loc errno Nothing Nothing) + + +-- guards for IO operations that may fail +-- -------------------------------------- + +-- | Throw an 'IOError' corresponding to the current value of 'getErrno' +-- if the result value of the 'IO' action meets the given predicate. +-- +throwErrnoIf :: (a -> Bool) -- ^ predicate to apply to the result value + -- of the 'IO' operation + -> String -- ^ textual description of the location + -> IO a -- ^ the 'IO' operation to be executed + -> IO a +throwErrnoIf pred loc f = + do + res <- f + if pred res then throwErrno loc else return res + +-- | as 'throwErrnoIf', but discards the result of the 'IO' action after +-- error handling. +-- +throwErrnoIf_ :: (a -> Bool) -> String -> IO a -> IO () +throwErrnoIf_ pred loc f = void $ throwErrnoIf pred loc f + +-- | as 'throwErrnoIf', but retry the 'IO' action when it yields the +-- error code 'eINTR' - this amounts to the standard retry loop for +-- interrupted POSIX system calls. +-- +throwErrnoIfRetry :: (a -> Bool) -> String -> IO a -> IO a +throwErrnoIfRetry pred loc f = + do + res <- f + if pred res + then do + err <- getErrno + if err == eINTR + then throwErrnoIfRetry pred loc f + else throwErrno loc + else return res + +-- | as 'throwErrnoIfRetry', but additionally if the operation +-- yields the error code 'eAGAIN' or 'eWOULDBLOCK', an alternative +-- action is executed before retrying. +-- +throwErrnoIfRetryMayBlock + :: (a -> Bool) -- ^ predicate to apply to the result value + -- of the 'IO' operation + -> String -- ^ textual description of the location + -> IO a -- ^ the 'IO' operation to be executed + -> IO b -- ^ action to execute before retrying if + -- an immediate retry would block + -> IO a +throwErrnoIfRetryMayBlock pred loc f on_block = + do + res <- f + if pred res + then do + err <- getErrno + if err == eINTR + then throwErrnoIfRetryMayBlock pred loc f on_block + else if err == eWOULDBLOCK || err == eAGAIN + then do _ <- on_block + throwErrnoIfRetryMayBlock pred loc f on_block + else throwErrno loc + else return res + +-- | as 'throwErrnoIfRetry', but discards the result. +-- +throwErrnoIfRetry_ :: (a -> Bool) -> String -> IO a -> IO () +throwErrnoIfRetry_ pred loc f = void $ throwErrnoIfRetry pred loc f + +-- | as 'throwErrnoIfRetryMayBlock', but discards the result. +-- +throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO () +throwErrnoIfRetryMayBlock_ pred loc f on_block + = void $ throwErrnoIfRetryMayBlock pred loc f on_block + +-- | Throw an 'IOError' corresponding to the current value of 'getErrno' +-- if the 'IO' action returns a result of @-1@. +-- +throwErrnoIfMinus1 :: (Eq a, Num a) => String -> IO a -> IO a +throwErrnoIfMinus1 = throwErrnoIf (== -1) + +-- | as 'throwErrnoIfMinus1', but discards the result. +-- +throwErrnoIfMinus1_ :: (Eq a, Num a) => String -> IO a -> IO () +throwErrnoIfMinus1_ = throwErrnoIf_ (== -1) + +-- | Throw an 'IOError' corresponding to the current value of 'getErrno' +-- if the 'IO' action returns a result of @-1@, but retries in case of +-- an interrupted operation. +-- +throwErrnoIfMinus1Retry :: (Eq a, Num a) => String -> IO a -> IO a +throwErrnoIfMinus1Retry = throwErrnoIfRetry (== -1) + +-- | as 'throwErrnoIfMinus1', but discards the result. +-- +throwErrnoIfMinus1Retry_ :: (Eq a, Num a) => String -> IO a -> IO () +throwErrnoIfMinus1Retry_ = throwErrnoIfRetry_ (== -1) + +-- | as 'throwErrnoIfMinus1Retry', but checks for operations that would block. +-- +throwErrnoIfMinus1RetryMayBlock :: (Eq a, Num a) + => String -> IO a -> IO b -> IO a +throwErrnoIfMinus1RetryMayBlock = throwErrnoIfRetryMayBlock (== -1) + +-- | as 'throwErrnoIfMinus1RetryMayBlock', but discards the result. +-- +throwErrnoIfMinus1RetryMayBlock_ :: (Eq a, Num a) + => String -> IO a -> IO b -> IO () +throwErrnoIfMinus1RetryMayBlock_ = throwErrnoIfRetryMayBlock_ (== -1) + +-- | Throw an 'IOError' corresponding to the current value of 'getErrno' +-- if the 'IO' action returns 'nullPtr'. +-- +throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a) +throwErrnoIfNull = throwErrnoIf (== nullPtr) + +-- | Throw an 'IOError' corresponding to the current value of 'getErrno' +-- if the 'IO' action returns 'nullPtr', +-- but retry in case of an interrupted operation. +-- +throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a) +throwErrnoIfNullRetry = throwErrnoIfRetry (== nullPtr) + +-- | as 'throwErrnoIfNullRetry', but checks for operations that would block. +-- +throwErrnoIfNullRetryMayBlock :: String -> IO (Ptr a) -> IO b -> IO (Ptr a) +throwErrnoIfNullRetryMayBlock = throwErrnoIfRetryMayBlock (== nullPtr) + +-- | as 'throwErrno', but exceptions include the given path when appropriate. +-- +throwErrnoPath :: String -> FilePath -> IO a +throwErrnoPath loc path = + do + errno <- getErrno + ioError (errnoToIOError loc errno Nothing (Just path)) + +-- | as 'throwErrnoIf', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIf :: (a -> Bool) -> String -> FilePath -> IO a -> IO a +throwErrnoPathIf pred loc path f = + do + res <- f + if pred res then throwErrnoPath loc path else return res + +-- | as 'throwErrnoIf_', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIf_ :: (a -> Bool) -> String -> FilePath -> IO a -> IO () +throwErrnoPathIf_ pred loc path f = void $ throwErrnoPathIf pred loc path f + +-- | as 'throwErrnoIfNull', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIfNull :: String -> FilePath -> IO (Ptr a) -> IO (Ptr a) +throwErrnoPathIfNull = throwErrnoPathIf (== nullPtr) + +-- | as 'throwErrnoIfMinus1', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIfMinus1 :: (Eq a, Num a) => String -> FilePath -> IO a -> IO a +throwErrnoPathIfMinus1 = throwErrnoPathIf (== -1) + +-- | as 'throwErrnoIfMinus1_', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIfMinus1_ :: (Eq a, Num a) => String -> FilePath -> IO a -> IO () +throwErrnoPathIfMinus1_ = throwErrnoPathIf_ (== -1) + +-- conversion of an "errno" value into IO error +-- -------------------------------------------- + +-- | Construct an 'IOError' based on the given 'Errno' value. +-- The optional information can be used to improve the accuracy of +-- error messages. +-- +errnoToIOError :: String -- ^ the location where the error occurred + -> Errno -- ^ the error number + -> Maybe Handle -- ^ optional handle associated with the error + -> Maybe String -- ^ optional filename associated with the error + -> IOError +errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do + str <- strerror errno >>= peekCString + return (IOError maybeHdl errType loc str (Just errno') maybeName) + where + Errno errno' = errno + errType + | errno == eOK = OtherError + | errno == e2BIG = ResourceExhausted + | errno == eACCES = PermissionDenied + | errno == eADDRINUSE = ResourceBusy + | errno == eADDRNOTAVAIL = UnsupportedOperation + | errno == eADV = OtherError + | errno == eAFNOSUPPORT = UnsupportedOperation + | errno == eAGAIN = ResourceExhausted + | errno == eALREADY = AlreadyExists + | errno == eBADF = InvalidArgument + | errno == eBADMSG = InappropriateType + | errno == eBADRPC = OtherError + | errno == eBUSY = ResourceBusy + | errno == eCHILD = NoSuchThing + | errno == eCOMM = ResourceVanished + | errno == eCONNABORTED = OtherError + | errno == eCONNREFUSED = NoSuchThing + | errno == eCONNRESET = ResourceVanished + | errno == eDEADLK = ResourceBusy + | errno == eDESTADDRREQ = InvalidArgument + | errno == eDIRTY = UnsatisfiedConstraints + | errno == eDOM = InvalidArgument + | errno == eDQUOT = PermissionDenied + | errno == eEXIST = AlreadyExists + | errno == eFAULT = OtherError + | errno == eFBIG = PermissionDenied + | errno == eFTYPE = InappropriateType + | errno == eHOSTDOWN = NoSuchThing + | errno == eHOSTUNREACH = NoSuchThing + | errno == eIDRM = ResourceVanished + | errno == eILSEQ = InvalidArgument + | errno == eINPROGRESS = AlreadyExists + | errno == eINTR = Interrupted + | errno == eINVAL = InvalidArgument + | errno == eIO = HardwareFault + | errno == eISCONN = AlreadyExists + | errno == eISDIR = InappropriateType + | errno == eLOOP = InvalidArgument + | errno == eMFILE = ResourceExhausted + | errno == eMLINK = ResourceExhausted + | errno == eMSGSIZE = ResourceExhausted + | errno == eMULTIHOP = UnsupportedOperation + | errno == eNAMETOOLONG = InvalidArgument + | errno == eNETDOWN = ResourceVanished + | errno == eNETRESET = ResourceVanished + | errno == eNETUNREACH = NoSuchThing + | errno == eNFILE = ResourceExhausted + | errno == eNOBUFS = ResourceExhausted + | errno == eNODATA = NoSuchThing + | errno == eNODEV = UnsupportedOperation + | errno == eNOENT = NoSuchThing + | errno == eNOEXEC = InvalidArgument + | errno == eNOLCK = ResourceExhausted + | errno == eNOLINK = ResourceVanished + | errno == eNOMEM = ResourceExhausted + | errno == eNOMSG = NoSuchThing + | errno == eNONET = NoSuchThing + | errno == eNOPROTOOPT = UnsupportedOperation + | errno == eNOSPC = ResourceExhausted + | errno == eNOSR = ResourceExhausted + | errno == eNOSTR = InvalidArgument + | errno == eNOSYS = UnsupportedOperation + | errno == eNOTBLK = InvalidArgument + | errno == eNOTCONN = InvalidArgument + | errno == eNOTDIR = InappropriateType + | errno == eNOTEMPTY = UnsatisfiedConstraints + | errno == eNOTSOCK = InvalidArgument + | errno == eNOTTY = IllegalOperation + | errno == eNXIO = NoSuchThing + | errno == eOPNOTSUPP = UnsupportedOperation + | errno == ePERM = PermissionDenied + | errno == ePFNOSUPPORT = UnsupportedOperation + | errno == ePIPE = ResourceVanished + | errno == ePROCLIM = PermissionDenied + | errno == ePROCUNAVAIL = UnsupportedOperation + | errno == ePROGMISMATCH = ProtocolError + | errno == ePROGUNAVAIL = UnsupportedOperation + | errno == ePROTO = ProtocolError + | errno == ePROTONOSUPPORT = ProtocolError + | errno == ePROTOTYPE = ProtocolError + | errno == eRANGE = UnsupportedOperation + | errno == eREMCHG = ResourceVanished + | errno == eREMOTE = IllegalOperation + | errno == eROFS = PermissionDenied + | errno == eRPCMISMATCH = ProtocolError + | errno == eRREMOTE = IllegalOperation + | errno == eSHUTDOWN = IllegalOperation + | errno == eSOCKTNOSUPPORT = UnsupportedOperation + | errno == eSPIPE = UnsupportedOperation + | errno == eSRCH = NoSuchThing + | errno == eSRMNT = UnsatisfiedConstraints + | errno == eSTALE = ResourceVanished + | errno == eTIME = TimeExpired + | errno == eTIMEDOUT = TimeExpired + | errno == eTOOMANYREFS = ResourceExhausted + | errno == eTXTBSY = ResourceBusy + | errno == eUSERS = ResourceExhausted + | errno == eWOULDBLOCK = OtherError + | errno == eXDEV = UnsupportedOperation + | otherwise = OtherError + +foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar) + diff --git a/libraries/base/Foreign/C/String.hs b/libraries/base/Foreign/C/String.hs new file mode 100644 index 0000000..a162460 --- /dev/null +++ b/libraries/base/Foreign/C/String.hs @@ -0,0 +1,459 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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 ( -- representation of strings in C + -- * 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 Foreign.Marshal.Array +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Storable + +import Data.Word + +import GHC.Char +import GHC.List +import GHC.Real +import GHC.Num +import GHC.Base + +import {-# SOURCE #-} GHC.IO.Encoding +import qualified GHC.Foreign as GHC + +----------------------------------------------------------------------------- +-- Strings + +-- representation of strings in C +-- ------------------------------ + +-- | A C string is a reference to an array of C characters terminated by NUL. +type CString = Ptr CChar + +-- | A string with explicit length information in bytes instead of a +-- terminating NUL (allowing NUL characters in the middle of the string). +type CStringLen = (Ptr CChar, Int) + +-- exported functions +-- ------------------ +-- +-- * the following routines apply the default conversion when converting the +-- C-land character encoding into the Haskell-land character encoding + +-- | Marshal a NUL terminated C string into a Haskell string. +-- +peekCString :: CString -> IO String +peekCString s = getForeignEncoding >>= flip GHC.peekCString s + +-- | Marshal a C string with explicit length into a Haskell string. +-- +peekCStringLen :: CStringLen -> IO String +peekCStringLen s = getForeignEncoding >>= flip GHC.peekCStringLen s + +-- | Marshal a Haskell string into a NUL terminated C string. +-- +-- * the Haskell string may /not/ contain any NUL characters +-- +-- * new storage is allocated for the C string and must be +-- explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +newCString :: String -> IO CString +newCString s = getForeignEncoding >>= flip GHC.newCString s + +-- | Marshal a Haskell string into a C string (ie, character array) with +-- explicit length information. +-- +-- * new storage is allocated for the C string and must be +-- explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +newCStringLen :: String -> IO CStringLen +newCStringLen s = getForeignEncoding >>= flip GHC.newCStringLen s + +-- | Marshal a Haskell string into a NUL terminated C string using temporary +-- storage. +-- +-- * the Haskell string may /not/ contain any NUL characters +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withCString :: String -> (CString -> IO a) -> IO a +withCString s f = getForeignEncoding >>= \enc -> GHC.withCString enc s f + +-- | Marshal a Haskell string into a C string (ie, character array) +-- in temporary storage, with explicit length information. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withCStringLen :: String -> (CStringLen -> IO a) -> IO a +withCStringLen s f = getForeignEncoding >>= \enc -> GHC.withCStringLen enc s f + +-- -- | Determines whether a character can be accurately encoded in a 'CString'. +-- -- Unrepresentable characters are converted to '?' or their nearest visual equivalent. +charIsRepresentable :: Char -> IO Bool +charIsRepresentable c = getForeignEncoding >>= flip GHC.charIsRepresentable c + +-- single byte characters +-- ---------------------- +-- +-- ** NOTE: These routines don't handle conversions! ** + +-- | Convert a C byte, representing a Latin-1 character, to the corresponding +-- Haskell character. +castCCharToChar :: CChar -> Char +castCCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8)) + +-- | Convert a Haskell character to a C character. +-- This function is only safe on the first 256 characters. +castCharToCChar :: Char -> CChar +castCharToCChar ch = fromIntegral (ord ch) + +-- | Convert a C @unsigned char@, representing a Latin-1 character, to +-- the corresponding Haskell character. +castCUCharToChar :: CUChar -> Char +castCUCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8)) + +-- | Convert a Haskell character to a C @unsigned char@. +-- This function is only safe on the first 256 characters. +castCharToCUChar :: Char -> CUChar +castCharToCUChar ch = fromIntegral (ord ch) + +-- | Convert a C @signed char@, representing a Latin-1 character, to the +-- corresponding Haskell character. +castCSCharToChar :: CSChar -> Char +castCSCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8)) + +-- | Convert a Haskell character to a C @signed char@. +-- This function is only safe on the first 256 characters. +castCharToCSChar :: Char -> CSChar +castCharToCSChar ch = fromIntegral (ord ch) + +-- | Marshal a NUL terminated C string into a Haskell string. +-- +peekCAString :: CString -> IO String +peekCAString cp = do + l <- lengthArray0 nUL cp + if l <= 0 then return "" else loop "" (l-1) + where + loop s i = do + xval <- peekElemOff cp i + let val = castCCharToChar xval + val `seq` if i <= 0 then return (val:s) else loop (val:s) (i-1) + +-- | Marshal a C string with explicit length into a Haskell string. +-- +peekCAStringLen :: CStringLen -> IO String +peekCAStringLen (cp, len) + | len <= 0 = return "" -- being (too?) nice. + | otherwise = loop [] (len-1) + where + loop acc i = do + xval <- peekElemOff cp i + let val = castCCharToChar xval + -- blow away the coercion ASAP. + if (val `seq` (i == 0)) + then return (val:acc) + else loop (val:acc) (i-1) + +-- | Marshal a Haskell string into a NUL terminated C string. +-- +-- * the Haskell string may /not/ contain any NUL characters +-- +-- * new storage is allocated for the C string and must be +-- explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +newCAString :: String -> IO CString +newCAString str = do + ptr <- mallocArray0 (length str) + let + go [] n = pokeElemOff ptr n nUL + go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) + go str 0 + return ptr + +-- | Marshal a Haskell string into a C string (ie, character array) with +-- explicit length information. +-- +-- * new storage is allocated for the C string and must be +-- explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +newCAStringLen :: String -> IO CStringLen +newCAStringLen str = do + ptr <- mallocArray0 len + let + go [] n = n `seq` return () -- make it strict in n + go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) + go str 0 + return (ptr, len) + where + len = length str + +-- | Marshal a Haskell string into a NUL terminated C string using temporary +-- storage. +-- +-- * the Haskell string may /not/ contain any NUL characters +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withCAString :: String -> (CString -> IO a) -> IO a +withCAString str f = + allocaArray0 (length str) $ \ptr -> + let + go [] n = pokeElemOff ptr n nUL + go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) + in do + go str 0 + f ptr + +-- | Marshal a Haskell string into a C string (ie, character array) +-- in temporary storage, with explicit length information. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withCAStringLen :: String -> (CStringLen -> IO a) -> IO a +withCAStringLen str f = + allocaArray len $ \ptr -> + let + go [] n = n `seq` return () -- make it strict in n + go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) + in do + go str 0 + f (ptr,len) + where + len = length str + +-- auxiliary definitions +-- ---------------------- + +-- C's end of string character +-- +nUL :: CChar +nUL = 0 + +-- allocate an array to hold the list and pair it with the number of elements +newArrayLen :: Storable a => [a] -> IO (Ptr a, Int) +newArrayLen xs = do + a <- newArray xs + return (a, length xs) + +----------------------------------------------------------------------------- +-- Wide strings + +-- representation of wide strings in C +-- ----------------------------------- + +-- | A C wide string is a reference to an array of C wide characters +-- terminated by NUL. +type CWString = Ptr CWchar + +-- | A wide character string with explicit length information in 'CWchar's +-- instead of a terminating NUL (allowing NUL characters in the middle +-- of the string). +type CWStringLen = (Ptr CWchar, Int) + +-- | Marshal a NUL terminated C wide string into a Haskell string. +-- +peekCWString :: CWString -> IO String +peekCWString cp = do + cs <- peekArray0 wNUL cp + return (cWcharsToChars cs) + +-- | Marshal a C wide string with explicit length into a Haskell string. +-- +peekCWStringLen :: CWStringLen -> IO String +peekCWStringLen (cp, len) = do + cs <- peekArray len cp + return (cWcharsToChars cs) + +-- | Marshal a Haskell string into a NUL terminated C wide string. +-- +-- * the Haskell string may /not/ contain any NUL characters +-- +-- * new storage is allocated for the C wide string and must +-- be explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +newCWString :: String -> IO CWString +newCWString = newArray0 wNUL . charsToCWchars + +-- | Marshal a Haskell string into a C wide string (ie, wide character array) +-- with explicit length information. +-- +-- * new storage is allocated for the C wide string and must +-- be explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +newCWStringLen :: String -> IO CWStringLen +newCWStringLen str = newArrayLen (charsToCWchars str) + +-- | Marshal a Haskell string into a NUL terminated C wide string using +-- temporary storage. +-- +-- * the Haskell string may /not/ contain any NUL characters +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withCWString :: String -> (CWString -> IO a) -> IO a +withCWString = withArray0 wNUL . charsToCWchars + +-- | Marshal a Haskell string into a C wide string (i.e. wide +-- character array) in temporary storage, with explicit length +-- information. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withCWStringLen :: String -> (CWStringLen -> IO a) -> IO a +withCWStringLen str f = + withArrayLen (charsToCWchars str) $ \ len ptr -> f (ptr, len) + +-- auxiliary definitions +-- ---------------------- + +wNUL :: CWchar +wNUL = 0 + +cWcharsToChars :: [CWchar] -> [Char] +charsToCWchars :: [Char] -> [CWchar] + +#ifdef mingw32_HOST_OS + +-- On Windows, wchar_t is 16 bits wide and CWString uses the UTF-16 encoding. + +-- coding errors generate Chars in the surrogate range +cWcharsToChars = map chr . fromUTF16 . map fromIntegral + where + fromUTF16 (c1:c2:wcs) + | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = + ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs + fromUTF16 (c:wcs) = c : fromUTF16 wcs + fromUTF16 [] = [] + +charsToCWchars = foldr utf16Char [] . map ord + where + utf16Char c wcs + | c < 0x10000 = fromIntegral c : wcs + | otherwise = let c' = c - 0x10000 in + fromIntegral (c' `div` 0x400 + 0xd800) : + fromIntegral (c' `mod` 0x400 + 0xdc00) : wcs + +#else /* !mingw32_HOST_OS */ + +cWcharsToChars xs = map castCWcharToChar xs +charsToCWchars xs = map castCharToCWchar xs + +-- These conversions only make sense if __STDC_ISO_10646__ is defined +-- (meaning that wchar_t is ISO 10646, aka Unicode) + +castCWcharToChar :: CWchar -> Char +castCWcharToChar ch = chr (fromIntegral ch ) + +castCharToCWchar :: Char -> CWchar +castCharToCWchar ch = fromIntegral (ord ch) + +#endif /* !mingw32_HOST_OS */ + diff --git a/libraries/base/Foreign/C/Types.hs b/libraries/base/Foreign/C/Types.hs new file mode 100644 index 0000000..fef8e4a --- /dev/null +++ b/libraries/base/Foreign/C/Types.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, GeneralizedNewtypeDeriving, + StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-unused-binds #-} +-- XXX -Wno-unused-binds stops us warning about unused constructors, +-- but really we should just remove them if we don't want them + +----------------------------------------------------------------------------- +-- | +-- 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 + + -- ** 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', '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(..) + , 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', 'Typeable' and 'Storable'. + , CClock(..), CTime(..), CUSeconds(..), CSUSeconds(..) + + -- extracted from CTime, because we don't want this comment in + -- the Haskell language reports: + + -- | 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', 'Typeable', 'Storable', + -- 'Prelude.Real', 'Prelude.Fractional', 'Prelude.Floating', + -- 'Prelude.RealFrac' and 'Prelude.RealFloat'. + , CFloat(..), CDouble(..) + -- XXX GHC doesn't support CLDouble yet + -- , CLDouble(..) + + -- ** Other types + + -- Instances of: Eq and Storable + , CFile, CFpos, CJmpBuf + ) where + +import Foreign.Storable +import Data.Bits ( Bits(..), FiniteBits(..) ) +import Data.Int ( Int8, Int16, Int32, Int64 ) +import Data.Word ( Word8, Word16, Word32, Word64 ) + +import GHC.Base +import GHC.Float +import GHC.Enum +import GHC.Real +import GHC.Show +import GHC.Read +import GHC.Num + +#include "HsBaseConfig.h" +#include "CTypes.h" + +-- | Haskell type representing the C @char@ type. +INTEGRAL_TYPE(CChar,HTYPE_CHAR) +-- | Haskell type representing the C @signed char@ type. +INTEGRAL_TYPE(CSChar,HTYPE_SIGNED_CHAR) +-- | Haskell type representing the C @unsigned char@ type. +INTEGRAL_TYPE(CUChar,HTYPE_UNSIGNED_CHAR) + +-- | Haskell type representing the C @short@ type. +INTEGRAL_TYPE(CShort,HTYPE_SHORT) +-- | Haskell type representing the C @unsigned short@ type. +INTEGRAL_TYPE(CUShort,HTYPE_UNSIGNED_SHORT) + +-- | Haskell type representing the C @int@ type. +INTEGRAL_TYPE(CInt,HTYPE_INT) +-- | Haskell type representing the C @unsigned int@ type. +INTEGRAL_TYPE(CUInt,HTYPE_UNSIGNED_INT) + +-- | Haskell type representing the C @long@ type. +INTEGRAL_TYPE(CLong,HTYPE_LONG) +-- | Haskell type representing the C @unsigned long@ type. +INTEGRAL_TYPE(CULong,HTYPE_UNSIGNED_LONG) + +-- | Haskell type representing the C @long long@ type. +INTEGRAL_TYPE(CLLong,HTYPE_LONG_LONG) +-- | Haskell type representing the C @unsigned long long@ type. +INTEGRAL_TYPE(CULLong,HTYPE_UNSIGNED_LONG_LONG) + +{-# RULES +"fromIntegral/a->CChar" fromIntegral = \x -> CChar (fromIntegral x) +"fromIntegral/a->CSChar" fromIntegral = \x -> CSChar (fromIntegral x) +"fromIntegral/a->CUChar" fromIntegral = \x -> CUChar (fromIntegral x) +"fromIntegral/a->CShort" fromIntegral = \x -> CShort (fromIntegral x) +"fromIntegral/a->CUShort" fromIntegral = \x -> CUShort (fromIntegral x) +"fromIntegral/a->CInt" fromIntegral = \x -> CInt (fromIntegral x) +"fromIntegral/a->CUInt" fromIntegral = \x -> CUInt (fromIntegral x) +"fromIntegral/a->CLong" fromIntegral = \x -> CLong (fromIntegral x) +"fromIntegral/a->CULong" fromIntegral = \x -> CULong (fromIntegral x) +"fromIntegral/a->CLLong" fromIntegral = \x -> CLLong (fromIntegral x) +"fromIntegral/a->CULLong" fromIntegral = \x -> CULLong (fromIntegral x) + +"fromIntegral/CChar->a" fromIntegral = \(CChar x) -> fromIntegral x +"fromIntegral/CSChar->a" fromIntegral = \(CSChar x) -> fromIntegral x +"fromIntegral/CUChar->a" fromIntegral = \(CUChar x) -> fromIntegral x +"fromIntegral/CShort->a" fromIntegral = \(CShort x) -> fromIntegral x +"fromIntegral/CUShort->a" fromIntegral = \(CUShort x) -> fromIntegral x +"fromIntegral/CInt->a" fromIntegral = \(CInt x) -> fromIntegral x +"fromIntegral/CUInt->a" fromIntegral = \(CUInt x) -> fromIntegral x +"fromIntegral/CLong->a" fromIntegral = \(CLong x) -> fromIntegral x +"fromIntegral/CULong->a" fromIntegral = \(CULong x) -> fromIntegral x +"fromIntegral/CLLong->a" fromIntegral = \(CLLong x) -> fromIntegral x +"fromIntegral/CULLong->a" fromIntegral = \(CULLong x) -> fromIntegral x + #-} + +-- | Haskell type representing the C @float@ type. +FLOATING_TYPE(CFloat,HTYPE_FLOAT) +-- | Haskell type representing the C @double@ type. +FLOATING_TYPE(CDouble,HTYPE_DOUBLE) +-- XXX GHC doesn't support CLDouble yet + +{-# RULES +"realToFrac/a->CFloat" realToFrac = \x -> CFloat (realToFrac x) +"realToFrac/a->CDouble" realToFrac = \x -> CDouble (realToFrac x) + +"realToFrac/CFloat->a" realToFrac = \(CFloat x) -> realToFrac x +"realToFrac/CDouble->a" realToFrac = \(CDouble x) -> realToFrac x + #-} + +-- GHC doesn't support CLDouble yet +-- "realToFrac/a->CLDouble" realToFrac = \x -> CLDouble (realToFrac x) +-- "realToFrac/CLDouble->a" realToFrac = \(CLDouble x) -> realToFrac x + +-- | Haskell type representing the C @ptrdiff_t@ type. +INTEGRAL_TYPE(CPtrdiff,HTYPE_PTRDIFF_T) +-- | Haskell type representing the C @size_t@ type. +INTEGRAL_TYPE(CSize,HTYPE_SIZE_T) +-- | Haskell type representing the C @wchar_t@ type. +INTEGRAL_TYPE(CWchar,HTYPE_WCHAR_T) +-- | Haskell type representing the C @sig_atomic_t@ type. +INTEGRAL_TYPE(CSigAtomic,HTYPE_SIG_ATOMIC_T) + +{-# RULES +"fromIntegral/a->CPtrdiff" fromIntegral = \x -> CPtrdiff (fromIntegral x) +"fromIntegral/a->CSize" fromIntegral = \x -> CSize (fromIntegral x) +"fromIntegral/a->CWchar" fromIntegral = \x -> CWchar (fromIntegral x) +"fromIntegral/a->CSigAtomic" fromIntegral = \x -> CSigAtomic (fromIntegral x) + +"fromIntegral/CPtrdiff->a" fromIntegral = \(CPtrdiff x) -> fromIntegral x +"fromIntegral/CSize->a" fromIntegral = \(CSize x) -> fromIntegral x +"fromIntegral/CWchar->a" fromIntegral = \(CWchar x) -> fromIntegral x +"fromIntegral/CSigAtomic->a" fromIntegral = \(CSigAtomic x) -> fromIntegral x + #-} + +-- | Haskell type representing the C @clock_t@ type. +ARITHMETIC_TYPE(CClock,HTYPE_CLOCK_T) +-- | Haskell type representing the C @time_t@ type. +ARITHMETIC_TYPE(CTime,HTYPE_TIME_T) +-- | Haskell type representing the C @useconds_t@ type. +-- +-- @since 4.4.0.0 +ARITHMETIC_TYPE(CUSeconds,HTYPE_USECONDS_T) +-- | Haskell type representing the C @suseconds_t@ type. +-- +-- @since 4.4.0.0 +ARITHMETIC_TYPE(CSUSeconds,HTYPE_SUSECONDS_T) + +-- FIXME: Implement and provide instances for Eq and Storable +-- | Haskell type representing the C @FILE@ type. +data CFile = CFile +-- | Haskell type representing the C @fpos_t@ type. +data CFpos = CFpos +-- | Haskell type representing the C @jmp_buf@ type. +data CJmpBuf = CJmpBuf + +INTEGRAL_TYPE(CIntPtr,HTYPE_INTPTR_T) +INTEGRAL_TYPE(CUIntPtr,HTYPE_UINTPTR_T) +INTEGRAL_TYPE(CIntMax,HTYPE_INTMAX_T) +INTEGRAL_TYPE(CUIntMax,HTYPE_UINTMAX_T) + +{-# RULES +"fromIntegral/a->CIntPtr" fromIntegral = \x -> CIntPtr (fromIntegral x) +"fromIntegral/a->CUIntPtr" fromIntegral = \x -> CUIntPtr (fromIntegral x) +"fromIntegral/a->CIntMax" fromIntegral = \x -> CIntMax (fromIntegral x) +"fromIntegral/a->CUIntMax" fromIntegral = \x -> CUIntMax (fromIntegral x) + #-} + +-- C99 types which are still missing include: +-- wint_t, wctrans_t, wctype_t + +{- $ctypes + +These types are needed to accurately represent C function prototypes, +in order to access C library interfaces in Haskell. The Haskell system +is not required to represent those types exactly as C does, but the +following guarantees are provided concerning a Haskell type @CT@ +representing a C type @t@: + +* If a C function prototype has @t@ as an argument or result type, the + use of @CT@ in the corresponding position in a foreign declaration + permits the Haskell program to access the full range of values encoded + by the C type; and conversely, any Haskell value for @CT@ has a valid + representation in C. + +* @'sizeOf' ('Prelude.undefined' :: CT)@ will yield the same value as + @sizeof (t)@ in C. + +* @'alignment' ('Prelude.undefined' :: CT)@ matches the alignment + constraint enforced by the C implementation for @t@. + +* The members 'peek' and 'poke' of the 'Storable' class map all values + of @CT@ to the corresponding value of @t@ and vice versa. + +* When an instance of 'Prelude.Bounded' is defined for @CT@, the values + of 'Prelude.minBound' and 'Prelude.maxBound' coincide with @t_MIN@ + and @t_MAX@ in C. + +* When an instance of 'Prelude.Eq' or 'Prelude.Ord' is defined for @CT@, + the predicates defined by the type class implement the same relation + as the corresponding predicate in C on @t@. + +* When an instance of 'Prelude.Num', 'Prelude.Read', 'Prelude.Integral', + 'Prelude.Fractional', 'Prelude.Floating', 'Prelude.RealFrac', or + 'Prelude.RealFloat' is defined for @CT@, the arithmetic operations + defined by the type class implement the same function as the + corresponding arithmetic operations (if available) in C on @t@. + +* When an instance of 'Bits' is defined for @CT@, the bitwise operation + defined by the type class implement the same function as the + corresponding bitwise operation in C on @t@. + +-} + diff --git a/libraries/base/Foreign/Concurrent.hs b/libraries/base/Foreign/Concurrent.hs new file mode 100644 index 0000000..9d27166 --- /dev/null +++ b/libraries/base/Foreign/Concurrent.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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.IO ( IO ) +import GHC.Ptr ( Ptr ) +import GHC.ForeignPtr ( ForeignPtr ) +import qualified GHC.ForeignPtr + +newForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a) +-- ^Turns a plain memory reference into a foreign object by associating +-- a finalizer - given by the monadic operation - with the reference. +-- The finalizer will be executed after the last reference to the +-- foreign object is dropped. There is no guarantee of promptness, and +-- in fact there is no guarantee that the finalizer will eventually +-- run at all. +newForeignPtr = GHC.ForeignPtr.newConcForeignPtr + +addForeignPtrFinalizer :: ForeignPtr a -> IO () -> IO () +-- ^This function adds a finalizer to the given 'ForeignPtr'. +-- The finalizer will run after the last reference to the foreign object +-- is dropped, but /before/ all previously registered finalizers for the +-- same object. +addForeignPtrFinalizer = GHC.ForeignPtr.addForeignPtrConcFinalizer diff --git a/libraries/base/Foreign/ForeignPtr.hs b/libraries/base/Foreign/ForeignPtr.hs new file mode 100644 index 0000000..cedfba7 --- /dev/null +++ b/libraries/base/Foreign/ForeignPtr.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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. +-- +----------------------------------------------------------------------------- + +module Foreign.ForeignPtr ( + -- * 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 Foreign.ForeignPtr.Imp + diff --git a/libraries/base/Foreign/ForeignPtr/Imp.hs b/libraries/base/Foreign/ForeignPtr/Imp.hs new file mode 100644 index 0000000..2c3f393 --- /dev/null +++ b/libraries/base/Foreign/ForeignPtr/Imp.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.ForeignPtr.Imp +-- 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. +-- +----------------------------------------------------------------------------- + +module Foreign.ForeignPtr.Imp + ( + -- * Finalised data pointers + ForeignPtr + , FinalizerPtr + , FinalizerEnvPtr + + -- ** Basic operations + , newForeignPtr + , newForeignPtr_ + , addForeignPtrFinalizer + , newForeignPtrEnv + , addForeignPtrFinalizerEnv + , withForeignPtr + , finalizeForeignPtr + + -- ** Low-level operations + , unsafeForeignPtrToPtr + , touchForeignPtr + , castForeignPtr + + -- ** Allocating managed memory + , mallocForeignPtr + , mallocForeignPtrBytes + , mallocForeignPtrArray + , mallocForeignPtrArray0 + ) + where + +import Foreign.Ptr +import Foreign.Storable ( Storable(sizeOf) ) + +import GHC.Base +import GHC.Num +import GHC.ForeignPtr + +newForeignPtr :: FinalizerPtr a -> Ptr a -> IO (ForeignPtr a) +-- ^Turns a plain memory reference into a foreign pointer, and +-- associates a finalizer with the reference. The finalizer will be +-- executed after the last reference to the foreign object is dropped. +-- There is no guarantee of promptness, however the finalizer will be +-- executed before the program exits. +newForeignPtr finalizer p + = do fObj <- newForeignPtr_ p + addForeignPtrFinalizer finalizer fObj + return fObj + +withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +-- ^This is a way to look at the pointer living inside a +-- foreign object. This function takes a function which is +-- applied to that pointer. The resulting 'IO' action is then +-- executed. The foreign object is kept alive at least during +-- the whole action, even if it is not used directly +-- inside. Note that it is not safe to return the pointer from +-- the action and use it after the action completes. All uses +-- of the pointer should be inside the +-- 'withForeignPtr' bracket. The reason for +-- this unsafeness is the same as for +-- 'unsafeForeignPtrToPtr' below: the finalizer +-- may run earlier than expected, because the compiler can only +-- track usage of the 'ForeignPtr' object, not +-- a 'Ptr' object made from it. +-- +-- This function is normally used for marshalling data to +-- or from the object pointed to by the +-- 'ForeignPtr', using the operations from the +-- 'Storable' class. +withForeignPtr fo io + = do r <- io (unsafeForeignPtrToPtr fo) + touchForeignPtr fo + return r + +-- | This variant of 'newForeignPtr' adds a finalizer that expects an +-- environment in addition to the finalized pointer. The environment +-- that will be passed to the finalizer is fixed by the second argument to +-- 'newForeignPtrEnv'. +newForeignPtrEnv :: + FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO (ForeignPtr a) +newForeignPtrEnv finalizer env p + = do fObj <- newForeignPtr_ p + addForeignPtrFinalizerEnv finalizer env fObj + return fObj + +-- | This function is similar to 'Foreign.Marshal.Array.mallocArray', +-- but yields a memory area that has a finalizer attached that releases +-- the memory area. As with 'mallocForeignPtr', it is not guaranteed that +-- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'. +mallocForeignPtrArray :: Storable a => Int -> IO (ForeignPtr a) +mallocForeignPtrArray = doMalloc undefined + where + doMalloc :: Storable b => b -> Int -> IO (ForeignPtr b) + doMalloc dummy size = mallocForeignPtrBytes (size * sizeOf dummy) + +-- | This function is similar to 'Foreign.Marshal.Array.mallocArray0', +-- but yields a memory area that has a finalizer attached that releases +-- the memory area. As with 'mallocForeignPtr', it is not guaranteed that +-- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'. +mallocForeignPtrArray0 :: Storable a => Int -> IO (ForeignPtr a) +mallocForeignPtrArray0 size = mallocForeignPtrArray (size + 1) + diff --git a/libraries/base/Foreign/ForeignPtr/Safe.hs b/libraries/base/Foreign/ForeignPtr/Safe.hs new file mode 100644 index 0000000..d8a7c53 --- /dev/null +++ b/libraries/base/Foreign/ForeignPtr/Safe.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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 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 Foreign.ForeignPtr.Imp + diff --git a/libraries/base/Foreign/ForeignPtr/Unsafe.hs b/libraries/base/Foreign/ForeignPtr/Unsafe.hs new file mode 100644 index 0000000..5a36a7e --- /dev/null +++ b/libraries/base/Foreign/ForeignPtr/Unsafe.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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 Foreign.ForeignPtr.Imp + diff --git a/libraries/base/Foreign/Marshal.hs b/libraries/base/Foreign/Marshal.hs new file mode 100644 index 0000000..15bed17 --- /dev/null +++ b/libraries/base/Foreign/Marshal.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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/libraries/base/Foreign/Marshal/Alloc.hs b/libraries/base/Foreign/Marshal/Alloc.hs new file mode 100644 index 0000000..264c10c --- /dev/null +++ b/libraries/base/Foreign/Marshal/Alloc.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} + +----------------------------------------------------------------------------- +-- | +-- 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. +-- +----------------------------------------------------------------------------- + +module Foreign.Marshal.Alloc ( + -- * Memory allocation + -- ** Local allocation + alloca, + allocaBytes, + allocaBytesAligned, + + -- ** Dynamic allocation + malloc, + mallocBytes, + + calloc, + callocBytes, + + realloc, + reallocBytes, + + free, + finalizerFree +) where + +import Data.Maybe +import Foreign.C.Types ( CSize(..) ) +import Foreign.Storable ( Storable(sizeOf,alignment) ) +import Foreign.ForeignPtr ( FinalizerPtr ) +import GHC.IO.Exception +import GHC.Real +import GHC.Ptr +import GHC.Base + +-- exported functions +-- ------------------ + +-- |Allocate a block of memory that is sufficient to hold values of type +-- @a@. The size of the area allocated is determined by the 'sizeOf' +-- method from the instance of 'Storable' for the appropriate type. +-- +-- The memory may be deallocated using 'free' or 'finalizerFree' when +-- no longer required. +-- +{-# INLINE malloc #-} +malloc :: Storable a => IO (Ptr a) +malloc = doMalloc undefined + where + doMalloc :: Storable b => b -> IO (Ptr b) + doMalloc dummy = mallocBytes (sizeOf dummy) + +-- |Like 'malloc' but memory is filled with bytes of value zero. +-- +{-# INLINE calloc #-} +calloc :: Storable a => IO (Ptr a) +calloc = doCalloc undefined + where + doCalloc :: Storable b => b -> IO (Ptr b) + doCalloc dummy = callocBytes (sizeOf dummy) + +-- |Allocate a block of memory of the given number of bytes. +-- The block of memory is sufficiently aligned for any of the basic +-- foreign types that fits into a memory block of the allocated size. +-- +-- The memory may be deallocated using 'free' or 'finalizerFree' when +-- no longer required. +-- +mallocBytes :: Int -> IO (Ptr a) +mallocBytes size = failWhenNULL "malloc" (_malloc (fromIntegral size)) + +-- |Llike 'mallocBytes' but memory is filled with bytes of value zero. +-- +callocBytes :: Int -> IO (Ptr a) +callocBytes size = failWhenNULL "calloc" $ _calloc 1 (fromIntegral size) + +-- |@'alloca' f@ executes the computation @f@, passing as argument +-- a pointer to a temporarily allocated block of memory sufficient to +-- hold values of type @a@. +-- +-- The memory is freed when @f@ terminates (either normally or via an +-- exception), so the pointer passed to @f@ must /not/ be used after this. +-- +{-# INLINE alloca #-} +alloca :: Storable a => (Ptr a -> IO b) -> IO b +alloca = doAlloca undefined + where + doAlloca :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b' + doAlloca dummy = allocaBytesAligned (sizeOf dummy) (alignment dummy) + +-- |@'allocaBytes' n f@ executes the computation @f@, passing as argument +-- a pointer to a temporarily allocated block of memory of @n@ bytes. +-- The block of memory is sufficiently aligned for any of the basic +-- foreign types that fits into a memory block of the allocated size. +-- +-- The memory is freed when @f@ terminates (either normally or via an +-- exception), so the pointer passed to @f@ must /not/ be used after this. +-- +allocaBytes :: Int -> (Ptr a -> IO b) -> IO b +allocaBytes (I# size) action = IO $ \ s0 -> + case newPinnedByteArray# size s0 of { (# s1, mbarr# #) -> + case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr# #) -> + let addr = Ptr (byteArrayContents# barr#) in + case action addr of { IO action' -> + case action' s2 of { (# s3, r #) -> + case touch# barr# s3 of { s4 -> + (# s4, r #) + }}}}} + +allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b +allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 -> + case newAlignedPinnedByteArray# size align s0 of { (# s1, mbarr# #) -> + case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr# #) -> + let addr = Ptr (byteArrayContents# barr#) in + case action addr of { IO action' -> + case action' s2 of { (# s3, r #) -> + case touch# barr# s3 of { s4 -> + (# s4, r #) + }}}}} + +-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes' +-- to the size needed to store values of type @b@. The returned pointer +-- may refer to an entirely different memory area, but will be suitably +-- aligned to hold values of type @b@. The contents of the referenced +-- memory area will be the same as of the original pointer up to the +-- minimum of the original size and the size of values of type @b@. +-- +-- If the argument to 'realloc' is 'nullPtr', 'realloc' behaves like +-- 'malloc'. +-- +realloc :: Storable b => Ptr a -> IO (Ptr b) +realloc = doRealloc undefined + where + doRealloc :: Storable b' => b' -> Ptr a' -> IO (Ptr b') + doRealloc dummy ptr = let + size = fromIntegral (sizeOf dummy) + in + failWhenNULL "realloc" (_realloc ptr size) + +-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes' +-- to the given size. The returned pointer may refer to an entirely +-- different memory area, but will be sufficiently aligned for any of the +-- basic foreign types that fits into a memory block of the given size. +-- The contents of the referenced memory area will be the same as of +-- the original pointer up to the minimum of the original size and the +-- given size. +-- +-- If the pointer argument to 'reallocBytes' is 'nullPtr', 'reallocBytes' +-- behaves like 'malloc'. If the requested size is 0, 'reallocBytes' +-- behaves like 'free'. +-- +reallocBytes :: Ptr a -> Int -> IO (Ptr a) +reallocBytes ptr 0 = do free ptr; return nullPtr +reallocBytes ptr size = + failWhenNULL "realloc" (_realloc ptr (fromIntegral size)) + +-- |Free a block of memory that was allocated with 'malloc', +-- 'mallocBytes', 'realloc', 'reallocBytes', 'Foreign.Marshal.Utils.new' +-- or any of the @new@/X/ functions in "Foreign.Marshal.Array" or +-- "Foreign.C.String". +-- +free :: Ptr a -> IO () +free = _free + + +-- auxilliary routines +-- ------------------- + +-- asserts that the pointer returned from the action in the second argument is +-- non-null +-- +failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a) +failWhenNULL name f = do + addr <- f + if addr == nullPtr + then ioError (IOError Nothing ResourceExhausted name + "out of memory" Nothing Nothing) + else return addr + +-- basic C routines needed for memory allocation +-- +foreign import ccall unsafe "stdlib.h malloc" _malloc :: CSize -> IO (Ptr a) +foreign import ccall unsafe "stdlib.h calloc" _calloc :: CSize -> CSize -> IO (Ptr a) +foreign import ccall unsafe "stdlib.h realloc" _realloc :: Ptr a -> CSize -> IO (Ptr b) +foreign import ccall unsafe "stdlib.h free" _free :: Ptr a -> IO () + +-- | A pointer to a foreign function equivalent to 'free', which may be +-- used as a finalizer (cf 'Foreign.ForeignPtr.ForeignPtr') for storage +-- allocated with 'malloc', 'mallocBytes', 'realloc' or 'reallocBytes'. +foreign import ccall unsafe "stdlib.h &free" finalizerFree :: FinalizerPtr a + diff --git a/libraries/base/Foreign/Marshal/Array.hs b/libraries/base/Foreign/Marshal/Array.hs new file mode 100644 index 0000000..5e10341 --- /dev/null +++ b/libraries/base/Foreign/Marshal/Array.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- 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 Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (Storable(alignment,sizeOf,peekElemOff,pokeElemOff)) +import Foreign.Marshal.Alloc (mallocBytes, callocBytes, allocaBytesAligned, reallocBytes) +import Foreign.Marshal.Utils (copyBytes, moveBytes) + +import GHC.Num +import GHC.List +import GHC.Base + +-- allocation +-- ---------- + +-- |Allocate storage for the given number of elements of a storable type +-- (like 'Foreign.Marshal.Alloc.malloc', but for multiple elements). +-- +mallocArray :: Storable a => Int -> IO (Ptr a) +mallocArray = doMalloc undefined + where + doMalloc :: Storable a' => a' -> Int -> IO (Ptr a') + doMalloc dummy size = mallocBytes (size * sizeOf dummy) + +-- |Like 'mallocArray', but add an extra position to hold a special +-- termination element. +-- +mallocArray0 :: Storable a => Int -> IO (Ptr a) +mallocArray0 size = mallocArray (size + 1) + +-- |Like 'mallocArray', but allocated memory is filled with bytes of value zero. +-- +callocArray :: Storable a => Int -> IO (Ptr a) +callocArray = doCalloc undefined + where + doCalloc :: Storable a' => a' -> Int -> IO (Ptr a') + doCalloc dummy size = callocBytes (size * sizeOf dummy) + +-- |Like 'callocArray0', but allocated memory is filled with bytes of value +-- zero. +-- +callocArray0 :: Storable a => Int -> IO (Ptr a) +callocArray0 size = callocArray (size + 1) + +-- |Temporarily allocate space for the given number of elements +-- (like 'Foreign.Marshal.Alloc.alloca', but for multiple elements). +-- +allocaArray :: Storable a => Int -> (Ptr a -> IO b) -> IO b +allocaArray = doAlloca undefined + where + doAlloca :: Storable a' => a' -> Int -> (Ptr a' -> IO b') -> IO b' + doAlloca dummy size = allocaBytesAligned (size * sizeOf dummy) + (alignment dummy) + +-- |Like 'allocaArray', but add an extra position to hold a special +-- termination element. +-- +allocaArray0 :: Storable a => Int -> (Ptr a -> IO b) -> IO b +allocaArray0 size = allocaArray (size + 1) +{-# INLINE allocaArray0 #-} + -- needed to get allocaArray to inline into withCString, for unknown + -- reasons --SDM 23/4/2010, see #4004 for benchmark + +-- |Adjust the size of an array +-- +reallocArray :: Storable a => Ptr a -> Int -> IO (Ptr a) +reallocArray = doRealloc undefined + where + doRealloc :: Storable a' => a' -> Ptr a' -> Int -> IO (Ptr a') + doRealloc dummy ptr size = reallocBytes ptr (size * sizeOf dummy) + +-- |Adjust the size of an array including an extra position for the end marker. +-- +reallocArray0 :: Storable a => Ptr a -> Int -> IO (Ptr a) +reallocArray0 ptr size = reallocArray ptr (size + 1) + + +-- marshalling +-- ----------- + +-- |Convert an array of given length into a Haskell list. The implementation +-- is tail-recursive and so uses constant stack space. +-- +peekArray :: Storable a => Int -> Ptr a -> IO [a] +peekArray size ptr | size <= 0 = return [] + | otherwise = f (size-1) [] + where + f 0 acc = do e <- peekElemOff ptr 0; return (e:acc) + f n acc = do e <- peekElemOff ptr n; f (n-1) (e:acc) + +-- |Convert an array terminated by the given end marker into a Haskell list +-- +peekArray0 :: (Storable a, Eq a) => a -> Ptr a -> IO [a] +peekArray0 marker ptr = do + size <- lengthArray0 marker ptr + peekArray size ptr + +-- |Write the list elements consecutive into memory +-- +pokeArray :: Storable a => Ptr a -> [a] -> IO () +pokeArray ptr vals0 = go vals0 0# + where go [] _ = return () + go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#) + +-- |Write the list elements consecutive into memory and terminate them with the +-- given marker element +-- +pokeArray0 :: Storable a => a -> Ptr a -> [a] -> IO () +pokeArray0 marker ptr vals0 = go vals0 0# + where go [] n# = pokeElemOff ptr (I# n#) marker + go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#) + +-- combined allocation and marshalling +-- ----------------------------------- + +-- |Write a list of storable elements into a newly allocated, consecutive +-- sequence of storable values +-- (like 'Foreign.Marshal.Utils.new', but for multiple elements). +-- +newArray :: Storable a => [a] -> IO (Ptr a) +newArray vals = do + ptr <- mallocArray (length vals) + pokeArray ptr vals + return ptr + +-- |Write a list of storable elements into a newly allocated, consecutive +-- sequence of storable values, where the end is fixed by the given end marker +-- +newArray0 :: Storable a => a -> [a] -> IO (Ptr a) +newArray0 marker vals = do + ptr <- mallocArray0 (length vals) + pokeArray0 marker ptr vals + return ptr + +-- |Temporarily store a list of storable values in memory +-- (like 'Foreign.Marshal.Utils.with', but for multiple elements). +-- +withArray :: Storable a => [a] -> (Ptr a -> IO b) -> IO b +withArray vals = withArrayLen vals . const + +-- |Like 'withArray', but the action gets the number of values +-- as an additional parameter +-- +withArrayLen :: Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b +withArrayLen vals f = + allocaArray len $ \ptr -> do + pokeArray ptr vals + f len ptr + where + len = length vals + +-- |Like 'withArray', but a terminator indicates where the array ends +-- +withArray0 :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b +withArray0 marker vals = withArrayLen0 marker vals . const + +-- |Like 'withArrayLen', but a terminator indicates where the array ends +-- +withArrayLen0 :: Storable a => a -> [a] -> (Int -> Ptr a -> IO b) -> IO b +withArrayLen0 marker vals f = + allocaArray0 len $ \ptr -> do + pokeArray0 marker ptr vals + res <- f len ptr + return res + where + len = length vals + + +-- copying (argument order: destination, source) +-- ------- + +-- |Copy the given number of elements from the second array (source) into the +-- first array (destination); the copied areas may /not/ overlap +-- +copyArray :: Storable a => Ptr a -> Ptr a -> Int -> IO () +copyArray = doCopy undefined + where + doCopy :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO () + doCopy dummy dest src size = copyBytes dest src (size * sizeOf dummy) + +-- |Copy the given number of elements from the second array (source) into the +-- first array (destination); the copied areas /may/ overlap +-- +moveArray :: Storable a => Ptr a -> Ptr a -> Int -> IO () +moveArray = doMove undefined + where + doMove :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO () + doMove dummy dest src size = moveBytes dest src (size * sizeOf dummy) + + +-- finding the length +-- ------------------ + +-- |Return the number of elements in an array, excluding the terminator +-- +lengthArray0 :: (Storable a, Eq a) => a -> Ptr a -> IO Int +lengthArray0 marker ptr = loop 0 + where + loop i = do + val <- peekElemOff ptr i + if val == marker then return i else loop (i+1) + + +-- indexing +-- -------- + +-- |Advance a pointer into an array by the given number of elements +-- +advancePtr :: Storable a => Ptr a -> Int -> Ptr a +advancePtr = doAdvance undefined + where + doAdvance :: Storable a' => a' -> Ptr a' -> Int -> Ptr a' + doAdvance dummy ptr i = ptr `plusPtr` (i * sizeOf dummy) + diff --git a/libraries/base/Foreign/Marshal/Error.hs b/libraries/base/Foreign/Marshal/Error.hs new file mode 100644 index 0000000..be75043 --- /dev/null +++ b/libraries/base/Foreign/Marshal/Error.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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, + + -- Discard return value + -- + void +) where + +import Foreign.Ptr + +import GHC.Base +import GHC.Num +import GHC.IO.Exception + +-- exported functions +-- ------------------ + +-- |Execute an 'IO' action, throwing a 'userError' if the predicate yields +-- 'True' when applied to the result returned by the 'IO' action. +-- If no exception is raised, return the result of the computation. +-- +throwIf :: (a -> Bool) -- ^ error condition on the result of the 'IO' action + -> (a -> String) -- ^ computes an error message from erroneous results + -- of the 'IO' action + -> IO a -- ^ the 'IO' action to be executed + -> IO a +throwIf pred msgfct act = + do + res <- act + (if pred res then ioError . userError . msgfct else return) res + +-- |Like 'throwIf', but discarding the result +-- +throwIf_ :: (a -> Bool) -> (a -> String) -> IO a -> IO () +throwIf_ pred msgfct act = void $ throwIf pred msgfct act + +-- |Guards against negative result values +-- +throwIfNeg :: (Ord a, Num a) => (a -> String) -> IO a -> IO a +throwIfNeg = throwIf (< 0) + +-- |Like 'throwIfNeg', but discarding the result +-- +throwIfNeg_ :: (Ord a, Num a) => (a -> String) -> IO a -> IO () +throwIfNeg_ = throwIf_ (< 0) + +-- |Guards against null pointers +-- +throwIfNull :: String -> IO (Ptr a) -> IO (Ptr a) +throwIfNull = throwIf (== nullPtr) . const + +-- |Discard the return value of an 'IO' action +-- +void :: IO a -> IO () +void act = act >> return () +{-# DEPRECATED void "use 'Control.Monad.void' instead" #-} -- deprecated in 7.6 diff --git a/libraries/base/Foreign/Marshal/Pool.hs b/libraries/base/Foreign/Marshal/Pool.hs new file mode 100644 index 0000000..5d92f6f --- /dev/null +++ b/libraries/base/Foreign/Marshal/Pool.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-------------------------------------------------------------------------------- +-- | +-- 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.Base ( Int, Monad(..), (.), liftM, not ) +import GHC.Err ( undefined ) +import GHC.Exception ( throw ) +import GHC.IO ( IO, mask, catchAny ) +import GHC.IORef ( IORef, newIORef, readIORef, writeIORef ) +import GHC.List ( elem, length ) +import GHC.Num ( Num(..) ) + +import Data.OldList ( delete ) +import Foreign.Marshal.Alloc ( mallocBytes, reallocBytes, free ) +import Foreign.Marshal.Array ( pokeArray, pokeArray0 ) +import Foreign.Marshal.Error ( throwIf ) +import Foreign.Ptr ( Ptr, castPtr ) +import Foreign.Storable ( Storable(sizeOf, poke) ) + +-------------------------------------------------------------------------------- + +-- To avoid non-H2010 stuff like existentially quantified data constructors, we +-- simply use pointers to () below. Not very nice, but... + +-- | A memory pool. + +newtype Pool = Pool (IORef [Ptr ()]) + +-- | Allocate a fresh memory pool. + +newPool :: IO Pool +newPool = liftM Pool (newIORef []) + +-- | Deallocate a memory pool and everything which has been allocated in the +-- pool itself. + +freePool :: Pool -> IO () +freePool (Pool pool) = readIORef pool >>= freeAll + where freeAll [] = return () + freeAll (p:ps) = free p >> freeAll ps + +-- | Execute an action with a fresh memory pool, which gets automatically +-- deallocated (including its contents) after the action has finished. + +withPool :: (Pool -> IO b) -> IO b +withPool act = -- ATTENTION: cut-n-paste from Control.Exception below! + mask (\restore -> do + pool <- newPool + val <- catchAny + (restore (act pool)) + (\e -> do freePool pool; throw e) + freePool pool + return val) + +-------------------------------------------------------------------------------- + +-- | Allocate space for storable type in the given pool. The size of the area +-- allocated is determined by the 'sizeOf' method from the instance of +-- 'Storable' for the appropriate type. + +pooledMalloc :: Storable a => Pool -> IO (Ptr a) +pooledMalloc = pm undefined + where + pm :: Storable a' => a' -> Pool -> IO (Ptr a') + pm dummy pool = pooledMallocBytes pool (sizeOf dummy) + +-- | Allocate the given number of bytes of storage in the pool. + +pooledMallocBytes :: Pool -> Int -> IO (Ptr a) +pooledMallocBytes (Pool pool) size = do + ptr <- mallocBytes size + ptrs <- readIORef pool + writeIORef pool (ptr:ptrs) + return (castPtr ptr) + +-- | Adjust the storage area for an element in the pool to the given size of +-- the required type. + +pooledRealloc :: Storable a => Pool -> Ptr a -> IO (Ptr a) +pooledRealloc = pr undefined + where + pr :: Storable a' => a' -> Pool -> Ptr a' -> IO (Ptr a') + pr dummy pool ptr = pooledReallocBytes pool ptr (sizeOf dummy) + +-- | Adjust the storage area for an element in the pool to the given size. + +pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a) +pooledReallocBytes (Pool pool) ptr size = do + let cPtr = castPtr ptr + _ <- throwIf (not . (cPtr `elem`)) (\_ -> "pointer not in pool") (readIORef pool) + newPtr <- reallocBytes cPtr size + ptrs <- readIORef pool + writeIORef pool (newPtr : delete cPtr ptrs) + return (castPtr newPtr) + +-- | Allocate storage for the given number of elements of a storable type in the +-- pool. + +pooledMallocArray :: Storable a => Pool -> Int -> IO (Ptr a) +pooledMallocArray = pma undefined + where + pma :: Storable a' => a' -> Pool -> Int -> IO (Ptr a') + pma dummy pool size = pooledMallocBytes pool (size * sizeOf dummy) + +-- | Allocate storage for the given number of elements of a storable type in the +-- pool, but leave room for an extra element to signal the end of the array. + +pooledMallocArray0 :: Storable a => Pool -> Int -> IO (Ptr a) +pooledMallocArray0 pool size = + pooledMallocArray pool (size + 1) + +-- | Adjust the size of an array in the given pool. + +pooledReallocArray :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a) +pooledReallocArray = pra undefined + where + pra :: Storable a' => a' -> Pool -> Ptr a' -> Int -> IO (Ptr a') + pra dummy pool ptr size = pooledReallocBytes pool ptr (size * sizeOf dummy) + +-- | Adjust the size of an array with an end marker in the given pool. + +pooledReallocArray0 :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a) +pooledReallocArray0 pool ptr size = + pooledReallocArray pool ptr (size + 1) + +-------------------------------------------------------------------------------- + +-- | Allocate storage for a value in the given pool and marshal the value into +-- this storage. + +pooledNew :: Storable a => Pool -> a -> IO (Ptr a) +pooledNew pool val = do + ptr <- pooledMalloc pool + poke ptr val + return ptr + +-- | Allocate consecutive storage for a list of values in the given pool and +-- marshal these values into it. + +pooledNewArray :: Storable a => Pool -> [a] -> IO (Ptr a) +pooledNewArray pool vals = do + ptr <- pooledMallocArray pool (length vals) + pokeArray ptr vals + return ptr + +-- | Allocate consecutive storage for a list of values in the given pool and +-- marshal these values into it, terminating the end with the given marker. + +pooledNewArray0 :: Storable a => Pool -> a -> [a] -> IO (Ptr a) +pooledNewArray0 pool marker vals = do + ptr <- pooledMallocArray0 pool (length vals) + pokeArray0 marker ptr vals + return ptr + diff --git a/libraries/base/Foreign/Marshal/Safe.hs b/libraries/base/Foreign/Marshal/Safe.hs new file mode 100644 index 0000000..5cc2982 --- /dev/null +++ b/libraries/base/Foreign/Marshal/Safe.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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 {-# DEPRECATED "Safe is now the default, please use Foreign.Marshal instead" #-} + ( + -- | 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/libraries/base/Foreign/Marshal/Unsafe.hs b/libraries/base/Foreign/Marshal/Unsafe.hs new file mode 100644 index 0000000..7e986f9 --- /dev/null +++ b/libraries/base/Foreign/Marshal/Unsafe.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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.IO + +{- | +Sometimes an external entity is a pure function, except that it passes +arguments and/or results via pointers. The function +@unsafeLocalState@ permits the packaging of such entities as pure +functions. + +The only IO operations allowed in the IO action passed to +@unsafeLocalState@ are (a) local allocation (@alloca@, @allocaBytes@ +and derived operations such as @withArray@ and @withCString@), and (b) +pointer operations (@Foreign.Storable@ and @Foreign.Ptr@) on the +pointers to local storage, and (c) foreign functions whose only +observable effect is to read and/or write the locally allocated +memory. Passing an IO operation that does not obey these rules +results in undefined behaviour. + +It is expected that this operation will be +replaced in a future revision of Haskell. +-} +unsafeLocalState :: IO a -> a +unsafeLocalState = unsafeDupablePerformIO + diff --git a/libraries/base/Foreign/Marshal/Utils.hs b/libraries/base/Foreign/Marshal/Utils.hs new file mode 100644 index 0000000..6f24346 --- /dev/null +++ b/libraries/base/Foreign/Marshal/Utils.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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 Data.Maybe +import Foreign.Ptr ( Ptr, nullPtr ) +import Foreign.Storable ( Storable(poke) ) +import Foreign.C.Types ( CSize(..), CInt(..) ) +import Foreign.Marshal.Alloc ( malloc, alloca ) +import Data.Word ( Word8 ) + +import GHC.Real ( fromIntegral ) +import GHC.Num +import GHC.Base + +-- combined allocation and marshalling +-- ----------------------------------- + +-- |Allocate a block of memory and marshal a value into it +-- (the combination of 'malloc' and 'poke'). +-- The size of the area allocated is determined by the 'Foreign.Storable.sizeOf' +-- method from the instance of 'Storable' for the appropriate type. +-- +-- The memory may be deallocated using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree' when no longer required. +-- +new :: Storable a => a -> IO (Ptr a) +new val = + do + ptr <- malloc + poke ptr val + return ptr + +-- |@'with' val f@ executes the computation @f@, passing as argument +-- a pointer to a temporarily allocated block of memory into which +-- @val@ has been marshalled (the combination of 'alloca' and 'poke'). +-- +-- The memory is freed when @f@ terminates (either normally or via an +-- exception), so the pointer passed to @f@ must /not/ be used after this. +-- +with :: Storable a => a -> (Ptr a -> IO b) -> IO b +with val f = + alloca $ \ptr -> do + poke ptr val + res <- f ptr + return res + + +-- marshalling of Boolean values (non-zero corresponds to 'True') +-- ----------------------------- + +-- |Convert a Haskell 'Bool' to its numeric representation +-- +fromBool :: Num a => Bool -> a +fromBool False = 0 +fromBool True = 1 + +-- |Convert a Boolean in numeric representation to a Haskell value +-- +toBool :: (Eq a, Num a) => a -> Bool +toBool = (/= 0) + + +-- marshalling of Maybe values +-- --------------------------- + +-- |Allocate storage and marshal a storable value wrapped into a 'Maybe' +-- +-- * the 'nullPtr' is used to represent 'Nothing' +-- +maybeNew :: ( a -> IO (Ptr b)) + -> (Maybe a -> IO (Ptr b)) +maybeNew = maybe (return nullPtr) + +-- |Converts a @withXXX@ combinator into one marshalling a value wrapped +-- into a 'Maybe', using 'nullPtr' to represent 'Nothing'. +-- +maybeWith :: ( a -> (Ptr b -> IO c) -> IO c) + -> (Maybe a -> (Ptr b -> IO c) -> IO c) +maybeWith = maybe ($ nullPtr) + +-- |Convert a peek combinator into a one returning 'Nothing' if applied to a +-- 'nullPtr' +-- +maybePeek :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b) +maybePeek peek ptr | ptr == nullPtr = return Nothing + | otherwise = do a <- peek ptr; return (Just a) + + +-- marshalling lists of storable objects +-- ------------------------------------- + +-- |Replicates a @withXXX@ combinator over a list of objects, yielding a list of +-- marshalled objects +-- +withMany :: (a -> (b -> res) -> res) -- withXXX combinator for one object + -> [a] -- storable objects + -> ([b] -> res) -- action on list of marshalled obj.s + -> res +withMany _ [] f = f [] +withMany withFoo (x:xs) f = withFoo x $ \x' -> + withMany withFoo xs (\xs' -> f (x':xs')) + + +-- Haskellish interface to memcpy and memmove +-- ------------------------------------------ + +-- |Copies the given number of bytes from the second area (source) into the +-- first (destination); the copied areas may /not/ overlap +-- +copyBytes :: Ptr a -> Ptr a -> Int -> IO () +copyBytes dest src size = do _ <- memcpy dest src (fromIntegral size) + return () + +-- |Copies the given number of bytes from the second area (source) into the +-- first (destination); the copied areas /may/ overlap +-- +moveBytes :: Ptr a -> Ptr a -> Int -> IO () +moveBytes dest src size = do _ <- memmove dest src (fromIntegral size) + return () + +-- Filling up memory area with required values +-- ------------------------------------------- + +-- |Fill a given number of bytes in memory area with a byte value. +-- +-- @since 4.8.0.0 +fillBytes :: Ptr a -> Word8 -> Int -> IO () +fillBytes dest char size = do + _ <- memset dest (fromIntegral char) (fromIntegral size) + return () + +-- auxilliary routines +-- ------------------- + +-- |Basic C routines needed for memory copying +-- +foreign import ccall unsafe "string.h" memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) +foreign import ccall unsafe "string.h" memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) +foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) diff --git a/libraries/base/Foreign/Ptr.hs b/libraries/base/Foreign/Ptr.hs new file mode 100644 index 0000000..efe580a --- /dev/null +++ b/libraries/base/Foreign/Ptr.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, GeneralizedNewtypeDeriving, + StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- 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, + -- Free the function pointer created by foreign export dynamic. + + -- * Integral types with lossless conversion to and from pointers + IntPtr, + ptrToIntPtr, + intPtrToPtr, + WordPtr, + ptrToWordPtr, + wordPtrToPtr + ) where + +import GHC.Ptr +import GHC.Base +import GHC.Num +import GHC.Read +import GHC.Real +import GHC.Show +import GHC.Enum + +import Data.Bits +import Foreign.Storable ( Storable(..) ) + +-- | Release the storage associated with the given 'FunPtr', which +-- must have been obtained from a wrapper stub. This should be called +-- whenever the return value from a foreign import wrapper function is +-- no longer required; otherwise, the storage it uses will leak. +foreign import ccall unsafe "freeHaskellFunctionPtr" + freeHaskellFunPtr :: FunPtr a -> IO () + +#include "HsBaseConfig.h" +#include "CTypes.h" + +-- | An unsigned integral type that can be losslessly converted to and from +-- @Ptr@. This type is also compatible with the C99 type @uintptr_t@, and +-- can be marshalled to and from that type safely. +INTEGRAL_TYPE(WordPtr,Word) + -- Word and Int are guaranteed pointer-sized in GHC + +-- | A signed integral type that can be losslessly converted to and from +-- @Ptr@. This type is also compatible with the C99 type @intptr_t@, and +-- can be marshalled to and from that type safely. +INTEGRAL_TYPE(IntPtr,Int) + -- Word and Int are guaranteed pointer-sized in GHC + +-- | casts a @Ptr@ to a @WordPtr@ +ptrToWordPtr :: Ptr a -> WordPtr +ptrToWordPtr (Ptr a#) = WordPtr (W# (int2Word# (addr2Int# a#))) + +-- | casts a @WordPtr@ to a @Ptr@ +wordPtrToPtr :: WordPtr -> Ptr a +wordPtrToPtr (WordPtr (W# w#)) = Ptr (int2Addr# (word2Int# w#)) + +-- | casts a @Ptr@ to an @IntPtr@ +ptrToIntPtr :: Ptr a -> IntPtr +ptrToIntPtr (Ptr a#) = IntPtr (I# (addr2Int# a#)) + +-- | casts an @IntPtr@ to a @Ptr@ +intPtrToPtr :: IntPtr -> Ptr a +intPtrToPtr (IntPtr (I# i#)) = Ptr (int2Addr# i#) diff --git a/libraries/base/Foreign/Safe.hs b/libraries/base/Foreign/Safe.hs new file mode 100644 index 0000000..6b84d17 --- /dev/null +++ b/libraries/base/Foreign/Safe.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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/libraries/base/Foreign/StablePtr.hs b/libraries/base/Foreign/StablePtr.hs new file mode 100644 index 0000000..acd89e5 --- /dev/null +++ b/libraries/base/Foreign/StablePtr.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- 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 -- abstract + , newStablePtr + , deRefStablePtr + , freeStablePtr + , castStablePtrToPtr + , castPtrToStablePtr + , -- ** The C-side interface + + -- $cinterface + ) where + +import GHC.Stable + +-- $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/libraries/base/Foreign/Storable.hs b/libraries/base/Foreign/Storable.hs new file mode 100644 index 0000000..5b657a1 --- /dev/null +++ b/libraries/base/Foreign/Storable.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables, BangPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- 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 + + +#include "MachDeps.h" +#include "HsBaseConfig.h" + +import GHC.Storable +import GHC.Stable ( StablePtr ) +import GHC.Num +import GHC.Int +import GHC.Word +import GHC.Ptr +import GHC.Base +import GHC.Fingerprint.Type +import Data.Bits +import GHC.Real + +{- | +The member functions of this class facilitate writing values of +primitive types to raw memory (which may have been allocated with the +above mentioned routines) and reading values from blocks of raw +memory. The class, furthermore, includes support for computing the +storage requirements and alignment restrictions of storable types. + +Memory addresses are represented as values of type @'Ptr' a@, for some +@a@ which is an instance of class 'Storable'. The type argument to +'Ptr' helps provide some valuable type safety in FFI code (you can\'t +mix pointers of different types without an explicit cast), while +helping the Haskell type system figure out which marshalling method is +needed for a given pointer. + +All marshalling between Haskell and a foreign language ultimately +boils down to translating Haskell data structures into the binary +representation of a corresponding data structure of the foreign +language and vice versa. To code this marshalling in Haskell, it is +necessary to manipulate primitive data types stored in unstructured +memory blocks. The class 'Storable' facilitates this manipulation on +all types for which it is instantiated, which are the standard basic +types of Haskell, the fixed size @Int@ types ('Int8', 'Int16', +'Int32', 'Int64'), the fixed size @Word@ types ('Word8', 'Word16', +'Word32', 'Word64'), 'StablePtr', all types from "Foreign.C.Types", +as well as 'Ptr'. +-} + +class Storable a where + {-# MINIMAL sizeOf, alignment, + (peek | peekElemOff | peekByteOff), + (poke | pokeElemOff | pokeByteOff) #-} + + sizeOf :: a -> Int + -- ^ Computes the storage requirements (in bytes) of the argument. + -- The value of the argument is not used. + + alignment :: a -> Int + -- ^ Computes the alignment constraint of the argument. An + -- alignment constraint @x@ is fulfilled by any address divisible + -- by @x@. The value of the argument is not used. + + peekElemOff :: Ptr a -> Int -> IO a + -- ^ Read a value from a memory area regarded as an array + -- of values of the same kind. The first argument specifies + -- the start address of the array and the second the index into + -- the array (the first element of the array has index + -- @0@). The following equality holds, + -- + -- > peekElemOff addr idx = IOExts.fixIO $ \result -> + -- > peek (addr `plusPtr` (idx * sizeOf result)) + -- + -- Note that this is only a specification, not + -- necessarily the concrete implementation of the + -- function. + + pokeElemOff :: Ptr a -> Int -> a -> IO () + -- ^ Write a value to a memory area regarded as an array of + -- values of the same kind. The following equality holds: + -- + -- > pokeElemOff addr idx x = + -- > poke (addr `plusPtr` (idx * sizeOf x)) x + + peekByteOff :: Ptr b -> Int -> IO a + -- ^ Read a value from a memory location given by a base + -- address and offset. The following equality holds: + -- + -- > peekByteOff addr off = peek (addr `plusPtr` off) + + pokeByteOff :: Ptr b -> Int -> a -> IO () + -- ^ Write a value to a memory location given by a base + -- address and offset. The following equality holds: + -- + -- > pokeByteOff addr off x = poke (addr `plusPtr` off) x + + peek :: Ptr a -> IO a + -- ^ Read a value from the given memory location. + -- + -- Note that the peek and poke functions might require properly + -- aligned addresses to function correctly. This is architecture + -- dependent; thus, portable code should ensure that when peeking or + -- poking values of some type @a@, the alignment + -- constraint for @a@, as given by the function + -- 'alignment' is fulfilled. + + poke :: Ptr a -> a -> IO () + -- ^ Write the given value to the given memory location. Alignment + -- restrictions might apply; see 'peek'. + + -- circular default instances + peekElemOff = peekElemOff_ undefined + where peekElemOff_ :: a -> Ptr a -> Int -> IO a + peekElemOff_ undef ptr off = peekByteOff ptr (off * sizeOf undef) + pokeElemOff ptr off val = pokeByteOff ptr (off * sizeOf val) val + + peekByteOff ptr off = peek (ptr `plusPtr` off) + pokeByteOff ptr off = poke (ptr `plusPtr` off) + + peek ptr = peekElemOff ptr 0 + poke ptr = pokeElemOff ptr 0 + +instance Storable () where + sizeOf _ = 0 + alignment _ = 1 + peek _ = return () + poke _ _ = return () + +-- System-dependent, but rather obvious instances + +instance Storable Bool where + sizeOf _ = sizeOf (undefined::HTYPE_INT) + alignment _ = alignment (undefined::HTYPE_INT) + peekElemOff p i = liftM (/= (0::HTYPE_INT)) $ peekElemOff (castPtr p) i + pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::HTYPE_INT) + +#define STORABLE(T,size,align,read,write) \ +instance Storable (T) where { \ + sizeOf _ = size; \ + alignment _ = align; \ + peekElemOff = read; \ + pokeElemOff = write } + +STORABLE(Char,SIZEOF_INT32,ALIGNMENT_INT32, + readWideCharOffPtr,writeWideCharOffPtr) + +STORABLE(Int,SIZEOF_HSINT,ALIGNMENT_HSINT, + readIntOffPtr,writeIntOffPtr) + +STORABLE(Word,SIZEOF_HSWORD,ALIGNMENT_HSWORD, + readWordOffPtr,writeWordOffPtr) + +STORABLE((Ptr a),SIZEOF_HSPTR,ALIGNMENT_HSPTR, + readPtrOffPtr,writePtrOffPtr) + +STORABLE((FunPtr a),SIZEOF_HSFUNPTR,ALIGNMENT_HSFUNPTR, + readFunPtrOffPtr,writeFunPtrOffPtr) + +STORABLE((StablePtr a),SIZEOF_HSSTABLEPTR,ALIGNMENT_HSSTABLEPTR, + readStablePtrOffPtr,writeStablePtrOffPtr) + +STORABLE(Float,SIZEOF_HSFLOAT,ALIGNMENT_HSFLOAT, + readFloatOffPtr,writeFloatOffPtr) + +STORABLE(Double,SIZEOF_HSDOUBLE,ALIGNMENT_HSDOUBLE, + readDoubleOffPtr,writeDoubleOffPtr) + +STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8, + readWord8OffPtr,writeWord8OffPtr) + +STORABLE(Word16,SIZEOF_WORD16,ALIGNMENT_WORD16, + readWord16OffPtr,writeWord16OffPtr) + +STORABLE(Word32,SIZEOF_WORD32,ALIGNMENT_WORD32, + readWord32OffPtr,writeWord32OffPtr) + +STORABLE(Word64,SIZEOF_WORD64,ALIGNMENT_WORD64, + readWord64OffPtr,writeWord64OffPtr) + +STORABLE(Int8,SIZEOF_INT8,ALIGNMENT_INT8, + readInt8OffPtr,writeInt8OffPtr) + +STORABLE(Int16,SIZEOF_INT16,ALIGNMENT_INT16, + readInt16OffPtr,writeInt16OffPtr) + +STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32, + readInt32OffPtr,writeInt32OffPtr) + +STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64, + readInt64OffPtr,writeInt64OffPtr) + +instance (Storable a, Integral a) => Storable (Ratio a) where + sizeOf _ = 2 * sizeOf (undefined :: a) + alignment _ = alignment (undefined :: 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 + +-- XXX: here to avoid orphan instance in GHC.Fingerprint +instance Storable Fingerprint where + sizeOf _ = 16 + alignment _ = 8 + peek = peekFingerprint + poke = pokeFingerprint + +-- peek/poke in fixed BIG-endian 128-bit format +peekFingerprint :: Ptr Fingerprint -> IO Fingerprint +peekFingerprint p0 = do + let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64 + peekW64 _ 0 !i = return i + peekW64 !p !n !i = do + w8 <- peek p + peekW64 (p `plusPtr` 1) (n-1) + ((i `shiftL` 8) .|. fromIntegral w8) + + high <- peekW64 (castPtr p0) 8 0 + low <- peekW64 (castPtr p0 `plusPtr` 8) 8 0 + return (Fingerprint high low) + +pokeFingerprint :: Ptr Fingerprint -> Fingerprint -> IO () +pokeFingerprint p0 (Fingerprint high low) = do + let pokeW64 :: Ptr Word8 -> Int -> Word64 -> IO () + pokeW64 _ 0 _ = return () + pokeW64 p !n !i = do + pokeElemOff p (n-1) (fromIntegral i) + pokeW64 p (n-1) (i `shiftR` 8) + + pokeW64 (castPtr p0) 8 high + pokeW64 (castPtr p0 `plusPtr` 8) 8 low diff --git a/libraries/base/GHC/Arr.hs b/libraries/base/GHC/Arr.hs new file mode 100644 index 0000000..c736f56 --- /dev/null +++ b/libraries/base/GHC/Arr.hs @@ -0,0 +1,901 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, RoleAnnotations #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Arr +-- Copyright : (c) The University of Glasgow, 1994-2000 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- GHC\'s array implementation. +-- +----------------------------------------------------------------------------- + +module GHC.Arr ( + Ix(..), Array(..), STArray(..), + + indexError, hopelessIndexError, + 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.Enum +import GHC.Num +import GHC.ST +import GHC.Base +import GHC.List +import GHC.Real( fromIntegral ) +import GHC.Show + +infixl 9 !, // + +default () + +-- | The 'Ix' class is used to map a contiguous subrange of values in +-- a type onto integers. It is used primarily for array indexing +-- (see the array package). +-- +-- The first argument @(l,u)@ of each of these operations is a pair +-- specifying the lower and upper bounds of a contiguous subrange of values. +-- +-- An implementation is entitled to assume the following laws about these +-- operations: +-- +-- * @'inRange' (l,u) i == 'elem' i ('range' (l,u))@ @ @ +-- +-- * @'range' (l,u) '!!' 'index' (l,u) i == i@, when @'inRange' (l,u) i@ +-- +-- * @'map' ('index' (l,u)) ('range' (l,u))) == [0..'rangeSize' (l,u)-1]@ @ @ +-- +-- * @'rangeSize' (l,u) == 'length' ('range' (l,u))@ @ @ +-- +class (Ord a) => Ix a where + {-# MINIMAL range, (index | unsafeIndex), inRange #-} + + -- | The list of values in the subrange defined by a bounding pair. + range :: (a,a) -> [a] + -- | The position of a subscript in the subrange. + index :: (a,a) -> a -> Int + -- | Like 'index', but without checking that the value is in range. + unsafeIndex :: (a,a) -> a -> Int + -- | Returns 'True' the given subscript lies in the range defined + -- the bounding pair. + inRange :: (a,a) -> a -> Bool + -- | The size of the subrange defined by a bounding pair. + rangeSize :: (a,a) -> Int + -- | like 'rangeSize', but without checking that the upper bound is + -- in range. + unsafeRangeSize :: (a,a) -> Int + + -- Must specify one of index, unsafeIndex + + -- 'index' is typically over-ridden in instances, with essentially + -- the same code, but using indexError instead of hopelessIndexError + -- Reason: we have 'Show' at the instances + {-# INLINE index #-} -- See Note [Inlining index] + index b i | inRange b i = unsafeIndex b i + | otherwise = hopelessIndexError + + unsafeIndex b i = index b i + + rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1 + | otherwise = 0 -- This case is only here to + -- check for an empty range + -- NB: replacing (inRange b h) by (l <= h) fails for + -- tuples. E.g. (1,2) <= (2,1) but the range is empty + + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + +{- +Note that the following is NOT right + rangeSize (l,h) | l <= h = index b h + 1 + | otherwise = 0 + +Because it might be the case that l (a,a) -> a -> String -> b +indexError rng i tp + = errorWithoutStackTrace (showString "Ix{" . showString tp . showString "}.index: Index " . + showParen True (showsPrec 0 i) . + showString " out of range " $ + showParen True (showsPrec 0 rng) "") + +hopelessIndexError :: Int -- Try to use 'indexError' instead! +hopelessIndexError = errorWithoutStackTrace "Error in array index" + +---------------------------------------------------------------------- +instance Ix Char where + {-# INLINE range #-} + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (m,_n) i = fromEnum i - fromEnum m + + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Char" + + inRange (m,n) i = m <= i && i <= n + +---------------------------------------------------------------------- +instance Ix Int where + {-# INLINE range #-} + -- The INLINE stops the build in the RHS from getting inlined, + -- so that callers can fuse with the result of range + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (m,_n) i = i - m + + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Int" + + {-# INLINE inRange #-} + inRange (I# m,I# n) (I# i) = isTrue# (m <=# i) && isTrue# (i <=# n) + +instance Ix Word where + range (m,n) = [m..n] + unsafeIndex (m,_) i = fromIntegral (i - m) + inRange (m,n) i = m <= i && i <= n + +---------------------------------------------------------------------- +instance Ix Integer where + {-# INLINE range #-} + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (m,_n) i = fromInteger (i - m) + + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Integer" + + inRange (m,n) i = m <= i && i <= n + +---------------------------------------------------------------------- +instance Ix Bool where -- as derived + {-# INLINE range #-} + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (l,_) i = fromEnum i - fromEnum l + + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Bool" + + inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u + +---------------------------------------------------------------------- +instance Ix Ordering where -- as derived + {-# INLINE range #-} + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (l,_) i = fromEnum i - fromEnum l + + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Ordering" + + inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u + +---------------------------------------------------------------------- +instance Ix () where + {-# INLINE range #-} + range ((), ()) = [()] + {-# INLINE unsafeIndex #-} + unsafeIndex ((), ()) () = 0 + {-# INLINE inRange #-} + inRange ((), ()) () = True + + {-# INLINE index #-} -- See Note [Inlining index] + index b i = unsafeIndex b i + +---------------------------------------------------------------------- +instance (Ix a, Ix b) => Ix (a, b) where -- as derived + {-# SPECIALISE instance Ix (Int,Int) #-} + + {-# INLINE range #-} + range ((l1,l2),(u1,u2)) = + [ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ] + + {-# INLINE unsafeIndex #-} + unsafeIndex ((l1,l2),(u1,u2)) (i1,i2) = + unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2 + + {-# INLINE inRange #-} + inRange ((l1,l2),(u1,u2)) (i1,i2) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 + + -- Default method for index + +---------------------------------------------------------------------- +instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where + {-# SPECIALISE instance Ix (Int,Int,Int) #-} + + range ((l1,l2,l3),(u1,u2,u3)) = + [(i1,i2,i3) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3)] + + unsafeIndex ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( + unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( + unsafeIndex (l1,u1) i1)) + + inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 + + -- Default method for index + +---------------------------------------------------------------------- +instance (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4) where + range ((l1,l2,l3,l4),(u1,u2,u3,u4)) = + [(i1,i2,i3,i4) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3), + i4 <- range (l4,u4)] + + unsafeIndex ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = + unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * ( + unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( + unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( + unsafeIndex (l1,u1) i1))) + + inRange ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 && inRange (l4,u4) i4 + + -- Default method for index + +instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where + range ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) = + [(i1,i2,i3,i4,i5) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3), + i4 <- range (l4,u4), + i5 <- range (l5,u5)] + + unsafeIndex ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = + unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * ( + unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * ( + unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( + unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( + unsafeIndex (l1,u1) i1)))) + + inRange ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 && inRange (l4,u4) i4 && + inRange (l5,u5) i5 + + -- Default method for index + +-- | The type of immutable non-strict (boxed) arrays +-- with indices in @i@ and elements in @e@. +data Array i e + = Array !i -- the lower bound, l + !i -- the upper bound, u + {-# UNPACK #-} !Int -- A cache of (rangeSize (l,u)) + -- used to make sure an index is + -- really in range + (Array# e) -- The actual elements + +-- | Mutable, boxed, non-strict arrays in the 'ST' monad. The type +-- arguments are as follows: +-- +-- * @s@: the state variable argument for the 'ST' type +-- +-- * @i@: the index type of the array (should be an instance of 'Ix') +-- +-- * @e@: the element type of the array. +-- +data STArray s i e + = STArray !i -- the lower bound, l + !i -- the upper bound, u + {-# UNPACK #-} !Int -- A cache of (rangeSize (l,u)) + -- used to make sure an index is + -- really in range + (MutableArray# s e) -- The actual elements + -- No Ix context for STArray. They are stupid, + -- and force an Ix context on the equality instance. + +-- Index types should have nominal role, because of Ix class. See also #9220. +type role Array nominal representational +type role STArray nominal nominal representational + +-- Just pointer equality on mutable arrays: +instance Eq (STArray s i e) where + STArray _ _ _ arr1# == STArray _ _ _ arr2# = + isTrue# (sameMutableArray# arr1# arr2#) + +---------------------------------------------------------------------- +-- Operations on immutable arrays + +{-# NOINLINE arrEleBottom #-} +arrEleBottom :: a +arrEleBottom = errorWithoutStackTrace "(Array.!): undefined array element" + +-- | Construct an array with the specified bounds and containing values +-- for given indices within these bounds. +-- +-- The array is undefined (i.e. bottom) if any index in the list is +-- out of bounds. The Haskell 2010 Report further specifies that if any +-- two associations in the list have the same index, the value at that +-- index is undefined (i.e. bottom). However in GHC's implementation, +-- the value at such an index is the value part of the last association +-- with that index in the list. +-- +-- Because the indices must be checked for these errors, 'array' is +-- strict in the bounds argument and in the indices of the association +-- list, but non-strict in the values. Thus, recurrences such as the +-- following are possible: +-- +-- > a = array (1,100) ((1,1) : [(i, i * a!(i-1)) | i <- [2..100]]) +-- +-- Not every index within the bounds of the array need appear in the +-- association list, but the values associated with indices that do not +-- appear will be undefined (i.e. bottom). +-- +-- If, in any dimension, the lower bound is greater than the upper bound, +-- then the array is legal, but empty. Indexing an empty array always +-- gives an array-bounds error, but 'bounds' still yields the bounds +-- with which the array was constructed. +{-# INLINE array #-} +array :: Ix i + => (i,i) -- ^ a pair of /bounds/, each of the index type + -- of the array. These bounds are the lowest and + -- highest indices in the array, in that order. + -- For example, a one-origin vector of length + -- '10' has bounds '(1,10)', and a one-origin '10' + -- by '10' matrix has bounds '((1,1),(10,10))'. + -> [(i, e)] -- ^ a list of /associations/ of the form + -- (/index/, /value/). Typically, this list will + -- be expressed as a comprehension. An + -- association '(i, x)' defines the value of + -- the array at index 'i' to be 'x'. + -> Array i e +array (l,u) ies + = let n = safeRangeSize (l,u) + in unsafeArray' (l,u) n + [(safeIndex (l,u) n i, e) | (i, e) <- ies] + +{-# INLINE unsafeArray #-} +unsafeArray :: Ix i => (i,i) -> [(Int, e)] -> Array i e +unsafeArray b ies = unsafeArray' b (rangeSize b) ies + +{-# INLINE unsafeArray' #-} +unsafeArray' :: (i,i) -> Int -> [(Int, e)] -> Array i e +unsafeArray' (l,u) n@(I# n#) ies = runST (ST $ \s1# -> + case newArray# n# arrEleBottom s1# of + (# s2#, marr# #) -> + foldr (fill marr#) (done l u n marr#) ies s2#) + +{-# INLINE fill #-} +fill :: MutableArray# s e -> (Int, e) -> STRep s a -> STRep s a +-- NB: put the \s after the "=" so that 'fill' +-- inlines when applied to three args +fill marr# (I# i#, e) next + = \s1# -> case writeArray# marr# i# e s1# of + s2# -> next s2# + +{-# INLINE done #-} +done :: i -> i -> Int -> MutableArray# s e -> STRep s (Array i e) +-- See NB on 'fill' +-- Make sure it is strict in 'n' +done l u n@(I# _) marr# + = \s1# -> case unsafeFreezeArray# marr# s1# of + (# s2#, arr# #) -> (# s2#, Array l u n arr# #) + +-- | Construct an array from a pair of bounds and a list of values in +-- index order. +{-# INLINE listArray #-} +listArray :: Ix i => (i,i) -> [e] -> Array i e +listArray (l,u) es = runST (ST $ \s1# -> + case safeRangeSize (l,u) of { n@(I# n#) -> + case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) -> + let + go y r = \ i# s3# -> + case writeArray# marr# i# y s3# of + s4# -> if (isTrue# (i# ==# n# -# 1#)) + then s4# + else r (i# +# 1#) s4# + in + done l u n marr# ( + if n == 0 + then s2# + else foldr go (\_ s# -> s#) es 0# s2#)}}) + +-- | The value at the given index in an array. +{-# INLINE (!) #-} +(!) :: Ix i => Array i e -> i -> e +arr@(Array l u n _) ! i = unsafeAt arr $ safeIndex (l,u) n i + +{-# INLINE safeRangeSize #-} +safeRangeSize :: Ix i => (i, i) -> Int +safeRangeSize (l,u) = let r = rangeSize (l, u) + in if r < 0 then negRange + else r + +-- Don't inline this error message everywhere!! +negRange :: Int -- Uninformative, but Ix does not provide Show +negRange = errorWithoutStackTrace "Negative range size" + +{-# INLINE[1] safeIndex #-} +-- See Note [Double bounds-checking of index values] +-- Inline *after* (!) so the rules can fire +-- Make sure it is strict in n +safeIndex :: Ix i => (i, i) -> Int -> i -> Int +safeIndex (l,u) n@(I# _) i + | (0 <= i') && (i' < n) = i' + | otherwise = badSafeIndex i' n + where + i' = index (l,u) i + +-- See Note [Double bounds-checking of index values] +{-# RULES +"safeIndex/I" safeIndex = lessSafeIndex :: (Int,Int) -> Int -> Int -> Int +"safeIndex/(I,I)" safeIndex = lessSafeIndex :: ((Int,Int),(Int,Int)) -> Int -> (Int,Int) -> Int +"safeIndex/(I,I,I)" safeIndex = lessSafeIndex :: ((Int,Int,Int),(Int,Int,Int)) -> Int -> (Int,Int,Int) -> Int + #-} + +lessSafeIndex :: Ix i => (i, i) -> Int -> i -> Int +-- See Note [Double bounds-checking of index values] +-- Do only (A), the semantic check +lessSafeIndex (l,u) _ i = index (l,u) i + +-- Don't inline this long error message everywhere!! +badSafeIndex :: Int -> Int -> Int +badSafeIndex i' n = errorWithoutStackTrace ("Error in array index; " ++ show i' ++ + " not in range [0.." ++ show n ++ ")") + +{-# INLINE unsafeAt #-} +unsafeAt :: Array i e -> Int -> e +unsafeAt (Array _ _ _ arr#) (I# i#) = + case indexArray# arr# i# of (# e #) -> e + +-- | The bounds with which an array was constructed. +{-# INLINE bounds #-} +bounds :: Array i e -> (i,i) +bounds (Array l u _ _) = (l,u) + +-- | The number of elements in the array. +{-# INLINE numElements #-} +numElements :: Array i e -> Int +numElements (Array _ _ n _) = n + +-- | The list of indices of an array in ascending order. +{-# INLINE indices #-} +indices :: Ix i => Array i e -> [i] +indices (Array l u _ _) = range (l,u) + +-- | The list of elements of an array in index order. +{-# INLINE elems #-} +elems :: Array i e -> [e] +elems arr@(Array _ _ n _) = + [unsafeAt arr i | i <- [0 .. n - 1]] + +-- | A right fold over the elements +{-# INLINABLE foldrElems #-} +foldrElems :: (a -> b -> b) -> b -> Array i a -> b +foldrElems f b0 = \ arr@(Array _ _ n _) -> + let + go i | i == n = b0 + | otherwise = f (unsafeAt arr i) (go (i+1)) + in go 0 + +-- | A left fold over the elements +{-# INLINABLE foldlElems #-} +foldlElems :: (b -> a -> b) -> b -> Array i a -> b +foldlElems f b0 = \ arr@(Array _ _ n _) -> + let + go i | i == (-1) = b0 + | otherwise = f (go (i-1)) (unsafeAt arr i) + in go (n-1) + +-- | A strict right fold over the elements +{-# INLINABLE foldrElems' #-} +foldrElems' :: (a -> b -> b) -> b -> Array i a -> b +foldrElems' f b0 = \ arr@(Array _ _ n _) -> + let + go i a | i == (-1) = a + | otherwise = go (i-1) (f (unsafeAt arr i) $! a) + in go (n-1) b0 + +-- | A strict left fold over the elements +{-# INLINABLE foldlElems' #-} +foldlElems' :: (b -> a -> b) -> b -> Array i a -> b +foldlElems' f b0 = \ arr@(Array _ _ n _) -> + let + go i a | i == n = a + | otherwise = go (i+1) (a `seq` f a (unsafeAt arr i)) + in go 0 b0 + +-- | A left fold over the elements with no starting value +{-# INLINABLE foldl1Elems #-} +foldl1Elems :: (a -> a -> a) -> Array i a -> a +foldl1Elems f = \ arr@(Array _ _ n _) -> + let + go i | i == 0 = unsafeAt arr 0 + | otherwise = f (go (i-1)) (unsafeAt arr i) + in + if n == 0 then errorWithoutStackTrace "foldl1: empty Array" else go (n-1) + +-- | A right fold over the elements with no starting value +{-# INLINABLE foldr1Elems #-} +foldr1Elems :: (a -> a -> a) -> Array i a -> a +foldr1Elems f = \ arr@(Array _ _ n _) -> + let + go i | i == n-1 = unsafeAt arr i + | otherwise = f (unsafeAt arr i) (go (i + 1)) + in + if n == 0 then errorWithoutStackTrace "foldr1: empty Array" else go 0 + +-- | The list of associations of an array in index order. +{-# INLINE assocs #-} +assocs :: Ix i => Array i e -> [(i, e)] +assocs arr@(Array l u _ _) = + [(i, arr ! i) | i <- range (l,u)] + +-- | The 'accumArray' function deals with repeated indices in the association +-- list using an /accumulating function/ which combines the values of +-- associations with the same index. +-- For example, given a list of values of some index type, @hist@ +-- produces a histogram of the number of occurrences of each index within +-- a specified range: +-- +-- > hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b +-- > hist bnds is = accumArray (+) 0 bnds [(i, 1) | i<-is, inRange bnds i] +-- +-- If the accumulating function is strict, then 'accumArray' is strict in +-- the values, as well as the indices, in the association list. Thus, +-- unlike ordinary arrays built with 'array', accumulated arrays should +-- not in general be recursive. +{-# INLINE accumArray #-} +accumArray :: Ix i + => (e -> a -> e) -- ^ accumulating function + -> e -- ^ initial value + -> (i,i) -- ^ bounds of the array + -> [(i, a)] -- ^ association list + -> Array i e +accumArray f initial (l,u) ies = + let n = safeRangeSize (l,u) + in unsafeAccumArray' f initial (l,u) n + [(safeIndex (l,u) n i, e) | (i, e) <- ies] + +{-# INLINE unsafeAccumArray #-} +unsafeAccumArray :: Ix i => (e -> a -> e) -> e -> (i,i) -> [(Int, a)] -> Array i e +unsafeAccumArray f initial b ies = unsafeAccumArray' f initial b (rangeSize b) ies + +{-# INLINE unsafeAccumArray' #-} +unsafeAccumArray' :: (e -> a -> e) -> e -> (i,i) -> Int -> [(Int, a)] -> Array i e +unsafeAccumArray' f initial (l,u) n@(I# n#) ies = runST (ST $ \s1# -> + case newArray# n# initial s1# of { (# s2#, marr# #) -> + foldr (adjust f marr#) (done l u n marr#) ies s2# }) + +{-# INLINE adjust #-} +adjust :: (e -> a -> e) -> MutableArray# s e -> (Int, a) -> STRep s b -> STRep s b +-- See NB on 'fill' +adjust f marr# (I# i#, new) next + = \s1# -> case readArray# marr# i# s1# of + (# s2#, old #) -> + case writeArray# marr# i# (f old new) s2# of + s3# -> next s3# + +-- | Constructs an array identical to the first argument except that it has +-- been updated by the associations in the right argument. +-- For example, if @m@ is a 1-origin, @n@ by @n@ matrix, then +-- +-- > m//[((i,i), 0) | i <- [1..n]] +-- +-- is the same matrix, except with the diagonal zeroed. +-- +-- Repeated indices in the association list are handled as for 'array': +-- Haskell 2010 specifies that the resulting array is undefined (i.e. bottom), +-- but GHC's implementation uses the last association for each index. +{-# INLINE (//) #-} +(//) :: Ix i => Array i e -> [(i, e)] -> Array i e +arr@(Array l u n _) // ies = + unsafeReplace arr [(safeIndex (l,u) n i, e) | (i, e) <- ies] + +{-# INLINE unsafeReplace #-} +unsafeReplace :: Array i e -> [(Int, e)] -> Array i e +unsafeReplace arr ies = runST (do + STArray l u n marr# <- thawSTArray arr + ST (foldr (fill marr#) (done l u n marr#) ies)) + +-- | @'accum' f@ takes an array and an association list and accumulates +-- pairs from the list into the array with the accumulating function @f@. +-- Thus 'accumArray' can be defined using 'accum': +-- +-- > accumArray f z b = accum f (array b [(i, z) | i <- range b]) +-- +{-# INLINE accum #-} +accum :: Ix i => (e -> a -> e) -> Array i e -> [(i, a)] -> Array i e +accum f arr@(Array l u n _) ies = + unsafeAccum f arr [(safeIndex (l,u) n i, e) | (i, e) <- ies] + +{-# INLINE unsafeAccum #-} +unsafeAccum :: (e -> a -> e) -> Array i e -> [(Int, a)] -> Array i e +unsafeAccum f arr ies = runST (do + STArray l u n marr# <- thawSTArray arr + ST (foldr (adjust f marr#) (done l u n marr#) ies)) + +{-# INLINE [1] amap #-} -- See Note [amap] +amap :: (a -> b) -> Array i a -> Array i b +amap f arr@(Array l u n@(I# n#) _) = runST (ST $ \s1# -> + case newArray# n# arrEleBottom s1# of + (# s2#, marr# #) -> + let go i s# + | i == n = done l u n marr# s# + | otherwise = fill marr# (i, f (unsafeAt arr i)) (go (i+1)) s# + in go 0 s2# ) + +{- Note [amap] +~~~~~~~~~~~~~~ +amap was originally defined like this: + + amap f arr@(Array l u n _) = + unsafeArray' (l,u) n [(i, f (unsafeAt arr i)) | i <- [0 .. n - 1]] + +There are two problems: + +1. The enumFromTo implementation produces (spurious) code for the impossible + case of n<0 that ends up duplicating the array freezing code. + +2. This implementation relies on list fusion for efficiency. In order + to implement the "amap/coerce" rule, we need to delay inlining amap + until simplifier phase 1, which is when the eftIntList rule kicks + in and makes that impossible. (c.f. Trac #8767) +-} + + +-- See Breitner, Eisenberg, Peyton Jones, and Weirich, "Safe Zero-cost +-- Coercions for Haskell", section 6.5: +-- http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/coercible.pdf +{-# RULES +"amap/coerce" amap coerce = coerce -- See Note [amap] + #-} + +-- Second functor law: +{-# RULES +"amap/amap" forall f g a . amap f (amap g a) = amap (f . g) a + #-} + +-- | 'ixmap' allows for transformations on array indices. +-- It may be thought of as providing function composition on the right +-- with the mapping that the original array embodies. +-- +-- A similar transformation of array values may be achieved using 'fmap' +-- from the 'Array' instance of the 'Functor' class. +{-# INLINE ixmap #-} +ixmap :: (Ix i, Ix j) => (i,i) -> (i -> j) -> Array j e -> Array i e +ixmap (l,u) f arr = + array (l,u) [(i, arr ! f i) | i <- range (l,u)] + +{-# INLINE eqArray #-} +eqArray :: (Ix i, Eq e) => Array i e -> Array i e -> Bool +eqArray arr1@(Array l1 u1 n1 _) arr2@(Array l2 u2 n2 _) = + if n1 == 0 then n2 == 0 else + l1 == l2 && u1 == u2 && + and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. n1 - 1]] + +{-# INLINE [1] cmpArray #-} +cmpArray :: (Ix i, Ord e) => Array i e -> Array i e -> Ordering +cmpArray arr1 arr2 = compare (assocs arr1) (assocs arr2) + +{-# INLINE cmpIntArray #-} +cmpIntArray :: Ord e => Array Int e -> Array Int e -> Ordering +cmpIntArray arr1@(Array l1 u1 n1 _) arr2@(Array l2 u2 n2 _) = + if n1 == 0 then + if n2 == 0 then EQ else LT + else if n2 == 0 then GT + else case compare l1 l2 of + EQ -> foldr cmp (compare u1 u2) [0 .. (n1 `min` n2) - 1] + other -> other + where + cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of + EQ -> rest + other -> other + +{-# RULES "cmpArray/Int" cmpArray = cmpIntArray #-} + +---------------------------------------------------------------------- +-- Array instances + +instance Functor (Array i) where + fmap = amap + +instance (Ix i, Eq e) => Eq (Array i e) where + (==) = eqArray + +instance (Ix i, Ord e) => Ord (Array i e) where + compare = cmpArray + +instance (Ix a, Show a, Show b) => Show (Array a b) where + showsPrec p a = + showParen (p > appPrec) $ + showString "array " . + showsPrec appPrec1 (bounds a) . + showChar ' ' . + showsPrec appPrec1 (assocs a) + -- Precedence of 'array' is the precedence of application + +-- The Read instance is in GHC.Read + +---------------------------------------------------------------------- +-- Operations on mutable arrays + +{- +Idle ADR question: What's the tradeoff here between flattening these +datatypes into @STArray ix ix (MutableArray# s elt)@ and using +it as is? As I see it, the former uses slightly less heap and +provides faster access to the individual parts of the bounds while the +code used has the benefit of providing a ready-made @(lo, hi)@ pair as +required by many array-related functions. Which wins? Is the +difference significant (probably not). + +Idle AJG answer: When I looked at the outputted code (though it was 2 +years ago) it seems like you often needed the tuple, and we build +it frequently. Now we've got the overloading specialiser things +might be different, though. +-} + +{-# INLINE newSTArray #-} +newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e) +newSTArray (l,u) initial = ST $ \s1# -> + case safeRangeSize (l,u) of { n@(I# n#) -> + case newArray# n# initial s1# of { (# s2#, marr# #) -> + (# s2#, STArray l u n marr# #) }} + +{-# INLINE boundsSTArray #-} +boundsSTArray :: STArray s i e -> (i,i) +boundsSTArray (STArray l u _ _) = (l,u) + +{-# INLINE numElementsSTArray #-} +numElementsSTArray :: STArray s i e -> Int +numElementsSTArray (STArray _ _ n _) = n + +{-# INLINE readSTArray #-} +readSTArray :: Ix i => STArray s i e -> i -> ST s e +readSTArray marr@(STArray l u n _) i = + unsafeReadSTArray marr (safeIndex (l,u) n i) + +{-# INLINE unsafeReadSTArray #-} +unsafeReadSTArray :: STArray s i e -> Int -> ST s e +unsafeReadSTArray (STArray _ _ _ marr#) (I# i#) + = ST $ \s1# -> readArray# marr# i# s1# + +{-# INLINE writeSTArray #-} +writeSTArray :: Ix i => STArray s i e -> i -> e -> ST s () +writeSTArray marr@(STArray l u n _) i e = + unsafeWriteSTArray marr (safeIndex (l,u) n i) e + +{-# INLINE unsafeWriteSTArray #-} +unsafeWriteSTArray :: STArray s i e -> Int -> e -> ST s () +unsafeWriteSTArray (STArray _ _ _ marr#) (I# i#) e = ST $ \s1# -> + case writeArray# marr# i# e s1# of + s2# -> (# s2#, () #) + +---------------------------------------------------------------------- +-- Moving between mutable and immutable + +freezeSTArray :: STArray s i e -> ST s (Array i e) +freezeSTArray (STArray l u n@(I# n#) marr#) = ST $ \s1# -> + case newArray# n# arrEleBottom s1# of { (# s2#, marr'# #) -> + let copy i# s3# | isTrue# (i# ==# n#) = s3# + | otherwise = + case readArray# marr# i# s3# of { (# s4#, e #) -> + case writeArray# marr'# i# e s4# of { s5# -> + copy (i# +# 1#) s5# }} in + case copy 0# s2# of { s3# -> + case unsafeFreezeArray# marr'# s3# of { (# s4#, arr# #) -> + (# s4#, Array l u n arr# #) }}} + +{-# INLINE unsafeFreezeSTArray #-} +unsafeFreezeSTArray :: STArray s i e -> ST s (Array i e) +unsafeFreezeSTArray (STArray l u n marr#) = ST $ \s1# -> + case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) -> + (# s2#, Array l u n arr# #) } + +thawSTArray :: Array i e -> ST s (STArray s i e) +thawSTArray (Array l u n@(I# n#) arr#) = ST $ \s1# -> + case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) -> + let copy i# s3# | isTrue# (i# ==# n#) = s3# + | otherwise = + case indexArray# arr# i# of { (# e #) -> + case writeArray# marr# i# e s3# of { s4# -> + copy (i# +# 1#) s4# }} in + case copy 0# s2# of { s3# -> + (# s3#, STArray l u n marr# #) }} + +{-# INLINE unsafeThawSTArray #-} +unsafeThawSTArray :: Array i e -> ST s (STArray s i e) +unsafeThawSTArray (Array l u n arr#) = ST $ \s1# -> + case unsafeThawArray# arr# s1# of { (# s2#, marr# #) -> + (# s2#, STArray l u n marr# #) } diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs new file mode 100644 index 0000000..1f989c4 --- /dev/null +++ b/libraries/base/GHC/Base.hs @@ -0,0 +1,1224 @@ +{- + +NOTA BENE: Do NOT use ($) anywhere in this module! The type of ($) is +slightly magical (it can return unlifted types), and it is wired in. +But, it is also *defined* in this module, with a non-magical type. +GHC gets terribly confused (and *hangs*) if you try to use ($) in this +module, because it has different types in different scenarios. + +This is not a problem in general, because the type ($), being wired in, is not +written out to the interface file, so importing files don't get confused. +The problem is only if ($) is used here. So don't! + +--------------------------------------------- + +The overall structure of the GHC Prelude is a bit tricky. + + a) We want to avoid "orphan modules", i.e. ones with instance + decls that don't belong either to a tycon or a class + defined in the same module + + b) We want to avoid giant modules + +So the rough structure is as follows, in (linearised) dependency order + + +GHC.Prim Has no implementation. It defines built-in things, and + by importing it you bring them into scope. + The source file is GHC.Prim.hi-boot, which is just + copied to make GHC.Prim.hi + +GHC.Base Classes: Eq, Ord, Functor, Monad + Types: list, (), Int, Bool, Ordering, Char, String + +Data.Tuple Types: tuples, plus instances for GHC.Base classes + +GHC.Show Class: Show, plus instances for GHC.Base/GHC.Tup types + +GHC.Enum Class: Enum, plus instances for GHC.Base/GHC.Tup types + +Data.Maybe Type: Maybe, plus instances for GHC.Base classes + +GHC.List List functions + +GHC.Num Class: Num, plus instances for Int + Type: Integer, plus instances for all classes so far (Eq, Ord, Num, Show) + + Integer is needed here because it is mentioned in the signature + of 'fromInteger' in class Num + +GHC.Real Classes: Real, Integral, Fractional, RealFrac + plus instances for Int, Integer + Types: Ratio, Rational + plus intances for classes so far + + Rational is needed here because it is mentioned in the signature + of 'toRational' in class Real + +GHC.ST The ST monad, instances and a few helper functions + +Ix Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples + +GHC.Arr Types: Array, MutableArray, MutableVar + + Arrays are used by a function in GHC.Float + +GHC.Float Classes: Floating, RealFloat + Types: Float, Double, plus instances of all classes so far + + This module contains everything to do with floating point. + It is a big module (900 lines) + With a bit of luck, many modules can be compiled without ever reading GHC.Float.hi + + +Other Prelude modules are much easier with fewer complex dependencies. +-} + +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , BangPatterns + , ExplicitForAll + , MagicHash + , UnboxedTuples + , ExistentialQuantification + , RankNTypes + #-} +-- -Wno-orphans is needed for things like: +-- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0 +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Base +-- Copyright : (c) The University of Glasgow, 1992-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Basic data types and classes. +-- +----------------------------------------------------------------------------- + +#include "MachDeps.h" + +module GHC.Base + ( + module GHC.Base, + module GHC.Classes, + module GHC.CString, + module GHC.Magic, + module GHC.Types, + module GHC.Prim, -- Re-export GHC.Prim and [boot] GHC.Err, + -- to avoid lots of people having to + module GHC.Err -- import it explicitly + ) + where + +import GHC.Types +import GHC.Classes +import GHC.CString +import GHC.Magic +import GHC.Prim +import GHC.Err +import {-# SOURCE #-} GHC.IO (failIO,mplusIO) + +import GHC.Tuple () -- Note [Depend on GHC.Tuple] +import GHC.Integer () -- Note [Depend on GHC.Integer] + +infixr 9 . +infixr 5 ++ +infixl 4 <$ +infixl 1 >>, >>= +infixr 1 =<< +infixr 0 $, $! + +infixl 4 <*>, <*, *>, <**> + +default () -- Double isn't available yet + +{- +Note [Depend on GHC.Integer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Integer type is special because TidyPgm uses +GHC.Integer.Type.mkInteger to construct Integer literal values +Currently it reads the interface file whether or not the current +module *has* any Integer literals, so it's important that +GHC.Integer.Type (in package integer-gmp or integer-simple) is +compiled before any other module. (There's a hack in GHC to disable +this for packages ghc-prim, integer-gmp, integer-simple, which aren't +allowed to contain any Integer literals.) + +Likewise we implicitly need Integer when deriving things like Eq +instances. + +The danger is that if the build system doesn't know about the dependency +on Integer, it'll compile some base module before GHC.Integer.Type, +resulting in: + Failed to load interface for ‘GHC.Integer.Type’ + There are files missing in the ‘integer-gmp’ package, + +Bottom line: we make GHC.Base depend on GHC.Integer; and everything +else either depends on GHC.Base, or does not have NoImplicitPrelude +(and hence depends on Prelude). + +Note [Depend on GHC.Tuple] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Similarly, tuple syntax (or ()) creates an implicit dependency on +GHC.Tuple, so we use the same rule as for Integer --- see Note [Depend on +GHC.Integer] --- to explain this to the build system. We make GHC.Base +depend on GHC.Tuple, and everything else depends on GHC.Base or Prelude. +-} + +#if 0 +-- for use when compiling GHC.Base itself doesn't work +data Bool = False | True +data Ordering = LT | EQ | GT +data Char = C# Char# +type String = [Char] +data Int = I# Int# +data () = () +data [] a = MkNil + +not True = False +(&&) True True = True +otherwise = True + +build = errorWithoutStackTrace "urk" +foldr = errorWithoutStackTrace "urk" +#endif + +-- | The 'Maybe' type encapsulates an optional value. A value of type +-- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@), +-- or it is empty (represented as 'Nothing'). Using 'Maybe' is a good way to +-- deal with errors or exceptional cases without resorting to drastic +-- measures such as 'error'. +-- +-- The 'Maybe' type is also a monad. It is a simple kind of error +-- monad, where all errors are represented by 'Nothing'. A richer +-- error monad can be built using the 'Data.Either.Either' type. +-- +data Maybe a = Nothing | Just a + deriving (Eq, Ord) + +-- | The class of monoids (types with an associative binary operation that +-- has an identity). Instances should satisfy the following laws: +-- +-- * @mappend mempty x = x@ +-- +-- * @mappend x mempty = x@ +-- +-- * @mappend x (mappend y z) = mappend (mappend x y) z@ +-- +-- * @mconcat = 'foldr' mappend mempty@ +-- +-- The method names refer to the monoid of lists under concatenation, +-- but there are many other instances. +-- +-- Some types can be viewed as a monoid in more than one way, +-- e.g. both addition and multiplication on numbers. +-- In such cases we often define @newtype@s and make those instances +-- of 'Monoid', e.g. 'Sum' and 'Product'. + +class Monoid a where + mempty :: a + -- ^ Identity of 'mappend' + mappend :: a -> a -> a + -- ^ An associative operation + mconcat :: [a] -> a + + -- ^ Fold a list using the monoid. + -- For most types, the default definition for 'mconcat' will be + -- used, but the function is included in the class definition so + -- that an optimized version can be provided for specific types. + + mconcat = foldr mappend mempty + +instance Monoid [a] where + {-# INLINE mempty #-} + mempty = [] + {-# INLINE mappend #-} + mappend = (++) + {-# INLINE mconcat #-} + mconcat xss = [x | xs <- xss, x <- xs] +-- See Note: [List comprehensions and inlining] + +{- +Note: [List comprehensions and inlining] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The list monad operations are traditionally described in terms of concatMap: + +xs >>= f = concatMap f xs + +Similarly, mconcat for lists is just concat. Here in Base, however, we don't +have concatMap, and we'll refrain from adding it here so it won't have to be +hidden in imports. Instead, we use GHC's list comprehension desugaring +mechanism to define mconcat and the Applicative and Monad instances for lists. +We mark them INLINE because the inliner is not generally too keen to inline +build forms such as the ones these desugar to without our insistence. Defining +these using list comprehensions instead of foldr has an additional potential +benefit, as described in compiler/deSugar/DsListComp.lhs: if optimizations +needed to make foldr/build forms efficient are turned off, we'll get reasonably +efficient translations anyway. +-} + +instance Monoid b => Monoid (a -> b) where + mempty _ = mempty + mappend f g x = f x `mappend` g x + +instance Monoid () where + -- Should it be strict? + mempty = () + _ `mappend` _ = () + mconcat _ = () + +instance (Monoid a, Monoid b) => Monoid (a,b) where + mempty = (mempty, mempty) + (a1,b1) `mappend` (a2,b2) = + (a1 `mappend` a2, b1 `mappend` b2) + +instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where + mempty = (mempty, mempty, mempty) + (a1,b1,c1) `mappend` (a2,b2,c2) = + (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2) + +instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where + mempty = (mempty, mempty, mempty, mempty) + (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) = + (a1 `mappend` a2, b1 `mappend` b2, + c1 `mappend` c2, d1 `mappend` d2) + +instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) => + Monoid (a,b,c,d,e) where + mempty = (mempty, mempty, mempty, mempty, mempty) + (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) = + (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2, + d1 `mappend` d2, e1 `mappend` e2) + +-- lexicographical ordering +instance Monoid Ordering where + mempty = EQ + LT `mappend` _ = LT + EQ `mappend` y = y + GT `mappend` _ = GT + +-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to +-- : \"Any semigroup @S@ may be +-- turned into a monoid simply by adjoining an element @e@ not in @S@ +-- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since +-- there is no \"Semigroup\" typeclass providing just 'mappend', we +-- use 'Monoid' instead. +instance Monoid a => Monoid (Maybe a) where + mempty = Nothing + Nothing `mappend` m = m + m `mappend` Nothing = m + Just m1 `mappend` Just m2 = Just (m1 `mappend` m2) + +instance Monoid a => Applicative ((,) a) where + pure x = (mempty, x) + (u, f) <*> (v, x) = (u `mappend` v, f x) + +instance Monoid a => Monad ((,) a) where + (u, a) >>= k = case k a of (v, b) -> (u `mappend` v, b) + +instance Monoid a => Monoid (IO a) where + mempty = pure mempty + mappend = liftA2 mappend + +{- | The 'Functor' class is used for types that can be mapped over. +Instances of 'Functor' should satisfy the following laws: + +> fmap id == id +> fmap (f . g) == fmap f . fmap g + +The instances of 'Functor' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO' +satisfy these laws. +-} + +class Functor f where + fmap :: (a -> b) -> f a -> f b + + -- | Replace all locations in the input with the same value. + -- The default definition is @'fmap' . 'const'@, but this may be + -- overridden with a more efficient version. + (<$) :: a -> f b -> f a + (<$) = fmap . const + +-- | A functor with application, providing operations to +-- +-- * embed pure expressions ('pure'), and +-- +-- * sequence computations and combine their results ('<*>'). +-- +-- A minimal complete definition must include implementations of these +-- functions satisfying the following laws: +-- +-- [/identity/] +-- +-- @'pure' 'id' '<*>' v = v@ +-- +-- [/composition/] +-- +-- @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@ +-- +-- [/homomorphism/] +-- +-- @'pure' f '<*>' 'pure' x = 'pure' (f x)@ +-- +-- [/interchange/] +-- +-- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@ +-- +-- The other methods have the following default definitions, which may +-- be overridden with equivalent specialized implementations: +-- +-- * @u '*>' v = 'pure' ('const' 'id') '<*>' u '<*>' v@ +-- +-- * @u '<*' v = 'pure' 'const' '<*>' u '<*>' v@ +-- +-- As a consequence of these laws, the 'Functor' instance for @f@ will satisfy +-- +-- * @'fmap' f x = 'pure' f '<*>' x@ +-- +-- If @f@ is also a 'Monad', it should satisfy +-- +-- * @'pure' = 'return'@ +-- +-- * @('<*>') = 'ap'@ +-- +-- (which implies that 'pure' and '<*>' satisfy the applicative functor laws). + +class Functor f => Applicative f where + -- | Lift a value. + pure :: a -> f a + + -- | Sequential application. + (<*>) :: f (a -> b) -> f a -> f b + + -- | Sequence actions, discarding the value of the first argument. + (*>) :: f a -> f b -> f b + a1 *> a2 = (id <$ a1) <*> a2 + -- This is essentially the same as liftA2 (const id), but if the + -- Functor instance has an optimized (<$), we want to use that instead. + + -- | Sequence actions, discarding the value of the second argument. + (<*) :: f a -> f b -> f a + (<*) = liftA2 const + +-- | A variant of '<*>' with the arguments reversed. +(<**>) :: Applicative f => f a -> f (a -> b) -> f b +(<**>) = liftA2 (flip ($)) + +-- | Lift a function to actions. +-- This function may be used as a value for `fmap` in a `Functor` instance. +liftA :: Applicative f => (a -> b) -> f a -> f b +liftA f a = pure f <*> a +-- Caution: since this may be used for `fmap`, we can't use the obvious +-- definition of liftA = fmap. + +-- | Lift a binary function to actions. +liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c +liftA2 f a b = fmap f a <*> b + +-- | Lift a ternary function to actions. +liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d +liftA3 f a b c = fmap f a <*> b <*> c + + +{-# INLINEABLE liftA #-} +{-# SPECIALISE liftA :: (a1->r) -> IO a1 -> IO r #-} +{-# SPECIALISE liftA :: (a1->r) -> Maybe a1 -> Maybe r #-} +{-# INLINEABLE liftA2 #-} +{-# SPECIALISE liftA2 :: (a1->a2->r) -> IO a1 -> IO a2 -> IO r #-} +{-# SPECIALISE liftA2 :: (a1->a2->r) -> Maybe a1 -> Maybe a2 -> Maybe r #-} +{-# INLINEABLE liftA3 #-} +{-# SPECIALISE liftA3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-} +{-# SPECIALISE liftA3 :: (a1->a2->a3->r) -> + Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe r #-} + +-- | The 'join' function is the conventional monad join operator. It +-- is used to remove one level of monadic structure, projecting its +-- bound argument into the outer level. +join :: (Monad m) => m (m a) -> m a +join x = x >>= id + +{- | The 'Monad' class defines the basic operations over a /monad/, +a concept from a branch of mathematics known as /category theory/. +From the perspective of a Haskell programmer, however, it is best to +think of a monad as an /abstract datatype/ of actions. +Haskell's @do@ expressions provide a convenient syntax for writing +monadic expressions. + +Instances of 'Monad' should satisfy the following laws: + +* @'return' a '>>=' k = k a@ +* @m '>>=' 'return' = m@ +* @m '>>=' (\x -> k x '>>=' h) = (m '>>=' k) '>>=' h@ + +Furthermore, the 'Monad' and 'Applicative' operations should relate as follows: + +* @'pure' = 'return'@ +* @('<*>') = 'ap'@ + +The above laws imply: + +* @'fmap' f xs = xs '>>=' 'return' . f@ +* @('>>') = ('*>')@ + +and that 'pure' and ('<*>') satisfy the applicative functor laws. + +The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO' +defined in the "Prelude" satisfy these laws. +-} +class Applicative m => Monad m where + -- | Sequentially compose two actions, passing any value produced + -- by the first as an argument to the second. + (>>=) :: forall a b. m a -> (a -> m b) -> m b + + -- | Sequentially compose two actions, discarding any value produced + -- by the first, like sequencing operators (such as the semicolon) + -- in imperative languages. + (>>) :: forall a b. m a -> m b -> m b + m >> k = m >>= \_ -> k -- See Note [Recursive bindings for Applicative/Monad] + {-# INLINE (>>) #-} + + -- | Inject a value into the monadic type. + return :: a -> m a + return = pure + + -- | Fail with a message. This operation is not part of the + -- mathematical definition of a monad, but is invoked on pattern-match + -- failure in a @do@ expression. + -- + -- As part of the MonadFail proposal (MFP), this function is moved + -- to its own class 'MonadFail' (see "Control.Monad.Fail" for more + -- details). The definition here will be removed in a future + -- release. + fail :: String -> m a + fail s = errorWithoutStackTrace s + +{- Note [Recursive bindings for Applicative/Monad] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The original Applicative/Monad proposal stated that after +implementation, the designated implementation of (>>) would become + + (>>) :: forall a b. m a -> m b -> m b + (>>) = (*>) + +by default. You might be inclined to change this to reflect the stated +proposal, but you really shouldn't! Why? Because people tend to define +such instances the /other/ way around: in particular, it is perfectly +legitimate to define an instance of Applicative (*>) in terms of (>>), +which would lead to an infinite loop for the default implementation of +Monad! And people do this in the wild. + +This turned into a nasty bug that was tricky to track down, and rather +than eliminate it everywhere upstream, it's easier to just retain the +original default. + +-} + +-- | Same as '>>=', but with the arguments interchanged. +{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-} +(=<<) :: Monad m => (a -> m b) -> m a -> m b +f =<< x = x >>= f + +-- | Conditional execution of 'Applicative' expressions. For example, +-- +-- > when debug (putStrLn "Debugging") +-- +-- will output the string @Debugging@ if the Boolean value @debug@ +-- is 'True', and otherwise do nothing. +when :: (Applicative f) => Bool -> f () -> f () +{-# INLINEABLE when #-} +{-# SPECIALISE when :: Bool -> IO () -> IO () #-} +{-# SPECIALISE when :: Bool -> Maybe () -> Maybe () #-} +when p s = if p then s else pure () + +-- | Evaluate each action in the sequence from left to right, +-- and collect the results. +sequence :: Monad m => [m a] -> m [a] +{-# INLINE sequence #-} +sequence = mapM id +-- Note: [sequence and mapM] + +-- | @'mapM' f@ is equivalent to @'sequence' . 'map' f@. +mapM :: Monad m => (a -> m b) -> [a] -> m [b] +{-# INLINE mapM #-} +mapM f as = foldr k (return []) as + where + k a r = do { x <- f a; xs <- r; return (x:xs) } + +{- +Note: [sequence and mapM] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Originally, we defined + +mapM f = sequence . map f + +This relied on list fusion to produce efficient code for mapM, and led to +excessive allocation in cryptarithm2. Defining + +sequence = mapM id + +relies only on inlining a tiny function (id) and beta reduction, which tends to +be a more reliable aspect of simplification. Indeed, this does not lead to +similar problems in nofib. +-} + +-- | Promote a function to a monad. +liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r +liftM f m1 = do { x1 <- m1; return (f x1) } + +-- | Promote a function to a monad, scanning the monadic arguments from +-- left to right. For example, +-- +-- > liftM2 (+) [0,1] [0,2] = [0,2,1,3] +-- > liftM2 (+) (Just 1) Nothing = Nothing +-- +liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r +liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) } + +-- | Promote a function to a monad, scanning the monadic arguments from +-- left to right (cf. 'liftM2'). +liftM3 :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r +liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) } + +-- | Promote a function to a monad, scanning the monadic arguments from +-- left to right (cf. 'liftM2'). +liftM4 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r +liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) } + +-- | Promote a function to a monad, scanning the monadic arguments from +-- left to right (cf. 'liftM2'). +liftM5 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r +liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) } + +{-# INLINEABLE liftM #-} +{-# SPECIALISE liftM :: (a1->r) -> IO a1 -> IO r #-} +{-# SPECIALISE liftM :: (a1->r) -> Maybe a1 -> Maybe r #-} +{-# INLINEABLE liftM2 #-} +{-# SPECIALISE liftM2 :: (a1->a2->r) -> IO a1 -> IO a2 -> IO r #-} +{-# SPECIALISE liftM2 :: (a1->a2->r) -> Maybe a1 -> Maybe a2 -> Maybe r #-} +{-# INLINEABLE liftM3 #-} +{-# SPECIALISE liftM3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-} +{-# SPECIALISE liftM3 :: (a1->a2->a3->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe r #-} +{-# INLINEABLE liftM4 #-} +{-# SPECIALISE liftM4 :: (a1->a2->a3->a4->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO r #-} +{-# SPECIALISE liftM4 :: (a1->a2->a3->a4->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe a4 -> Maybe r #-} +{-# INLINEABLE liftM5 #-} +{-# SPECIALISE liftM5 :: (a1->a2->a3->a4->a5->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO a5 -> IO r #-} +{-# SPECIALISE liftM5 :: (a1->a2->a3->a4->a5->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe a4 -> Maybe a5 -> Maybe r #-} + +{- | In many situations, the 'liftM' operations can be replaced by uses of +'ap', which promotes function application. + +> return f `ap` x1 `ap` ... `ap` xn + +is equivalent to + +> liftMn f x1 x2 ... xn + +-} + +ap :: (Monad m) => m (a -> b) -> m a -> m b +ap m1 m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) } +-- Since many Applicative instances define (<*>) = ap, we +-- cannot define ap = (<*>) +{-# INLINEABLE ap #-} +{-# SPECIALISE ap :: IO (a -> b) -> IO a -> IO b #-} +{-# SPECIALISE ap :: Maybe (a -> b) -> Maybe a -> Maybe b #-} + +-- instances for Prelude types + +instance Functor ((->) r) where + fmap = (.) + +instance Applicative ((->) a) where + pure = const + (<*>) f g x = f x (g x) + +instance Monad ((->) r) where + f >>= k = \ r -> k (f r) r + +instance Functor ((,) a) where + fmap f (x,y) = (x, f y) + + +instance Functor Maybe where + fmap _ Nothing = Nothing + fmap f (Just a) = Just (f a) + +instance Applicative Maybe where + pure = Just + + Just f <*> m = fmap f m + Nothing <*> _m = Nothing + + Just _m1 *> m2 = m2 + Nothing *> _m2 = Nothing + +instance Monad Maybe where + (Just x) >>= k = k x + Nothing >>= _ = Nothing + + (>>) = (*>) + + fail _ = Nothing + +-- ----------------------------------------------------------------------------- +-- The Alternative class definition + +infixl 3 <|> + +-- | A monoid on applicative functors. +-- +-- If defined, 'some' and 'many' should be the least solutions +-- of the equations: +-- +-- * @some v = (:) '<$>' v '<*>' many v@ +-- +-- * @many v = some v '<|>' 'pure' []@ +class Applicative f => Alternative f where + -- | The identity of '<|>' + empty :: f a + -- | An associative binary operation + (<|>) :: f a -> f a -> f a + + -- | One or more. + some :: f a -> f [a] + some v = some_v + where + many_v = some_v <|> pure [] + some_v = (fmap (:) v) <*> many_v + + -- | Zero or more. + many :: f a -> f [a] + many v = many_v + where + many_v = some_v <|> pure [] + some_v = (fmap (:) v) <*> many_v + + +instance Alternative Maybe where + empty = Nothing + Nothing <|> r = r + l <|> _ = l + +-- ----------------------------------------------------------------------------- +-- The MonadPlus class definition + +-- | Monads that also support choice and failure. +class (Alternative m, Monad m) => MonadPlus m where + -- | the identity of 'mplus'. It should also satisfy the equations + -- + -- > mzero >>= f = mzero + -- > v >> mzero = mzero + -- + mzero :: m a + mzero = empty + + -- | an associative operation + mplus :: m a -> m a -> m a + mplus = (<|>) + +instance MonadPlus Maybe + +---------------------------------------------- +-- The list type + +instance Functor [] where + {-# INLINE fmap #-} + fmap = map + +-- See Note: [List comprehensions and inlining] +instance Applicative [] where + {-# INLINE pure #-} + pure x = [x] + {-# INLINE (<*>) #-} + fs <*> xs = [f x | f <- fs, x <- xs] + {-# INLINE (*>) #-} + xs *> ys = [y | _ <- xs, y <- ys] + +-- See Note: [List comprehensions and inlining] +instance Monad [] where + {-# INLINE (>>=) #-} + xs >>= f = [y | x <- xs, y <- f x] + {-# INLINE (>>) #-} + (>>) = (*>) + {-# INLINE fail #-} + fail _ = [] + +instance Alternative [] where + empty = [] + (<|>) = (++) + +instance MonadPlus [] + +{- +A few list functions that appear here because they are used here. +The rest of the prelude list functions are in GHC.List. +-} + +---------------------------------------------- +-- foldr/build/augment +---------------------------------------------- + +-- | 'foldr', applied to a binary operator, a starting value (typically +-- the right-identity of the operator), and a list, reduces the list +-- using the binary operator, from right to left: +-- +-- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...) + +foldr :: (a -> b -> b) -> b -> [a] -> b +-- foldr _ z [] = z +-- foldr f z (x:xs) = f x (foldr f z xs) +{-# INLINE [0] foldr #-} +-- Inline only in the final stage, after the foldr/cons rule has had a chance +-- Also note that we inline it when it has *two* parameters, which are the +-- ones we are keen about specialising! +foldr k z = go + where + go [] = z + go (y:ys) = y `k` go ys + +-- | A list producer that can be fused with 'foldr'. +-- This function is merely +-- +-- > build g = g (:) [] +-- +-- but GHC's simplifier will transform an expression of the form +-- @'foldr' k z ('build' g)@, which may arise after inlining, to @g k z@, +-- which avoids producing an intermediate list. + +build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a] +{-# INLINE [1] build #-} + -- The INLINE is important, even though build is tiny, + -- because it prevents [] getting inlined in the version that + -- appears in the interface file. If [] *is* inlined, it + -- won't match with [] appearing in rules in an importing module. + -- + -- The "1" says to inline in phase 1 + +build g = g (:) [] + +-- | A list producer that can be fused with 'foldr'. +-- This function is merely +-- +-- > augment g xs = g (:) xs +-- +-- but GHC's simplifier will transform an expression of the form +-- @'foldr' k z ('augment' g xs)@, which may arise after inlining, to +-- @g k ('foldr' k z xs)@, which avoids producing an intermediate list. + +augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a] +{-# INLINE [1] augment #-} +augment g xs = g (:) xs + +{-# RULES +"fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) . + foldr k z (build g) = g k z + +"foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) . + foldr k z (augment g xs) = g k (foldr k z xs) + +"foldr/id" foldr (:) [] = \x -> x +"foldr/app" [1] forall ys. foldr (:) ys = \xs -> xs ++ ys + -- Only activate this from phase 1, because that's + -- when we disable the rule that expands (++) into foldr + +-- The foldr/cons rule looks nice, but it can give disastrously +-- bloated code when commpiling +-- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ] +-- i.e. when there are very very long literal lists +-- So I've disabled it for now. We could have special cases +-- for short lists, I suppose. +-- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs) + +"foldr/single" forall k z x. foldr k z [x] = k x z +"foldr/nil" forall k z. foldr k z [] = z + +"foldr/cons/build" forall k z x (g::forall b. (a->b->b) -> b -> b) . + foldr k z (x:build g) = k x (g k z) + +"augment/build" forall (g::forall b. (a->b->b) -> b -> b) + (h::forall b. (a->b->b) -> b -> b) . + augment g (build h) = build (\c n -> g c (h c n)) +"augment/nil" forall (g::forall b. (a->b->b) -> b -> b) . + augment g [] = build g + #-} + +-- This rule is true, but not (I think) useful: +-- augment g (augment h t) = augment (\cn -> g c (h c n)) t + +---------------------------------------------- +-- map +---------------------------------------------- + +-- | 'map' @f xs@ is the list obtained by applying @f@ to each element +-- of @xs@, i.e., +-- +-- > map f [x1, x2, ..., xn] == [f x1, f x2, ..., f xn] +-- > map f [x1, x2, ...] == [f x1, f x2, ...] + +map :: (a -> b) -> [a] -> [b] +{-# NOINLINE [0] map #-} + -- We want the RULEs "map" and "map/coerce" to fire first. + -- map is recursive, so won't inline anyway, + -- but saying so is more explicit, and silences warnings +map _ [] = [] +map f (x:xs) = f x : map f xs + +-- Note eta expanded +mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst +{-# INLINE [0] mapFB #-} +mapFB c f = \x ys -> c (f x) ys + +-- The rules for map work like this. +-- +-- Up to (but not including) phase 1, we use the "map" rule to +-- rewrite all saturated applications of map with its build/fold +-- form, hoping for fusion to happen. +-- In phase 1 and 0, we switch off that rule, inline build, and +-- switch on the "mapList" rule, which rewrites the foldr/mapFB +-- thing back into plain map. +-- +-- It's important that these two rules aren't both active at once +-- (along with build's unfolding) else we'd get an infinite loop +-- in the rules. Hence the activation control below. +-- +-- The "mapFB" rule optimises compositions of map. +-- +-- This same pattern is followed by many other functions: +-- e.g. append, filter, iterate, repeat, etc. + +{-# RULES +"map" [~1] forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs) +"mapList" [1] forall f. foldr (mapFB (:) f) [] = map f +"mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g) + #-} + +-- See Breitner, Eisenberg, Peyton Jones, and Weirich, "Safe Zero-cost +-- Coercions for Haskell", section 6.5: +-- http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/coercible.pdf + +{-# RULES "map/coerce" [1] map coerce = coerce #-} + + +---------------------------------------------- +-- append +---------------------------------------------- + +-- | Append two lists, i.e., +-- +-- > [x1, ..., xm] ++ [y1, ..., yn] == [x1, ..., xm, y1, ..., yn] +-- > [x1, ..., xm] ++ [y1, ...] == [x1, ..., xm, y1, ...] +-- +-- If the first list is not finite, the result is the first list. + +(++) :: [a] -> [a] -> [a] +{-# NOINLINE [1] (++) #-} -- We want the RULE to fire first. + -- It's recursive, so won't inline anyway, + -- but saying so is more explicit +(++) [] ys = ys +(++) (x:xs) ys = x : xs ++ ys + +{-# RULES +"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys + #-} + + +-- |'otherwise' is defined as the value 'True'. It helps to make +-- guards more readable. eg. +-- +-- > f x | x < 0 = ... +-- > | otherwise = ... +otherwise :: Bool +otherwise = True + +---------------------------------------------- +-- Type Char and String +---------------------------------------------- + +-- | A 'String' is a list of characters. String constants in Haskell are values +-- of type 'String'. +-- +type String = [Char] + +unsafeChr :: Int -> Char +unsafeChr (I# i#) = C# (chr# i#) + +-- | The 'Prelude.fromEnum' method restricted to the type 'Data.Char.Char'. +ord :: Char -> Int +ord (C# c#) = I# (ord# c#) + +-- | This 'String' equality predicate is used when desugaring +-- pattern-matches against strings. +eqString :: String -> String -> Bool +eqString [] [] = True +eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2 +eqString _ _ = False + +{-# RULES "eqString" (==) = eqString #-} +-- eqString also has a BuiltInRule in PrelRules.lhs: +-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 + + +---------------------------------------------- +-- 'Int' related definitions +---------------------------------------------- + +maxInt, minInt :: Int + +{- Seems clumsy. Should perhaps put minInt and MaxInt directly into MachDeps.h -} +#if WORD_SIZE_IN_BITS == 31 +minInt = I# (-0x40000000#) +maxInt = I# 0x3FFFFFFF# +#elif WORD_SIZE_IN_BITS == 32 +minInt = I# (-0x80000000#) +maxInt = I# 0x7FFFFFFF# +#else +minInt = I# (-0x8000000000000000#) +maxInt = I# 0x7FFFFFFFFFFFFFFF# +#endif + +---------------------------------------------- +-- The function type +---------------------------------------------- + +-- | Identity function. +id :: a -> a +id x = x + +-- Assertion function. This simply ignores its boolean argument. +-- The compiler may rewrite it to @('assertError' line)@. + +-- | If the first argument evaluates to 'True', then the result is the +-- second argument. Otherwise an 'AssertionFailed' exception is raised, +-- containing a 'String' with the source file and line number of the +-- call to 'assert'. +-- +-- Assertions can normally be turned on or off with a compiler flag +-- (for GHC, assertions are normally on unless optimisation is turned on +-- with @-O@ or the @-fignore-asserts@ +-- option is given). When assertions are turned off, the first +-- argument to 'assert' is ignored, and the second argument is +-- returned as the result. + +-- SLPJ: in 5.04 etc 'assert' is in GHC.Prim, +-- but from Template Haskell onwards it's simply +-- defined here in Base.lhs +assert :: Bool -> a -> a +assert _pred r = r + +breakpoint :: a -> a +breakpoint r = r + +breakpointCond :: Bool -> a -> a +breakpointCond _ r = r + +data Opaque = forall a. O a + +-- | @const x@ is a unary function which evaluates to @x@ for all inputs. +-- +-- For instance, +-- +-- >>> map (const 42) [0..3] +-- [42,42,42,42] +const :: a -> b -> a +const x _ = x + +-- | Function composition. +{-# INLINE (.) #-} +-- Make sure it has TWO args only on the left, so that it inlines +-- when applied to two functions, even if there is no final argument +(.) :: (b -> c) -> (a -> b) -> a -> c +(.) f g = \x -> f (g x) + +-- | @'flip' f@ takes its (first) two arguments in the reverse order of @f@. +flip :: (a -> b -> c) -> b -> a -> c +flip f x y = f y x + +-- | Application operator. This operator is redundant, since ordinary +-- application @(f x)@ means the same as @(f '$' x)@. However, '$' has +-- low, right-associative binding precedence, so it sometimes allows +-- parentheses to be omitted; for example: +-- +-- > f $ g $ h x = f (g (h x)) +-- +-- It is also useful in higher-order situations, such as @'map' ('$' 0) xs@, +-- or @'Data.List.zipWith' ('$') fs xs@. +{-# INLINE ($) #-} +($) :: (a -> b) -> a -> b +f $ x = f x + +-- | Strict (call-by-value) application operator. It takes a function and an +-- argument, evaluates the argument to weak head normal form (WHNF), then calls +-- the function with that value. + +($!) :: (a -> b) -> a -> b +f $! x = let !vx = x in f vx -- see #2273 + +-- | @'until' p f@ yields the result of applying @f@ until @p@ holds. +until :: (a -> Bool) -> (a -> a) -> a -> a +until p f = go + where + go x | p x = x + | otherwise = go (f x) + +-- | 'asTypeOf' is a type-restricted version of 'const'. It is usually +-- used as an infix operator, and its typing forces its first argument +-- (which is usually overloaded) to have the same type as the second. +asTypeOf :: a -> a -> a +asTypeOf = const + +---------------------------------------------- +-- Functor/Applicative/Monad instances for IO +---------------------------------------------- + +instance Functor IO where + fmap f x = x >>= (pure . f) + +instance Applicative IO where + {-# INLINE pure #-} + {-# INLINE (*>) #-} + pure = returnIO + m *> k = m >>= \ _ -> k + (<*>) = ap + +instance Monad IO where + {-# INLINE (>>) #-} + {-# INLINE (>>=) #-} + (>>) = (*>) + (>>=) = bindIO + fail s = failIO s + +instance Alternative IO where + empty = failIO "mzero" + (<|>) = mplusIO + +instance MonadPlus IO + +returnIO :: a -> IO a +returnIO x = IO (\ s -> (# s, x #)) + +bindIO :: IO a -> (a -> IO b) -> IO b +bindIO (IO m) k = IO (\ s -> case m s of (# new_s, a #) -> unIO (k a) new_s) + +thenIO :: IO a -> IO b -> IO b +thenIO (IO m) k = IO (\ s -> case m s of (# new_s, _ #) -> unIO k new_s) + +unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) +unIO (IO a) = a + +{- | +Returns the 'tag' of a constructor application; this function is used +by the deriving code for Eq, Ord and Enum. + +The primitive dataToTag# requires an evaluated constructor application +as its argument, so we provide getTag as a wrapper that performs the +evaluation before calling dataToTag#. We could have dataToTag# +evaluate its argument, but we prefer to do it this way because (a) +dataToTag# can be an inline primop if it doesn't need to do any +evaluation, and (b) we want to expose the evaluation to the +simplifier, because it might be possible to eliminate the evaluation +in the case when the argument is already known to be evaluated. +-} +{-# INLINE getTag #-} +getTag :: a -> Int# +getTag !x = dataToTag# x + +---------------------------------------------- +-- Numeric primops +---------------------------------------------- + +-- Definitions of the boxed PrimOps; these will be +-- used in the case of partial applications, etc. + +{-# INLINE quotInt #-} +{-# INLINE remInt #-} + +quotInt, remInt, divInt, modInt :: Int -> Int -> Int +(I# x) `quotInt` (I# y) = I# (x `quotInt#` y) +(I# x) `remInt` (I# y) = I# (x `remInt#` y) +(I# x) `divInt` (I# y) = I# (x `divInt#` y) +(I# x) `modInt` (I# y) = I# (x `modInt#` y) + +quotRemInt :: Int -> Int -> (Int, Int) +(I# x) `quotRemInt` (I# y) = case x `quotRemInt#` y of + (# q, r #) -> + (I# q, I# r) + +divModInt :: Int -> Int -> (Int, Int) +(I# x) `divModInt` (I# y) = case x `divModInt#` y of + (# q, r #) -> (I# q, I# r) + +divModInt# :: Int# -> Int# -> (# Int#, Int# #) +x# `divModInt#` y# + | isTrue# (x# ># 0#) && isTrue# (y# <# 0#) = + case (x# -# 1#) `quotRemInt#` y# of + (# q, r #) -> (# q -# 1#, r +# y# +# 1# #) + | isTrue# (x# <# 0#) && isTrue# (y# ># 0#) = + case (x# +# 1#) `quotRemInt#` y# of + (# q, r #) -> (# q -# 1#, r +# y# -# 1# #) + | otherwise = + x# `quotRemInt#` y# + +-- Wrappers for the shift operations. The uncheckedShift# family are +-- undefined when the amount being shifted by is greater than the size +-- in bits of Int#, so these wrappers perform a check and return +-- either zero or -1 appropriately. +-- +-- Note that these wrappers still produce undefined results when the +-- second argument (the shift amount) is negative. + +-- | Shift the argument left by the specified number of bits +-- (which must be non-negative). +shiftL# :: Word# -> Int# -> Word# +a `shiftL#` b | isTrue# (b >=# WORD_SIZE_IN_BITS#) = 0## + | otherwise = a `uncheckedShiftL#` b + +-- | Shift the argument right by the specified number of bits +-- (which must be non-negative). +-- The "RL" means "right, logical" (as opposed to RA for arithmetic) +-- (although an arithmetic right shift wouldn't make sense for Word#) +shiftRL# :: Word# -> Int# -> Word# +a `shiftRL#` b | isTrue# (b >=# WORD_SIZE_IN_BITS#) = 0## + | otherwise = a `uncheckedShiftRL#` b + +-- | Shift the argument left by the specified number of bits +-- (which must be non-negative). +iShiftL# :: Int# -> Int# -> Int# +a `iShiftL#` b | isTrue# (b >=# WORD_SIZE_IN_BITS#) = 0# + | otherwise = a `uncheckedIShiftL#` b + +-- | Shift the argument right (signed) by the specified number of bits +-- (which must be non-negative). +-- The "RA" means "right, arithmetic" (as opposed to RL for logical) +iShiftRA# :: Int# -> Int# -> Int# +a `iShiftRA#` b | isTrue# (b >=# WORD_SIZE_IN_BITS#) = if isTrue# (a <# 0#) + then (-1#) + else 0# + | otherwise = a `uncheckedIShiftRA#` b + +-- | Shift the argument right (unsigned) by the specified number of bits +-- (which must be non-negative). +-- The "RL" means "right, logical" (as opposed to RA for arithmetic) +iShiftRL# :: Int# -> Int# -> Int# +a `iShiftRL#` b | isTrue# (b >=# WORD_SIZE_IN_BITS#) = 0# + | otherwise = a `uncheckedIShiftRL#` b + +-- Rules for C strings (the functions themselves are now in GHC.CString) +{-# RULES +"unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a) +"unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCString# a +"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n + +-- There's a built-in rule (in PrelRules.lhs) for +-- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n + + #-} diff --git a/libraries/base/GHC/Char.hs b/libraries/base/GHC/Char.hs new file mode 100644 index 0000000..9e638f5 --- /dev/null +++ b/libraries/base/GHC/Char.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash #-} + +module GHC.Char + ( -- * Utilities + chr + + -- * Monomorphic equality operators + -- | See GHC.Classes#matching_overloaded_methods_in_rules + , eqChar, neChar + ) where + +import GHC.Base +import GHC.Show + +-- | The 'Prelude.toEnum' method restricted to the type 'Data.Char.Char'. +chr :: Int -> Char +chr i@(I# i#) + | isTrue# (int2Word# i# `leWord#` 0x10FFFF##) = C# (chr# i#) + | otherwise + = errorWithoutStackTrace ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "") + diff --git a/libraries/base/GHC/Conc.hs b/libraries/base/GHC/Conc.hs new file mode 100644 index 0000000..38fac43 --- /dev/null +++ b/libraries/base/GHC/Conc.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_HADDOCK not-home #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Conc +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Basic concurrency stuff. +-- +----------------------------------------------------------------------------- + +-- 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 + + , ThreadStatus(..), BlockReason(..) + , threadStatus + , threadCapability + + -- * Waiting + , threadDelay + , registerDelay + , threadWaitRead + , threadWaitWrite + , threadWaitReadSTM + , threadWaitWriteSTM + , closeFdWith + + -- * Allocation counter and limit + , setAllocationCounter + , getAllocationCounter + , enableAllocationLimit + , disableAllocationLimit + + -- * TVars + , STM(..) + , atomically + , retry + , orElse + , throwSTM + , catchSTM + , alwaysSucceeds + , always + , TVar(..) + , newTVar + , newTVarIO + , readTVar + , readTVarIO + , writeTVar + , unsafeIOToSTM + + -- * Miscellaneous + , withMVar +#ifdef mingw32_HOST_OS + , asyncRead + , asyncWrite + , asyncDoProc + + , asyncReadBA + , asyncWriteBA +#endif + +#ifndef mingw32_HOST_OS + , Signal, HandlerFun, setHandler, runHandlers +#endif + + , ensureIOManagerIsRunning + , ioManagerCapabilitiesChanged + +#ifdef mingw32_HOST_OS + , ConsoleEvent(..) + , win32ConsoleHandler + , toWin32ConsoleEvent +#endif + , setUncaughtExceptionHandler + , getUncaughtExceptionHandler + + , reportError, reportStackOverflow + ) where + +import GHC.Conc.IO +import GHC.Conc.Sync + +#ifndef mingw32_HOST_OS +import GHC.Conc.Signal +#endif diff --git a/libraries/base/GHC/Conc/IO.hs b/libraries/base/GHC/Conc/IO.hs new file mode 100644 index 0000000..1e9ffd5 --- /dev/null +++ b/libraries/base/GHC/Conc/IO.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , MagicHash + , UnboxedTuples + #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_HADDOCK not-home #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Conc.IO +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Basic concurrency stuff. +-- +----------------------------------------------------------------------------- + +-- 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.IO + ( ensureIOManagerIsRunning + , ioManagerCapabilitiesChanged + + -- * Waiting + , threadDelay + , registerDelay + , threadWaitRead + , threadWaitWrite + , threadWaitReadSTM + , threadWaitWriteSTM + , closeFdWith + +#ifdef mingw32_HOST_OS + , asyncRead + , asyncWrite + , asyncDoProc + + , asyncReadBA + , asyncWriteBA + + , ConsoleEvent(..) + , win32ConsoleHandler + , toWin32ConsoleEvent +#endif + ) where + +import Foreign +import GHC.Base +import GHC.Conc.Sync as Sync +import GHC.Real ( fromIntegral ) +import System.Posix.Types + +#ifdef mingw32_HOST_OS +import qualified GHC.Conc.Windows as Windows +import GHC.Conc.Windows (asyncRead, asyncWrite, asyncDoProc, asyncReadBA, + asyncWriteBA, ConsoleEvent(..), win32ConsoleHandler, + toWin32ConsoleEvent) +#else +import qualified GHC.Event.Thread as Event +#endif + +ensureIOManagerIsRunning :: IO () +#ifndef mingw32_HOST_OS +ensureIOManagerIsRunning = Event.ensureIOManagerIsRunning +#else +ensureIOManagerIsRunning = Windows.ensureIOManagerIsRunning +#endif + +ioManagerCapabilitiesChanged :: IO () +#ifndef mingw32_HOST_OS +ioManagerCapabilitiesChanged = Event.ioManagerCapabilitiesChanged +#else +ioManagerCapabilitiesChanged = return () +#endif + +-- | 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 'closeFdWith'. +threadWaitRead :: Fd -> IO () +threadWaitRead fd +#ifndef mingw32_HOST_OS + | threaded = Event.threadWaitRead fd +#endif + | otherwise = IO $ \s -> + case fromIntegral fd of { I# fd# -> + case waitRead# fd# s of { s' -> (# s', () #) + }} + +-- | 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 'closeFdWith'. +threadWaitWrite :: Fd -> IO () +threadWaitWrite fd +#ifndef mingw32_HOST_OS + | threaded = Event.threadWaitWrite fd +#endif + | otherwise = IO $ \s -> + case fromIntegral fd of { I# fd# -> + case waitWrite# fd# s of { s' -> (# s', () #) + }} + +-- | 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. +threadWaitReadSTM :: Fd -> IO (Sync.STM (), IO ()) +threadWaitReadSTM fd +#ifndef mingw32_HOST_OS + | threaded = Event.threadWaitReadSTM fd +#endif + | otherwise = do + m <- Sync.newTVarIO False + _ <- Sync.forkIO $ do + threadWaitRead fd + Sync.atomically $ Sync.writeTVar m True + let waitAction = do b <- Sync.readTVar m + if b then return () else retry + let killAction = return () + return (waitAction, killAction) + +-- | 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. +threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ()) +threadWaitWriteSTM fd +#ifndef mingw32_HOST_OS + | threaded = Event.threadWaitWriteSTM fd +#endif + | otherwise = do + m <- Sync.newTVarIO False + _ <- Sync.forkIO $ do + threadWaitWrite fd + Sync.atomically $ Sync.writeTVar m True + let waitAction = do b <- Sync.readTVar m + if b then return () else retry + let killAction = return () + return (waitAction, killAction) + +-- | Close a file descriptor in a concurrency-safe way (GHC only). If +-- you are using 'threadWaitRead' or 'threadWaitWrite' to perform +-- blocking I\/O, you /must/ use this function to close file +-- descriptors, or blocked threads may not be woken. +-- +-- Any threads that are blocked on the file descriptor via +-- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having +-- IO exceptions thrown. +closeFdWith :: (Fd -> IO ()) -- ^ Low-level action that performs the real close. + -> Fd -- ^ File descriptor to close. + -> IO () +closeFdWith close fd +#ifndef mingw32_HOST_OS + | threaded = Event.closeFdWith close fd +#endif + | otherwise = close fd + +-- | Suspends the current thread for a given number of microseconds +-- (GHC only). +-- +-- There is no guarantee that the thread will be rescheduled promptly +-- when the delay has expired, but the thread will never continue to +-- run /earlier/ than specified. +-- +threadDelay :: Int -> IO () +threadDelay time +#ifdef mingw32_HOST_OS + | threaded = Windows.threadDelay time +#else + | threaded = Event.threadDelay time +#endif + | otherwise = IO $ \s -> + case time of { I# time# -> + case delay# time# s of { s' -> (# s', () #) + }} + +-- | Set the value of returned TVar to True after a given number of +-- microseconds. The caveats associated with threadDelay also apply. +-- +registerDelay :: Int -> IO (TVar Bool) +registerDelay usecs +#ifdef mingw32_HOST_OS + | threaded = Windows.registerDelay usecs +#else + | threaded = Event.registerDelay usecs +#endif + | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded" + +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool diff --git a/libraries/base/GHC/Conc/Signal.hs b/libraries/base/GHC/Conc/Signal.hs new file mode 100644 index 0000000..e5cb5e3 --- /dev/null +++ b/libraries/base/GHC/Conc/Signal.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Conc.Signal + ( Signal + , HandlerFun + , setHandler + , runHandlers + , runHandlersPtr + ) where + +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Data.Dynamic (Dynamic) +import Foreign.C.Types (CInt) +import Foreign.ForeignPtr (ForeignPtr, newForeignPtr) +import Foreign.StablePtr (castPtrToStablePtr, castStablePtrToPtr, + deRefStablePtr, freeStablePtr, newStablePtr) +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Marshal.Alloc (finalizerFree) +import GHC.Arr (inRange) +import GHC.Base +import GHC.Conc.Sync (forkIO) +import GHC.IO (mask_, unsafePerformIO) +import GHC.IOArray (IOArray, boundsIOArray, newIOArray, + unsafeReadIOArray, unsafeWriteIOArray) +import GHC.Real (fromIntegral) +import GHC.Word (Word8) + +------------------------------------------------------------------------ +-- Signal handling + +type Signal = CInt + +maxSig :: Int +maxSig = 64 + +type HandlerFun = ForeignPtr Word8 -> IO () + +-- Lock used to protect concurrent access to signal_handlers. Symptom +-- of this race condition is GHC bug #1922, although that bug was on +-- Windows a similar bug also exists on Unix. +signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic))) +signal_handlers = unsafePerformIO $ do + arr <- newIOArray (0, maxSig) Nothing + m <- newMVar arr + sharedCAF m getOrSetGHCConcSignalSignalHandlerStore +{-# NOINLINE signal_handlers #-} + +foreign import ccall unsafe "getOrSetGHCConcSignalSignalHandlerStore" + getOrSetGHCConcSignalSignalHandlerStore :: Ptr a -> IO (Ptr a) + +setHandler :: Signal -> Maybe (HandlerFun, Dynamic) + -> IO (Maybe (HandlerFun, Dynamic)) +setHandler sig handler = do + let int = fromIntegral sig + withMVar signal_handlers $ \arr -> + if not (inRange (boundsIOArray arr) int) + then errorWithoutStackTrace "GHC.Conc.setHandler: signal out of range" + else do old <- unsafeReadIOArray arr int + unsafeWriteIOArray arr int handler + return old + +runHandlers :: ForeignPtr Word8 -> Signal -> IO () +runHandlers p_info sig = do + let int = fromIntegral sig + withMVar signal_handlers $ \arr -> + if not (inRange (boundsIOArray arr) int) + then return () + else do handler <- unsafeReadIOArray arr int + case handler of + Nothing -> return () + Just (f,_) -> do _ <- forkIO (f p_info) + return () + +-- It is our responsibility to free the memory buffer, so we create a +-- foreignPtr. +runHandlersPtr :: Ptr Word8 -> Signal -> IO () +runHandlersPtr p s = do + fp <- newForeignPtr finalizerFree p + runHandlers fp s + +-- Machinery needed to ensure that we only have one copy of certain +-- CAFs in this module even when the base package is present twice, as +-- it is when base is dynamically loaded into GHCi. The RTS keeps +-- track of the single true value of the CAF, so even when the CAFs in +-- the dynamically-loaded base package are reverted, nothing bad +-- happens. +-- +sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a +sharedCAF a get_or_set = + mask_ $ do + stable_ref <- newStablePtr a + let ref = castPtr (castStablePtrToPtr stable_ref) + ref2 <- get_or_set ref + if ref == ref2 + then return a + else do freeStablePtr stable_ref + deRefStablePtr (castPtrToStablePtr (castPtr ref2)) + diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs new file mode 100644 index 0000000..e1d894a --- /dev/null +++ b/libraries/base/GHC/Conc/Sync.hs @@ -0,0 +1,894 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , BangPatterns + , MagicHash + , UnboxedTuples + , UnliftedFFITypes + , StandaloneDeriving + , RankNTypes + #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_HADDOCK not-home #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Conc.Sync +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Basic concurrency stuff. +-- +----------------------------------------------------------------------------- + +-- 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.Sync + ( ThreadId(..) + + -- * Forking and suchlike + , forkIO + , forkIOWithUnmask + , forkOn + , forkOnWithUnmask + , numCapabilities + , getNumCapabilities + , setNumCapabilities + , getNumProcessors + , numSparks + , childHandler + , myThreadId + , killThread + , throwTo + , par + , pseq + , runSparks + , yield + , labelThread + , mkWeakThreadId + + , ThreadStatus(..), BlockReason(..) + , threadStatus + , threadCapability + + -- * Allocation counter and quota + , setAllocationCounter + , getAllocationCounter + , enableAllocationLimit + , disableAllocationLimit + + -- * TVars + , STM(..) + , atomically + , retry + , orElse + , throwSTM + , catchSTM + , alwaysSucceeds + , always + , TVar(..) + , newTVar + , newTVarIO + , readTVar + , readTVarIO + , writeTVar + , unsafeIOToSTM + + -- * Miscellaneous + , withMVar + , modifyMVar_ + + , setUncaughtExceptionHandler + , getUncaughtExceptionHandler + + , reportError, reportStackOverflow + + , sharedCAF + ) where + +import Foreign +import Foreign.C + +#ifndef mingw32_HOST_OS +import Data.Dynamic +#else +import Data.Typeable +#endif +import Data.Maybe + +import GHC.Base +import {-# SOURCE #-} GHC.IO.Handle ( hFlush ) +import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout ) +import GHC.IO +import GHC.IO.Encoding.UTF8 +import GHC.IO.Exception +import GHC.Exception +import qualified GHC.Foreign +import GHC.IORef +import GHC.MVar +import GHC.Ptr +import GHC.Real ( fromIntegral ) +import GHC.Show ( Show(..), showString ) +import GHC.Weak + +infixr 0 `par`, `pseq` + +----------------------------------------------------------------------------- +-- 'ThreadId', 'par', and 'fork' +----------------------------------------------------------------------------- + +data ThreadId = ThreadId ThreadId# +-- ToDo: data ThreadId = ThreadId (Weak ThreadId#) +-- But since ThreadId# is unlifted, the Weak type must use open +-- type variables. +{- ^ +A 'ThreadId' is an abstract type representing a handle to a thread. +'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where +the 'Ord' instance implements an arbitrary total ordering over +'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued +'ThreadId' to string form; showing a 'ThreadId' value is occasionally +useful when debugging or diagnosing the behaviour of a concurrent +program. + +/Note/: in GHC, if you have a 'ThreadId', you essentially have +a pointer to the thread itself. This means the thread itself can\'t be +garbage collected until you drop the 'ThreadId'. +This misfeature will hopefully be corrected at a later date. + +-} + +instance Show ThreadId where + showsPrec d t = + showString "ThreadId " . + showsPrec d (getThreadId (id2TSO t)) + +foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt + +id2TSO :: ThreadId -> ThreadId# +id2TSO (ThreadId t) = t + +foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt +-- Returns -1, 0, 1 + +cmpThread :: ThreadId -> ThreadId -> Ordering +cmpThread t1 t2 = + case cmp_thread (id2TSO t1) (id2TSO t2) of + -1 -> LT + 0 -> EQ + _ -> GT -- must be 1 + +instance Eq ThreadId where + t1 == t2 = + case t1 `cmpThread` t2 of + EQ -> True + _ -> False + +instance Ord ThreadId where + compare = cmpThread + +-- | Every thread has an allocation counter that tracks how much +-- memory has been allocated by the thread. The counter is +-- initialized to zero, and 'setAllocationCounter' sets the current +-- value. The allocation counter counts *down*, so in the absence of +-- a call to 'setAllocationCounter' its value is the negation of the +-- number of bytes of memory allocated by the thread. +-- +-- There are two things that you can do with this counter: +-- +-- * Use it as a simple profiling mechanism, with +-- 'getAllocationCounter'. +-- +-- * Use it as a resource limit. See 'enableAllocationLimit'. +-- +-- Allocation accounting is accurate only to about 4Kbytes. +-- +-- @since 4.8.0.0 +setAllocationCounter :: Int64 -> IO () +setAllocationCounter i = do + ThreadId t <- myThreadId + rts_setThreadAllocationCounter t i + +-- | Return the current value of the allocation counter for the +-- current thread. +-- +-- @since 4.8.0.0 +getAllocationCounter :: IO Int64 +getAllocationCounter = do + ThreadId t <- myThreadId + rts_getThreadAllocationCounter t + +-- | Enables the allocation counter to be treated as a limit for the +-- current thread. When the allocation limit is enabled, if the +-- allocation counter counts down below zero, the thread will be sent +-- the 'AllocationLimitExceeded' asynchronous exception. When this +-- happens, the counter is reinitialised (by default +-- to 100K, but tunable with the @+RTS -xq@ option) so that it can handle +-- the exception and perform any necessary clean up. If it exhausts +-- this additional allowance, another 'AllocationLimitExceeded' exception +-- is sent, and so forth. Like other asynchronous exceptions, the +-- 'AllocationLimitExceeded' exception is deferred while the thread is inside +-- 'mask' or an exception handler in 'catch'. +-- +-- Note that memory allocation is unrelated to /live memory/, also +-- known as /heap residency/. A thread can allocate a large amount of +-- memory and retain anything between none and all of it. It is +-- better to think of the allocation limit as a limit on +-- /CPU time/, rather than a limit on memory. +-- +-- Compared to using timeouts, allocation limits don't count time +-- spent blocked or in foreign calls. +-- +-- @since 4.8.0.0 +enableAllocationLimit :: IO () +enableAllocationLimit = do + ThreadId t <- myThreadId + rts_enableThreadAllocationLimit t + +-- | Disable allocation limit processing for the current thread. +-- +-- @since 4.8.0.0 +disableAllocationLimit :: IO () +disableAllocationLimit = do + ThreadId t <- myThreadId + rts_disableThreadAllocationLimit t + +-- We cannot do these operations safely on another thread, because on +-- a 32-bit machine we cannot do atomic operations on a 64-bit value. +-- Therefore, we only expose APIs that allow getting and setting the +-- limit of the current thread. +foreign import ccall unsafe "rts_setThreadAllocationCounter" + rts_setThreadAllocationCounter :: ThreadId# -> Int64 -> IO () + +foreign import ccall unsafe "rts_getThreadAllocationCounter" + rts_getThreadAllocationCounter :: ThreadId# -> IO Int64 + +foreign import ccall unsafe "rts_enableThreadAllocationLimit" + rts_enableThreadAllocationLimit :: ThreadId# -> IO () + +foreign import ccall unsafe "rts_disableThreadAllocationLimit" + rts_disableThreadAllocationLimit :: ThreadId# -> IO () + +{- | +Creates a new thread to run the 'IO' computation passed as the +first argument, and returns the 'ThreadId' of the newly created +thread. + +The new thread will be a lightweight, /unbound/ thread. Foreign calls +made by this thread are not guaranteed to be made by any particular OS +thread; if you need foreign calls to be made by a particular OS +thread, then use 'Control.Concurrent.forkOS' instead. + +The new thread inherits the /masked/ state of the parent (see +'Control.Exception.mask'). + +The newly created thread has an exception handler that discards the +exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and +'ThreadKilled', and passes all other exceptions to the uncaught +exception handler. +-} +forkIO :: IO () -> IO ThreadId +forkIO action = IO $ \ s -> + case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #) + where + action_plus = catchException action childHandler + +-- | Like 'forkIO', but the child thread is passed a function that can +-- be used to unmask asynchronous exceptions. This function is +-- typically used in the following way +-- +-- > ... mask_ $ forkIOWithUnmask $ \unmask -> +-- > catch (unmask ...) handler +-- +-- so that the exception handler in the child thread is established +-- with asynchronous exceptions masked, meanwhile the main body of +-- the child thread is executed in the unmasked state. +-- +-- Note that the unmask function passed to the child thread should +-- only be used in that thread; the behaviour is undefined if it is +-- invoked in a different thread. +-- +-- @since 4.4.0.0 +forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId +forkIOWithUnmask io = forkIO (io unsafeUnmask) + +{- | +Like 'forkIO', but lets you specify on which capability the thread +should run. Unlike a `forkIO` thread, a thread created by `forkOn` +will stay on the same capability for its entire lifetime (`forkIO` +threads can migrate between capabilities according to the scheduling +policy). `forkOn` is useful for overriding the scheduling policy when +you know in advance how best to distribute the threads. + +The `Int` argument specifies a /capability number/ (see +'getNumCapabilities'). Typically capabilities correspond to physical +processors, but the exact behaviour is implementation-dependent. The +value passed to 'forkOn' is interpreted modulo the total number of +capabilities as returned by 'getNumCapabilities'. + +GHC note: the number of capabilities is specified by the @+RTS -N@ +option when the program is started. Capabilities can be fixed to +actual processor cores with @+RTS -qa@ if the underlying operating +system supports that, although in practice this is usually unnecessary +(and may actually degrade performance in some cases - experimentation +is recommended). + +@since 4.4.0.0 +-} +forkOn :: Int -> IO () -> IO ThreadId +forkOn (I# cpu) action = IO $ \ s -> + case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #) + where + action_plus = catchException action childHandler + +-- | Like 'forkIOWithUnmask', but the child thread is pinned to the +-- given CPU, as with 'forkOn'. +-- +-- @since 4.4.0.0 +forkOnWithUnmask :: Int -> ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId +forkOnWithUnmask cpu io = forkOn cpu (io unsafeUnmask) + +-- | the value passed to the @+RTS -N@ flag. This is the number of +-- Haskell threads that can run truly simultaneously at any given +-- time, and is typically set to the number of physical processor cores on +-- the machine. +-- +-- Strictly speaking it is better to use 'getNumCapabilities', because +-- the number of capabilities might vary at runtime. +-- +numCapabilities :: Int +numCapabilities = unsafePerformIO $ getNumCapabilities + +{- | +Returns the number of Haskell threads that can run truly +simultaneously (on separate physical processors) at any given time. To change +this value, use 'setNumCapabilities'. + +@since 4.4.0.0 +-} +getNumCapabilities :: IO Int +getNumCapabilities = do + n <- peek enabled_capabilities + return (fromIntegral n) + +{- | +Set the number of Haskell threads that can run truly simultaneously +(on separate physical processors) at any given time. The number +passed to `forkOn` is interpreted modulo this value. The initial +value is given by the @+RTS -N@ runtime flag. + +This is also the number of threads that will participate in parallel +garbage collection. It is strongly recommended that the number of +capabilities is not set larger than the number of physical processor +cores, and it may often be beneficial to leave one or more cores free +to avoid contention with other processes in the machine. + +@since 4.5.0.0 +-} +setNumCapabilities :: Int -> IO () +setNumCapabilities i = c_setNumCapabilities (fromIntegral i) + +foreign import ccall safe "setNumCapabilities" + c_setNumCapabilities :: CUInt -> IO () + +-- | Returns the number of CPUs that the machine has +-- +-- @since 4.5.0.0 +getNumProcessors :: IO Int +getNumProcessors = fmap fromIntegral c_getNumberOfProcessors + +foreign import ccall unsafe "getNumberOfProcessors" + c_getNumberOfProcessors :: IO CUInt + +-- | Returns the number of sparks currently in the local spark pool +numSparks :: IO Int +numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #) + +foreign import ccall "&enabled_capabilities" enabled_capabilities :: Ptr CInt + +childHandler :: SomeException -> IO () +childHandler err = catchException (real_handler err) childHandler + +real_handler :: SomeException -> IO () +real_handler se + | Just BlockedIndefinitelyOnMVar <- fromException se = return () + | Just BlockedIndefinitelyOnSTM <- fromException se = return () + | Just ThreadKilled <- fromException se = return () + | Just StackOverflow <- fromException se = reportStackOverflow + | otherwise = reportError se + +{- | 'killThread' raises the 'ThreadKilled' exception in the given +thread (GHC only). + +> killThread tid = throwTo tid ThreadKilled + +-} +killThread :: ThreadId -> IO () +killThread tid = throwTo tid ThreadKilled + +{- | 'throwTo' raises an arbitrary exception in the target thread (GHC only). + +Exception delivery synchronizes between the source and target thread: +'throwTo' does not return until the exception has been raised in the +target thread. The calling thread can thus be certain that the target +thread has received the exception. Exception delivery is also atomic +with respect to other exceptions. Atomicity is a useful property to have +when dealing with race conditions: e.g. if there are two threads that +can kill each other, it is guaranteed that only one of the threads +will get to kill the other. + +Whatever work the target thread was doing when the exception was +raised is not lost: the computation is suspended until required by +another thread. + +If the target thread is currently making a foreign call, then the +exception will not be raised (and hence 'throwTo' will not return) +until the call has completed. This is the case regardless of whether +the call is inside a 'mask' or not. However, in GHC a foreign call +can be annotated as @interruptible@, in which case a 'throwTo' will +cause the RTS to attempt to cause the call to return; see the GHC +documentation for more details. + +Important note: the behaviour of 'throwTo' differs from that described in +the paper \"Asynchronous exceptions in Haskell\" +(). +In the paper, 'throwTo' is non-blocking; but the library implementation adopts +a more synchronous design in which 'throwTo' does not return until the exception +is received by the target thread. The trade-off is discussed in Section 9 of the paper. +Like any blocking operation, 'throwTo' is therefore interruptible (see Section 5.3 of +the paper). Unlike other interruptible operations, however, 'throwTo' +is /always/ interruptible, even if it does not actually block. + +There is no guarantee that the exception will be delivered promptly, +although the runtime will endeavour to ensure that arbitrary +delays don't occur. In GHC, an exception can only be raised when a +thread reaches a /safe point/, where a safe point is where memory +allocation occurs. Some loops do not perform any memory allocation +inside the loop and therefore cannot be interrupted by a 'throwTo'. + +If the target of 'throwTo' is the calling thread, then the behaviour +is the same as 'Control.Exception.throwIO', except that the exception +is thrown as an asynchronous exception. This means that if there is +an enclosing pure computation, which would be the case if the current +IO operation is inside 'unsafePerformIO' or 'unsafeInterleaveIO', that +computation is not permanently replaced by the exception, but is +suspended as if it had received an asynchronous exception. + +Note that if 'throwTo' is called with the current thread as the +target, the exception will be thrown even if the thread is currently +inside 'mask' or 'uninterruptibleMask'. + -} +throwTo :: Exception e => ThreadId -> e -> IO () +throwTo (ThreadId tid) ex = IO $ \ s -> + case (killThread# tid (toException ex) s) of s1 -> (# s1, () #) + +-- | Returns the 'ThreadId' of the calling thread (GHC only). +myThreadId :: IO ThreadId +myThreadId = IO $ \s -> + case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #) + + +-- |The 'yield' action allows (forces, in a co-operative multitasking +-- implementation) a context-switch to any other currently runnable +-- threads (if any), and is occasionally useful when implementing +-- concurrency abstractions. +yield :: IO () +yield = IO $ \s -> + case (yield# s) of s1 -> (# s1, () #) + +{- | 'labelThread' stores a string as identifier for this thread if +you built a RTS with debugging support. This identifier will be used in +the debugging output to make distinction of different threads easier +(otherwise you only have the thread state object\'s address in the heap). + +Other applications like the graphical Concurrent Haskell Debugger +() may choose to overload +'labelThread' for their purposes as well. +-} + +labelThread :: ThreadId -> String -> IO () +labelThread (ThreadId t) str = + GHC.Foreign.withCString utf8 str $ \(Ptr p) -> + IO $ \ s -> + case labelThread# t p s of s1 -> (# s1, () #) + +-- Nota Bene: 'pseq' used to be 'seq' +-- but 'seq' is now defined in PrelGHC +-- +-- "pseq" is defined a bit weirdly (see below) +-- +-- The reason for the strange "lazy" call is that +-- it fools the compiler into thinking that pseq and par are non-strict in +-- their second argument (even if it inlines pseq at the call site). +-- If it thinks pseq is strict in "y", then it often evaluates +-- "y" before "x", which is totally wrong. + +{-# INLINE pseq #-} +pseq :: a -> b -> b +pseq x y = x `seq` lazy y + +{-# INLINE par #-} +par :: a -> b -> b +par x y = case (par# x) of { _ -> lazy y } + +-- | Internal function used by the RTS to run sparks. +runSparks :: IO () +runSparks = IO loop + where loop s = case getSpark# s of + (# s', n, p #) -> + if isTrue# (n ==# 0#) + then (# s', () #) + else p `seq` loop s' + +data BlockReason + = BlockedOnMVar + -- ^blocked on 'MVar' + {- possibly (see 'threadstatus' below): + | BlockedOnMVarRead + -- ^blocked on reading an empty 'MVar' + -} + | BlockedOnBlackHole + -- ^blocked on a computation in progress by another thread + | BlockedOnException + -- ^blocked in 'throwTo' + | BlockedOnSTM + -- ^blocked in 'retry' in an STM transaction + | BlockedOnForeignCall + -- ^currently in a foreign call + | BlockedOnOther + -- ^blocked on some other resource. Without @-threaded@, + -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@ + -- they show up as 'BlockedOnMVar'. + deriving (Eq,Ord,Show) + +-- | The current status of a thread +data ThreadStatus + = ThreadRunning + -- ^the thread is currently runnable or running + | ThreadFinished + -- ^the thread has finished + | ThreadBlocked BlockReason + -- ^the thread is blocked on some resource + | ThreadDied + -- ^the thread received an uncaught exception + deriving (Eq,Ord,Show) + +threadStatus :: ThreadId -> IO ThreadStatus +threadStatus (ThreadId t) = IO $ \s -> + case threadStatus# t s of + (# s', stat, _cap, _locked #) -> (# s', mk_stat (I# stat) #) + where + -- NB. keep these in sync with includes/rts/Constants.h + mk_stat 0 = ThreadRunning + mk_stat 1 = ThreadBlocked BlockedOnMVar + mk_stat 2 = ThreadBlocked BlockedOnBlackHole + mk_stat 6 = ThreadBlocked BlockedOnSTM + mk_stat 10 = ThreadBlocked BlockedOnForeignCall + mk_stat 11 = ThreadBlocked BlockedOnForeignCall + mk_stat 12 = ThreadBlocked BlockedOnException + mk_stat 14 = ThreadBlocked BlockedOnMVar -- possibly: BlockedOnMVarRead + -- NB. these are hardcoded in rts/PrimOps.cmm + mk_stat 16 = ThreadFinished + mk_stat 17 = ThreadDied + mk_stat _ = ThreadBlocked BlockedOnOther + +-- | returns the number of the capability on which the thread is currently +-- running, and a boolean indicating whether the thread is locked to +-- that capability or not. A thread is locked to a capability if it +-- was created with @forkOn@. +-- +-- @since 4.4.0.0 +threadCapability :: ThreadId -> IO (Int, Bool) +threadCapability (ThreadId t) = IO $ \s -> + case threadStatus# t s of + (# s', _, cap#, locked# #) -> (# s', (I# cap#, isTrue# (locked# /=# 0#)) #) + +-- | make a weak pointer to a 'ThreadId'. It can be important to do +-- this if you want to hold a reference to a 'ThreadId' while still +-- allowing the thread to receive the @BlockedIndefinitely@ family of +-- exceptions (e.g. 'BlockedIndefinitelyOnMVar'). Holding a normal +-- 'ThreadId' reference will prevent the delivery of +-- @BlockedIndefinitely@ exceptions because the reference could be +-- used as the target of 'throwTo' at any time, which would unblock +-- the thread. +-- +-- Holding a @Weak ThreadId@, on the other hand, will not prevent the +-- thread from receiving @BlockedIndefinitely@ exceptions. It is +-- still possible to throw an exception to a @Weak ThreadId@, but the +-- caller must use @deRefWeak@ first to determine whether the thread +-- still exists. +-- +-- @since 4.6.0.0 +mkWeakThreadId :: ThreadId -> IO (Weak ThreadId) +mkWeakThreadId t@(ThreadId t#) = IO $ \s -> + case mkWeakNoFinalizer# t# t s of + (# s1, w #) -> (# s1, Weak w #) + + +----------------------------------------------------------------------------- +-- Transactional heap operations +----------------------------------------------------------------------------- + +-- TVars are shared memory locations which support atomic memory +-- transactions. + +-- |A monad supporting atomic memory transactions. +newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #)) + +unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #)) +unSTM (STM a) = a + +instance Functor STM where + fmap f x = x >>= (pure . f) + +instance Applicative STM where + {-# INLINE pure #-} + {-# INLINE (*>) #-} + pure x = returnSTM x + (<*>) = ap + m *> k = thenSTM m k + +instance Monad STM where + {-# INLINE (>>=) #-} + m >>= k = bindSTM m k + (>>) = (*>) + +bindSTM :: STM a -> (a -> STM b) -> STM b +bindSTM (STM m) k = STM ( \s -> + case m s of + (# new_s, a #) -> unSTM (k a) new_s + ) + +thenSTM :: STM a -> STM b -> STM b +thenSTM (STM m) k = STM ( \s -> + case m s of + (# new_s, _ #) -> unSTM k new_s + ) + +returnSTM :: a -> STM a +returnSTM x = STM (\s -> (# s, x #)) + +instance Alternative STM where + empty = retry + (<|>) = orElse + +instance MonadPlus STM where + mzero = empty + mplus = (<|>) + +-- | Unsafely performs IO in the STM monad. Beware: this is a highly +-- dangerous thing to do. +-- +-- * The STM implementation will often run transactions multiple +-- times, so you need to be prepared for this if your IO has any +-- side effects. +-- +-- * The STM implementation will abort transactions that are known to +-- be invalid and need to be restarted. This may happen in the middle +-- of `unsafeIOToSTM`, so make sure you don't acquire any resources +-- that need releasing (exception handlers are ignored when aborting +-- the transaction). That includes doing any IO using Handles, for +-- example. Getting this wrong will probably lead to random deadlocks. +-- +-- * The transaction may have seen an inconsistent view of memory when +-- the IO runs. Invariants that you expect to be true throughout +-- your program may not be true inside a transaction, due to the +-- way transactions are implemented. Normally this wouldn't be visible +-- to the programmer, but using `unsafeIOToSTM` can expose it. +-- +unsafeIOToSTM :: IO a -> STM a +unsafeIOToSTM (IO m) = STM m + +-- |Perform a series of STM actions atomically. +-- +-- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'. +-- Any attempt to do so will result in a runtime error. (Reason: allowing +-- this would effectively allow a transaction inside a transaction, depending +-- on exactly when the thunk is evaluated.) +-- +-- However, see 'newTVarIO', which can be called inside 'unsafePerformIO', +-- and which allows top-level TVars to be allocated. + +atomically :: STM a -> IO a +atomically (STM m) = IO (\s -> (atomically# m) s ) + +-- |Retry execution of the current memory transaction because it has seen +-- values in TVars which mean that it should not continue (e.g. the TVars +-- represent a shared buffer that is now empty). The implementation may +-- block the thread until one of the TVars that it has read from has been +-- udpated. (GHC only) +retry :: STM a +retry = STM $ \s# -> retry# s# + +-- |Compose two alternative STM actions (GHC only). If the first action +-- completes without retrying then it forms the result of the orElse. +-- Otherwise, if the first action retries, then the second action is +-- tried in its place. If both actions retry then the orElse as a +-- whole retries. +orElse :: STM a -> STM a -> STM a +orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s + +-- | A variant of 'throw' that can only be used within the 'STM' monad. +-- +-- Throwing an exception in @STM@ aborts the transaction and propagates the +-- exception. +-- +-- Although 'throwSTM' has a type that is an instance of the type of 'throw', the +-- two functions are subtly different: +-- +-- > throw e `seq` x ===> throw e +-- > throwSTM e `seq` x ===> x +-- +-- The first example will cause the exception @e@ to be raised, +-- whereas the second one won\'t. In fact, 'throwSTM' will only cause +-- an exception to be raised when it is used within the 'STM' monad. +-- The 'throwSTM' variant should be used in preference to 'throw' to +-- raise an exception within the 'STM' monad because it guarantees +-- ordering with respect to other 'STM' operations, whereas 'throw' +-- does not. +throwSTM :: Exception e => e -> STM a +throwSTM e = STM $ raiseIO# (toException e) + +-- |Exception handling within STM actions. +catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a +catchSTM (STM m) handler = STM $ catchSTM# m handler' + where + handler' e = case fromException e of + Just e' -> unSTM (handler e') + Nothing -> raiseIO# e + +-- | Low-level primitive on which always and alwaysSucceeds are built. +-- checkInv differs form these in that (i) the invariant is not +-- checked when checkInv is called, only at the end of this and +-- subsequent transcations, (ii) the invariant failure is indicated +-- by raising an exception. +checkInv :: STM a -> STM () +checkInv (STM m) = STM (\s -> case (check# m) s of s' -> (# s', () #)) + +-- | alwaysSucceeds adds a new invariant that must be true when passed +-- to alwaysSucceeds, at the end of the current transaction, and at +-- the end of every subsequent transaction. If it fails at any +-- of those points then the transaction violating it is aborted +-- and the exception raised by the invariant is propagated. +alwaysSucceeds :: STM a -> STM () +alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () ) + checkInv i + +-- | always is a variant of alwaysSucceeds in which the invariant is +-- expressed as an STM Bool action that must return True. Returning +-- False or raising an exception are both treated as invariant failures. +always :: STM Bool -> STM () +always i = alwaysSucceeds ( do v <- i + if (v) then return () else ( errorWithoutStackTrace "Transactional invariant violation" ) ) + +-- |Shared memory locations that support atomic memory transactions. +data TVar a = TVar (TVar# RealWorld a) + +instance Eq (TVar a) where + (TVar tvar1#) == (TVar tvar2#) = isTrue# (sameTVar# tvar1# tvar2#) + +-- |Create a new TVar holding a value supplied +newTVar :: a -> STM (TVar a) +newTVar val = STM $ \s1# -> + case newTVar# val s1# of + (# s2#, tvar# #) -> (# s2#, TVar tvar# #) + +-- |@IO@ version of 'newTVar'. This is useful for creating top-level +-- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using +-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't +-- possible. +newTVarIO :: a -> IO (TVar a) +newTVarIO val = IO $ \s1# -> + case newTVar# val s1# of + (# s2#, tvar# #) -> (# s2#, TVar tvar# #) + +-- |Return the current value stored in a TVar. +-- This is equivalent to +-- +-- > readTVarIO = atomically . readTVar +-- +-- but works much faster, because it doesn't perform a complete +-- transaction, it just reads the current value of the 'TVar'. +readTVarIO :: TVar a -> IO a +readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s# + +-- |Return the current value stored in a TVar +readTVar :: TVar a -> STM a +readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s# + +-- |Write the supplied value into a TVar +writeTVar :: TVar a -> a -> STM () +writeTVar (TVar tvar#) val = STM $ \s1# -> + case writeTVar# tvar# val s1# of + s2# -> (# s2#, () #) + +----------------------------------------------------------------------------- +-- MVar utilities +----------------------------------------------------------------------------- + +withMVar :: MVar a -> (a -> IO b) -> IO b +withMVar m io = + mask $ \restore -> do + a <- takeMVar m + b <- catchAny (restore (io a)) + (\e -> do putMVar m a; throw e) + putMVar m a + return b + +modifyMVar_ :: MVar a -> (a -> IO a) -> IO () +modifyMVar_ m io = + mask $ \restore -> do + a <- takeMVar m + a' <- catchAny (restore (io a)) + (\e -> do putMVar m a; throw e) + putMVar m a' + return () + +----------------------------------------------------------------------------- +-- Thread waiting +----------------------------------------------------------------------------- + +-- Machinery needed to ensureb that we only have one copy of certain +-- CAFs in this module even when the base package is present twice, as +-- it is when base is dynamically loaded into GHCi. The RTS keeps +-- track of the single true value of the CAF, so even when the CAFs in +-- the dynamically-loaded base package are reverted, nothing bad +-- happens. +-- +sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a +sharedCAF a get_or_set = + mask_ $ do + stable_ref <- newStablePtr a + let ref = castPtr (castStablePtrToPtr stable_ref) + ref2 <- get_or_set ref + if ref==ref2 + then return a + else do freeStablePtr stable_ref + deRefStablePtr (castPtrToStablePtr (castPtr ref2)) + +reportStackOverflow :: IO () +reportStackOverflow = do + ThreadId tid <- myThreadId + callStackOverflowHook tid + +reportError :: SomeException -> IO () +reportError ex = do + handler <- getUncaughtExceptionHandler + handler ex + +-- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove +-- the unsafe below. +foreign import ccall unsafe "stackOverflow" + callStackOverflowHook :: ThreadId# -> IO () + +{-# NOINLINE uncaughtExceptionHandler #-} +uncaughtExceptionHandler :: IORef (SomeException -> IO ()) +uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler) + where + defaultHandler :: SomeException -> IO () + defaultHandler se@(SomeException ex) = do + (hFlush stdout) `catchAny` (\ _ -> return ()) + let msg = case cast ex of + Just Deadlock -> "no threads to run: infinite loop or deadlock?" + _ -> showsPrec 0 se "" + withCString "%s" $ \cfmt -> + withCString msg $ \cmsg -> + errorBelch cfmt cmsg + +-- don't use errorBelch() directly, because we cannot call varargs functions +-- using the FFI. +foreign import ccall unsafe "HsBase.h errorBelch2" + errorBelch :: CString -> CString -> IO () + +setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO () +setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler + +getUncaughtExceptionHandler :: IO (SomeException -> IO ()) +getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler diff --git a/libraries/base/GHC/Conc/Windows.hs b/libraries/base/GHC/Conc/Windows.hs new file mode 100644 index 0000000..4cbb8ca --- /dev/null +++ b/libraries/base/GHC/Conc/Windows.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_HADDOCK not-home #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Conc.Windows +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Windows I/O manager +-- +----------------------------------------------------------------------------- + +-- #not-home +module GHC.Conc.Windows + ( ensureIOManagerIsRunning + + -- * Waiting + , threadDelay + , registerDelay + + -- * Miscellaneous + , asyncRead + , asyncWrite + , asyncDoProc + + , asyncReadBA + , asyncWriteBA + + , ConsoleEvent(..) + , win32ConsoleHandler + , toWin32ConsoleEvent + ) where + +import Data.Bits (shiftR) +import GHC.Base +import GHC.Conc.Sync +import GHC.Enum (Enum) +import GHC.IO (unsafePerformIO) +import GHC.IORef +import GHC.MVar +import GHC.Num (Num(..)) +import GHC.Ptr +import GHC.Read (Read) +import GHC.Real (div, fromIntegral) +import GHC.Show (Show) +import GHC.Word (Word32, Word64) +import GHC.Windows + +#ifdef mingw32_HOST_OS +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif +#endif + +-- ---------------------------------------------------------------------------- +-- Thread waiting + +-- Note: threadWaitRead and threadWaitWrite aren't really functional +-- on Win32, but left in there because lib code (still) uses them (the manner +-- in which they're used doesn't cause problems on a Win32 platform though.) + +asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) +asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) = + IO $ \s -> case asyncRead# fd isSock len buf s of + (# s', len#, err# #) -> (# s', (I# len#, I# err#) #) + +asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) +asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) = + IO $ \s -> case asyncWrite# fd isSock len buf s of + (# s', len#, err# #) -> (# s', (I# len#, I# err#) #) + +asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int +asyncDoProc (FunPtr proc) (Ptr param) = + -- the 'length' value is ignored; simplifies implementation of + -- the async*# primops to have them all return the same result. + IO $ \s -> case asyncDoProc# proc param s of + (# s', _len#, err# #) -> (# s', I# err# #) + +-- to aid the use of these primops by the IO Handle implementation, +-- provide the following convenience funs: + +-- this better be a pinned byte array! +asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int) +asyncReadBA fd isSock len off bufB = + asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off) + +asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int) +asyncWriteBA fd isSock len off bufB = + asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off) + +-- ---------------------------------------------------------------------------- +-- Threaded RTS implementation of threadDelay + +-- | Suspends the current thread for a given number of microseconds +-- (GHC only). +-- +-- There is no guarantee that the thread will be rescheduled promptly +-- when the delay has expired, but the thread will never continue to +-- run /earlier/ than specified. +-- +threadDelay :: Int -> IO () +threadDelay time + | threaded = waitForDelayEvent time + | otherwise = IO $ \s -> + case time of { I# time# -> + case delay# time# s of { s' -> (# s', () #) + }} + +-- | Set the value of returned TVar to True after a given number of +-- microseconds. The caveats associated with threadDelay also apply. +-- +registerDelay :: Int -> IO (TVar Bool) +registerDelay usecs + | threaded = waitForDelayEventSTM usecs + | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded" + +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool + +waitForDelayEvent :: Int -> IO () +waitForDelayEvent usecs = do + m <- newEmptyMVar + target <- calculateTarget usecs + atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ())) + prodServiceThread + takeMVar m + +-- Delays for use in STM +waitForDelayEventSTM :: Int -> IO (TVar Bool) +waitForDelayEventSTM usecs = do + t <- atomically $ newTVar False + target <- calculateTarget usecs + atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ())) + prodServiceThread + return t + +calculateTarget :: Int -> IO USecs +calculateTarget usecs = do + now <- getMonotonicUSec + return $ now + (fromIntegral usecs) + +data DelayReq + = Delay {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ()) + | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool) + +{-# NOINLINE pendingDelays #-} +pendingDelays :: IORef [DelayReq] +pendingDelays = unsafePerformIO $ do + m <- newIORef [] + sharedCAF m getOrSetGHCConcWindowsPendingDelaysStore + +foreign import ccall unsafe "getOrSetGHCConcWindowsPendingDelaysStore" + getOrSetGHCConcWindowsPendingDelaysStore :: Ptr a -> IO (Ptr a) + +{-# NOINLINE ioManagerThread #-} +ioManagerThread :: MVar (Maybe ThreadId) +ioManagerThread = unsafePerformIO $ do + m <- newMVar Nothing + sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore + +foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore" + getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a) + +ensureIOManagerIsRunning :: IO () +ensureIOManagerIsRunning + | threaded = startIOManagerThread + | otherwise = return () + +startIOManagerThread :: IO () +startIOManagerThread = do + modifyMVar_ ioManagerThread $ \old -> do + let create = do t <- forkIO ioManager; return (Just t) + case old of + Nothing -> create + Just t -> do + s <- threadStatus t + case s of + ThreadFinished -> create + ThreadDied -> create + _other -> return (Just t) + +insertDelay :: DelayReq -> [DelayReq] -> [DelayReq] +insertDelay d [] = [d] +insertDelay d1 ds@(d2 : rest) + | delayTime d1 <= delayTime d2 = d1 : ds + | otherwise = d2 : insertDelay d1 rest + +delayTime :: DelayReq -> USecs +delayTime (Delay t _) = t +delayTime (DelaySTM t _) = t + +type USecs = Word64 +type NSecs = Word64 + +foreign import ccall unsafe "getMonotonicNSec" + getMonotonicNSec :: IO NSecs + +getMonotonicUSec :: IO USecs +getMonotonicUSec = fmap (`div` 1000) getMonotonicNSec + +{-# NOINLINE prodding #-} +prodding :: IORef Bool +prodding = unsafePerformIO $ do + r <- newIORef False + sharedCAF r getOrSetGHCConcWindowsProddingStore + +foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore" + getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a) + +prodServiceThread :: IO () +prodServiceThread = do + -- NB. use atomicModifyIORef here, otherwise there are race + -- conditions in which prodding is left at True but the server is + -- blocked in select(). + was_set <- atomicModifyIORef prodding $ \b -> (True,b) + when (not was_set) wakeupIOManager + +-- ---------------------------------------------------------------------------- +-- Windows IO manager thread + +ioManager :: IO () +ioManager = do + wakeup <- c_getIOManagerEvent + service_loop wakeup [] + +service_loop :: HANDLE -- read end of pipe + -> [DelayReq] -- current delay requests + -> IO () + +service_loop wakeup old_delays = do + -- pick up new delay requests + new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a)) + let delays = foldr insertDelay old_delays new_delays + + now <- getMonotonicUSec + (delays', timeout) <- getDelay now delays + + r <- c_WaitForSingleObject wakeup timeout + case r of + 0xffffffff -> do throwGetLastError "service_loop" + 0 -> do + r2 <- c_readIOManagerEvent + exit <- + case r2 of + _ | r2 == io_MANAGER_WAKEUP -> return False + _ | r2 == io_MANAGER_DIE -> return True + 0 -> return False -- spurious wakeup + _ -> do start_console_handler (r2 `shiftR` 1); return False + when (not exit) $ service_cont wakeup delays' + + _other -> service_cont wakeup delays' -- probably timeout + +service_cont :: HANDLE -> [DelayReq] -> IO () +service_cont wakeup delays = do + r <- atomicModifyIORef prodding (\_ -> (False,False)) + r `seq` return () -- avoid space leak + service_loop wakeup delays + +-- must agree with rts/win32/ThrIOManager.c +io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32 +io_MANAGER_WAKEUP = 0xffffffff +io_MANAGER_DIE = 0xfffffffe + +data ConsoleEvent + = ControlC + | Break + | Close + -- these are sent to Services only. + | Logoff + | Shutdown + deriving (Eq, Ord, Enum, Show, Read) + +start_console_handler :: Word32 -> IO () +start_console_handler r = + case toWin32ConsoleEvent r of + Just x -> withMVar win32ConsoleHandler $ \handler -> do + _ <- forkIO (handler x) + return () + Nothing -> return () + +toWin32ConsoleEvent :: (Eq a, Num a) => a -> Maybe ConsoleEvent +toWin32ConsoleEvent ev = + case ev of + 0 {- CTRL_C_EVENT-} -> Just ControlC + 1 {- CTRL_BREAK_EVENT-} -> Just Break + 2 {- CTRL_CLOSE_EVENT-} -> Just Close + 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff + 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown + _ -> Nothing + +win32ConsoleHandler :: MVar (ConsoleEvent -> IO ()) +win32ConsoleHandler = unsafePerformIO (newMVar (errorWithoutStackTrace "win32ConsoleHandler")) + +wakeupIOManager :: IO () +wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP + +-- Walk the queue of pending delays, waking up any that have passed +-- and return the smallest delay to wait for. The queue of pending +-- delays is kept ordered. +getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD) +getDelay _ [] = return ([], iNFINITE) +getDelay now all@(d : rest) + = case d of + Delay time m | now >= time -> do + putMVar m () + getDelay now rest + DelaySTM time t | now >= time -> do + atomically $ writeTVar t True + getDelay now rest + _otherwise -> + -- delay is in millisecs for WaitForSingleObject + let micro_seconds = delayTime d - now + milli_seconds = (micro_seconds + 999) `div` 1000 + in return (all, fromIntegral milli_seconds) + +foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c) + c_getIOManagerEvent :: IO HANDLE + +foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c) + c_readIOManagerEvent :: IO Word32 + +foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c) + c_sendIOManagerEvent :: Word32 -> IO () + +foreign import WINDOWS_CCONV "WaitForSingleObject" + c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD + diff --git a/libraries/base/GHC/ConsoleHandler.hs b/libraries/base/GHC/ConsoleHandler.hs new file mode 100644 index 0000000..6d1e36f --- /dev/null +++ b/libraries/base/GHC/ConsoleHandler.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.ConsoleHandler +-- Copyright : (c) The University of Glasgow +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- NB. the contents of this module are only available on Windows. +-- +-- Installing Win32 console handlers. +-- +----------------------------------------------------------------------------- + +module GHC.ConsoleHandler +#if !defined(mingw32_HOST_OS) + where + +import GHC.Base () -- dummy dependency +#else /* whole file */ + ( Handler(..) + , installHandler + , ConsoleEvent(..) + , flushConsole + ) where + +{- +#include "rts/Signals.h" + +Note: this #include is inside a Haskell comment + but it brings into scope some #defines + that are used by CPP below (eg STG_SIG_DFL). + Having it in a comment means that there's no + danger that C-like crap will be misunderstood + by GHC +-} + +import GHC.Base +import Foreign +import Foreign.C +import GHC.IO.FD +import GHC.IO.Exception +import GHC.IO.Handle.Types +import GHC.IO.Handle.Internals +import GHC.Conc +import Control.Concurrent.MVar +import Data.Typeable + +data Handler + = Default + | Ignore + | Catch (ConsoleEvent -> IO ()) + +-- | Allows Windows console events to be caught and handled. To +-- handle a console event, call 'installHandler' passing the +-- appropriate 'Handler' value. When the event is received, if the +-- 'Handler' value is @Catch f@, then a new thread will be spawned by +-- the system to execute @f e@, where @e@ is the 'ConsoleEvent' that +-- was received. +-- +-- Note that console events can only be received by an application +-- running in a Windows console. Certain environments that look like consoles +-- do not support console events, these include: +-- +-- * Cygwin shells with @CYGWIN=tty@ set (if you don't set @CYGWIN=tty@, +-- then a Cygwin shell behaves like a Windows console). +-- * Cygwin xterm and rxvt windows +-- * MSYS rxvt windows +-- +-- In order for your application to receive console events, avoid running +-- it in one of these environments. +-- +installHandler :: Handler -> IO Handler +installHandler handler + | threaded = + modifyMVar win32ConsoleHandler $ \old_h -> do + (new_h,rc) <- + case handler of + Default -> do + r <- rts_installHandler STG_SIG_DFL nullPtr + return (no_handler, r) + Ignore -> do + r <- rts_installHandler STG_SIG_IGN nullPtr + return (no_handler, r) + Catch h -> do + r <- rts_installHandler STG_SIG_HAN nullPtr + return (h, r) + prev_handler <- + case rc of + STG_SIG_DFL -> return Default + STG_SIG_IGN -> return Ignore + STG_SIG_HAN -> return (Catch old_h) + _ -> errorWithoutStackTrace "installHandler: Bad threaded rc value" + return (new_h, prev_handler) + + | otherwise = + alloca $ \ p_sp -> do + rc <- + case handler of + Default -> rts_installHandler STG_SIG_DFL p_sp + Ignore -> rts_installHandler STG_SIG_IGN p_sp + Catch h -> do + v <- newStablePtr (toHandler h) + poke p_sp v + rts_installHandler STG_SIG_HAN p_sp + case rc of + STG_SIG_DFL -> return Default + STG_SIG_IGN -> return Ignore + STG_SIG_HAN -> do + osptr <- peek p_sp + oldh <- deRefStablePtr osptr + -- stable pointer is no longer in use, free it. + freeStablePtr osptr + return (Catch (\ ev -> oldh (fromConsoleEvent ev))) + _ -> errorWithoutStackTrace "installHandler: Bad non-threaded rc value" + where + fromConsoleEvent ev = + case ev of + ControlC -> 0 {- CTRL_C_EVENT-} + Break -> 1 {- CTRL_BREAK_EVENT-} + Close -> 2 {- CTRL_CLOSE_EVENT-} + Logoff -> 5 {- CTRL_LOGOFF_EVENT-} + Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-} + + toHandler hdlr ev = do + case toWin32ConsoleEvent ev of + -- see rts/win32/ConsoleHandler.c for comments as to why + -- rts_ConsoleHandlerDone is called here. + Just x -> hdlr x >> rts_ConsoleHandlerDone ev + Nothing -> return () -- silently ignore.. + + no_handler = errorWithoutStackTrace "win32ConsoleHandler" + +foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool + +foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent" + rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt +foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone" + rts_ConsoleHandlerDone :: CInt -> IO () + + +flushConsole :: Handle -> IO () +flushConsole h = + wantReadableHandle_ "flushConsole" h $ \ Handle__{haDevice=dev} -> + case cast dev of + Nothing -> ioException $ + IOError (Just h) IllegalOperation "flushConsole" + "handle is not a file descriptor" Nothing Nothing + Just fd -> do + throwErrnoIfMinus1Retry_ "flushConsole" $ + flush_console_fd (fdFD fd) + +foreign import ccall unsafe "consUtils.h flush_input_console__" + flush_console_fd :: CInt -> IO CInt + +#endif /* mingw32_HOST_OS */ diff --git a/libraries/base/GHC/Constants.hs b/libraries/base/GHC/Constants.hs new file mode 100644 index 0000000..981dc43 --- /dev/null +++ b/libraries/base/GHC/Constants.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Constants where + +-- TODO: This used to include HaskellConstants.hs, but that has now gone. +-- We probably want to include the constants in platformConstants somehow +-- instead. + +import GHC.Base () -- dummy dependency diff --git a/libraries/base/GHC/Desugar.hs b/libraries/base/GHC/Desugar.hs new file mode 100644 index 0000000..cdea698 --- /dev/null +++ b/libraries/base/GHC/Desugar.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude + , RankNTypes + , ExistentialQuantification + #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Desugar +-- Copyright : (c) The University of Glasgow, 2007 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Support code for desugaring in GHC +-- +----------------------------------------------------------------------------- + +module GHC.Desugar ((>>>), AnnotationWrapper(..), toAnnotationWrapper) where + +import Control.Arrow (Arrow(..)) +import Control.Category ((.)) +import Data.Data (Data) + +-- A version of Control.Category.>>> overloaded on Arrow +(>>>) :: forall arr. Arrow arr => forall a b c. arr a b -> arr b c -> arr a c +-- NB: the type of this function is the "shape" that GHC expects +-- in tcInstClassOp. So don't put all the foralls at the front! +-- Yes, this is a bit grotesque, but heck it works and the whole +-- arrows stuff needs reworking anyway! +f >>> g = g . f + +-- A wrapper data type that lets the typechecker get at the appropriate dictionaries for an annotation +data AnnotationWrapper = forall a. (Data a) => AnnotationWrapper a + +toAnnotationWrapper :: (Data a) => a -> AnnotationWrapper +toAnnotationWrapper what = AnnotationWrapper what + diff --git a/libraries/base/GHC/Enum.hs b/libraries/base/GHC/Enum.hs new file mode 100644 index 0000000..729b801 --- /dev/null +++ b/libraries/base/GHC/Enum.hs @@ -0,0 +1,768 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Enum +-- Copyright : (c) The University of Glasgow, 1992-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- The 'Enum' and 'Bounded' classes. +-- +----------------------------------------------------------------------------- + +#include "MachDeps.h" + +module GHC.Enum( + Bounded(..), Enum(..), + boundedEnumFrom, boundedEnumFromThen, + toEnumError, fromEnumError, succError, predError, + + -- Instances for Bounded and Enum: (), Char, Int + + ) where + +import GHC.Base hiding ( many ) +import GHC.Char +import GHC.Integer +import GHC.Num +import GHC.Show +default () -- Double isn't available yet + +-- | The 'Bounded' class is used to name the upper and lower limits of a +-- type. 'Ord' is not a superclass of 'Bounded' since types that are not +-- totally ordered may also have upper and lower bounds. +-- +-- The 'Bounded' class may be derived for any enumeration type; +-- 'minBound' is the first constructor listed in the @data@ declaration +-- and 'maxBound' is the last. +-- 'Bounded' may also be derived for single-constructor datatypes whose +-- constituent types are in 'Bounded'. + +class Bounded a where + minBound, maxBound :: a + +-- | Class 'Enum' defines operations on sequentially ordered types. +-- +-- The @enumFrom@... methods are used in Haskell's translation of +-- arithmetic sequences. +-- +-- Instances of 'Enum' may be derived for any enumeration type (types +-- whose constructors have no fields). The nullary constructors are +-- assumed to be numbered left-to-right by 'fromEnum' from @0@ through @n-1@. +-- See Chapter 10 of the /Haskell Report/ for more details. +-- +-- For any type that is an instance of class 'Bounded' as well as 'Enum', +-- the following should hold: +-- +-- * The calls @'succ' 'maxBound'@ and @'pred' 'minBound'@ should result in +-- a runtime error. +-- +-- * 'fromEnum' and 'toEnum' should give a runtime error if the +-- result value is not representable in the result type. +-- For example, @'toEnum' 7 :: 'Bool'@ is an error. +-- +-- * 'enumFrom' and 'enumFromThen' should be defined with an implicit bound, +-- thus: +-- +-- > enumFrom x = enumFromTo x maxBound +-- > enumFromThen x y = enumFromThenTo x y bound +-- > where +-- > bound | fromEnum y >= fromEnum x = maxBound +-- > | otherwise = minBound +-- +class Enum a where + -- | the successor of a value. For numeric types, 'succ' adds 1. + succ :: a -> a + -- | the predecessor of a value. For numeric types, 'pred' subtracts 1. + pred :: a -> a + -- | Convert from an 'Int'. + toEnum :: Int -> a + -- | Convert to an 'Int'. + -- It is implementation-dependent what 'fromEnum' returns when + -- applied to a value that is too large to fit in an 'Int'. + fromEnum :: a -> Int + + -- | Used in Haskell's translation of @[n..]@. + enumFrom :: a -> [a] + -- | Used in Haskell's translation of @[n,n'..]@. + enumFromThen :: a -> a -> [a] + -- | Used in Haskell's translation of @[n..m]@. + enumFromTo :: a -> a -> [a] + -- | Used in Haskell's translation of @[n,n'..m]@. + enumFromThenTo :: a -> a -> a -> [a] + + succ = toEnum . (+ 1) . fromEnum + pred = toEnum . (subtract 1) . fromEnum + enumFrom x = map toEnum [fromEnum x ..] + enumFromThen x y = map toEnum [fromEnum x, fromEnum y ..] + enumFromTo x y = map toEnum [fromEnum x .. fromEnum y] + enumFromThenTo x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y] + +-- Default methods for bounded enumerations +boundedEnumFrom :: (Enum a, Bounded a) => a -> [a] +boundedEnumFrom n = map toEnum [fromEnum n .. fromEnum (maxBound `asTypeOf` n)] + +boundedEnumFromThen :: (Enum a, Bounded a) => a -> a -> [a] +boundedEnumFromThen n1 n2 + | i_n2 >= i_n1 = map toEnum [i_n1, i_n2 .. fromEnum (maxBound `asTypeOf` n1)] + | otherwise = map toEnum [i_n1, i_n2 .. fromEnum (minBound `asTypeOf` n1)] + where + i_n1 = fromEnum n1 + i_n2 = fromEnum n2 + +------------------------------------------------------------------------ +-- Helper functions +------------------------------------------------------------------------ + +{-# NOINLINE toEnumError #-} +toEnumError :: (Show a) => String -> Int -> (a,a) -> b +toEnumError inst_ty i bnds = + errorWithoutStackTrace $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" ++ + show i ++ + ") is outside of bounds " ++ + show bnds + +{-# NOINLINE fromEnumError #-} +fromEnumError :: (Show a) => String -> a -> b +fromEnumError inst_ty x = + errorWithoutStackTrace $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" ++ + show x ++ + ") is outside of Int's bounds " ++ + show (minBound::Int, maxBound::Int) + +{-# NOINLINE succError #-} +succError :: String -> a +succError inst_ty = + errorWithoutStackTrace $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound" + +{-# NOINLINE predError #-} +predError :: String -> a +predError inst_ty = + errorWithoutStackTrace $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound" + +------------------------------------------------------------------------ +-- Tuples +------------------------------------------------------------------------ + +instance Bounded () where + minBound = () + maxBound = () + +instance Enum () where + succ _ = errorWithoutStackTrace "Prelude.Enum.().succ: bad argument" + pred _ = errorWithoutStackTrace "Prelude.Enum.().pred: bad argument" + + toEnum x | x == 0 = () + | otherwise = errorWithoutStackTrace "Prelude.Enum.().toEnum: bad argument" + + fromEnum () = 0 + enumFrom () = [()] + enumFromThen () () = let many = ():many in many + enumFromTo () () = [()] + enumFromThenTo () () () = let many = ():many in many + +-- Report requires instances up to 15 +instance (Bounded a, Bounded b) => Bounded (a,b) where + minBound = (minBound, minBound) + maxBound = (maxBound, maxBound) + +instance (Bounded a, Bounded b, Bounded c) => Bounded (a,b,c) where + minBound = (minBound, minBound, minBound) + maxBound = (maxBound, maxBound, maxBound) + +instance (Bounded a, Bounded b, Bounded c, Bounded d) => Bounded (a,b,c,d) where + minBound = (minBound, minBound, minBound, minBound) + maxBound = (maxBound, maxBound, maxBound, maxBound) + +instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e) => Bounded (a,b,c,d,e) where + minBound = (minBound, minBound, minBound, minBound, minBound) + maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound) + +instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f) + => Bounded (a,b,c,d,e,f) where + minBound = (minBound, minBound, minBound, minBound, minBound, minBound) + maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound) + +instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g) + => Bounded (a,b,c,d,e,f,g) where + minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound) + maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound) + +instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, + Bounded h) + => Bounded (a,b,c,d,e,f,g,h) where + minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound) + maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound) + +instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, + Bounded h, Bounded i) + => Bounded (a,b,c,d,e,f,g,h,i) where + minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound, + minBound) + maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, + maxBound) + +instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, + Bounded h, Bounded i, Bounded j) + => Bounded (a,b,c,d,e,f,g,h,i,j) where + minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound, + minBound, minBound) + maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, + maxBound, maxBound) + +instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, + Bounded h, Bounded i, Bounded j, Bounded k) + => Bounded (a,b,c,d,e,f,g,h,i,j,k) where + minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound, + minBound, minBound, minBound) + maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, + maxBound, maxBound, maxBound) + +instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, + Bounded h, Bounded i, Bounded j, Bounded k, Bounded l) + => Bounded (a,b,c,d,e,f,g,h,i,j,k,l) where + minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound, + minBound, minBound, minBound, minBound) + maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, + maxBound, maxBound, maxBound, maxBound) + +instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, + Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m) + => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m) where + minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound, + minBound, minBound, minBound, minBound, minBound) + maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, + maxBound, maxBound, maxBound, maxBound, maxBound) + +instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, + Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m, Bounded n) + => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where + minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound, + minBound, minBound, minBound, minBound, minBound, minBound) + maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, + maxBound, maxBound, maxBound, maxBound, maxBound, maxBound) + +instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, + Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m, Bounded n, Bounded o) + => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where + minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound, + minBound, minBound, minBound, minBound, minBound, minBound, minBound) + maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, + maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound) + +------------------------------------------------------------------------ +-- Bool +------------------------------------------------------------------------ + +instance Bounded Bool where + minBound = False + maxBound = True + +instance Enum Bool where + succ False = True + succ True = errorWithoutStackTrace "Prelude.Enum.Bool.succ: bad argument" + + pred True = False + pred False = errorWithoutStackTrace "Prelude.Enum.Bool.pred: bad argument" + + toEnum n | n == 0 = False + | n == 1 = True + | otherwise = errorWithoutStackTrace "Prelude.Enum.Bool.toEnum: bad argument" + + fromEnum False = 0 + fromEnum True = 1 + + -- Use defaults for the rest + enumFrom = boundedEnumFrom + enumFromThen = boundedEnumFromThen + +------------------------------------------------------------------------ +-- Ordering +------------------------------------------------------------------------ + +instance Bounded Ordering where + minBound = LT + maxBound = GT + +instance Enum Ordering where + succ LT = EQ + succ EQ = GT + succ GT = errorWithoutStackTrace "Prelude.Enum.Ordering.succ: bad argument" + + pred GT = EQ + pred EQ = LT + pred LT = errorWithoutStackTrace "Prelude.Enum.Ordering.pred: bad argument" + + toEnum n | n == 0 = LT + | n == 1 = EQ + | n == 2 = GT + toEnum _ = errorWithoutStackTrace "Prelude.Enum.Ordering.toEnum: bad argument" + + fromEnum LT = 0 + fromEnum EQ = 1 + fromEnum GT = 2 + + -- Use defaults for the rest + enumFrom = boundedEnumFrom + enumFromThen = boundedEnumFromThen + +------------------------------------------------------------------------ +-- Char +------------------------------------------------------------------------ + +instance Bounded Char where + minBound = '\0' + maxBound = '\x10FFFF' + +instance Enum Char where + succ (C# c#) + | isTrue# (ord# c# /=# 0x10FFFF#) = C# (chr# (ord# c# +# 1#)) + | otherwise = errorWithoutStackTrace ("Prelude.Enum.Char.succ: bad argument") + pred (C# c#) + | isTrue# (ord# c# /=# 0#) = C# (chr# (ord# c# -# 1#)) + | otherwise = errorWithoutStackTrace ("Prelude.Enum.Char.pred: bad argument") + + toEnum = chr + fromEnum = ord + + {-# INLINE enumFrom #-} + enumFrom (C# x) = eftChar (ord# x) 0x10FFFF# + -- Blarg: technically I guess enumFrom isn't strict! + + {-# INLINE enumFromTo #-} + enumFromTo (C# x) (C# y) = eftChar (ord# x) (ord# y) + + {-# INLINE enumFromThen #-} + enumFromThen (C# x1) (C# x2) = efdChar (ord# x1) (ord# x2) + + {-# INLINE enumFromThenTo #-} + enumFromThenTo (C# x1) (C# x2) (C# y) = efdtChar (ord# x1) (ord# x2) (ord# y) + +-- See Note [How the Enum rules work] +{-# RULES +"eftChar" [~1] forall x y. eftChar x y = build (\c n -> eftCharFB c n x y) +"efdChar" [~1] forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2) +"efdtChar" [~1] forall x1 x2 l. efdtChar x1 x2 l = build (\ c n -> efdtCharFB c n x1 x2 l) +"eftCharList" [1] eftCharFB (:) [] = eftChar +"efdCharList" [1] efdCharFB (:) [] = efdChar +"efdtCharList" [1] efdtCharFB (:) [] = efdtChar + #-} + + +-- We can do better than for Ints because we don't +-- have hassles about arithmetic overflow at maxBound +{-# INLINE [0] eftCharFB #-} +eftCharFB :: (Char -> a -> a) -> a -> Int# -> Int# -> a +eftCharFB c n x0 y = go x0 + where + go x | isTrue# (x ># y) = n + | otherwise = C# (chr# x) `c` go (x +# 1#) + +{-# NOINLINE [1] eftChar #-} +eftChar :: Int# -> Int# -> String +eftChar x y | isTrue# (x ># y ) = [] + | otherwise = C# (chr# x) : eftChar (x +# 1#) y + + +-- For enumFromThenTo we give up on inlining +{-# NOINLINE [0] efdCharFB #-} +efdCharFB :: (Char -> a -> a) -> a -> Int# -> Int# -> a +efdCharFB c n x1 x2 + | isTrue# (delta >=# 0#) = go_up_char_fb c n x1 delta 0x10FFFF# + | otherwise = go_dn_char_fb c n x1 delta 0# + where + !delta = x2 -# x1 + +{-# NOINLINE [1] efdChar #-} +efdChar :: Int# -> Int# -> String +efdChar x1 x2 + | isTrue# (delta >=# 0#) = go_up_char_list x1 delta 0x10FFFF# + | otherwise = go_dn_char_list x1 delta 0# + where + !delta = x2 -# x1 + +{-# NOINLINE [0] efdtCharFB #-} +efdtCharFB :: (Char -> a -> a) -> a -> Int# -> Int# -> Int# -> a +efdtCharFB c n x1 x2 lim + | isTrue# (delta >=# 0#) = go_up_char_fb c n x1 delta lim + | otherwise = go_dn_char_fb c n x1 delta lim + where + !delta = x2 -# x1 + +{-# NOINLINE [1] efdtChar #-} +efdtChar :: Int# -> Int# -> Int# -> String +efdtChar x1 x2 lim + | isTrue# (delta >=# 0#) = go_up_char_list x1 delta lim + | otherwise = go_dn_char_list x1 delta lim + where + !delta = x2 -# x1 + +go_up_char_fb :: (Char -> a -> a) -> a -> Int# -> Int# -> Int# -> a +go_up_char_fb c n x0 delta lim + = go_up x0 + where + go_up x | isTrue# (x ># lim) = n + | otherwise = C# (chr# x) `c` go_up (x +# delta) + +go_dn_char_fb :: (Char -> a -> a) -> a -> Int# -> Int# -> Int# -> a +go_dn_char_fb c n x0 delta lim + = go_dn x0 + where + go_dn x | isTrue# (x <# lim) = n + | otherwise = C# (chr# x) `c` go_dn (x +# delta) + +go_up_char_list :: Int# -> Int# -> Int# -> String +go_up_char_list x0 delta lim + = go_up x0 + where + go_up x | isTrue# (x ># lim) = [] + | otherwise = C# (chr# x) : go_up (x +# delta) + +go_dn_char_list :: Int# -> Int# -> Int# -> String +go_dn_char_list x0 delta lim + = go_dn x0 + where + go_dn x | isTrue# (x <# lim) = [] + | otherwise = C# (chr# x) : go_dn (x +# delta) + + +------------------------------------------------------------------------ +-- Int +------------------------------------------------------------------------ + +{- +Be careful about these instances. + (a) remember that you have to count down as well as up e.g. [13,12..0] + (b) be careful of Int overflow + (c) remember that Int is bounded, so [1..] terminates at maxInt +-} + +instance Bounded Int where + minBound = minInt + maxBound = maxInt + +instance Enum Int where + succ x + | x == maxBound = errorWithoutStackTrace "Prelude.Enum.succ{Int}: tried to take `succ' of maxBound" + | otherwise = x + 1 + pred x + | x == minBound = errorWithoutStackTrace "Prelude.Enum.pred{Int}: tried to take `pred' of minBound" + | otherwise = x - 1 + + toEnum x = x + fromEnum x = x + + {-# INLINE enumFrom #-} + enumFrom (I# x) = eftInt x maxInt# + where !(I# maxInt#) = maxInt + -- Blarg: technically I guess enumFrom isn't strict! + + {-# INLINE enumFromTo #-} + enumFromTo (I# x) (I# y) = eftInt x y + + {-# INLINE enumFromThen #-} + enumFromThen (I# x1) (I# x2) = efdInt x1 x2 + + {-# INLINE enumFromThenTo #-} + enumFromThenTo (I# x1) (I# x2) (I# y) = efdtInt x1 x2 y + + +----------------------------------------------------- +-- eftInt and eftIntFB deal with [a..b], which is the +-- most common form, so we take a lot of care +-- In particular, we have rules for deforestation + +{-# RULES +"eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) +"eftIntList" [1] eftIntFB (:) [] = eftInt + #-} + +{- Note [How the Enum rules work] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Phase 2: eftInt ---> build . eftIntFB +* Phase 1: inline build; eftIntFB (:) --> eftInt +* Phase 0: optionally inline eftInt +-} + +{-# NOINLINE [1] eftInt #-} +eftInt :: Int# -> Int# -> [Int] +-- [x1..x2] +eftInt x0 y | isTrue# (x0 ># y) = [] + | otherwise = go x0 + where + go x = I# x : if isTrue# (x ==# y) + then [] + else go (x +# 1#) + +{-# INLINE [0] eftIntFB #-} +eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r +eftIntFB c n x0 y | isTrue# (x0 ># y) = n + | otherwise = go x0 + where + go x = I# x `c` if isTrue# (x ==# y) + then n + else go (x +# 1#) + -- Watch out for y=maxBound; hence ==, not > + -- Be very careful not to have more than one "c" + -- so that when eftInfFB is inlined we can inline + -- whatever is bound to "c" + + +----------------------------------------------------- +-- efdInt and efdtInt deal with [a,b..] and [a,b..c]. +-- The code is more complicated because of worries about Int overflow. + +-- See Note [How the Enum rules work] +{-# RULES +"efdtInt" [~1] forall x1 x2 y. + efdtInt x1 x2 y = build (\ c n -> efdtIntFB c n x1 x2 y) +"efdtIntUpList" [1] efdtIntFB (:) [] = efdtInt + #-} + +efdInt :: Int# -> Int# -> [Int] +-- [x1,x2..maxInt] +efdInt x1 x2 + | isTrue# (x2 >=# x1) = case maxInt of I# y -> efdtIntUp x1 x2 y + | otherwise = case minInt of I# y -> efdtIntDn x1 x2 y + +{-# NOINLINE [1] efdtInt #-} +efdtInt :: Int# -> Int# -> Int# -> [Int] +-- [x1,x2..y] +efdtInt x1 x2 y + | isTrue# (x2 >=# x1) = efdtIntUp x1 x2 y + | otherwise = efdtIntDn x1 x2 y + +{-# INLINE [0] efdtIntFB #-} +efdtIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> Int# -> r +efdtIntFB c n x1 x2 y + | isTrue# (x2 >=# x1) = efdtIntUpFB c n x1 x2 y + | otherwise = efdtIntDnFB c n x1 x2 y + +-- Requires x2 >= x1 +efdtIntUp :: Int# -> Int# -> Int# -> [Int] +efdtIntUp x1 x2 y -- Be careful about overflow! + | isTrue# (y <# x2) = if isTrue# (y <# x1) then [] else [I# x1] + | otherwise = -- Common case: x1 <= x2 <= y + let !delta = x2 -# x1 -- >= 0 + !y' = y -# delta -- x1 <= y' <= y; hence y' is representable + + -- Invariant: x <= y + -- Note that: z <= y' => z + delta won't overflow + -- so we are guaranteed not to overflow if/when we recurse + go_up x | isTrue# (x ># y') = [I# x] + | otherwise = I# x : go_up (x +# delta) + in I# x1 : go_up x2 + +-- Requires x2 >= x1 +efdtIntUpFB :: (Int -> r -> r) -> r -> Int# -> Int# -> Int# -> r +efdtIntUpFB c n x1 x2 y -- Be careful about overflow! + | isTrue# (y <# x2) = if isTrue# (y <# x1) then n else I# x1 `c` n + | otherwise = -- Common case: x1 <= x2 <= y + let !delta = x2 -# x1 -- >= 0 + !y' = y -# delta -- x1 <= y' <= y; hence y' is representable + + -- Invariant: x <= y + -- Note that: z <= y' => z + delta won't overflow + -- so we are guaranteed not to overflow if/when we recurse + go_up x | isTrue# (x ># y') = I# x `c` n + | otherwise = I# x `c` go_up (x +# delta) + in I# x1 `c` go_up x2 + +-- Requires x2 <= x1 +efdtIntDn :: Int# -> Int# -> Int# -> [Int] +efdtIntDn x1 x2 y -- Be careful about underflow! + | isTrue# (y ># x2) = if isTrue# (y ># x1) then [] else [I# x1] + | otherwise = -- Common case: x1 >= x2 >= y + let !delta = x2 -# x1 -- <= 0 + !y' = y -# delta -- y <= y' <= x1; hence y' is representable + + -- Invariant: x >= y + -- Note that: z >= y' => z + delta won't underflow + -- so we are guaranteed not to underflow if/when we recurse + go_dn x | isTrue# (x <# y') = [I# x] + | otherwise = I# x : go_dn (x +# delta) + in I# x1 : go_dn x2 + +-- Requires x2 <= x1 +efdtIntDnFB :: (Int -> r -> r) -> r -> Int# -> Int# -> Int# -> r +efdtIntDnFB c n x1 x2 y -- Be careful about underflow! + | isTrue# (y ># x2) = if isTrue# (y ># x1) then n else I# x1 `c` n + | otherwise = -- Common case: x1 >= x2 >= y + let !delta = x2 -# x1 -- <= 0 + !y' = y -# delta -- y <= y' <= x1; hence y' is representable + + -- Invariant: x >= y + -- Note that: z >= y' => z + delta won't underflow + -- so we are guaranteed not to underflow if/when we recurse + go_dn x | isTrue# (x <# y') = I# x `c` n + | otherwise = I# x `c` go_dn (x +# delta) + in I# x1 `c` go_dn x2 + + +------------------------------------------------------------------------ +-- Word +------------------------------------------------------------------------ + +instance Bounded Word where + minBound = 0 + + -- use unboxed literals for maxBound, because GHC doesn't optimise + -- (fromInteger 0xffffffff :: Word). +#if WORD_SIZE_IN_BITS == 32 + maxBound = W# (int2Word# 0xFFFFFFFF#) +#elif WORD_SIZE_IN_BITS == 64 + maxBound = W# (int2Word# 0xFFFFFFFFFFFFFFFF#) +#else +#error Unhandled value for WORD_SIZE_IN_BITS +#endif + +instance Enum Word where + succ x + | x /= maxBound = x + 1 + | otherwise = succError "Word" + pred x + | x /= minBound = x - 1 + | otherwise = predError "Word" + toEnum i@(I# i#) + | i >= 0 = W# (int2Word# i#) + | otherwise = toEnumError "Word" i (minBound::Word, maxBound::Word) + fromEnum x@(W# x#) + | x <= maxIntWord = I# (word2Int# x#) + | otherwise = fromEnumError "Word" x + + enumFrom n = map integerToWordX [wordToIntegerX n .. wordToIntegerX (maxBound :: Word)] + enumFromTo n1 n2 = map integerToWordX [wordToIntegerX n1 .. wordToIntegerX n2] + enumFromThenTo n1 n2 m = map integerToWordX [wordToIntegerX n1, wordToIntegerX n2 .. wordToIntegerX m] + enumFromThen n1 n2 = map integerToWordX [wordToIntegerX n1, wordToIntegerX n2 .. wordToIntegerX limit] + where + limit :: Word + limit | n2 >= n1 = maxBound + | otherwise = minBound + +maxIntWord :: Word +-- The biggest word representable as an Int +maxIntWord = W# (case maxInt of I# i -> int2Word# i) + +-- For some reason integerToWord and wordToInteger (GHC.Integer.Type) +-- work over Word# +integerToWordX :: Integer -> Word +integerToWordX i = W# (integerToWord i) + +wordToIntegerX :: Word -> Integer +wordToIntegerX (W# x#) = wordToInteger x# + +------------------------------------------------------------------------ +-- Integer +------------------------------------------------------------------------ + +instance Enum Integer where + succ x = x + 1 + pred x = x - 1 + toEnum (I# n) = smallInteger n + fromEnum n = I# (integerToInt n) + + {-# INLINE enumFrom #-} + {-# INLINE enumFromThen #-} + {-# INLINE enumFromTo #-} + {-# INLINE enumFromThenTo #-} + enumFrom x = enumDeltaInteger x 1 + enumFromThen x y = enumDeltaInteger x (y-x) + enumFromTo x lim = enumDeltaToInteger x 1 lim + enumFromThenTo x y lim = enumDeltaToInteger x (y-x) lim + +-- See Note [How the Enum rules work] +{-# RULES +"enumDeltaInteger" [~1] forall x y. enumDeltaInteger x y = build (\c _ -> enumDeltaIntegerFB c x y) +"efdtInteger" [~1] forall x d l. enumDeltaToInteger x d l = build (\c n -> enumDeltaToIntegerFB c n x d l) +"efdtInteger1" [~1] forall x l. enumDeltaToInteger x 1 l = build (\c n -> enumDeltaToInteger1FB c n x l) + +"enumDeltaToInteger1FB" [1] forall c n x. enumDeltaToIntegerFB c n x 1 = enumDeltaToInteger1FB c n x + +"enumDeltaInteger" [1] enumDeltaIntegerFB (:) = enumDeltaInteger +"enumDeltaToInteger" [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger +"enumDeltaToInteger1" [1] enumDeltaToInteger1FB (:) [] = enumDeltaToInteger1 + #-} + +{- Note [Enum Integer rules for literal 1] +The "1" rules above specialise for the common case where delta = 1, +so that we can avoid the delta>=0 test in enumDeltaToIntegerFB. +Then enumDeltaToInteger1FB is nice and small and can be inlined, +which would allow the constructor to be inlined and good things to happen. + +We match on the literal "1" both in phase 2 (rule "efdtInteger1") and +phase 1 (rule "enumDeltaToInteger1FB"), just for belt and braces + +We do not do it for Int this way because hand-tuned code already exists, and +the special case varies more from the general case, due to the issue of overflows. +-} + +{-# NOINLINE [0] enumDeltaIntegerFB #-} +enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b +enumDeltaIntegerFB c x0 d = go x0 + where go x = x `seq` (x `c` go (x+d)) + +{-# NOINLINE [1] enumDeltaInteger #-} +enumDeltaInteger :: Integer -> Integer -> [Integer] +enumDeltaInteger x d = x `seq` (x : enumDeltaInteger (x+d) d) +-- strict accumulator, so +-- head (drop 1000000 [1 .. ] +-- works + +{-# NOINLINE [0] enumDeltaToIntegerFB #-} +-- Don't inline this until RULE "enumDeltaToInteger" has had a chance to fire +enumDeltaToIntegerFB :: (Integer -> a -> a) -> a + -> Integer -> Integer -> Integer -> a +enumDeltaToIntegerFB c n x delta lim + | delta >= 0 = up_fb c n x delta lim + | otherwise = dn_fb c n x delta lim + +{-# NOINLINE [0] enumDeltaToInteger1FB #-} +-- Don't inline this until RULE "enumDeltaToInteger" has had a chance to fire +enumDeltaToInteger1FB :: (Integer -> a -> a) -> a + -> Integer -> Integer -> a +enumDeltaToInteger1FB c n x0 lim = go (x0 :: Integer) + where + go x | x > lim = n + | otherwise = x `c` go (x+1) + +{-# NOINLINE [1] enumDeltaToInteger #-} +enumDeltaToInteger :: Integer -> Integer -> Integer -> [Integer] +enumDeltaToInteger x delta lim + | delta >= 0 = up_list x delta lim + | otherwise = dn_list x delta lim + +{-# NOINLINE [1] enumDeltaToInteger1 #-} +enumDeltaToInteger1 :: Integer -> Integer -> [Integer] +-- Special case for Delta = 1 +enumDeltaToInteger1 x0 lim = go (x0 :: Integer) + where + go x | x > lim = [] + | otherwise = x : go (x+1) + +up_fb :: (Integer -> a -> a) -> a -> Integer -> Integer -> Integer -> a +up_fb c n x0 delta lim = go (x0 :: Integer) + where + go x | x > lim = n + | otherwise = x `c` go (x+delta) +dn_fb :: (Integer -> a -> a) -> a -> Integer -> Integer -> Integer -> a +dn_fb c n x0 delta lim = go (x0 :: Integer) + where + go x | x < lim = n + | otherwise = x `c` go (x+delta) + +up_list :: Integer -> Integer -> Integer -> [Integer] +up_list x0 delta lim = go (x0 :: Integer) + where + go x | x > lim = [] + | otherwise = x : go (x+delta) +dn_list :: Integer -> Integer -> Integer -> [Integer] +dn_list x0 delta lim = go (x0 :: Integer) + where + go x | x < lim = [] + | otherwise = x : go (x+delta) diff --git a/libraries/base/GHC/Environment.hs b/libraries/base/GHC/Environment.hs new file mode 100644 index 0000000..97005eb --- /dev/null +++ b/libraries/base/GHC/Environment.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} + +module GHC.Environment (getFullArgs) where + +import Foreign +import Foreign.C +import GHC.Base +import GHC.Real ( fromIntegral ) + +#ifdef mingw32_HOST_OS +import GHC.IO (finally) +import GHC.Windows + +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif +#else +import GHC.IO.Encoding +import qualified GHC.Foreign as GHC +#endif + +-- | Computation 'getFullArgs' is the "raw" version of 'getArgs', similar +-- to @argv@ in other languages. It returns a list of the program's +-- command line arguments, starting with the program name, and +-- including those normally eaten by the RTS (+RTS ... -RTS). +getFullArgs :: IO [String] +#ifdef mingw32_HOST_OS +-- Ignore the arguments to hs_init on Windows for the sake of Unicode compat +getFullArgs = do + p_arg_string <- c_GetCommandLine + alloca $ \p_argc -> do + p_argv <- c_CommandLineToArgv p_arg_string p_argc + if p_argv == nullPtr + then throwGetLastError "getFullArgs" + else flip finally (c_LocalFree p_argv) $ do + argc <- peek p_argc + p_argvs <- peekArray (fromIntegral argc) p_argv + mapM peekCWString p_argvs + +foreign import WINDOWS_CCONV unsafe "windows.h GetCommandLineW" + c_GetCommandLine :: IO (Ptr CWString) + +foreign import WINDOWS_CCONV unsafe "windows.h CommandLineToArgvW" + c_CommandLineToArgv :: Ptr CWString -> Ptr CInt -> IO (Ptr CWString) + +foreign import WINDOWS_CCONV unsafe "Windows.h LocalFree" + c_LocalFree :: Ptr a -> IO (Ptr a) +#else +getFullArgs = + alloca $ \ p_argc -> + alloca $ \ p_argv -> do + getFullProgArgv p_argc p_argv + p <- fromIntegral `liftM` peek p_argc + argv <- peek p_argv + enc <- getFileSystemEncoding + peekArray p argv >>= mapM (GHC.peekCString enc) + +foreign import ccall unsafe "getFullProgArgv" + getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () +#endif diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs new file mode 100644 index 0000000..4231fce --- /dev/null +++ b/libraries/base/GHC/Err.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-} +{-# LANGUAGE RankNTypes, TypeInType #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Err +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@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.CString () +import GHC.Types (Char, RuntimeRep) +import GHC.Stack.Types +import GHC.Prim +import GHC.Integer () -- Make sure Integer is compiled first + -- because GHC depends on it in a wired-in way + -- so the build system doesn't see the dependency +import {-# SOURCE #-} GHC.Exception( errorCallWithCallStackException ) + +-- | 'error' stops execution and displays an error message. +error :: forall (r :: RuntimeRep). forall (a :: TYPE r). + HasCallStack => [Char] -> a +error s = raise# (errorCallWithCallStackException s ?callStack) + -- Bleh, we should be using 'GHC.Stack.callStack' instead of + -- '?callStack' here, but 'GHC.Stack.callStack' depends on + -- 'GHC.Stack.popCallStack', which is partial and depends on + -- 'error'.. Do as I say, not as I do. + +-- | A variant of 'error' that does not produce a stack trace. +-- +-- @since 4.9.0.0 +errorWithoutStackTrace :: forall (r :: RuntimeRep). forall (a :: TYPE r). + [Char] -> a +errorWithoutStackTrace s = + -- we don't have withFrozenCallStack yet, so we just inline the definition + let ?callStack = freezeCallStack emptyCallStack + in error s + + +-- Note [Errors in base] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- As of base-4.9.0.0, `error` produces a stack trace alongside the +-- error message using the HasCallStack machinery. This provides +-- a partial stack trace, containing the call-site of each function +-- with a HasCallStack constraint. +-- +-- In base, however, the only functions that have such constraints are +-- error and undefined, so the stack traces from partial functions in +-- base will never contain a call-site in user code. Instead we'll +-- usually just get the actual call to error. Base functions already +-- have a good habit of providing detailed error messages, including the +-- name of the offending partial function, so the partial stack-trace +-- does not provide any extra information, just noise. Thus, we export +-- the callstack-aware error, but within base we use the +-- errorWithoutStackTrace variant for more hygienic error messages. + + +-- | A special case of 'error'. +-- It is expected that compilers will recognize this and insert error +-- messages which are more appropriate to the context in which 'undefined' +-- appears. +undefined :: forall (r :: RuntimeRep). forall (a :: TYPE r). + HasCallStack => a +undefined = error "Prelude.undefined" + +-- | Used for compiler-generated error message; +-- encoding saves bytes of string junk. +absentErr :: a +absentErr = errorWithoutStackTrace "Oops! The program has entered an `absent' argument!\n" diff --git a/libraries/base/GHC/Event.hs b/libraries/base/GHC/Event.hs new file mode 100644 index 0000000..9f1d3df --- /dev/null +++ b/libraries/base/GHC/Event.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- ---------------------------------------------------------------------------- +-- | This module provides scalable event notification for file +-- descriptors and timeouts. +-- +-- This module should be considered GHC internal. +-- +-- ---------------------------------------------------------------------------- + +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.Event.Manager +import GHC.Event.TimerManager (TimeoutCallback, TimeoutKey, registerTimeout, + updateTimeout, unregisterTimeout, TimerManager) +import GHC.Event.Thread (getSystemEventManager, getSystemTimerManager) + diff --git a/libraries/base/GHC/Event/Arr.hs b/libraries/base/GHC/Event/Arr.hs new file mode 100644 index 0000000..c2ca8f9 --- /dev/null +++ b/libraries/base/GHC/Event/Arr.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-} + +module GHC.Event.Arr + ( + Arr(..) + , new + , size + , read + , write + ) where + +import GHC.Base (($)) +import GHC.Prim (MutableArray#, RealWorld, newArray#, readArray#, + sizeofMutableArray#, writeArray#) +import GHC.Types (IO(..), Int(..)) + +data Arr a = Arr (MutableArray# RealWorld a) + +new :: a -> Int -> IO (Arr a) +new defval (I# n#) = IO $ \s0# -> + case newArray# n# defval s0# of (# s1#, marr# #) -> (# s1#, Arr marr# #) + +size :: Arr a -> Int +size (Arr a) = I# (sizeofMutableArray# a) + +read :: Arr a -> Int -> IO a +read (Arr a) (I# n#) = IO $ \s0# -> + case readArray# a n# s0# of (# s1#, val #) -> (# s1#, val #) + +write :: Arr a -> Int -> a -> IO () +write (Arr a) (I# n#) val = IO $ \s0# -> + case writeArray# a n# val s0# of s1# -> (# s1#, () #) diff --git a/libraries/base/GHC/Event/Array.hs b/libraries/base/GHC/Event/Array.hs new file mode 100644 index 0000000..903f7c0 --- /dev/null +++ b/libraries/base/GHC/Event/Array.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns, CPP, NoImplicitPrelude #-} + +module GHC.Event.Array + ( + Array + , capacity + , clear + , concat + , copy + , duplicate + , empty + , ensureCapacity + , findIndex + , forM_ + , length + , loop + , new + , removeAt + , snoc + , unsafeLoad + , unsafeRead + , unsafeWrite + , useAsPtr + ) where + +import Data.Bits ((.|.), shiftR) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.Maybe +import Foreign.C.Types (CSize(..)) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, nullPtr, plusPtr) +import Foreign.Storable (Storable(..)) +import GHC.Base hiding (empty) +import GHC.ForeignPtr (mallocPlainForeignPtrBytes, newForeignPtr_) +import GHC.Num (Num(..)) +import GHC.Real (fromIntegral) +import GHC.Show (show) + +#include "MachDeps.h" + +#define BOUNDS_CHECKING 1 + +#if defined(BOUNDS_CHECKING) +-- This fugly hack is brought by GHC's apparent reluctance to deal +-- with MagicHash and UnboxedTuples when inferring types. Eek! +#define CHECK_BOUNDS(_func_,_len_,_k_) \ +if (_k_) < 0 || (_k_) >= (_len_) then errorWithoutStackTrace ("GHC.Event.Array." ++ (_func_) ++ ": bounds error, index " ++ show (_k_) ++ ", capacity " ++ show (_len_)) else +#else +#define CHECK_BOUNDS(_func_,_len_,_k_) +#endif + +-- Invariant: size <= capacity +newtype Array a = Array (IORef (AC a)) + +-- The actual array content. +data AC a = AC + !(ForeignPtr a) -- Elements + !Int -- Number of elements (length) + !Int -- Maximum number of elements (capacity) + +empty :: IO (Array a) +empty = do + p <- newForeignPtr_ nullPtr + Array `fmap` newIORef (AC p 0 0) + +allocArray :: Storable a => Int -> IO (ForeignPtr a) +allocArray n = allocHack undefined + where + allocHack :: Storable a => a -> IO (ForeignPtr a) + allocHack dummy = mallocPlainForeignPtrBytes (n * sizeOf dummy) + +reallocArray :: Storable a => ForeignPtr a -> Int -> Int -> IO (ForeignPtr a) +reallocArray p newSize oldSize = reallocHack undefined p + where + reallocHack :: Storable a => a -> ForeignPtr a -> IO (ForeignPtr a) + reallocHack dummy src = do + let size = sizeOf dummy + dst <- mallocPlainForeignPtrBytes (newSize * size) + withForeignPtr src $ \s -> + when (s /= nullPtr && oldSize > 0) . + withForeignPtr dst $ \d -> do + _ <- memcpy d s (fromIntegral (oldSize * size)) + return () + return dst + +new :: Storable a => Int -> IO (Array a) +new c = do + es <- allocArray cap + fmap Array (newIORef (AC es 0 cap)) + where + cap = firstPowerOf2 c + +duplicate :: Storable a => Array a -> IO (Array a) +duplicate a = dupHack undefined a + where + dupHack :: Storable b => b -> Array b -> IO (Array b) + dupHack dummy (Array ref) = do + AC es len cap <- readIORef ref + ary <- allocArray cap + withForeignPtr ary $ \dest -> + withForeignPtr es $ \src -> do + _ <- memcpy dest src (fromIntegral (len * sizeOf dummy)) + return () + Array `fmap` newIORef (AC ary len cap) + +length :: Array a -> IO Int +length (Array ref) = do + AC _ len _ <- readIORef ref + return len + +capacity :: Array a -> IO Int +capacity (Array ref) = do + AC _ _ cap <- readIORef ref + return cap + +unsafeRead :: Storable a => Array a -> Int -> IO a +unsafeRead (Array ref) ix = do + AC es _ cap <- readIORef ref + CHECK_BOUNDS("unsafeRead",cap,ix) + withForeignPtr es $ \p -> + peekElemOff p ix + +unsafeWrite :: Storable a => Array a -> Int -> a -> IO () +unsafeWrite (Array ref) ix a = do + ac <- readIORef ref + unsafeWrite' ac ix a + +unsafeWrite' :: Storable a => AC a -> Int -> a -> IO () +unsafeWrite' (AC es _ cap) ix a = do + CHECK_BOUNDS("unsafeWrite'",cap,ix) + withForeignPtr es $ \p -> + pokeElemOff p ix a + +unsafeLoad :: Array a -> (Ptr a -> Int -> IO Int) -> IO Int +unsafeLoad (Array ref) load = do + AC es _ cap <- readIORef ref + len' <- withForeignPtr es $ \p -> load p cap + writeIORef ref (AC es len' cap) + return len' + +ensureCapacity :: Storable a => Array a -> Int -> IO () +ensureCapacity (Array ref) c = do + ac@(AC _ _ cap) <- readIORef ref + ac'@(AC _ _ cap') <- ensureCapacity' ac c + when (cap' /= cap) $ + writeIORef ref ac' + +ensureCapacity' :: Storable a => AC a -> Int -> IO (AC a) +ensureCapacity' ac@(AC es len cap) c = do + if c > cap + then do + es' <- reallocArray es cap' cap + return (AC es' len cap') + else + return ac + where + cap' = firstPowerOf2 c + +useAsPtr :: Array a -> (Ptr a -> Int -> IO b) -> IO b +useAsPtr (Array ref) f = do + AC es len _ <- readIORef ref + withForeignPtr es $ \p -> f p len + +snoc :: Storable a => Array a -> a -> IO () +snoc (Array ref) e = do + ac@(AC _ len _) <- readIORef ref + let len' = len + 1 + ac'@(AC es _ cap) <- ensureCapacity' ac len' + unsafeWrite' ac' len e + writeIORef ref (AC es len' cap) + +clear :: Array a -> IO () +clear (Array ref) = do + atomicModifyIORef' ref $ \(AC es _ cap) -> + (AC es 0 cap, ()) + +forM_ :: Storable a => Array a -> (a -> IO ()) -> IO () +forM_ ary g = forHack ary g undefined + where + forHack :: Storable b => Array b -> (b -> IO ()) -> b -> IO () + forHack (Array ref) f dummy = do + AC es len _ <- readIORef ref + let size = sizeOf dummy + offset = len * size + withForeignPtr es $ \p -> do + let go n | n >= offset = return () + | otherwise = do + f =<< peek (p `plusPtr` n) + go (n + size) + go 0 + +loop :: Storable a => Array a -> b -> (b -> a -> IO (b,Bool)) -> IO () +loop ary z g = loopHack ary z g undefined + where + loopHack :: Storable b => Array b -> c -> (c -> b -> IO (c,Bool)) -> b + -> IO () + loopHack (Array ref) y f dummy = do + AC es len _ <- readIORef ref + let size = sizeOf dummy + offset = len * size + withForeignPtr es $ \p -> do + let go n k + | n >= offset = return () + | otherwise = do + (k',cont) <- f k =<< peek (p `plusPtr` n) + when cont $ go (n + size) k' + go 0 y + +findIndex :: Storable a => (a -> Bool) -> Array a -> IO (Maybe (Int,a)) +findIndex = findHack undefined + where + findHack :: Storable b => b -> (b -> Bool) -> Array b -> IO (Maybe (Int,b)) + findHack dummy p (Array ref) = do + AC es len _ <- readIORef ref + let size = sizeOf dummy + offset = len * size + withForeignPtr es $ \ptr -> + let go !n !i + | n >= offset = return Nothing + | otherwise = do + val <- peek (ptr `plusPtr` n) + if p val + then return $ Just (i, val) + else go (n + size) (i + 1) + in go 0 0 + +concat :: Storable a => Array a -> Array a -> IO () +concat (Array d) (Array s) = do + da@(AC _ dlen _) <- readIORef d + sa@(AC _ slen _) <- readIORef s + writeIORef d =<< copy' da dlen sa 0 slen + +-- | Copy part of the source array into the destination array. The +-- destination array is resized if not large enough. +copy :: Storable a => Array a -> Int -> Array a -> Int -> Int -> IO () +copy (Array d) dstart (Array s) sstart maxCount = do + da <- readIORef d + sa <- readIORef s + writeIORef d =<< copy' da dstart sa sstart maxCount + +-- | Copy part of the source array into the destination array. The +-- destination array is resized if not large enough. +copy' :: Storable a => AC a -> Int -> AC a -> Int -> Int -> IO (AC a) +copy' d dstart s sstart maxCount = copyHack d s undefined + where + copyHack :: Storable b => AC b -> AC b -> b -> IO (AC b) + copyHack dac@(AC _ oldLen _) (AC src slen _) dummy = do + when (maxCount < 0 || dstart < 0 || dstart > oldLen || sstart < 0 || + sstart > slen) $ errorWithoutStackTrace "copy: bad offsets or lengths" + let size = sizeOf dummy + count = min maxCount (slen - sstart) + if count == 0 + then return dac + else do + AC dst dlen dcap <- ensureCapacity' dac (dstart + count) + withForeignPtr dst $ \dptr -> + withForeignPtr src $ \sptr -> do + _ <- memcpy (dptr `plusPtr` (dstart * size)) + (sptr `plusPtr` (sstart * size)) + (fromIntegral (count * size)) + return $ AC dst (max dlen (dstart + count)) dcap + +removeAt :: Storable a => Array a -> Int -> IO () +removeAt a i = removeHack a undefined + where + removeHack :: Storable b => Array b -> b -> IO () + removeHack (Array ary) dummy = do + AC fp oldLen cap <- readIORef ary + when (i < 0 || i >= oldLen) $ errorWithoutStackTrace "removeAt: invalid index" + let size = sizeOf dummy + newLen = oldLen - 1 + when (newLen > 0 && i < newLen) . + withForeignPtr fp $ \ptr -> do + _ <- memmove (ptr `plusPtr` (size * i)) + (ptr `plusPtr` (size * (i+1))) + (fromIntegral (size * (newLen-i))) + return () + writeIORef ary (AC fp newLen cap) + +{-The firstPowerOf2 function works by setting all bits on the right-hand +side of the most significant flagged bit to 1, and then incrementing +the entire value at the end so it "rolls over" to the nearest power of +two. +-} + +-- | Computes the next-highest power of two for a particular integer, +-- @n@. If @n@ is already a power of two, returns @n@. If @n@ is +-- zero, returns zero, even though zero is not a power of two. +firstPowerOf2 :: Int -> Int +firstPowerOf2 !n = + let !n1 = n - 1 + !n2 = n1 .|. (n1 `shiftR` 1) + !n3 = n2 .|. (n2 `shiftR` 2) + !n4 = n3 .|. (n3 `shiftR` 4) + !n5 = n4 .|. (n4 `shiftR` 8) + !n6 = n5 .|. (n5 `shiftR` 16) +#if WORD_SIZE_IN_BITS == 32 + in n6 + 1 +#elif WORD_SIZE_IN_BITS == 64 + !n7 = n6 .|. (n6 `shiftR` 32) + in n7 + 1 +#else +# error firstPowerOf2 not defined on this architecture +#endif + +foreign import ccall unsafe "string.h memcpy" + memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) + +foreign import ccall unsafe "string.h memmove" + memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) + diff --git a/libraries/base/GHC/Event/Clock.hsc b/libraries/base/GHC/Event/Clock.hsc new file mode 100644 index 0000000..5dbdb67 --- /dev/null +++ b/libraries/base/GHC/Event/Clock.hsc @@ -0,0 +1,17 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Event.Clock (getMonotonicTime) where + +import GHC.Base +import GHC.Real +import Data.Word + +-- | Return monotonic time in seconds, since some unspecified starting point +getMonotonicTime :: IO Double +getMonotonicTime = do w <- getMonotonicNSec + return (fromIntegral w / 1000000000) + +foreign import ccall unsafe "getMonotonicNSec" + getMonotonicNSec :: IO Word64 + diff --git a/libraries/base/GHC/Event/Control.hs b/libraries/base/GHC/Event/Control.hs new file mode 100644 index 0000000..0b0f558 --- /dev/null +++ b/libraries/base/GHC/Event/Control.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , ScopedTypeVariables + , BangPatterns + #-} + +module GHC.Event.Control + ( + -- * Managing the IO manager + Signal + , ControlMessage(..) + , Control + , newControl + , closeControl + -- ** Control message reception + , readControlMessage + -- *** File descriptors + , controlReadFd + , controlWriteFd + , wakeupReadFd + -- ** Control message sending + , sendWakeup + , sendDie + -- * Utilities + , setNonBlockingFD + ) where + +#include "EventConfig.h" + +import Foreign.ForeignPtr (ForeignPtr) +import GHC.Base +import GHC.Conc.Signal (Signal) +import GHC.Real (fromIntegral) +import GHC.Show (Show) +import GHC.Word (Word8) +import Foreign.C.Error (throwErrnoIfMinus1_) +import Foreign.C.Types (CInt(..), CSize(..)) +import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr) +import Foreign.Marshal (alloca, allocaBytes) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr (castPtr) +import Foreign.Storable (peek, peekElemOff, poke) +import System.Posix.Internals (c_close, c_pipe, c_read, c_write, + setCloseOnExec, setNonBlockingFD) +import System.Posix.Types (Fd) + +#if defined(HAVE_EVENTFD) +import Foreign.C.Error (throwErrnoIfMinus1) +import Foreign.C.Types (CULLong(..)) +#else +import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno) +#endif + +data ControlMessage = CMsgWakeup + | CMsgDie + | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !Signal + deriving (Eq, Show) + +-- | The structure used to tell the IO manager thread what to do. +data Control = W { + controlReadFd :: {-# UNPACK #-} !Fd + , controlWriteFd :: {-# UNPACK #-} !Fd +#if defined(HAVE_EVENTFD) + , controlEventFd :: {-# UNPACK #-} !Fd +#else + , wakeupReadFd :: {-# UNPACK #-} !Fd + , wakeupWriteFd :: {-# UNPACK #-} !Fd +#endif + , didRegisterWakeupFd :: !Bool + } deriving (Show) + +#if defined(HAVE_EVENTFD) +wakeupReadFd :: Control -> Fd +wakeupReadFd = controlEventFd +{-# INLINE wakeupReadFd #-} +#endif + +-- | Create the structure (usually a pipe) used for waking up the IO +-- manager thread from another thread. +newControl :: Bool -> IO Control +newControl shouldRegister = allocaArray 2 $ \fds -> do + let createPipe = do + throwErrnoIfMinus1_ "pipe" $ c_pipe fds + rd <- peekElemOff fds 0 + wr <- peekElemOff fds 1 + -- The write end must be non-blocking, since we may need to + -- poke the event manager from a signal handler. + setNonBlockingFD wr True + setCloseOnExec rd + setCloseOnExec wr + return (rd, wr) + (ctrl_rd, ctrl_wr) <- createPipe +#if defined(HAVE_EVENTFD) + ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0 + setNonBlockingFD ev True + setCloseOnExec ev + when shouldRegister $ c_setIOManagerWakeupFd ev +#else + (wake_rd, wake_wr) <- createPipe + when shouldRegister $ c_setIOManagerWakeupFd wake_wr +#endif + return W { controlReadFd = fromIntegral ctrl_rd + , controlWriteFd = fromIntegral ctrl_wr +#if defined(HAVE_EVENTFD) + , controlEventFd = fromIntegral ev +#else + , wakeupReadFd = fromIntegral wake_rd + , wakeupWriteFd = fromIntegral wake_wr +#endif + , didRegisterWakeupFd = shouldRegister + } + +-- | Close the control structure used by the IO manager thread. +-- N.B. If this Control is the Control whose wakeup file was registered with +-- the RTS, then *BEFORE* the wakeup file is closed, we must call +-- c_setIOManagerWakeupFd (-1), so that the RTS does not try to use the wakeup +-- file after it has been closed. +closeControl :: Control -> IO () +closeControl w = do + _ <- c_close . fromIntegral . controlReadFd $ w + _ <- c_close . fromIntegral . controlWriteFd $ w + when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1) +#if defined(HAVE_EVENTFD) + _ <- c_close . fromIntegral . controlEventFd $ w +#else + _ <- c_close . fromIntegral . wakeupReadFd $ w + _ <- c_close . fromIntegral . wakeupWriteFd $ w +#endif + return () + +io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8 +io_MANAGER_WAKEUP = 0xff +io_MANAGER_DIE = 0xfe + +foreign import ccall "__hscore_sizeof_siginfo_t" + sizeof_siginfo_t :: CSize + +readControlMessage :: Control -> Fd -> IO ControlMessage +readControlMessage ctrl fd + | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do + throwErrnoIfMinus1_ "readWakeupMessage" $ + c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize) + return CMsgWakeup + | otherwise = + alloca $ \p -> do + throwErrnoIfMinus1_ "readControlMessage" $ + c_read (fromIntegral fd) p 1 + s <- peek p + case s of + -- Wakeup messages shouldn't be sent on the control + -- file descriptor but we handle them anyway. + _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup + _ | s == io_MANAGER_DIE -> return CMsgDie + _ -> do -- Signal + fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t) + withForeignPtr fp $ \p_siginfo -> do + r <- c_read (fromIntegral fd) (castPtr p_siginfo) + sizeof_siginfo_t + when (r /= fromIntegral sizeof_siginfo_t) $ + errorWithoutStackTrace "failed to read siginfo_t" + let !s' = fromIntegral s + return $ CMsgSignal fp s' + + where wakeupBufferSize = +#if defined(HAVE_EVENTFD) + 8 +#else + 4096 +#endif + +sendWakeup :: Control -> IO () +#if defined(HAVE_EVENTFD) +sendWakeup c = + throwErrnoIfMinus1_ "sendWakeup" $ + c_eventfd_write (fromIntegral (controlEventFd c)) 1 +#else +sendWakeup c = do + n <- sendMessage (wakeupWriteFd c) CMsgWakeup + case n of + _ | n /= -1 -> return () + | otherwise -> do + errno <- getErrno + when (errno /= eAGAIN && errno /= eWOULDBLOCK) $ + throwErrno "sendWakeup" +#endif + +sendDie :: Control -> IO () +sendDie c = throwErrnoIfMinus1_ "sendDie" $ + sendMessage (controlWriteFd c) CMsgDie + +sendMessage :: Fd -> ControlMessage -> IO Int +sendMessage fd msg = alloca $ \p -> do + case msg of + CMsgWakeup -> poke p io_MANAGER_WAKEUP + CMsgDie -> poke p io_MANAGER_DIE + CMsgSignal _fp _s -> errorWithoutStackTrace "Signals can only be sent from within the RTS" + fromIntegral `fmap` c_write (fromIntegral fd) p 1 + +#if defined(HAVE_EVENTFD) +foreign import ccall unsafe "sys/eventfd.h eventfd" + c_eventfd :: CInt -> CInt -> IO CInt + +foreign import ccall unsafe "sys/eventfd.h eventfd_write" + c_eventfd_write :: CInt -> CULLong -> IO CInt +#endif + +foreign import ccall unsafe "setIOManagerWakeupFd" + c_setIOManagerWakeupFd :: CInt -> IO () diff --git a/libraries/base/GHC/Event/EPoll.hsc b/libraries/base/GHC/Event/EPoll.hsc new file mode 100644 index 0000000..26b6861 --- /dev/null +++ b/libraries/base/GHC/Event/EPoll.hsc @@ -0,0 +1,239 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE GeneralizedNewtypeDeriving + , NoImplicitPrelude + , BangPatterns + #-} + +----------------------------------------------------------------------------- +-- | +-- A binding to the epoll I/O event notification facility +-- +-- epoll is a variant of poll that can be used either as an edge-triggered or +-- a level-triggered interface and scales well to large numbers of watched file +-- descriptors. +-- +-- epoll decouples monitor an fd from the process of registering it. +-- +----------------------------------------------------------------------------- + +module GHC.Event.EPoll + ( + new + , available + ) where + +import qualified GHC.Event.Internal as E + +#include "EventConfig.h" +#if !defined(HAVE_EPOLL) +import GHC.Base + +new :: IO E.Backend +new = errorWithoutStackTrace "EPoll back end not implemented for this platform" + +available :: Bool +available = False +{-# INLINE available #-} +#else + +#include + +import Data.Bits (Bits, FiniteBits, (.|.), (.&.)) +import Data.Word (Word32) +import Foreign.C.Error (eNOENT, getErrno, throwErrno, + throwErrnoIfMinus1, throwErrnoIfMinus1_) +import Foreign.C.Types (CInt(..)) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) +import GHC.Base +import GHC.Num (Num(..)) +import GHC.Real (ceiling, fromIntegral) +import GHC.Show (Show) +import System.Posix.Internals (c_close) +import System.Posix.Internals (setCloseOnExec) +import System.Posix.Types (Fd(..)) + +import qualified GHC.Event.Array as A +import GHC.Event.Internal (Timeout(..)) + +available :: Bool +available = True +{-# INLINE available #-} + +data EPoll = EPoll { + epollFd :: {-# UNPACK #-} !EPollFd + , epollEvents :: {-# UNPACK #-} !(A.Array Event) + } + +-- | Create a new epoll backend. +new :: IO E.Backend +new = do + epfd <- epollCreate + evts <- A.new 64 + let !be = E.backend poll modifyFd modifyFdOnce delete (EPoll epfd evts) + return be + +delete :: EPoll -> IO () +delete be = do + _ <- c_close . fromEPollFd . epollFd $ be + return () + +-- | Change the set of events we are interested in for a given file +-- descriptor. +modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO Bool +modifyFd ep fd oevt nevt = + with (Event (fromEvent nevt) fd) $ \evptr -> do + epollControl (epollFd ep) op fd evptr + return True + where op | oevt == mempty = controlOpAdd + | nevt == mempty = controlOpDelete + | otherwise = controlOpModify + +modifyFdOnce :: EPoll -> Fd -> E.Event -> IO Bool +modifyFdOnce ep fd evt = + do let !ev = fromEvent evt .|. epollOneShot + res <- with (Event ev fd) $ + epollControl_ (epollFd ep) controlOpModify fd + if res == 0 + then return True + else do err <- getErrno + if err == eNOENT + then with (Event ev fd) $ \evptr -> do + epollControl (epollFd ep) controlOpAdd fd evptr + return True + else throwErrno "modifyFdOnce" + +-- | Select a set of file descriptors which are ready for I/O +-- operations and call @f@ for all ready file descriptors, passing the +-- events that are ready. +poll :: EPoll -- ^ state + -> Maybe Timeout -- ^ timeout in milliseconds + -> (Fd -> E.Event -> IO ()) -- ^ I/O callback + -> IO Int +poll ep mtimeout f = do + let events = epollEvents ep + fd = epollFd ep + + -- Will return zero if the system call was interrupted, in which case + -- we just return (and try again later.) + n <- A.unsafeLoad events $ \es cap -> case mtimeout of + Just timeout -> epollWait fd es cap $ fromTimeout timeout + Nothing -> epollWaitNonBlock fd es cap + + when (n > 0) $ do + A.forM_ events $ \e -> f (eventFd e) (toEvent (eventTypes e)) + cap <- A.capacity events + when (cap == n) $ A.ensureCapacity events (2 * cap) + return n + +newtype EPollFd = EPollFd { + fromEPollFd :: CInt + } deriving (Eq, Show) + +data Event = Event { + eventTypes :: EventType + , eventFd :: Fd + } deriving (Show) + +instance Storable Event where + sizeOf _ = #size struct epoll_event + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + ets <- #{peek struct epoll_event, events} ptr + ed <- #{peek struct epoll_event, data.fd} ptr + let !ev = Event (EventType ets) ed + return ev + + poke ptr e = do + #{poke struct epoll_event, events} ptr (unEventType $ eventTypes e) + #{poke struct epoll_event, data.fd} ptr (eventFd e) + +newtype ControlOp = ControlOp CInt + +#{enum ControlOp, ControlOp + , controlOpAdd = EPOLL_CTL_ADD + , controlOpModify = EPOLL_CTL_MOD + , controlOpDelete = EPOLL_CTL_DEL + } + +newtype EventType = EventType { + unEventType :: Word32 + } deriving (Show, Eq, Num, Bits, FiniteBits) + +#{enum EventType, EventType + , epollIn = EPOLLIN + , epollOut = EPOLLOUT + , epollErr = EPOLLERR + , epollHup = EPOLLHUP + , epollOneShot = EPOLLONESHOT + } + +-- | Create a new epoll context, returning a file descriptor associated with the context. +-- The fd may be used for subsequent calls to this epoll context. +-- +-- The size parameter to epoll_create is a hint about the expected number of handles. +-- +-- The file descriptor returned from epoll_create() should be destroyed via +-- a call to close() after polling is finished +-- +epollCreate :: IO EPollFd +epollCreate = do + fd <- throwErrnoIfMinus1 "epollCreate" $ + c_epoll_create 256 -- argument is ignored + setCloseOnExec fd + let !epollFd' = EPollFd fd + return epollFd' + +epollControl :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO () +epollControl epfd op fd event = + throwErrnoIfMinus1_ "epollControl" $ epollControl_ epfd op fd event + +epollControl_ :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO CInt +epollControl_ (EPollFd epfd) (ControlOp op) (Fd fd) event = + c_epoll_ctl epfd op fd event + +epollWait :: EPollFd -> Ptr Event -> Int -> Int -> IO Int +epollWait (EPollFd epfd) events numEvents timeout = + fmap fromIntegral . + E.throwErrnoIfMinus1NoRetry "epollWait" $ + c_epoll_wait epfd events (fromIntegral numEvents) (fromIntegral timeout) + +epollWaitNonBlock :: EPollFd -> Ptr Event -> Int -> IO Int +epollWaitNonBlock (EPollFd epfd) events numEvents = + fmap fromIntegral . + E.throwErrnoIfMinus1NoRetry "epollWaitNonBlock" $ + c_epoll_wait_unsafe epfd events (fromIntegral numEvents) 0 + +fromEvent :: E.Event -> EventType +fromEvent e = remap E.evtRead epollIn .|. + remap E.evtWrite epollOut + where remap evt to + | e `E.eventIs` evt = to + | otherwise = 0 + +toEvent :: EventType -> E.Event +toEvent e = remap (epollIn .|. epollErr .|. epollHup) E.evtRead `mappend` + remap (epollOut .|. epollErr .|. epollHup) E.evtWrite + where remap evt to + | e .&. evt /= 0 = to + | otherwise = mempty + +fromTimeout :: Timeout -> Int +fromTimeout Forever = -1 +fromTimeout (Timeout s) = ceiling $ 1000 * s + +foreign import ccall unsafe "sys/epoll.h epoll_create" + c_epoll_create :: CInt -> IO CInt + +foreign import ccall unsafe "sys/epoll.h epoll_ctl" + c_epoll_ctl :: CInt -> CInt -> CInt -> Ptr Event -> IO CInt + +foreign import ccall safe "sys/epoll.h epoll_wait" + c_epoll_wait :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt + +foreign import ccall unsafe "sys/epoll.h epoll_wait" + c_epoll_wait_unsafe :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt +#endif /* defined(HAVE_EPOLL) */ + diff --git a/libraries/base/GHC/Event/IntTable.hs b/libraries/base/GHC/Event/IntTable.hs new file mode 100644 index 0000000..7ae2e1a --- /dev/null +++ b/libraries/base/GHC/Event/IntTable.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns, NoImplicitPrelude, RecordWildCards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module GHC.Event.IntTable + ( + IntTable + , new + , lookup + , insertWith + , reset + , delete + , updateWith + ) where + +import Data.Bits ((.&.), shiftL, shiftR) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Maybe (Maybe(..), isJust) +import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr, withForeignPtr) +import Foreign.Storable (peek, poke) +import GHC.Base (Monad(..), (=<<), ($), ($!), const, liftM, otherwise, when) +import GHC.Classes (Eq(..), Ord(..)) +import GHC.Event.Arr (Arr) +import GHC.Num (Num(..)) +import GHC.Prim (seq) +import GHC.Types (Bool(..), IO(..), Int(..)) +import qualified GHC.Event.Arr as Arr + +-- A very simple chained integer-keyed mutable hash table. We use +-- power-of-two sizing, grow at a load factor of 0.75, and never +-- shrink. The "hash function" is the identity function. + +newtype IntTable a = IntTable (IORef (IT a)) + +data IT a = IT { + tabArr :: {-# UNPACK #-} !(Arr (Bucket a)) + , tabSize :: {-# UNPACK #-} !(ForeignPtr Int) + } + +data Bucket a = Empty + | Bucket { + bucketKey :: {-# UNPACK #-} !Int + , bucketValue :: a + , bucketNext :: Bucket a + } + +lookup :: Int -> IntTable a -> IO (Maybe a) +lookup k (IntTable ref) = do + let go Bucket{..} + | bucketKey == k = Just bucketValue + | otherwise = go bucketNext + go _ = Nothing + it@IT{..} <- readIORef ref + bkt <- Arr.read tabArr (indexOf k it) + return $! go bkt + +new :: Int -> IO (IntTable a) +new capacity = IntTable `liftM` (newIORef =<< new_ capacity) + +new_ :: Int -> IO (IT a) +new_ capacity = do + arr <- Arr.new Empty capacity + size <- mallocForeignPtr + withForeignPtr size $ \ptr -> poke ptr 0 + return IT { tabArr = arr + , tabSize = size + } + +grow :: IT a -> IORef (IT a) -> Int -> IO () +grow oldit ref size = do + newit <- new_ (Arr.size (tabArr oldit) `shiftL` 1) + let copySlot n !i + | n == size = return () + | otherwise = do + let copyBucket !m Empty = copySlot m (i+1) + copyBucket m bkt@Bucket{..} = do + let idx = indexOf bucketKey newit + next <- Arr.read (tabArr newit) idx + Arr.write (tabArr newit) idx bkt { bucketNext = next } + copyBucket (m+1) bucketNext + copyBucket n =<< Arr.read (tabArr oldit) i + copySlot 0 0 + withForeignPtr (tabSize newit) $ \ptr -> poke ptr size + writeIORef ref newit + +-- | @insertWith f k v table@ inserts @k@ into @table@ with value @v@. +-- If @k@ already appears in @table@ with value @v0@, the value is updated +-- to @f v0 v@ and @Just v0@ is returned. +insertWith :: (a -> a -> a) -> Int -> a -> IntTable a -> IO (Maybe a) +insertWith f k v inttable@(IntTable ref) = do + it@IT{..} <- readIORef ref + let idx = indexOf k it + go seen bkt@Bucket{..} + | bucketKey == k = do + let !v' = f v bucketValue + !next = seen <> bucketNext + Empty <> bs = bs + b@Bucket{..} <> bs = b { bucketNext = bucketNext <> bs } + Arr.write tabArr idx (Bucket k v' next) + return (Just bucketValue) + | otherwise = go bkt { bucketNext = seen } bucketNext + go seen _ = withForeignPtr tabSize $ \ptr -> do + size <- peek ptr + if size + 1 >= Arr.size tabArr - (Arr.size tabArr `shiftR` 2) + then grow it ref size >> insertWith f k v inttable + else do + v `seq` Arr.write tabArr idx (Bucket k v seen) + poke ptr (size + 1) + return Nothing + go Empty =<< Arr.read tabArr idx +{-# INLINABLE insertWith #-} + +-- | Used to undo the effect of a prior insertWith. +reset :: Int -> Maybe a -> IntTable a -> IO () +reset k (Just v) tbl = insertWith const k v tbl >> return () +reset k Nothing tbl = delete k tbl >> return () + +indexOf :: Int -> IT a -> Int +indexOf k IT{..} = k .&. (Arr.size tabArr - 1) + +-- | Remove the given key from the table and return its associated value. +delete :: Int -> IntTable a -> IO (Maybe a) +delete k t = updateWith (const Nothing) k t + +updateWith :: (a -> Maybe a) -> Int -> IntTable a -> IO (Maybe a) +updateWith f k (IntTable ref) = do + it@IT{..} <- readIORef ref + let idx = indexOf k it + go bkt@Bucket{..} + | bucketKey == k = case f bucketValue of + Just val -> let !nb = bkt { bucketValue = val } + in (False, Just bucketValue, nb) + Nothing -> (True, Just bucketValue, bucketNext) + | otherwise = case go bucketNext of + (fbv, ov, nb) -> (fbv, ov, bkt { bucketNext = nb }) + go e = (False, Nothing, e) + (del, oldVal, newBucket) <- go `liftM` Arr.read tabArr idx + when (isJust oldVal) $ do + Arr.write tabArr idx newBucket + when del $ + withForeignPtr tabSize $ \ptr -> do + size <- peek ptr + poke ptr (size - 1) + return oldVal diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs new file mode 100644 index 0000000..a093352 --- /dev/null +++ b/libraries/base/GHC/Event/Internal.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-} + +module GHC.Event.Internal + ( + -- * Event back end + Backend + , backend + , delete + , poll + , modifyFd + , modifyFdOnce + -- * Event type + , Event + , evtRead + , evtWrite + , evtClose + , eventIs + -- * Lifetimes + , Lifetime(..) + , EventLifetime + , eventLifetime + , elLifetime + , elEvent + -- * Timeout type + , Timeout(..) + -- * Helpers + , throwErrnoIfMinus1NoRetry + ) where + +import Data.Bits ((.|.), (.&.)) +import Data.OldList (foldl', filter, intercalate, null) +import Foreign.C.Error (eINTR, getErrno, throwErrno) +import System.Posix.Types (Fd) +import GHC.Base +import GHC.Num (Num(..)) +import GHC.Show (Show(..)) + +-- | An I\/O event. +newtype Event = Event Int + deriving (Eq) + +evtNothing :: Event +evtNothing = Event 0 +{-# INLINE evtNothing #-} + +-- | Data is available to be read. +evtRead :: Event +evtRead = Event 1 +{-# INLINE evtRead #-} + +-- | The file descriptor is ready to accept a write. +evtWrite :: Event +evtWrite = Event 2 +{-# INLINE evtWrite #-} + +-- | Another thread closed the file descriptor. +evtClose :: Event +evtClose = Event 4 +{-# INLINE evtClose #-} + +eventIs :: Event -> Event -> Bool +eventIs (Event a) (Event b) = a .&. b /= 0 + +instance Show Event where + show e = '[' : (intercalate "," . filter (not . null) $ + [evtRead `so` "evtRead", + evtWrite `so` "evtWrite", + evtClose `so` "evtClose"]) ++ "]" + where ev `so` disp | e `eventIs` ev = disp + | otherwise = "" + +instance Monoid Event where + mempty = evtNothing + mappend = evtCombine + mconcat = evtConcat + +evtCombine :: Event -> Event -> Event +evtCombine (Event a) (Event b) = Event (a .|. b) +{-# INLINE evtCombine #-} + +evtConcat :: [Event] -> Event +evtConcat = foldl' evtCombine evtNothing +{-# INLINE evtConcat #-} + +-- | The lifetime of an event registration. +-- +-- @since 4.8.1.0 +data Lifetime = OneShot -- ^ the registration will be active for only one + -- event + | MultiShot -- ^ the registration will trigger multiple times + deriving (Show, Eq) + +-- | The longer of two lifetimes. +elSupremum :: Lifetime -> Lifetime -> Lifetime +elSupremum OneShot OneShot = OneShot +elSupremum _ _ = MultiShot +{-# INLINE elSupremum #-} + +-- | @mappend@ == @elSupremum@ +instance Monoid Lifetime where + mempty = OneShot + mappend = elSupremum + +-- | A pair of an event and lifetime +-- +-- Here we encode the event in the bottom three bits and the lifetime +-- in the fourth bit. +newtype EventLifetime = EL Int + deriving (Show, Eq) + +instance Monoid EventLifetime where + mempty = EL 0 + EL a `mappend` EL b = EL (a .|. b) + +eventLifetime :: Event -> Lifetime -> EventLifetime +eventLifetime (Event e) l = EL (e .|. lifetimeBit l) + where + lifetimeBit OneShot = 0 + lifetimeBit MultiShot = 8 +{-# INLINE eventLifetime #-} + +elLifetime :: EventLifetime -> Lifetime +elLifetime (EL x) = if x .&. 8 == 0 then OneShot else MultiShot +{-# INLINE elLifetime #-} + +elEvent :: EventLifetime -> Event +elEvent (EL x) = Event (x .&. 0x7) +{-# INLINE elEvent #-} + +-- | A type alias for timeouts, specified in seconds. +data Timeout = Timeout {-# UNPACK #-} !Double + | Forever + deriving (Show) + +-- | Event notification backend. +data Backend = forall a. Backend { + _beState :: !a + + -- | Poll backend for new events. The provided callback is called + -- once per file descriptor with new events. + , _bePoll :: a -- backend state + -> Maybe Timeout -- timeout in milliseconds ('Nothing' for non-blocking poll) + -> (Fd -> Event -> IO ()) -- I/O callback + -> IO Int + + -- | Register, modify, or unregister interest in the given events + -- on the given file descriptor. + , _beModifyFd :: a + -> Fd -- file descriptor + -> Event -- old events to watch for ('mempty' for new) + -> Event -- new events to watch for ('mempty' to delete) + -> IO Bool + + -- | Register interest in new events on a given file descriptor, set + -- to be deactivated after the first event. + , _beModifyFdOnce :: a + -> Fd -- file descriptor + -> Event -- new events to watch + -> IO Bool + + , _beDelete :: a -> IO () + } + +backend :: (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int) + -> (a -> Fd -> Event -> Event -> IO Bool) + -> (a -> Fd -> Event -> IO Bool) + -> (a -> IO ()) + -> a + -> Backend +backend bPoll bModifyFd bModifyFdOnce bDelete state = + Backend state bPoll bModifyFd bModifyFdOnce bDelete +{-# INLINE backend #-} + +poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int +poll (Backend bState bPoll _ _ _) = bPoll bState +{-# INLINE poll #-} + +-- | Returns 'True' if the modification succeeded. +-- Returns 'False' if this backend does not support +-- event notifications on this type of file. +modifyFd :: Backend -> Fd -> Event -> Event -> IO Bool +modifyFd (Backend bState _ bModifyFd _ _) = bModifyFd bState +{-# INLINE modifyFd #-} + +-- | Returns 'True' if the modification succeeded. +-- Returns 'False' if this backend does not support +-- event notifications on this type of file. +modifyFdOnce :: Backend -> Fd -> Event -> IO Bool +modifyFdOnce (Backend bState _ _ bModifyFdOnce _) = bModifyFdOnce bState +{-# INLINE modifyFdOnce #-} + +delete :: Backend -> IO () +delete (Backend bState _ _ _ bDelete) = bDelete bState +{-# INLINE delete #-} + +-- | Throw an 'IOError' corresponding to the current value of +-- 'getErrno' if the result value of the 'IO' action is -1 and +-- 'getErrno' is not 'eINTR'. If the result value is -1 and +-- 'getErrno' returns 'eINTR' 0 is returned. Otherwise the result +-- value is returned. +throwErrnoIfMinus1NoRetry :: (Eq a, Num a) => String -> IO a -> IO a +throwErrnoIfMinus1NoRetry loc f = do + res <- f + if res == -1 + then do + err <- getErrno + if err == eINTR then return 0 else throwErrno loc + else return res diff --git a/libraries/base/GHC/Event/KQueue.hsc b/libraries/base/GHC/Event/KQueue.hsc new file mode 100644 index 0000000..1068ec0 --- /dev/null +++ b/libraries/base/GHC/Event/KQueue.hsc @@ -0,0 +1,294 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CApiFFI + , GeneralizedNewtypeDeriving + , NoImplicitPrelude + , RecordWildCards + , BangPatterns + #-} + +module GHC.Event.KQueue + ( + new + , available + ) where + +import qualified GHC.Event.Internal as E + +#include "EventConfig.h" +#if !defined(HAVE_KQUEUE) +import GHC.Base + +new :: IO E.Backend +new = errorWithoutStackTrace "KQueue back end not implemented for this platform" + +available :: Bool +available = False +{-# INLINE available #-} +#else + +import Data.Bits (Bits(..), FiniteBits(..)) +import Data.Word (Word16, Word32) +import Foreign.C.Error (throwErrnoIfMinus1, eINTR, eINVAL, + eNOTSUP, getErrno, throwErrno) +import Foreign.C.Types +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (Storable(..)) +import GHC.Base +import GHC.Enum (toEnum) +import GHC.Num (Num(..)) +import GHC.Real (ceiling, floor, fromIntegral) +import GHC.Show (Show(show)) +import GHC.Event.Internal (Timeout(..)) +import System.Posix.Internals (c_close) +import System.Posix.Types (Fd(..)) +import qualified GHC.Event.Array as A + +#if defined(netbsd_HOST_OS) +import Data.Int (Int64) +#endif + +#include +#include +#include + +-- Handle brokenness on some BSD variants, notably OS X up to at least +-- 10.6. If NOTE_EOF isn't available, we have no way to receive a +-- notification from the kernel when we reach EOF on a plain file. +#ifndef NOTE_EOF +# define NOTE_EOF 0 +#endif + +available :: Bool +available = True +{-# INLINE available #-} + +------------------------------------------------------------------------ +-- Exported interface + +data KQueue = KQueue { + kqueueFd :: {-# UNPACK #-} !KQueueFd + , kqueueEvents :: {-# UNPACK #-} !(A.Array Event) + } + +new :: IO E.Backend +new = do + kqfd <- kqueue + events <- A.new 64 + let !be = E.backend poll modifyFd modifyFdOnce delete (KQueue kqfd events) + return be + +delete :: KQueue -> IO () +delete kq = do + _ <- c_close . fromKQueueFd . kqueueFd $ kq + return () + +modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO Bool +modifyFd kq fd oevt nevt + | nevt == mempty = do + let !ev = event fd (toFilter oevt) flagDelete noteEOF + kqueueControl (kqueueFd kq) ev + | otherwise = do + let !ev = event fd (toFilter nevt) flagAdd noteEOF + kqueueControl (kqueueFd kq) ev + +toFilter :: E.Event -> Filter +toFilter evt + | evt `E.eventIs` E.evtRead = filterRead + | otherwise = filterWrite + +modifyFdOnce :: KQueue -> Fd -> E.Event -> IO Bool +modifyFdOnce kq fd evt = do + let !ev = event fd (toFilter evt) (flagAdd .|. flagOneshot) noteEOF + kqueueControl (kqueueFd kq) ev + +poll :: KQueue + -> Maybe Timeout + -> (Fd -> E.Event -> IO ()) + -> IO Int +poll kq mtimeout f = do + let events = kqueueEvents kq + fd = kqueueFd kq + + n <- A.unsafeLoad events $ \es cap -> case mtimeout of + Just timeout -> kqueueWait fd es cap $ fromTimeout timeout + Nothing -> kqueueWaitNonBlock fd es cap + + when (n > 0) $ do + A.forM_ events $ \e -> f (fromIntegral (ident e)) (toEvent (filter e)) + cap <- A.capacity events + when (n == cap) $ A.ensureCapacity events (2 * cap) + return n +------------------------------------------------------------------------ +-- FFI binding + +newtype KQueueFd = KQueueFd { + fromKQueueFd :: CInt + } deriving (Eq, Show) + +data Event = KEvent { + ident :: {-# UNPACK #-} !CUIntPtr + , filter :: {-# UNPACK #-} !Filter + , flags :: {-# UNPACK #-} !Flag + , fflags :: {-# UNPACK #-} !FFlag +#ifdef netbsd_HOST_OS + , data_ :: {-# UNPACK #-} !Int64 +#else + , data_ :: {-# UNPACK #-} !CIntPtr +#endif + , udata :: {-# UNPACK #-} !(Ptr ()) + } deriving Show + +event :: Fd -> Filter -> Flag -> FFlag -> Event +event fd filt flag fflag = KEvent (fromIntegral fd) filt flag fflag 0 nullPtr + +instance Storable Event where + sizeOf _ = #size struct kevent + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + ident' <- #{peek struct kevent, ident} ptr + filter' <- #{peek struct kevent, filter} ptr + flags' <- #{peek struct kevent, flags} ptr + fflags' <- #{peek struct kevent, fflags} ptr + data' <- #{peek struct kevent, data} ptr + udata' <- #{peek struct kevent, udata} ptr + let !ev = KEvent ident' (Filter filter') (Flag flags') fflags' data' + udata' + return ev + + poke ptr ev = do + #{poke struct kevent, ident} ptr (ident ev) + #{poke struct kevent, filter} ptr (filter ev) + #{poke struct kevent, flags} ptr (flags ev) + #{poke struct kevent, fflags} ptr (fflags ev) + #{poke struct kevent, data} ptr (data_ ev) + #{poke struct kevent, udata} ptr (udata ev) + +newtype FFlag = FFlag Word32 + deriving (Eq, Show, Storable) + +#{enum FFlag, FFlag + , noteEOF = NOTE_EOF + } + +#if SIZEOF_KEV_FLAGS == 4 /* kevent.flag: uint32_t or uint16_t. */ +newtype Flag = Flag Word32 +#else +newtype Flag = Flag Word16 +#endif + deriving (Bits, FiniteBits, Eq, Num, Show, Storable) + +#{enum Flag, Flag + , flagAdd = EV_ADD + , flagDelete = EV_DELETE + , flagOneshot = EV_ONESHOT + } + +#if SIZEOF_KEV_FILTER == 4 /*kevent.filter: uint32_t or uint16_t. */ +newtype Filter = Filter Word32 +#else +newtype Filter = Filter Word16 +#endif + deriving (Bits, FiniteBits, Eq, Num, Show, Storable) + +filterRead :: Filter +filterRead = Filter (#const EVFILT_READ) +filterWrite :: Filter +filterWrite = Filter (#const EVFILT_WRITE) + +data TimeSpec = TimeSpec { + tv_sec :: {-# UNPACK #-} !CTime + , tv_nsec :: {-# UNPACK #-} !CLong + } + +instance Storable TimeSpec where + sizeOf _ = #size struct timespec + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + tv_sec' <- #{peek struct timespec, tv_sec} ptr + tv_nsec' <- #{peek struct timespec, tv_nsec} ptr + let !ts = TimeSpec tv_sec' tv_nsec' + return ts + + poke ptr ts = do + #{poke struct timespec, tv_sec} ptr (tv_sec ts) + #{poke struct timespec, tv_nsec} ptr (tv_nsec ts) + +kqueue :: IO KQueueFd +kqueue = KQueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue + +kqueueControl :: KQueueFd -> Event -> IO Bool +kqueueControl kfd ev = + withTimeSpec (TimeSpec 0 0) $ \tp -> + withEvent ev $ \evp -> do + res <- kevent False kfd evp 1 nullPtr 0 tp + if res == -1 + then do + err <- getErrno + case err of + _ | err == eINTR -> return True + _ | err == eINVAL -> return False + _ | err == eNOTSUP -> return False + _ -> throwErrno "kevent" + else return True + +kqueueWait :: KQueueFd -> Ptr Event -> Int -> TimeSpec -> IO Int +kqueueWait fd es cap tm = + fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $ + withTimeSpec tm $ kevent True fd nullPtr 0 es cap + +kqueueWaitNonBlock :: KQueueFd -> Ptr Event -> Int -> IO Int +kqueueWaitNonBlock fd es cap = + fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $ + withTimeSpec (TimeSpec 0 0) $ kevent False fd nullPtr 0 es cap + +-- TODO: We cannot retry on EINTR as the timeout would be wrong. +-- Perhaps we should just return without calling any callbacks. +kevent :: Bool -> KQueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec + -> IO CInt +kevent safe k chs chlen evs evlen ts + | safe = c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts + | otherwise = c_kevent_unsafe k chs (fromIntegral chlen) evs (fromIntegral evlen) ts + +withEvent :: Event -> (Ptr Event -> IO a) -> IO a +withEvent ev f = alloca $ \ptr -> poke ptr ev >> f ptr + +withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a +withTimeSpec ts f + | tv_sec ts < 0 = f nullPtr + | otherwise = alloca $ \ptr -> poke ptr ts >> f ptr + +fromTimeout :: Timeout -> TimeSpec +fromTimeout Forever = TimeSpec (-1) (-1) +fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec) + where + sec :: Int + sec = floor s + + nanosec :: Int + nanosec = ceiling $ (s - fromIntegral sec) * 1000000000 + +toEvent :: Filter -> E.Event +toEvent (Filter f) + | f == (#const EVFILT_READ) = E.evtRead + | f == (#const EVFILT_WRITE) = E.evtWrite + | otherwise = errorWithoutStackTrace $ "toEvent: unknown filter " ++ show f + +foreign import ccall unsafe "kqueue" + c_kqueue :: IO CInt + +#if defined(HAVE_KEVENT) +foreign import capi safe "sys/event.h kevent" + c_kevent :: KQueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt + -> Ptr TimeSpec -> IO CInt + +foreign import ccall unsafe "kevent" + c_kevent_unsafe :: KQueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt + -> Ptr TimeSpec -> IO CInt +#else +#error no kevent system call available!? +#endif + +#endif /* defined(HAVE_KQUEUE) */ diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs new file mode 100644 index 0000000..013850b --- /dev/null +++ b/libraries/base/GHC/Event/Manager.hs @@ -0,0 +1,520 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns + , CPP + , ExistentialQuantification + , NoImplicitPrelude + , RecordWildCards + , TypeSynonymInstances + , FlexibleInstances + #-} + +-- | +-- The event manager supports event notification on fds. Each fd may +-- have multiple callbacks registered, each listening for a different +-- set of events. Registrations may be automatically deactivated after +-- the occurrence of an event ("one-shot mode") or active until +-- explicitly unregistered. +-- +-- If an fd has only one-shot registrations then we use one-shot +-- polling if available. Otherwise we use multi-shot polling. + +module GHC.Event.Manager + ( -- * Types + EventManager + + -- * Creation + , new + , newWith + , newDefaultBackend + + -- * Running + , finished + , loop + , step + , shutdown + , release + , cleanup + , wakeManager + + -- * State + , callbackTableVar + , emControl + + -- * Registering interest in I/O events + , Lifetime (..) + , Event + , evtRead + , evtWrite + , IOCallback + , FdKey(keyFd) + , FdData + , registerFd + , unregisterFd_ + , unregisterFd + , closeFd + , closeFd_ + ) where + +#include "EventConfig.h" + +------------------------------------------------------------------------ +-- Imports + +import Control.Concurrent.MVar (MVar, newMVar, putMVar, + tryPutMVar, takeMVar, withMVar) +import Control.Exception (onException) +import Data.Bits ((.&.)) +import Data.Foldable (forM_) +import Data.Functor (void) +import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef, + writeIORef) +import Data.Maybe (maybe) +import Data.OldList (partition) +import GHC.Arr (Array, (!), listArray) +import GHC.Base +import GHC.Conc.Sync (yield) +import GHC.List (filter, replicate) +import GHC.Num (Num(..)) +import GHC.Real (fromIntegral) +import GHC.Show (Show(..)) +import GHC.Event.Control +import GHC.Event.IntTable (IntTable) +import GHC.Event.Internal (Backend, Event, evtClose, evtRead, evtWrite, + Lifetime(..), EventLifetime, Timeout(..)) +import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique) +import System.Posix.Types (Fd) + +import qualified GHC.Event.IntTable as IT +import qualified GHC.Event.Internal as I + +#if defined(HAVE_KQUEUE) +import qualified GHC.Event.KQueue as KQueue +#elif defined(HAVE_EPOLL) +import qualified GHC.Event.EPoll as EPoll +#elif defined(HAVE_POLL) +import qualified GHC.Event.Poll as Poll +#else +# error not implemented for this operating system +#endif + +------------------------------------------------------------------------ +-- Types + +data FdData = FdData { + fdKey :: {-# UNPACK #-} !FdKey + , fdEvents :: {-# UNPACK #-} !EventLifetime + , _fdCallback :: !IOCallback + } + +-- | A file descriptor registration cookie. +data FdKey = FdKey { + keyFd :: {-# UNPACK #-} !Fd + , keyUnique :: {-# UNPACK #-} !Unique + } deriving (Eq, Show) + +-- | Callback invoked on I/O events. +type IOCallback = FdKey -> Event -> IO () + +data State = Created + | Running + | Dying + | Releasing + | Finished + deriving (Eq, Show) + +-- | The event manager state. +data EventManager = EventManager + { emBackend :: !Backend + , emFds :: {-# UNPACK #-} !(Array Int (MVar (IntTable [FdData]))) + , emState :: {-# UNPACK #-} !(IORef State) + , emUniqueSource :: {-# UNPACK #-} !UniqueSource + , emControl :: {-# UNPACK #-} !Control + , emLock :: {-# UNPACK #-} !(MVar ()) + } + +-- must be power of 2 +callbackArraySize :: Int +callbackArraySize = 32 + +hashFd :: Fd -> Int +hashFd fd = fromIntegral fd .&. (callbackArraySize - 1) +{-# INLINE hashFd #-} + +callbackTableVar :: EventManager -> Fd -> MVar (IntTable [FdData]) +callbackTableVar mgr fd = emFds mgr ! hashFd fd +{-# INLINE callbackTableVar #-} + +haveOneShot :: Bool +{-# INLINE haveOneShot #-} +#if defined(darwin_HOST_OS) || defined(ios_HOST_OS) +haveOneShot = False +#elif defined(HAVE_EPOLL) || defined(HAVE_KQUEUE) +haveOneShot = True +#else +haveOneShot = False +#endif +------------------------------------------------------------------------ +-- Creation + +handleControlEvent :: EventManager -> Fd -> Event -> IO () +handleControlEvent mgr fd _evt = do + msg <- readControlMessage (emControl mgr) fd + case msg of + CMsgWakeup -> return () + CMsgDie -> writeIORef (emState mgr) Finished + _ -> return () + +newDefaultBackend :: IO Backend +#if defined(HAVE_KQUEUE) +newDefaultBackend = KQueue.new +#elif defined(HAVE_EPOLL) +newDefaultBackend = EPoll.new +#elif defined(HAVE_POLL) +newDefaultBackend = Poll.new +#else +newDefaultBackend = errorWithoutStackTrace "no back end for this platform" +#endif + +-- | Create a new event manager. +new :: IO EventManager +new = newWith =<< newDefaultBackend + +-- | Create a new 'EventManager' with the given polling backend. +newWith :: Backend -> IO EventManager +newWith be = do + iofds <- fmap (listArray (0, callbackArraySize-1)) $ + replicateM callbackArraySize (newMVar =<< IT.new 8) + ctrl <- newControl False + state <- newIORef Created + us <- newSource + _ <- mkWeakIORef state $ do + st <- atomicModifyIORef' state $ \s -> (Finished, s) + when (st /= Finished) $ do + I.delete be + closeControl ctrl + lockVar <- newMVar () + let mgr = EventManager { emBackend = be + , emFds = iofds + , emState = state + , emUniqueSource = us + , emControl = ctrl + , emLock = lockVar + } + registerControlFd mgr (controlReadFd ctrl) evtRead + registerControlFd mgr (wakeupReadFd ctrl) evtRead + return mgr + where + replicateM n x = sequence (replicate n x) + +failOnInvalidFile :: String -> Fd -> IO Bool -> IO () +failOnInvalidFile loc fd m = do + ok <- m + when (not ok) $ + let msg = "Failed while attempting to modify registration of file " ++ + show fd ++ " at location " ++ loc + in errorWithoutStackTrace msg + +registerControlFd :: EventManager -> Fd -> Event -> IO () +registerControlFd mgr fd evs = + failOnInvalidFile "registerControlFd" fd $ + I.modifyFd (emBackend mgr) fd mempty evs + +-- | Asynchronously shuts down the event manager, if running. +shutdown :: EventManager -> IO () +shutdown mgr = do + state <- atomicModifyIORef' (emState mgr) $ \s -> (Dying, s) + when (state == Running) $ sendDie (emControl mgr) + +-- | Asynchronously tell the thread executing the event +-- manager loop to exit. +release :: EventManager -> IO () +release EventManager{..} = do + state <- atomicModifyIORef' emState $ \s -> (Releasing, s) + when (state == Running) $ sendWakeup emControl + +finished :: EventManager -> IO Bool +finished mgr = (== Finished) `liftM` readIORef (emState mgr) + +cleanup :: EventManager -> IO () +cleanup EventManager{..} = do + writeIORef emState Finished + void $ tryPutMVar emLock () + I.delete emBackend + closeControl emControl + +------------------------------------------------------------------------ +-- Event loop + +-- | Start handling events. This function loops until told to stop, +-- using 'shutdown'. +-- +-- /Note/: This loop can only be run once per 'EventManager', as it +-- closes all of its control resources when it finishes. +loop :: EventManager -> IO () +loop mgr@EventManager{..} = do + void $ takeMVar emLock + state <- atomicModifyIORef' emState $ \s -> case s of + Created -> (Running, s) + Releasing -> (Running, s) + _ -> (s, s) + case state of + Created -> go `onException` cleanup mgr + Releasing -> go `onException` cleanup mgr + Dying -> cleanup mgr + -- While a poll loop is never forked when the event manager is in the + -- 'Finished' state, its state could read 'Finished' once the new thread + -- actually runs. This is not an error, just an unfortunate race condition + -- in Thread.restartPollLoop. See #8235 + Finished -> return () + _ -> do cleanup mgr + errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++ + show state + where + go = do state <- step mgr + case state of + Running -> yield >> go + Releasing -> putMVar emLock () + _ -> cleanup mgr + +-- | To make a step, we first do a non-blocking poll, in case +-- there are already events ready to handle. This improves performance +-- because we can make an unsafe foreign C call, thereby avoiding +-- forcing the current Task to release the Capability and forcing a context switch. +-- If the poll fails to find events, we yield, putting the poll loop thread at +-- end of the Haskell run queue. When it comes back around, we do one more +-- non-blocking poll, in case we get lucky and have ready events. +-- If that also returns no events, then we do a blocking poll. +step :: EventManager -> IO State +step mgr@EventManager{..} = do + waitForIO + state <- readIORef emState + state `seq` return state + where + waitForIO = do + n1 <- I.poll emBackend Nothing (onFdEvent mgr) + when (n1 <= 0) $ do + yield + n2 <- I.poll emBackend Nothing (onFdEvent mgr) + when (n2 <= 0) $ do + _ <- I.poll emBackend (Just Forever) (onFdEvent mgr) + return () + +------------------------------------------------------------------------ +-- Registering interest in I/O events + +-- | Register interest in the given events, without waking the event +-- manager thread. The 'Bool' return value indicates whether the +-- event manager ought to be woken. +-- +-- Note that the event manager is generally implemented in terms of the +-- platform's @select@ or @epoll@ system call, which tend to vary in +-- what sort of fds are permitted. For instance, waiting on regular files +-- is not allowed on many platforms. +registerFd_ :: EventManager -> IOCallback -> Fd -> Event -> Lifetime + -> IO (FdKey, Bool) +registerFd_ mgr@(EventManager{..}) cb fd evs lt = do + u <- newUnique emUniqueSource + let fd' = fromIntegral fd + reg = FdKey fd u + el = I.eventLifetime evs lt + !fdd = FdData reg el cb + (modify,ok) <- withMVar (callbackTableVar mgr fd) $ \tbl -> do + oldFdd <- IT.insertWith (++) fd' [fdd] tbl + let prevEvs :: EventLifetime + prevEvs = maybe mempty eventsOf oldFdd + + el' :: EventLifetime + el' = prevEvs `mappend` el + case I.elLifetime el' of + -- All registrations want one-shot semantics and this is supported + OneShot | haveOneShot -> do + ok <- I.modifyFdOnce emBackend fd (I.elEvent el') + if ok + then return (False, True) + else IT.reset fd' oldFdd tbl >> return (False, False) + + -- We don't want or don't support one-shot semantics + _ -> do + let modify = prevEvs /= el' + ok <- if modify + then let newEvs = I.elEvent el' + oldEvs = I.elEvent prevEvs + in I.modifyFd emBackend fd oldEvs newEvs + else return True + if ok + then return (modify, True) + else IT.reset fd' oldFdd tbl >> return (False, False) + -- this simulates behavior of old IO manager: + -- i.e. just call the callback if the registration fails. + when (not ok) (cb reg evs) + return (reg,modify) +{-# INLINE registerFd_ #-} + +-- | @registerFd mgr cb fd evs lt@ registers interest in the events @evs@ +-- on the file descriptor @fd@ for lifetime @lt@. @cb@ is called for +-- each event that occurs. Returns a cookie that can be handed to +-- 'unregisterFd'. +registerFd :: EventManager -> IOCallback -> Fd -> Event -> Lifetime -> IO FdKey +registerFd mgr cb fd evs lt = do + (r, wake) <- registerFd_ mgr cb fd evs lt + when wake $ wakeManager mgr + return r +{-# INLINE registerFd #-} + +{- + Building GHC with parallel IO manager on Mac freezes when + compiling the dph libraries in the phase 2. As workaround, we + don't use oneshot and we wake up an IO manager on Mac every time + when we register an event. + + For more information, please read: + http://ghc.haskell.org/trac/ghc/ticket/7651 +-} +-- | Wake up the event manager. +wakeManager :: EventManager -> IO () +#if defined(darwin_HOST_OS) || defined(ios_HOST_OS) +wakeManager mgr = sendWakeup (emControl mgr) +#elif defined(HAVE_EPOLL) || defined(HAVE_KQUEUE) +wakeManager _ = return () +#else +wakeManager mgr = sendWakeup (emControl mgr) +#endif + +eventsOf :: [FdData] -> EventLifetime +eventsOf [fdd] = fdEvents fdd +eventsOf fdds = mconcat $ map fdEvents fdds + +-- | Drop a previous file descriptor registration, without waking the +-- event manager thread. The return value indicates whether the event +-- manager ought to be woken. +unregisterFd_ :: EventManager -> FdKey -> IO Bool +unregisterFd_ mgr@(EventManager{..}) (FdKey fd u) = + withMVar (callbackTableVar mgr fd) $ \tbl -> do + let dropReg = nullToNothing . filter ((/= u) . keyUnique . fdKey) + fd' = fromIntegral fd + pairEvents :: [FdData] -> IO (EventLifetime, EventLifetime) + pairEvents prev = do + r <- maybe mempty eventsOf `fmap` IT.lookup fd' tbl + return (eventsOf prev, r) + (oldEls, newEls) <- IT.updateWith dropReg fd' tbl >>= + maybe (return (mempty, mempty)) pairEvents + let modify = oldEls /= newEls + when modify $ failOnInvalidFile "unregisterFd_" fd $ + case I.elLifetime newEls of + OneShot | I.elEvent newEls /= mempty, haveOneShot -> + I.modifyFdOnce emBackend fd (I.elEvent newEls) + _ -> + I.modifyFd emBackend fd (I.elEvent oldEls) (I.elEvent newEls) + return modify + +-- | Drop a previous file descriptor registration. +unregisterFd :: EventManager -> FdKey -> IO () +unregisterFd mgr reg = do + wake <- unregisterFd_ mgr reg + when wake $ wakeManager mgr + +-- | Close a file descriptor in a race-safe way. +closeFd :: EventManager -> (Fd -> IO ()) -> Fd -> IO () +closeFd mgr close fd = do + fds <- withMVar (callbackTableVar mgr fd) $ \tbl -> do + prev <- IT.delete (fromIntegral fd) tbl + case prev of + Nothing -> close fd >> return [] + Just fds -> do + let oldEls = eventsOf fds + when (I.elEvent oldEls /= mempty) $ do + _ <- I.modifyFd (emBackend mgr) fd (I.elEvent oldEls) mempty + wakeManager mgr + close fd + return fds + forM_ fds $ \(FdData reg el cb) -> cb reg (I.elEvent el `mappend` evtClose) + +-- | Close a file descriptor in a race-safe way. +-- It assumes the caller will update the callback tables and that the caller +-- holds the callback table lock for the fd. It must hold this lock because +-- this command executes a backend command on the fd. +closeFd_ :: EventManager + -> IntTable [FdData] + -> Fd + -> IO (IO ()) +closeFd_ mgr tbl fd = do + prev <- IT.delete (fromIntegral fd) tbl + case prev of + Nothing -> return (return ()) + Just fds -> do + let oldEls = eventsOf fds + when (oldEls /= mempty) $ do + _ <- I.modifyFd (emBackend mgr) fd (I.elEvent oldEls) mempty + wakeManager mgr + return $ + forM_ fds $ \(FdData reg el cb) -> + cb reg (I.elEvent el `mappend` evtClose) + +------------------------------------------------------------------------ +-- Utilities + +-- | Call the callbacks corresponding to the given file descriptor. +onFdEvent :: EventManager -> Fd -> Event -> IO () +onFdEvent mgr fd evs + | fd == controlReadFd (emControl mgr) || fd == wakeupReadFd (emControl mgr) = + handleControlEvent mgr fd evs + + | otherwise = do + fdds <- withMVar (callbackTableVar mgr fd) $ \tbl -> + IT.delete (fromIntegral fd) tbl >>= maybe (return []) (selectCallbacks tbl) + forM_ fdds $ \(FdData reg _ cb) -> cb reg evs + where + -- | Here we look through the list of registrations for the fd of interest + -- and sort out which match the events that were triggered. We, + -- + -- 1. re-arm the fd as appropriate + -- 2. reinsert registrations that weren't triggered and multishot + -- registrations + -- 3. return a list containing the callbacks that should be invoked. + selectCallbacks :: IntTable [FdData] -> [FdData] -> IO [FdData] + selectCallbacks tbl fdds = do + let -- figure out which registrations have been triggered + matches :: FdData -> Bool + matches fd' = evs `I.eventIs` I.elEvent (fdEvents fd') + (triggered, notTriggered) = partition matches fdds + + -- sort out which registrations we need to retain + isMultishot :: FdData -> Bool + isMultishot fd' = I.elLifetime (fdEvents fd') == MultiShot + saved = notTriggered ++ filter isMultishot triggered + + savedEls = eventsOf saved + allEls = eventsOf fdds + + -- Reinsert multishot registrations. + -- We deleted the table entry for this fd above so we there isn't a preexisting entry + _ <- IT.insertWith (\_ _ -> saved) (fromIntegral fd) saved tbl + + case I.elLifetime allEls of + -- we previously armed the fd for multiple shots, no need to rearm + MultiShot | allEls == savedEls -> + return () + + -- either we previously registered for one shot or the + -- events of interest have changed, we must re-arm + _ -> + case I.elLifetime savedEls of + OneShot | haveOneShot -> + -- if there are no saved events and we registered with one-shot + -- semantics then there is no need to re-arm + unless (OneShot == I.elLifetime allEls + && mempty == I.elEvent savedEls) $ do + void $ I.modifyFdOnce (emBackend mgr) fd (I.elEvent savedEls) + _ -> + -- we need to re-arm with multi-shot semantics + void $ I.modifyFd (emBackend mgr) fd + (I.elEvent allEls) (I.elEvent savedEls) + + return triggered + +nullToNothing :: [a] -> Maybe [a] +nullToNothing [] = Nothing +nullToNothing xs@(_:_) = Just xs + +unless :: Monad m => Bool -> m () -> m () +unless p = when (not p) diff --git a/libraries/base/GHC/Event/PSQ.hs b/libraries/base/GHC/Event/PSQ.hs new file mode 100644 index 0000000..e61c31b --- /dev/null +++ b/libraries/base/GHC/Event/PSQ.hs @@ -0,0 +1,484 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns, NoImplicitPrelude #-} + +-- Copyright (c) 2008, Ralf Hinze +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- * Redistributions of source code must retain the above +-- copyright notice, this list of conditions and the following +-- disclaimer. +-- +-- * Redistributions in binary form must reproduce the above +-- copyright notice, this list of conditions and the following +-- disclaimer in the documentation and/or other materials +-- provided with the distribution. +-- +-- * The names of the contributors may not be used to endorse or +-- promote products derived from this software without specific +-- prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +-- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +-- COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +-- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED +-- OF THE POSSIBILITY OF SUCH DAMAGE. + +-- | A /priority search queue/ (henceforth /queue/) efficiently +-- supports the operations of both a search tree and a priority queue. +-- An 'Elem'ent is a product of a key, a priority, and a +-- value. Elements can be inserted, deleted, modified and queried in +-- logarithmic time, and the element with the least priority can be +-- retrieved in constant time. A queue can be built from a list of +-- elements, sorted by keys, in linear time. +-- +-- This implementation is due to Ralf Hinze with some modifications by +-- Scott Dillard and Johan Tibell. +-- +-- * Hinze, R., /A Simple Implementation Technique for Priority Search +-- Queues/, ICFP 2001, pp. 110-121 +-- +-- +module GHC.Event.PSQ + ( + -- * Binding Type + Elem(..) + , Key + , Prio + + -- * Priority Search Queue Type + , PSQ + + -- * Query + , size + , null + , lookup + + -- * Construction + , empty + , singleton + + -- * Insertion + , insert + + -- * Delete/Update + , delete + , adjust + + -- * Conversion + , toList + , toAscList + , toDescList + , fromList + + -- * Min + , findMin + , deleteMin + , minView + , atMost + ) where + +import GHC.Base hiding (empty) +import GHC.Num (Num(..)) +import GHC.Show (Show(showsPrec)) +import GHC.Event.Unique (Unique) + +-- | @E k p@ binds the key @k@ with the priority @p@. +data Elem a = E + { key :: {-# UNPACK #-} !Key + , prio :: {-# UNPACK #-} !Prio + , value :: a + } deriving (Eq, Show) + +------------------------------------------------------------------------ +-- | A mapping from keys @k@ to priorites @p@. + +type Prio = Double +type Key = Unique + +data PSQ a = Void + | Winner {-# UNPACK #-} !(Elem a) + !(LTree a) + {-# UNPACK #-} !Key -- max key + deriving (Eq, Show) + +-- | /O(1)/ The number of elements in a queue. +size :: PSQ a -> Int +size Void = 0 +size (Winner _ lt _) = 1 + size' lt + +-- | /O(1)/ True if the queue is empty. +null :: PSQ a -> Bool +null Void = True +null (Winner _ _ _) = False + +-- | /O(log n)/ The priority and value of a given key, or Nothing if +-- the key is not bound. +lookup :: Key -> PSQ a -> Maybe (Prio, a) +lookup k q = case tourView q of + Null -> Nothing + Single (E k' p v) + | k == k' -> Just (p, v) + | otherwise -> Nothing + tl `Play` tr + | k <= maxKey tl -> lookup k tl + | otherwise -> lookup k tr + +------------------------------------------------------------------------ +-- Construction + +empty :: PSQ a +empty = Void + +-- | /O(1)/ Build a queue with one element. +singleton :: Key -> Prio -> a -> PSQ a +singleton k p v = Winner (E k p v) Start k + +------------------------------------------------------------------------ +-- Insertion + +-- | /O(log n)/ Insert a new key, priority and value in the queue. If +-- the key is already present in the queue, the associated priority +-- and value are replaced with the supplied priority and value. +insert :: Key -> Prio -> a -> PSQ a -> PSQ a +insert k p v q = case q of + Void -> singleton k p v + Winner (E k' p' v') Start _ -> case compare k k' of + LT -> singleton k p v `play` singleton k' p' v' + EQ -> singleton k p v + GT -> singleton k' p' v' `play` singleton k p v + Winner e (RLoser _ e' tl m tr) m' + | k <= m -> insert k p v (Winner e tl m) `play` (Winner e' tr m') + | otherwise -> (Winner e tl m) `play` insert k p v (Winner e' tr m') + Winner e (LLoser _ e' tl m tr) m' + | k <= m -> insert k p v (Winner e' tl m) `play` (Winner e tr m') + | otherwise -> (Winner e' tl m) `play` insert k p v (Winner e tr m') + +------------------------------------------------------------------------ +-- Delete/Update + +-- | /O(log n)/ Delete a key and its priority and value from the +-- queue. When the key is not a member of the queue, the original +-- queue is returned. +delete :: Key -> PSQ a -> PSQ a +delete k q = case q of + Void -> empty + Winner (E k' p v) Start _ + | k == k' -> empty + | otherwise -> singleton k' p v + Winner e (RLoser _ e' tl m tr) m' + | k <= m -> delete k (Winner e tl m) `play` (Winner e' tr m') + | otherwise -> (Winner e tl m) `play` delete k (Winner e' tr m') + Winner e (LLoser _ e' tl m tr) m' + | k <= m -> delete k (Winner e' tl m) `play` (Winner e tr m') + | otherwise -> (Winner e' tl m) `play` delete k (Winner e tr m') + +-- | /O(log n)/ Update a priority at a specific key with the result +-- of the provided function. When the key is not a member of the +-- queue, the original queue is returned. +adjust :: (Prio -> Prio) -> Key -> PSQ a -> PSQ a +adjust f k q0 = go q0 + where + go q = case q of + Void -> empty + Winner (E k' p v) Start _ + | k == k' -> singleton k' (f p) v + | otherwise -> singleton k' p v + Winner e (RLoser _ e' tl m tr) m' + | k <= m -> go (Winner e tl m) `unsafePlay` (Winner e' tr m') + | otherwise -> (Winner e tl m) `unsafePlay` go (Winner e' tr m') + Winner e (LLoser _ e' tl m tr) m' + | k <= m -> go (Winner e' tl m) `unsafePlay` (Winner e tr m') + | otherwise -> (Winner e' tl m) `unsafePlay` go (Winner e tr m') +{-# INLINE adjust #-} + +------------------------------------------------------------------------ +-- Conversion + +-- | /O(n*log n)/ Build a queue from a list of key/priority/value +-- tuples. If the list contains more than one priority and value for +-- the same key, the last priority and value for the key is retained. +fromList :: [Elem a] -> PSQ a +fromList = foldr (\(E k p v) q -> insert k p v q) empty + +-- | /O(n)/ Convert to a list of key/priority/value tuples. +toList :: PSQ a -> [Elem a] +toList = toAscList + +-- | /O(n)/ Convert to an ascending list. +toAscList :: PSQ a -> [Elem a] +toAscList q = seqToList (toAscLists q) + +toAscLists :: PSQ a -> Sequ (Elem a) +toAscLists q = case tourView q of + Null -> emptySequ + Single e -> singleSequ e + tl `Play` tr -> toAscLists tl <> toAscLists tr + +-- | /O(n)/ Convert to a descending list. +toDescList :: PSQ a -> [ Elem a ] +toDescList q = seqToList (toDescLists q) + +toDescLists :: PSQ a -> Sequ (Elem a) +toDescLists q = case tourView q of + Null -> emptySequ + Single e -> singleSequ e + tl `Play` tr -> toDescLists tr <> toDescLists tl + +------------------------------------------------------------------------ +-- Min + +-- | /O(1)/ The element with the lowest priority. +findMin :: PSQ a -> Maybe (Elem a) +findMin Void = Nothing +findMin (Winner e _ _) = Just e + +-- | /O(log n)/ Delete the element with the lowest priority. Returns +-- an empty queue if the queue is empty. +deleteMin :: PSQ a -> PSQ a +deleteMin Void = Void +deleteMin (Winner _ t m) = secondBest t m + +-- | /O(log n)/ Retrieve the binding with the least priority, and the +-- rest of the queue stripped of that binding. +minView :: PSQ a -> Maybe (Elem a, PSQ a) +minView Void = Nothing +minView (Winner e t m) = Just (e, secondBest t m) + +secondBest :: LTree a -> Key -> PSQ a +secondBest Start _ = Void +secondBest (LLoser _ e tl m tr) m' = Winner e tl m `play` secondBest tr m' +secondBest (RLoser _ e tl m tr) m' = secondBest tl m `play` Winner e tr m' + +-- | /O(r*(log n - log r))/ Return a list of elements ordered by +-- key whose priorities are at most @pt@. +atMost :: Prio -> PSQ a -> ([Elem a], PSQ a) +atMost pt q = let (sequ, q') = atMosts pt q + in (seqToList sequ, q') + +atMosts :: Prio -> PSQ a -> (Sequ (Elem a), PSQ a) +atMosts !pt q = case q of + (Winner e _ _) + | prio e > pt -> (emptySequ, q) + Void -> (emptySequ, Void) + Winner e Start _ -> (singleSequ e, Void) + Winner e (RLoser _ e' tl m tr) m' -> + let (sequ, q') = atMosts pt (Winner e tl m) + (sequ', q'') = atMosts pt (Winner e' tr m') + in (sequ <> sequ', q' `play` q'') + Winner e (LLoser _ e' tl m tr) m' -> + let (sequ, q') = atMosts pt (Winner e' tl m) + (sequ', q'') = atMosts pt (Winner e tr m') + in (sequ <> sequ', q' `play` q'') + +------------------------------------------------------------------------ +-- Loser tree + +type Size = Int + +data LTree a = Start + | LLoser {-# UNPACK #-} !Size + {-# UNPACK #-} !(Elem a) + !(LTree a) + {-# UNPACK #-} !Key -- split key + !(LTree a) + | RLoser {-# UNPACK #-} !Size + {-# UNPACK #-} !(Elem a) + !(LTree a) + {-# UNPACK #-} !Key -- split key + !(LTree a) + deriving (Eq, Show) + +size' :: LTree a -> Size +size' Start = 0 +size' (LLoser s _ _ _ _) = s +size' (RLoser s _ _ _ _) = s + +left, right :: LTree a -> LTree a + +left Start = moduleError "left" "empty loser tree" +left (LLoser _ _ tl _ _ ) = tl +left (RLoser _ _ tl _ _ ) = tl + +right Start = moduleError "right" "empty loser tree" +right (LLoser _ _ _ _ tr) = tr +right (RLoser _ _ _ _ tr) = tr + +maxKey :: PSQ a -> Key +maxKey Void = moduleError "maxKey" "empty queue" +maxKey (Winner _ _ m) = m + +lloser, rloser :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lloser k p v tl m tr = LLoser (1 + size' tl + size' tr) (E k p v) tl m tr +rloser k p v tl m tr = RLoser (1 + size' tl + size' tr) (E k p v) tl m tr + +------------------------------------------------------------------------ +-- Balancing + +-- | Balance factor +omega :: Int +omega = 4 + +lbalance, rbalance :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a + +lbalance k p v l m r + | size' l + size' r < 2 = lloser k p v l m r + | size' r > omega * size' l = lbalanceLeft k p v l m r + | size' l > omega * size' r = lbalanceRight k p v l m r + | otherwise = lloser k p v l m r + +rbalance k p v l m r + | size' l + size' r < 2 = rloser k p v l m r + | size' r > omega * size' l = rbalanceLeft k p v l m r + | size' l > omega * size' r = rbalanceRight k p v l m r + | otherwise = rloser k p v l m r + +lbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lbalanceLeft k p v l m r + | size' (left r) < size' (right r) = lsingleLeft k p v l m r + | otherwise = ldoubleLeft k p v l m r + +lbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lbalanceRight k p v l m r + | size' (left l) > size' (right l) = lsingleRight k p v l m r + | otherwise = ldoubleRight k p v l m r + +rbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rbalanceLeft k p v l m r + | size' (left r) < size' (right r) = rsingleLeft k p v l m r + | otherwise = rdoubleLeft k p v l m r + +rbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rbalanceRight k p v l m r + | size' (left l) > size' (right l) = rsingleRight k p v l m r + | otherwise = rdoubleRight k p v l m r + +lsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) + | p1 <= p2 = lloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3 + | otherwise = lloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3 +lsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = + rloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3 +lsingleLeft _ _ _ _ _ _ = moduleError "lsingleLeft" "malformed tree" + +rsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = + rloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3 +rsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = + rloser k2 p2 v2 (rloser k1 p1 v1 t1 m1 t2) m2 t3 +rsingleLeft _ _ _ _ _ _ = moduleError "rsingleLeft" "malformed tree" + +lsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lloser k2 p2 v2 t1 m1 (lloser k1 p1 v1 t2 m2 t3) +lsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3) +lsingleRight _ _ _ _ _ _ = moduleError "lsingleRight" "malformed tree" + +rsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3) +rsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 + | p1 <= p2 = rloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3) + | otherwise = rloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3) +rsingleRight _ _ _ _ _ _ = moduleError "rsingleRight" "malformed tree" + +ldoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +ldoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = + lsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3) +ldoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = + lsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3) +ldoubleLeft _ _ _ _ _ _ = moduleError "ldoubleLeft" "malformed tree" + +ldoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +ldoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 +ldoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 +ldoubleRight _ _ _ _ _ _ = moduleError "ldoubleRight" "malformed tree" + +rdoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rdoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = + rsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3) +rdoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = + rsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3) +rdoubleLeft _ _ _ _ _ _ = moduleError "rdoubleLeft" "malformed tree" + +rdoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rdoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + rsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 +rdoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + rsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 +rdoubleRight _ _ _ _ _ _ = moduleError "rdoubleRight" "malformed tree" + +-- | Take two pennants and returns a new pennant that is the union of +-- the two with the precondition that the keys in the first tree are +-- strictly smaller than the keys in the second tree. +play :: PSQ a -> PSQ a -> PSQ a +Void `play` t' = t' +t `play` Void = t +Winner e@(E k p v) t m `play` Winner e'@(E k' p' v') t' m' + | p <= p' = Winner e (rbalance k' p' v' t m t') m' + | otherwise = Winner e' (lbalance k p v t m t') m' +{-# INLINE play #-} + +-- | A version of 'play' that can be used if the shape of the tree has +-- not changed or if the tree is known to be balanced. +unsafePlay :: PSQ a -> PSQ a -> PSQ a +Void `unsafePlay` t' = t' +t `unsafePlay` Void = t +Winner e@(E k p v) t m `unsafePlay` Winner e'@(E k' p' v') t' m' + | p <= p' = Winner e (rloser k' p' v' t m t') m' + | otherwise = Winner e' (lloser k p v t m t') m' +{-# INLINE unsafePlay #-} + +data TourView a = Null + | Single {-# UNPACK #-} !(Elem a) + | (PSQ a) `Play` (PSQ a) + +tourView :: PSQ a -> TourView a +tourView Void = Null +tourView (Winner e Start _) = Single e +tourView (Winner e (RLoser _ e' tl m tr) m') = + Winner e tl m `Play` Winner e' tr m' +tourView (Winner e (LLoser _ e' tl m tr) m') = + Winner e' tl m `Play` Winner e tr m' + +------------------------------------------------------------------------ +-- Utility functions + +moduleError :: String -> String -> a +moduleError fun msg = errorWithoutStackTrace ("GHC.Event.PSQ." ++ fun ++ ':' : ' ' : msg) +{-# NOINLINE moduleError #-} + +------------------------------------------------------------------------ +-- Hughes's efficient sequence type + +newtype Sequ a = Sequ ([a] -> [a]) + +emptySequ :: Sequ a +emptySequ = Sequ (\as -> as) + +singleSequ :: a -> Sequ a +singleSequ a = Sequ (\as -> a : as) + +(<>) :: Sequ a -> Sequ a -> Sequ a +Sequ x1 <> Sequ x2 = Sequ (\as -> x1 (x2 as)) +infixr 5 <> + +seqToList :: Sequ a -> [a] +seqToList (Sequ x) = x [] + +instance Show a => Show (Sequ a) where + showsPrec d a = showsPrec d (seqToList a) + diff --git a/libraries/base/GHC/Event/Poll.hsc b/libraries/base/GHC/Event/Poll.hsc new file mode 100644 index 0000000..b128572 --- /dev/null +++ b/libraries/base/GHC/Event/Poll.hsc @@ -0,0 +1,211 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE GeneralizedNewtypeDeriving + , NoImplicitPrelude + , BangPatterns + #-} + +module GHC.Event.Poll + ( + new + , available + ) where + +#include "EventConfig.h" + +#if !defined(HAVE_POLL_H) +import GHC.Base +import qualified GHC.Event.Internal as E + +new :: IO E.Backend +new = errorWithoutStackTrace "Poll back end not implemented for this platform" + +available :: Bool +available = False +{-# INLINE available #-} +#else +#include + +import Control.Concurrent.MVar (MVar, newMVar, swapMVar) +import Data.Bits (Bits, FiniteBits, (.|.), (.&.)) +import Data.Word +import Foreign.C.Types (CInt(..), CShort(..)) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) +import GHC.Base +import GHC.Conc.Sync (withMVar) +import GHC.Enum (maxBound) +import GHC.Num (Num(..)) +import GHC.Real (ceiling, fromIntegral) +import GHC.Show (Show) +import System.Posix.Types (Fd(..)) + +import qualified GHC.Event.Array as A +import qualified GHC.Event.Internal as E + +available :: Bool +available = True +{-# INLINE available #-} + +data Poll = Poll { + pollChanges :: {-# UNPACK #-} !(MVar (A.Array PollFd)) + , pollFd :: {-# UNPACK #-} !(A.Array PollFd) + } + +new :: IO E.Backend +new = E.backend poll modifyFd modifyFdOnce (\_ -> return ()) `liftM` + liftM2 Poll (newMVar =<< A.empty) A.empty + +modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO Bool +modifyFd p fd oevt nevt = + withMVar (pollChanges p) $ \ary -> do + A.snoc ary $ PollFd fd (fromEvent nevt) (fromEvent oevt) + return True + +modifyFdOnce :: Poll -> Fd -> E.Event -> IO Bool +modifyFdOnce = errorWithoutStackTrace "modifyFdOnce not supported in Poll backend" + +reworkFd :: Poll -> PollFd -> IO () +reworkFd p (PollFd fd npevt opevt) = do + let ary = pollFd p + if opevt == 0 + then A.snoc ary $ PollFd fd npevt 0 + else do + found <- A.findIndex ((== fd) . pfdFd) ary + case found of + Nothing -> errorWithoutStackTrace "reworkFd: event not found" + Just (i,_) + | npevt /= 0 -> A.unsafeWrite ary i $ PollFd fd npevt 0 + | otherwise -> A.removeAt ary i + +poll :: Poll + -> Maybe E.Timeout + -> (Fd -> E.Event -> IO ()) + -> IO Int +poll p mtout f = do + let a = pollFd p + mods <- swapMVar (pollChanges p) =<< A.empty + A.forM_ mods (reworkFd p) + n <- A.useAsPtr a $ \ptr len -> + E.throwErrnoIfMinus1NoRetry "c_poll" $ + case mtout of + Just tout -> + c_pollLoop ptr (fromIntegral len) (fromTimeout tout) + Nothing -> + c_poll_unsafe ptr (fromIntegral len) 0 + when (n /= 0) $ do + A.loop a 0 $ \i e -> do + let r = pfdRevents e + if r /= 0 + then do f (pfdFd e) (toEvent r) + let i' = i + 1 + return (i', i' == n) + else return (i, True) + return (fromIntegral n) + where + -- The poll timeout is specified as an Int, but c_poll takes a CInt. These + -- can't be safely coerced as on many systems (e.g. x86_64) CInt has a + -- maxBound of (2^32 - 1), even though Int may have a significantly higher + -- bound. + -- + -- This function deals with timeouts greater than maxBound :: CInt, by + -- looping until c_poll returns a non-zero value (0 indicates timeout + -- expired) OR the full timeout has passed. + c_pollLoop :: Ptr PollFd -> (#type nfds_t) -> Int -> IO CInt + c_pollLoop ptr len tout + | isShortTimeout = c_poll ptr len (fromIntegral tout) + | otherwise = do + result <- c_poll ptr len (fromIntegral maxPollTimeout) + if result == 0 + then c_pollLoop ptr len (fromIntegral (tout - maxPollTimeout)) + else return result + where + -- maxPollTimeout is smaller than 0 IFF Int is smaller than CInt. + -- This means any possible Int input to poll can be safely directly + -- converted to CInt. + isShortTimeout = tout <= maxPollTimeout || maxPollTimeout < 0 + + -- We need to account for 3 cases: + -- 1. Int and CInt are of equal size. + -- 2. Int is larger than CInt + -- 3. Int is smaller than CInt + -- + -- In case 1, the value of maxPollTimeout will be the maxBound of Int. + -- + -- In case 2, the value of maxPollTimeout will be the maxBound of CInt, + -- which is the largest value accepted by c_poll. This will result in + -- c_pollLoop recursing if the provided timeout is larger. + -- + -- In case 3, "fromIntegral (maxBound :: CInt) :: Int" will result in a + -- negative Int. This will cause isShortTimeout to be true and result in + -- the timeout being directly converted to a CInt. + maxPollTimeout :: Int + maxPollTimeout = fromIntegral (maxBound :: CInt) + +fromTimeout :: E.Timeout -> Int +fromTimeout E.Forever = -1 +fromTimeout (E.Timeout s) = ceiling $ 1000 * s + +data PollFd = PollFd { + pfdFd :: {-# UNPACK #-} !Fd + , pfdEvents :: {-# UNPACK #-} !Event + , pfdRevents :: {-# UNPACK #-} !Event + } deriving (Show) + +newtype Event = Event CShort + deriving (Eq, Show, Num, Storable, Bits, FiniteBits) + +-- We have to duplicate the whole enum like this in order for the +-- hsc2hs cross-compilation mode to work +#ifdef POLLRDHUP +#{enum Event, Event + , pollIn = POLLIN + , pollOut = POLLOUT + , pollRdHup = POLLRDHUP + , pollErr = POLLERR + , pollHup = POLLHUP + } +#else +#{enum Event, Event + , pollIn = POLLIN + , pollOut = POLLOUT + , pollErr = POLLERR + , pollHup = POLLHUP + } +#endif + +fromEvent :: E.Event -> Event +fromEvent e = remap E.evtRead pollIn .|. + remap E.evtWrite pollOut + where remap evt to + | e `E.eventIs` evt = to + | otherwise = 0 + +toEvent :: Event -> E.Event +toEvent e = remap (pollIn .|. pollErr .|. pollHup) E.evtRead `mappend` + remap (pollOut .|. pollErr .|. pollHup) E.evtWrite + where remap evt to + | e .&. evt /= 0 = to + | otherwise = mempty + +instance Storable PollFd where + sizeOf _ = #size struct pollfd + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + fd <- #{peek struct pollfd, fd} ptr + events <- #{peek struct pollfd, events} ptr + revents <- #{peek struct pollfd, revents} ptr + let !pollFd' = PollFd fd events revents + return pollFd' + + poke ptr p = do + #{poke struct pollfd, fd} ptr (pfdFd p) + #{poke struct pollfd, events} ptr (pfdEvents p) + #{poke struct pollfd, revents} ptr (pfdRevents p) + +foreign import ccall safe "poll.h poll" + c_poll :: Ptr PollFd -> (#type nfds_t) -> CInt -> IO CInt + +foreign import ccall unsafe "poll.h poll" + c_poll_unsafe :: Ptr PollFd -> (#type nfds_t) -> CInt -> IO CInt +#endif /* defined(HAVE_POLL_H) */ diff --git a/libraries/base/GHC/Event/Thread.hs b/libraries/base/GHC/Event/Thread.hs new file mode 100644 index 0000000..d4b6792 --- /dev/null +++ b/libraries/base/GHC/Event/Thread.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns, NoImplicitPrelude #-} + +module GHC.Event.Thread + ( getSystemEventManager + , getSystemTimerManager + , ensureIOManagerIsRunning + , ioManagerCapabilitiesChanged + , threadWaitRead + , threadWaitWrite + , threadWaitReadSTM + , threadWaitWriteSTM + , closeFdWith + , threadDelay + , registerDelay + , blockedOnBadFD -- used by RTS + ) where + +import Control.Exception (finally, SomeException, toException) +import Data.Foldable (forM_, mapM_, sequence_) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Tuple (snd) +import Foreign.C.Error (eBADF, errnoToIOError) +import Foreign.C.Types (CInt(..), CUInt(..)) +import Foreign.Ptr (Ptr) +import GHC.Base +import GHC.List (zipWith, zipWith3) +import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO, + labelThread, modifyMVar_, withMVar, newTVar, sharedCAF, + getNumCapabilities, threadCapability, myThreadId, forkOn, + threadStatus, writeTVar, newTVarIO, readTVar, retry,throwSTM,STM) +import GHC.IO (mask_, onException) +import GHC.IO.Exception (ioError) +import GHC.IOArray (IOArray, newIOArray, readIOArray, writeIOArray, + boundsIOArray) +import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar) +import GHC.Event.Control (controlWriteFd) +import GHC.Event.Internal (eventIs, evtClose) +import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop, + new, registerFd, unregisterFd_) +import qualified GHC.Event.Manager as M +import qualified GHC.Event.TimerManager as TM +import GHC.Num ((-), (+)) +import GHC.Real (fromIntegral) +import GHC.Show (showSignedInt) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Types (Fd) + +-- | Suspends the current thread for a given number of microseconds +-- (GHC only). +-- +-- There is no guarantee that the thread will be rescheduled promptly +-- when the delay has expired, but the thread will never continue to +-- run /earlier/ than specified. +threadDelay :: Int -> IO () +threadDelay usecs = mask_ $ do + mgr <- getSystemTimerManager + m <- newEmptyMVar + reg <- TM.registerTimeout mgr usecs (putMVar m ()) + takeMVar m `onException` TM.unregisterTimeout mgr reg + +-- | Set the value of returned TVar to True after a given number of +-- microseconds. The caveats associated with threadDelay also apply. +-- +registerDelay :: Int -> IO (TVar Bool) +registerDelay usecs = do + t <- atomically $ newTVar False + mgr <- getSystemTimerManager + _ <- TM.registerTimeout mgr usecs . atomically $ writeTVar t True + return t + +-- | Block the current thread until data is available to read from the +-- given file descriptor. +-- +-- 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 'closeFdWith'. +threadWaitRead :: Fd -> IO () +threadWaitRead = threadWait evtRead +{-# INLINE threadWaitRead #-} + +-- | Block the current thread until the given file descriptor can +-- accept data to write. +-- +-- 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 'closeFdWith'. +threadWaitWrite :: Fd -> IO () +threadWaitWrite = threadWait evtWrite +{-# INLINE threadWaitWrite #-} + +-- | Close a file descriptor in a concurrency-safe way. +-- +-- Any threads that are blocked on the file descriptor via +-- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having +-- IO exceptions thrown. +closeFdWith :: (Fd -> IO ()) -- ^ Action that performs the close. + -> Fd -- ^ File descriptor to close. + -> IO () +closeFdWith close fd = do + eventManagerArray <- readIORef eventManager + let (low, high) = boundsIOArray eventManagerArray + mgrs <- flip mapM [low..high] $ \i -> do + Just (_,!mgr) <- readIOArray eventManagerArray i + return mgr + mask_ $ do + tables <- flip mapM mgrs $ \mgr -> takeMVar $ M.callbackTableVar mgr fd + cbApps <- zipWithM (\mgr table -> M.closeFd_ mgr table fd) mgrs tables + close fd `finally` sequence_ (zipWith3 finish mgrs tables cbApps) + where + finish mgr table cbApp = putMVar (M.callbackTableVar mgr fd) table >> cbApp + zipWithM f xs ys = sequence (zipWith f xs ys) + +threadWait :: Event -> Fd -> IO () +threadWait evt fd = mask_ $ do + m <- newEmptyMVar + mgr <- getSystemEventManager_ + reg <- registerFd mgr (\_ e -> putMVar m e) fd evt M.OneShot + evt' <- takeMVar m `onException` unregisterFd_ mgr reg + if evt' `eventIs` evtClose + then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing + else return () + +-- used at least by RTS in 'select()' IO manager backend +blockedOnBadFD :: SomeException +blockedOnBadFD = toException $ errnoToIOError "awaitEvent" eBADF Nothing Nothing + +threadWaitSTM :: Event -> Fd -> IO (STM (), IO ()) +threadWaitSTM evt fd = mask_ $ do + m <- newTVarIO Nothing + mgr <- getSystemEventManager_ + reg <- registerFd mgr (\_ e -> atomically (writeTVar m (Just e))) fd evt M.OneShot + let waitAction = + do mevt <- readTVar m + case mevt of + Nothing -> retry + Just evt' -> + if evt' `eventIs` evtClose + then throwSTM $ errnoToIOError "threadWaitSTM" eBADF Nothing Nothing + else return () + return (waitAction, unregisterFd_ mgr reg >> return ()) + +-- | Allows a thread to use an STM action to wait for a file descriptor to be readable. +-- The STM action will retry until the file descriptor has data ready. +-- The second element of the return value pair is an IO action that can be used +-- to deregister interest in the file descriptor. +-- +-- The STM action will throw an 'IOError' if the file descriptor was closed +-- while the STM action is being executed. To safely close a file descriptor +-- that has been used with 'threadWaitReadSTM', use 'closeFdWith'. +threadWaitReadSTM :: Fd -> IO (STM (), IO ()) +threadWaitReadSTM = threadWaitSTM evtRead +{-# INLINE threadWaitReadSTM #-} + +-- | Allows a thread to use an STM action to wait until a file descriptor can accept a write. +-- The STM action will retry while the file until the given file descriptor can accept a write. +-- The second element of the return value pair is an IO action that can be used to deregister +-- interest in the file descriptor. +-- +-- The STM action will throw an 'IOError' if the file descriptor was closed +-- while the STM action is being executed. To safely close a file descriptor +-- that has been used with 'threadWaitWriteSTM', use 'closeFdWith'. +threadWaitWriteSTM :: Fd -> IO (STM (), IO ()) +threadWaitWriteSTM = threadWaitSTM evtWrite +{-# INLINE threadWaitWriteSTM #-} + + +-- | Retrieve the system event manager for the capability on which the +-- calling thread is running. +-- +-- This function always returns 'Just' the current thread's event manager +-- when using the threaded RTS and 'Nothing' otherwise. +getSystemEventManager :: IO (Maybe EventManager) +getSystemEventManager = do + t <- myThreadId + (cap, _) <- threadCapability t + eventManagerArray <- readIORef eventManager + mmgr <- readIOArray eventManagerArray cap + return $ fmap snd mmgr + +getSystemEventManager_ :: IO EventManager +getSystemEventManager_ = do + Just mgr <- getSystemEventManager + return mgr +{-# INLINE getSystemEventManager_ #-} + +foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore" + getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a) + +eventManager :: IORef (IOArray Int (Maybe (ThreadId, EventManager))) +eventManager = unsafePerformIO $ do + numCaps <- getNumCapabilities + eventManagerArray <- newIOArray (0, numCaps - 1) Nothing + em <- newIORef eventManagerArray + sharedCAF em getOrSetSystemEventThreadEventManagerStore +{-# NOINLINE eventManager #-} + +numEnabledEventManagers :: IORef Int +numEnabledEventManagers = unsafePerformIO $ do + newIORef 0 +{-# NOINLINE numEnabledEventManagers #-} + +foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore" + getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a) + +-- | The ioManagerLock protects the 'eventManager' value: +-- Only one thread at a time can start or shutdown event managers. +{-# NOINLINE ioManagerLock #-} +ioManagerLock :: MVar () +ioManagerLock = unsafePerformIO $ do + m <- newMVar () + sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore + +getSystemTimerManager :: IO TM.TimerManager +getSystemTimerManager = do + Just mgr <- readIORef timerManager + return mgr + +foreign import ccall unsafe "getOrSetSystemTimerThreadEventManagerStore" + getOrSetSystemTimerThreadEventManagerStore :: Ptr a -> IO (Ptr a) + +timerManager :: IORef (Maybe TM.TimerManager) +timerManager = unsafePerformIO $ do + em <- newIORef Nothing + sharedCAF em getOrSetSystemTimerThreadEventManagerStore +{-# NOINLINE timerManager #-} + +foreign import ccall unsafe "getOrSetSystemTimerThreadIOManagerThreadStore" + getOrSetSystemTimerThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a) + +{-# NOINLINE timerManagerThreadVar #-} +timerManagerThreadVar :: MVar (Maybe ThreadId) +timerManagerThreadVar = unsafePerformIO $ do + m <- newMVar Nothing + sharedCAF m getOrSetSystemTimerThreadIOManagerThreadStore + +ensureIOManagerIsRunning :: IO () +ensureIOManagerIsRunning + | not threaded = return () + | otherwise = do + startIOManagerThreads + startTimerManagerThread + +startIOManagerThreads :: IO () +startIOManagerThreads = + withMVar ioManagerLock $ \_ -> do + eventManagerArray <- readIORef eventManager + let (_, high) = boundsIOArray eventManagerArray + mapM_ (startIOManagerThread eventManagerArray) [0..high] + writeIORef numEnabledEventManagers (high+1) + +show_int :: Int -> String +show_int i = showSignedInt 0 i "" + +restartPollLoop :: EventManager -> Int -> IO ThreadId +restartPollLoop mgr i = do + M.release mgr + !t <- forkOn i $ loop mgr + labelThread t ("IOManager on cap " ++ show_int i) + return t + +startIOManagerThread :: IOArray Int (Maybe (ThreadId, EventManager)) + -> Int + -> IO () +startIOManagerThread eventManagerArray i = do + let create = do + !mgr <- new + !t <- forkOn i $ do + c_setIOManagerControlFd + (fromIntegral i) + (fromIntegral $ controlWriteFd $ M.emControl mgr) + loop mgr + labelThread t ("IOManager on cap " ++ show_int i) + writeIOArray eventManagerArray i (Just (t,mgr)) + old <- readIOArray eventManagerArray i + case old of + Nothing -> create + Just (t,em) -> do + s <- threadStatus t + case s of + ThreadFinished -> create + ThreadDied -> do + -- Sanity check: if the thread has died, there is a chance + -- that event manager is still alive. This could happend during + -- the fork, for example. In this case we should clean up + -- open pipes and everything else related to the event manager. + -- See #4449 + c_setIOManagerControlFd (fromIntegral i) (-1) + M.cleanup em + create + _other -> return () + +startTimerManagerThread :: IO () +startTimerManagerThread = modifyMVar_ timerManagerThreadVar $ \old -> do + let create = do + !mgr <- TM.new + c_setTimerManagerControlFd + (fromIntegral $ controlWriteFd $ TM.emControl mgr) + writeIORef timerManager $ Just mgr + !t <- forkIO $ TM.loop mgr + labelThread t "TimerManager" + return $ Just t + case old of + Nothing -> create + st@(Just t) -> do + s <- threadStatus t + case s of + ThreadFinished -> create + ThreadDied -> do + -- Sanity check: if the thread has died, there is a chance + -- that event manager is still alive. This could happend during + -- the fork, for example. In this case we should clean up + -- open pipes and everything else related to the event manager. + -- See #4449 + mem <- readIORef timerManager + _ <- case mem of + Nothing -> return () + Just em -> do c_setTimerManagerControlFd (-1) + TM.cleanup em + create + _other -> return st + +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool + +ioManagerCapabilitiesChanged :: IO () +ioManagerCapabilitiesChanged = do + withMVar ioManagerLock $ \_ -> do + new_n_caps <- getNumCapabilities + numEnabled <- readIORef numEnabledEventManagers + writeIORef numEnabledEventManagers new_n_caps + eventManagerArray <- readIORef eventManager + let (_, high) = boundsIOArray eventManagerArray + let old_n_caps = high + 1 + if new_n_caps > old_n_caps + then do new_eventManagerArray <- newIOArray (0, new_n_caps - 1) Nothing + + -- copy the existing values into the new array: + forM_ [0..high] $ \i -> do + Just (tid,mgr) <- readIOArray eventManagerArray i + if i < numEnabled + then writeIOArray new_eventManagerArray i (Just (tid,mgr)) + else do tid' <- restartPollLoop mgr i + writeIOArray new_eventManagerArray i (Just (tid',mgr)) + + -- create new IO managers for the new caps: + forM_ [old_n_caps..new_n_caps-1] $ + startIOManagerThread new_eventManagerArray + + -- update the event manager array reference: + writeIORef eventManager new_eventManagerArray + else when (new_n_caps > numEnabled) $ + forM_ [numEnabled..new_n_caps-1] $ \i -> do + Just (_,mgr) <- readIOArray eventManagerArray i + tid <- restartPollLoop mgr i + writeIOArray eventManagerArray i (Just (tid,mgr)) + +-- Used to tell the RTS how it can send messages to the I/O manager. +foreign import ccall unsafe "setIOManagerControlFd" + c_setIOManagerControlFd :: CUInt -> CInt -> IO () + +foreign import ccall unsafe "setTimerManagerControlFd" + c_setTimerManagerControlFd :: CInt -> IO () diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs new file mode 100644 index 0000000..93b1766 --- /dev/null +++ b/libraries/base/GHC/Event/TimerManager.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns + , CPP + , ExistentialQuantification + , NoImplicitPrelude + , TypeSynonymInstances + , FlexibleInstances + #-} + +module GHC.Event.TimerManager + ( -- * Types + TimerManager + + -- * Creation + , new + , newWith + , newDefaultBackend + , emControl + + -- * Running + , finished + , loop + , step + , shutdown + , cleanup + , wakeManager + + -- * Registering interest in timeout events + , TimeoutCallback + , TimeoutKey + , registerTimeout + , updateTimeout + , unregisterTimeout + ) where + +#include "EventConfig.h" + +------------------------------------------------------------------------ +-- Imports + +import Control.Exception (finally) +import Data.Foldable (sequence_) +import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef, + writeIORef) +import GHC.Base +import GHC.Conc.Signal (runHandlers) +import GHC.Num (Num(..)) +import GHC.Real ((/), fromIntegral ) +import GHC.Show (Show(..)) +import GHC.Event.Clock (getMonotonicTime) +import GHC.Event.Control +import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..)) +import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique) +import System.Posix.Types (Fd) + +import qualified GHC.Event.Internal as I +import qualified GHC.Event.PSQ as Q + +#if defined(HAVE_POLL) +import qualified GHC.Event.Poll as Poll +#else +# error not implemented for this operating system +#endif + +------------------------------------------------------------------------ +-- Types + +-- | A timeout registration cookie. +newtype TimeoutKey = TK Unique + deriving (Eq) + +-- | Callback invoked on timeout events. +type TimeoutCallback = IO () + +data State = Created + | Running + | Dying + | Finished + deriving (Eq, Show) + +-- | A priority search queue, with timeouts as priorities. +type TimeoutQueue = Q.PSQ TimeoutCallback + +-- | An edit to apply to a 'TimeoutQueue'. +type TimeoutEdit = TimeoutQueue -> TimeoutQueue + +-- | The event manager state. +data TimerManager = TimerManager + { emBackend :: !Backend + , emTimeouts :: {-# UNPACK #-} !(IORef TimeoutQueue) + , emState :: {-# UNPACK #-} !(IORef State) + , emUniqueSource :: {-# UNPACK #-} !UniqueSource + , emControl :: {-# UNPACK #-} !Control + } + +------------------------------------------------------------------------ +-- Creation + +handleControlEvent :: TimerManager -> Fd -> Event -> IO () +handleControlEvent mgr fd _evt = do + msg <- readControlMessage (emControl mgr) fd + case msg of + CMsgWakeup -> return () + CMsgDie -> writeIORef (emState mgr) Finished + CMsgSignal fp s -> runHandlers fp s + +newDefaultBackend :: IO Backend +#if defined(HAVE_POLL) +newDefaultBackend = Poll.new +#else +newDefaultBackend = errorWithoutStackTrace "no back end for this platform" +#endif + +-- | Create a new event manager. +new :: IO TimerManager +new = newWith =<< newDefaultBackend + +newWith :: Backend -> IO TimerManager +newWith be = do + timeouts <- newIORef Q.empty + ctrl <- newControl True + state <- newIORef Created + us <- newSource + _ <- mkWeakIORef state $ do + st <- atomicModifyIORef' state $ \s -> (Finished, s) + when (st /= Finished) $ do + I.delete be + closeControl ctrl + let mgr = TimerManager { emBackend = be + , emTimeouts = timeouts + , emState = state + , emUniqueSource = us + , emControl = ctrl + } + _ <- I.modifyFd be (controlReadFd ctrl) mempty evtRead + _ <- I.modifyFd be (wakeupReadFd ctrl) mempty evtRead + return mgr + +-- | Asynchronously shuts down the event manager, if running. +shutdown :: TimerManager -> IO () +shutdown mgr = do + state <- atomicModifyIORef' (emState mgr) $ \s -> (Dying, s) + when (state == Running) $ sendDie (emControl mgr) + +finished :: TimerManager -> IO Bool +finished mgr = (== Finished) `liftM` readIORef (emState mgr) + +cleanup :: TimerManager -> IO () +cleanup mgr = do + writeIORef (emState mgr) Finished + I.delete (emBackend mgr) + closeControl (emControl mgr) + +------------------------------------------------------------------------ +-- Event loop + +-- | Start handling events. This function loops until told to stop, +-- using 'shutdown'. +-- +-- /Note/: This loop can only be run once per 'TimerManager', as it +-- closes all of its control resources when it finishes. +loop :: TimerManager -> IO () +loop mgr = do + state <- atomicModifyIORef' (emState mgr) $ \s -> case s of + Created -> (Running, s) + _ -> (s, s) + case state of + Created -> go `finally` cleanup mgr + Dying -> cleanup mgr + _ -> do cleanup mgr + errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++ + show state + where + go = do running <- step mgr + when running go + +step :: TimerManager -> IO Bool +step mgr = do + timeout <- mkTimeout + _ <- I.poll (emBackend mgr) (Just timeout) (handleControlEvent mgr) + state <- readIORef (emState mgr) + state `seq` return (state == Running) + where + + -- | Call all expired timer callbacks and return the time to the + -- next timeout. + mkTimeout :: IO Timeout + mkTimeout = do + now <- getMonotonicTime + (expired, timeout) <- atomicModifyIORef' (emTimeouts mgr) $ \tq -> + let (expired, tq') = Q.atMost now tq + timeout = case Q.minView tq' of + Nothing -> Forever + Just (Q.E _ t _, _) -> + -- This value will always be positive since the call + -- to 'atMost' above removed any timeouts <= 'now' + let t' = t - now in t' `seq` Timeout t' + in (tq', (expired, timeout)) + sequence_ $ map Q.value expired + return timeout + +-- | Wake up the event manager. +wakeManager :: TimerManager -> IO () +wakeManager mgr = sendWakeup (emControl mgr) + +------------------------------------------------------------------------ +-- Registering interest in timeout events + +-- | Register a timeout in the given number of microseconds. The +-- returned 'TimeoutKey' can be used to later unregister or update the +-- timeout. The timeout is automatically unregistered after the given +-- time has passed. +registerTimeout :: TimerManager -> Int -> TimeoutCallback -> IO TimeoutKey +registerTimeout mgr us cb = do + !key <- newUnique (emUniqueSource mgr) + if us <= 0 then cb + else do + now <- getMonotonicTime + let expTime = fromIntegral us / 1000000.0 + now + + editTimeouts mgr (Q.insert key expTime cb) + wakeManager mgr + return $ TK key + +-- | Unregister an active timeout. +unregisterTimeout :: TimerManager -> TimeoutKey -> IO () +unregisterTimeout mgr (TK key) = do + editTimeouts mgr (Q.delete key) + wakeManager mgr + +-- | Update an active timeout to fire in the given number of +-- microseconds. +updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO () +updateTimeout mgr (TK key) us = do + now <- getMonotonicTime + let expTime = fromIntegral us / 1000000.0 + now + + editTimeouts mgr (Q.adjust (const expTime) key) + wakeManager mgr + +editTimeouts :: TimerManager -> TimeoutEdit -> IO () +editTimeouts mgr g = atomicModifyIORef' (emTimeouts mgr) $ \tq -> (g tq, ()) + diff --git a/libraries/base/GHC/Event/Unique.hs b/libraries/base/GHC/Event/Unique.hs new file mode 100644 index 0000000..d3af627 --- /dev/null +++ b/libraries/base/GHC/Event/Unique.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, NoImplicitPrelude #-} + +module GHC.Event.Unique + ( + UniqueSource + , Unique(..) + , newSource + , newUnique + ) where + +import Data.Int (Int64) +import GHC.Base +import GHC.Conc.Sync (TVar, atomically, newTVarIO, readTVar, writeTVar) +import GHC.Num (Num(..)) +import GHC.Show (Show(..)) + +-- We used to use IORefs here, but Simon switched us to STM when we +-- found that our use of atomicModifyIORef was subject to a severe RTS +-- performance problem when used in a tight loop from multiple +-- threads: http://ghc.haskell.org/trac/ghc/ticket/3838 +-- +-- There seems to be no performance cost to using a TVar instead. + +newtype UniqueSource = US (TVar Int64) + +newtype Unique = Unique { asInt64 :: Int64 } + deriving (Eq, Ord, Num) + +instance Show Unique where + show = show . asInt64 + +newSource :: IO UniqueSource +newSource = US `fmap` newTVarIO 0 + +newUnique :: UniqueSource -> IO Unique +newUnique (US ref) = atomically $ do + u <- readTVar ref + let !u' = u+1 + writeTVar ref u' + return $ Unique u' +{-# INLINE newUnique #-} + diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs new file mode 100644 index 0000000..be9e6f9 --- /dev/null +++ b/libraries/base/GHC/Exception.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude + , ExistentialQuantification + , MagicHash + , RecordWildCards + , PatternSynonyms + #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Exception +-- 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