base 4.6.0.1 → 4.7.0.0

raw patch · 220 files changed

+32232/−30440 lines, 220 filesdep ~ghc-primdep ~integer-gmpdep ~integer-simplenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc-prim, integer-gmp, integer-simple, rts

API changes (from Hackage documentation)

Files

• Control/Applicative.hs +43/−30
• Control/Arrow.hs +5/−0
• Control/Category.hs +15/−0
• Control/Concurrent.hs +98/−130
• Control/Concurrent/Chan.hs +11/−17
• Control/Concurrent/MVar.hs +47/−47
• Control/Concurrent/QSem.hs +93/−53
• Control/Concurrent/QSemN.hs +86/−44
• Control/Concurrent/SampleVar.hs +0/−137
• Control/Exception.hs +13/−30
• Control/Exception/Base.hs +10/−322
• Control/Monad.hs +34/−39
• Control/Monad/Fix.hs +2/−15
• Control/Monad/Instances.hs +2/−4
• Control/Monad/ST.hs +7/−25
• Control/Monad/ST/Imp.hs +6/−39
• Control/Monad/ST/Lazy.hs +0/−17
• Control/Monad/ST/Lazy/Imp.hs +1/−14
• Control/Monad/ST/Safe.hs +4/−4
• Control/Monad/Zip.hs +1/−0
• Data/Bits.hs +161/−159
• Data/Bool.hs +14/−18
• Data/Char.hs +9/−42
• Data/Coerce.hs +27/−0
• Data/Complex.hs +10/−40
• Data/Data.hs +189/−133
• Data/Dynamic.hs +5/−31
• Data/Either.hs +31/−16
• Data/Eq.hs +1/−4
• Data/Fixed.hs +17/−52
• Data/Foldable.hs +34/−21
• Data/Functor.hs +11/−6
• Data/HashTable.hs +0/−536
• Data/IORef.hs +17/−42
• Data/Int.hs +1/−14
• Data/Ix.hs +4/−16
• Data/List.hs +112/−143
• Data/Maybe.hs +22/−32
• Data/Monoid.hs +21/−12
• Data/OldTypeable.hs +179/−0
• Data/OldTypeable/Internal.hs +475/−0
• Data/OldTypeable/Internal.hs-boot +28/−0
• Data/Ord.hs +8/−4
• Data/Proxy.hs +88/−0
• Data/Ratio.hs +4/−27
• Data/STRef.hs +8/−17
• Data/STRef/Lazy.hs +5/−5
• Data/String.hs +2/−7
• Data/Traversable.hs +92/−11
• Data/Tuple.hs +6/−51
• Data/Type/Bool.hs +56/−0
• Data/Type/Coercion.hs +101/−0
• Data/Type/Equality.hs +227/−0
• Data/Typeable.hs +59/−133
• Data/Typeable.hs-boot +0/−10
• Data/Typeable/Internal.hs +114/−330
• Data/Typeable/Internal.hs-boot +5/−3
• Data/Unique.hs +10/−20
• Data/Version.hs +2/−34
• Data/Word.hs +4/−13
• Debug/Trace.hs +127/−31
• Foreign.hs +0/−17
• Foreign/C/Error.hs +19/−63
• Foreign/C/String.hs +29/−113
• Foreign/C/Types.hs +39/−110
• Foreign/Concurrent.hs +1/−4
• Foreign/ForeignPtr.hs +2/−18
• Foreign/ForeignPtr/Imp.hs +2/−64
• Foreign/ForeignPtr/Safe.hs +2/−8
• Foreign/ForeignPtr/Unsafe.hs +1/−1
• Foreign/Marshal.hs +1/−33
• Foreign/Marshal/Alloc.hs +10/−47
• Foreign/Marshal/Array.hs +21/−37
• Foreign/Marshal/Error.hs +7/−11
• Foreign/Marshal/Pool.hs +16/−29
• Foreign/Marshal/Safe.hs +1/−1
• Foreign/Marshal/Unsafe.hs +1/−5
• Foreign/Marshal/Utils.hs +11/−20
• Foreign/Ptr.hs +16/−74
• Foreign/StablePtr.hs +6/−23
• Foreign/Storable.hs +11/−48
• GHC/Arr.lhs +30/−31
• GHC/Base.lhs +58/−136
• GHC/Char.hs +1/−1
• GHC/Conc.lhs +45/−48
• GHC/Conc/IO.hs +59/−15
• GHC/Conc/Signal.hs +1/−1
• GHC/Conc/Sync.lhs +79/−89
• GHC/Conc/Windows.hs +6/−7
• GHC/ConsoleHandler.hs +1/−1
• GHC/Constants.hs +4/−6
• GHC/Desugar.hs +3/−4
• GHC/Enum.lhs +87/−65
• GHC/Environment.hs +1/−1
• GHC/Err.lhs +9/−35
• GHC/Err.lhs-boot +0/−22
• GHC/Event.hs +5/−9
• GHC/Event/Arr.hs +32/−0
• GHC/Event/Array.hs +4/−6
• GHC/Event/Clock.hsc +1/−1
• GHC/Event/Control.hs +13/−21
• GHC/Event/EPoll.hsc +49/−18
• GHC/Event/IntMap.hs +0/−376
• GHC/Event/IntTable.hs +141/−0
• GHC/Event/Internal.hs +30/−11
• GHC/Event/KQueue.hsc +105/−124
• GHC/Event/Manager.hs +263/−189
• GHC/Event/Poll.hsc +62/−16
• GHC/Event/Thread.hs +224/−33
• GHC/Event/TimerManager.hs +270/−0
• GHC/Exception.lhs +19/−7
• GHC/Exception.lhs-boot +38/−0
• GHC/Exts.hs +55/−8
• GHC/Fingerprint.hs +47/−10
• GHC/Fingerprint/Type.hs +12/−1
• GHC/Float.lhs +76/−51
• GHC/Float/ConversionUtils.hs +10/−9
• GHC/Float/RealFracMethods.hs +26/−28
• GHC/Foreign.hs +10/−11
• GHC/ForeignPtr.hs +71/−52
• GHC/GHCi.hs +0/−1
• GHC/Generics.hs +554/−7
• GHC/Handle.hs +0/−57
• GHC/IO.hs +8/−16
• GHC/IO/Buffer.hs +5/−5
• GHC/IO/BufferedIO.hs +1/−1
• GHC/IO/Device.hs +1/−9
• GHC/IO/Encoding.hs +36/−5
• GHC/IO/Encoding/CodePage.hs +8/−6
• GHC/IO/Encoding/CodePage/API.hs +426/−0
• GHC/IO/Encoding/CodePage/Table.hs +1/−1
• GHC/IO/Encoding/Failure.hs +1/−1
• GHC/IO/Encoding/Iconv.hs +5/−4
• GHC/IO/Encoding/Latin1.hs +2/−0
• GHC/IO/Encoding/Types.hs +13/−15
• GHC/IO/Encoding/UTF16.hs +4/−2
• GHC/IO/Encoding/UTF32.hs +3/−0
• GHC/IO/Encoding/UTF8.hs +3/−1
• GHC/IO/Exception.hs +46/−17
• GHC/IO/FD.hs +10/−6
• GHC/IO/Handle/FD.hs +4/−2
• GHC/IO/Handle/Internals.hs +38/−11
• GHC/IO/Handle/Text.hs +6/−12
• GHC/IOArray.hs +3/−2
• GHC/IOBase.hs +0/−93
• GHC/IORef.hs +3/−2
• GHC/IP.hs +2/−0
• GHC/Int.hs +112/−95
• GHC/List.lhs +72/−43
• GHC/MVar.hs +51/−12
• GHC/Num.lhs +1/−1
• GHC/PArr.hs +0/−1
• GHC/Pack.lhs +3/−4
• GHC/Profiling.hs +5/−0
• GHC/Ptr.lhs +3/−2
• GHC/Read.lhs +38/−46
• GHC/Real.lhs +59/−16
• GHC/ST.lhs +1/−2
• GHC/STRef.lhs +1/−2
• GHC/Show.lhs +13/−13
• GHC/Stable.lhs +8/−8
• GHC/Stack.hsc +20/−1
• GHC/Stats.hsc +9/−2
• GHC/Storable.lhs +0/−1
• GHC/TopHandler.lhs +36/−20
• GHC/TypeLits.hs +161/−120
• GHC/Unicode.hs +1/−3
• GHC/Weak.lhs +2/−7
• GHC/Windows.hs +159/−12
• GHC/Word.hs +128/−86
• Numeric.hs +46/−34
• Prelude.hs +3/−29
• System/CPUTime.hsc +5/−39
• System/Console/GetOpt.hs +13/−0
• System/Environment.hs +106/−29
• System/Environment/ExecutablePath.hsc +4/−1
• System/Exit.hs +3/−22
• System/IO.hs +66/−170
• System/IO/Error.hs +26/−145
• System/IO/Unsafe.hs +6/−17
• System/Info.hs +9/−27
• System/Mem.hs +16/−19
• System/Mem/StableName.hs +13/−12
• System/Mem/Weak.hs +7/−15
• System/Posix/Internals.hs +13/−46
• System/Posix/Internals.hs-boot +0/−9
• System/Posix/Types.hs +14/−46
• System/Timeout.hs +48/−18
• Text/ParserCombinators/ReadP.hs +37/−87
• Text/ParserCombinators/ReadPrec.hs +18/−20
• Text/Printf.hs +768/−185
• Text/Read.hs +19/−43
• Text/Read/Lex.hs +39/−21
• Text/Show.hs +8/−24
• Text/Show/Functions.hs +0/−11
• Unsafe/Coerce.hs +25/−13
• aclocal.m4 +36/−38
• base.buildinfo.in +4/−0
• base.cabal +271/−198
• cbits/DarwinUtils.c +2/−1
• cbits/SetEnv.c +11/−0
• cbits/Win32Utils.c +38/−23
• cbits/md5.c +14/−14
• cbits/sysconf.c +19/−0
• changelog.md +145/−0
• config.guess +337/−279
• config.sub +287/−104
• configure +21820/−21656
• configure.ac +25/−3
• include/CTypes.h +10/−176
• include/EventConfig.h +0/−92
• include/EventConfig.h.in +91/−0
• include/HsBase.h +1/−21
• include/HsBaseConfig.h +0/−611
• include/HsBaseConfig.h.in +624/−0
• include/OldTypeable.h +29/−0
• include/Typeable.h +8/−100
• include/ieee-flpt.h +35/−0
• include/md5.h +4/−4
• install-sh +136/−116

@@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DeriveGeneric #-}  ----------------------------------------------------------------------------- -- |@@ -28,9 +29,9 @@ -- it admits more sharing than the monadic interface.  The names here are -- mostly based on parsing work by Doaitse Swierstra. ----- For more details, see /Applicative Programming with Effects/,--- by Conor McBride and Ross Paterson, online at--- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.+-- For more details, see+-- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html Applicative Programming with Effects>,+-- by Conor McBride and Ross Paterson.  module Control.Applicative (     -- * Applicative functors@@ -50,26 +51,17 @@ import Control.Category import Control.Arrow import Control.Monad (liftM, ap, MonadPlus(..))-#ifndef __NHC__ import Control.Monad.ST.Safe (ST) import qualified Control.Monad.ST.Lazy.Safe as Lazy (ST)-#endif import Data.Functor ((<$>), (<$)) import Data.Monoid (Monoid(..))--import Text.ParserCombinators.ReadP-#ifndef __NHC__-  (ReadP)-#else-  (ReadPN)-#define ReadP (ReadPN b)-#endif+import Data.Proxy +import Text.ParserCombinators.ReadP (ReadP) import Text.ParserCombinators.ReadPrec (ReadPrec) -#ifdef __GLASGOW_HASKELL__ import GHC.Conc (STM, retry, orElse)-#endif+import GHC.Generics  infixl 3 <|> infixl 4 <*>, <*, *>, <**>@@ -84,34 +76,39 @@ -- 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--- @+--   * @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--- @+--   * @'fmap' f x = 'pure' f '<*>' x@ ----- If @f@ is also a 'Monad', it should satisfy @'pure' = 'return'@ and--- @('<*>') = 'ap'@ (which implies that 'pure' and '<*>' satisfy the--- applicative functor laws).+-- 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.@@ -181,7 +178,6 @@     pure = return     (<*>) = ap -#ifndef __NHC__ instance Applicative (ST s) where     pure = return     (<*>) = ap@@ -189,9 +185,7 @@ instance Applicative (Lazy.ST s) where     pure = return     (<*>) = ap-#endif -#ifdef __GLASGOW_HASKELL__ instance Applicative STM where     pure = return     (<*>) = ap@@ -199,7 +193,6 @@ instance Alternative STM where     empty = retry     (<|>) = orElse-#endif  instance Applicative ((->) a) where     pure = const@@ -241,15 +234,22 @@ -- new instances  newtype Const a b = Const { getConst :: a }+                  deriving (Generic, Generic1)  instance Functor (Const m) where     fmap _ (Const v) = Const v +-- Added in base-4.7.0.0+instance Monoid a => Monoid (Const a b) where+    mempty = Const mempty+    mappend (Const a) (Const b) = Const (mappend a b)+ instance Monoid m => Applicative (Const m) where     pure _ = Const mempty     Const f <*> Const v = Const (f `mappend` v)  newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }+                         deriving (Generic, Generic1)  instance Monad m => Functor (WrappedMonad m) where     fmap f (WrapMonad v) = WrapMonad (liftM f v)@@ -258,11 +258,17 @@     pure = WrapMonad . return     WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v) +-- Added in base-4.7.0.0 (GHC Trac #8218)+instance Monad m => Monad (WrappedMonad m) where+    return = WrapMonad . return+    a >>= f = WrapMonad (unwrapMonad a >>= unwrapMonad . f)+ 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)@@ -280,6 +286,7 @@ -- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@ -- newtype ZipList a = ZipList { getZipList :: [a] }+                  deriving (Show, Eq, Ord, Read, Generic, Generic1)  instance Functor ZipList where     fmap f (ZipList xs) = ZipList (map f xs)@@ -287,6 +294,12 @@ instance Applicative ZipList where     pure x = ZipList (repeat x)     ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs)++instance Applicative Proxy where+    pure _ = Proxy+    {-# INLINE pure #-}+    _ <*> _ = Proxy+    {-# INLINE (<*>) #-}  -- extra functions 

@@ -10,11 +10,15 @@ -- 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 -- <http://www.haskell.org/arrows/>. @@ -186,6 +190,7 @@  -- | Choice, for arrows that support it.  This class underlies the -- @if@ and @case@ constructs in arrow notation.+-- -- Minimal complete definition: 'left', satisfying the laws -- --  * @'left' ('arr' f) = 'arr' ('left' f)@

@@ -1,6 +1,10 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds, GADTs #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Category@@ -16,6 +20,9 @@ module Control.Category where  import qualified Prelude+import Data.Type.Coercion+import Data.Type.Equality+import GHC.Prim (coerce)  infixr 9 . infixr 1 >>>, <<<@@ -41,6 +48,14 @@ instance Category (->) where     id = Prelude.id     (.) = (Prelude..)++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

@@ -1,6 +1,5 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP-           , ForeignFunctionInterface            , MagicHash            , UnboxedTuples            , ScopedTypeVariables@@ -15,7 +14,7 @@ -- 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)@@ -33,17 +32,13 @@         -- * Basic concurrency operations          ThreadId,-#ifdef __GLASGOW_HASKELL__         myThreadId,-#endif          forkIO,-#ifdef __GLASGOW_HASKELL__         forkFinally,         forkIOWithUnmask,         killThread,         throwTo,-#endif          -- ** Threads with affinity         forkOn,@@ -54,19 +49,19 @@          -- * Scheduling -        -- $conc_scheduling     -        yield,                  -- :: IO ()+        -- $conc_scheduling+        yield,          -- ** Blocking          -- $blocking -#ifdef __GLASGOW_HASKELL__         -- ** Waiting-        threadDelay,            -- :: Int -> IO ()-        threadWaitRead,         -- :: Int -> IO ()-        threadWaitWrite,        -- :: Int -> IO ()-#endif+        threadDelay,+        threadWaitRead,+        threadWaitWrite,+        threadWaitReadSTM,+        threadWaitWriteSTM,          -- * Communication abstractions @@ -74,16 +69,7 @@         module Control.Concurrent.Chan,         module Control.Concurrent.QSem,         module Control.Concurrent.QSemN,-        module Control.Concurrent.SampleVar, -        -- * Merging of streams-#ifndef __HUGS__-        mergeIO,                -- :: [a]   -> [a] -> IO [a]-        nmergeIO,               -- :: [[a]] -> IO [a]-#endif-        -- $merge--#ifdef __GLASGOW_HASKELL__         -- * Bound Threads         -- $boundthreads         rtsSupportsBoundThreads,@@ -91,7 +77,6 @@         isCurrentThreadBound,         runInBoundThread,         runInUnboundThread,-#endif          -- * Weak references to ThreadIds         mkWeakThreadId,@@ -113,18 +98,19 @@          -- $preemption -        -- * Deprecated functions-        forkIOUnmasked+        -- ** Deadlock +        -- $deadlock+     ) where  import Prelude  import Control.Exception.Base as Exception -#ifdef __GLASGOW_HASKELL__ import GHC.Exception-import GHC.Conc hiding (threadWaitRead, threadWaitWrite)+import GHC.Conc hiding (threadWaitRead, threadWaitWrite,+                        threadWaitReadSTM, threadWaitWriteSTM) import qualified GHC.Conc import GHC.IO           ( IO(..), unsafeInterleaveIO, unsafeUnmask ) import GHC.IORef        ( newIORef, readIORef, writeIORef )@@ -133,28 +119,19 @@ import System.Posix.Types ( Fd ) import Foreign.StablePtr import Foreign.C.Types-import Control.Monad    ( when )+import Control.Monad  #ifdef mingw32_HOST_OS import Foreign.C import System.IO-#endif-#endif--#ifdef __HUGS__-import Hugs.ConcBase+import Data.Maybe (Maybe(..)) #endif  import Control.Concurrent.MVar import Control.Concurrent.Chan import Control.Concurrent.QSem import Control.Concurrent.QSemN-import Control.Concurrent.SampleVar -#ifdef __HUGS__-type ThreadId = ()-#endif- {- $conc_intro  The concurrency extension for Haskell is described in the paper@@ -193,7 +170,7 @@     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.  +    simple graphical user interfaces. -}  {- $blocking@@ -205,8 +182,6 @@ not.  With the @-threaded@ option, only foreign calls with the @unsafe@ attribute will block all other threads. -Using Hugs, all I\/O operations and foreign calls will block all other-Haskell threads. -}  -- | fork a thread and call the supplied function when the thread is about@@ -220,91 +195,12 @@ -- 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 --- -------------------------------------------------------------------------------- Merging streams--#ifndef __HUGS__-max_buff_size :: Int-max_buff_size = 1--{-# DEPRECATED mergeIO "Control.Concurrent.mergeIO will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}-{-# DEPRECATED nmergeIO "Control.Concurrent.nmergeIO will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}-mergeIO :: [a] -> [a] -> IO [a]-nmergeIO :: [[a]] -> IO [a]---- $merge--- The 'mergeIO' and 'nmergeIO' functions fork one thread for each--- input list that concurrently evaluates that list; the results are--- merged into a single output list.  ------ Note: Hugs does not provide these functions, since they require--- preemptive multitasking.--mergeIO ls rs- = newEmptyMVar                >>= \ tail_node ->-   newMVar tail_node           >>= \ tail_list ->-   newQSem max_buff_size       >>= \ e ->-   newMVar 2                   >>= \ branches_running ->-   let-    buff = (tail_list,e)-   in-    forkIO (suckIO branches_running buff ls) >>-    forkIO (suckIO branches_running buff rs) >>-    takeMVar tail_node  >>= \ val ->-    signalQSem e        >>-    return val--type Buffer a- = (MVar (MVar [a]), QSem)--suckIO :: MVar Int -> Buffer a -> [a] -> IO ()--suckIO branches_running buff@(tail_list,e) vs- = case vs of-        [] -> takeMVar branches_running >>= \ val ->-              if val == 1 then-                 takeMVar tail_list     >>= \ node ->-                 putMVar node []        >>-                 putMVar tail_list node-              else-                 putMVar branches_running (val-1)-        (x:xs) ->-                waitQSem e                       >>-                takeMVar tail_list               >>= \ node ->-                newEmptyMVar                     >>= \ next_node ->-                unsafeInterleaveIO (-                        takeMVar next_node  >>= \ y ->-                        signalQSem e        >>-                        return y)                >>= \ next_node_val ->-                putMVar node (x:next_node_val)   >>-                putMVar tail_list next_node      >>-                suckIO branches_running buff xs--nmergeIO lss- = let-    len = length lss-   in-    newEmptyMVar          >>= \ tail_node ->-    newMVar tail_node     >>= \ tail_list ->-    newQSem max_buff_size >>= \ e ->-    newMVar len           >>= \ branches_running ->-    let-     buff = (tail_list,e)-    in-    mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>-    takeMVar tail_node  >>= \ val ->-    signalQSem e        >>-    return val-  where-    mapIO f xs = sequence (map f xs)-#endif /* __HUGS__ */--#ifdef __GLASGOW_HASKELL__ -- --------------------------------------------------------------------------- -- Bound Threads @@ -332,7 +228,7 @@ 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/ - +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@@ -362,7 +258,7 @@ 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.@@ -430,10 +326,10 @@ isCurrentThreadBound :: IO Bool isCurrentThreadBound = IO $ \ s# ->     case isCurrentThreadBound# s# of-        (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)+        (# 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.@@ -458,7 +354,7 @@                   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.@@ -489,9 +385,7 @@  unsafeResult :: Either SomeException a -> IO a unsafeResult = either Exception.throwIO return-#endif /* __GLASGOW_HASKELL__ */ -#ifdef __GLASGOW_HASKELL__ -- --------------------------------------------------------------------------- -- threadWaitRead/threadWaitWrite @@ -536,7 +430,55 @@   = 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 = error "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 = error "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@@ -635,7 +577,7 @@  >    children :: MVar [MVar ()] >    children = unsafePerformIO (newMVar [])->    +> >    waitForChildren :: IO () >    waitForChildren = do >      cs <- takeMVar children@@ -694,4 +636,30 @@       lock is woken up, but haven't found it to be useful for anything       other than this example :-) -}-#endif /* __GLASGOW_HASKELL__ */++{- $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'.+-}

@@ -1,8 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP #-}-#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif  ----------------------------------------------------------------------------- -- |@@ -24,16 +22,16 @@         Chan,                   -- abstract            -- * Operations-        newChan,                -- :: IO (Chan a)-        writeChan,              -- :: Chan a -> a -> IO ()-        readChan,               -- :: Chan a -> IO a-        dupChan,                -- :: Chan a -> IO (Chan a)-        unGetChan,              -- :: Chan a -> a -> IO ()-        isEmptyChan,            -- :: Chan a -> IO Bool+        newChan,+        writeChan,+        readChan,+        dupChan,+        unGetChan,+        isEmptyChan,            -- * Stream interface-        getChanContents,        -- :: Chan a -> IO [a]-        writeList2Chan,         -- :: Chan a -> [a] -> IO ()+        getChanContents,+        writeList2Chan,    ) where  import Prelude@@ -43,8 +41,6 @@ import Control.Exception (mask_) import Data.Typeable -#include "Typeable.h"- #define _UPK_(x) {-# UNPACK #-} !(x)  -- A channel is represented by two @MVar@s keeping track of the two ends@@ -55,9 +51,7 @@ data Chan a  = Chan _UPK_(MVar (Stream a))         _UPK_(MVar (Stream a)) -- Invariant: the Stream a is always an empty MVar-   deriving Eq--INSTANCE_TYPEABLE1(Chan,chanTc,"Chan")+   deriving (Eq,Typeable)  type Stream a = MVar (ChItem a) @@ -142,7 +136,7 @@    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 http://hackage.haskell.org/trac/ghc/ticket/4154 for details" #-}+{-# DEPRECATED unGetChan "if you need this operation, use Control.Concurrent.STM.TChan instead.  See <http://ghc.haskell.org/trac/ghc/ticket/4154> for details" #-} -- deprecated in 7.0  -- |Returns 'True' if the supplied 'Chan' is empty. isEmptyChan :: Chan a -> IO Bool@@ -151,7 +145,7 @@      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 http://hackage.haskell.org/trac/ghc/ticket/4154 for details" #-}+{-# DEPRECATED isEmptyChan "if you need this operation, use Control.Concurrent.STM.TChan instead.  See <http://ghc.haskell.org/trac/ghc/ticket/4154> for details" #-} -- deprecated in 7.0  -- Operators for interfacing with functional streams. 

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, UnboxedTuples, MagicHash #-}+{-# LANGUAGE NoImplicitPrelude, UnboxedTuples, MagicHash #-}  ----------------------------------------------------------------------------- -- |@@ -17,18 +17,22 @@ -- '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.+--   1. As synchronized mutable variables, ----- They were introduced in the paper "Concurrent Haskell" 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.)+--   2. As channels, with 'takeMVar' and 'putMVar' as receive and send, and ----- * Applicability+--   3. As a binary semaphore @'MVar' ()@, with 'takeMVar' and 'putMVar' as+--      wait and signal. --+-- They were introduced in the paper+-- <http://research.microsoft.com/~simonpj/papers/concurrent-haskell.ps.gz "Concurrent Haskell">+-- 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@@ -45,7 +49,7 @@ -- perform a 'takeMVar' before a 'putMVar' as well;  otherwise, they may -- block. ----- * Fairness+-- === Fairness -- -- No thread can be blocked indefinitely on an 'MVar' unless another -- thread holds that 'MVar' indefinitely.  One usual implementation of@@ -53,7 +57,7 @@ -- served in a first-in-first-out fashion, but this is not guaranteed -- in the semantics. ----- * Gotchas+-- === Gotchas -- -- Like many other Haskell data structures, 'MVar's are lazy.  This -- means that if you place an expensive unevaluated thunk inside an@@ -62,14 +66,14 @@ -- in an 'MVar' to the appropriate normal form, or utilize a strict -- MVar provided by the strict-concurrency package. ----- * Ordering+-- === 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+-- === Example -- -- Consider the following concurrent data structure, a skip channel. -- This is a channel for an intermittent source of high bandwidth@@ -135,52 +139,27 @@         , tryPutMVar         , isEmptyMVar         , withMVar+        , withMVarMasked         , modifyMVar_         , modifyMVar         , modifyMVarMasked_         , modifyMVarMasked-#ifndef __HUGS__+        , tryReadMVar         , mkWeakMVar-        , addMVarFinalizer -- :: MVar a -> IO () -> IO ()-#endif+        , addMVarFinalizer     ) where -#ifdef __HUGS__-import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,-                  tryTakeMVar, tryPutMVar, isEmptyMVar,-                )-#endif--#ifdef __GLASGOW_HASKELL__ import GHC.MVar ( MVar(..), newEmptyMVar, newMVar, takeMVar, putMVar,-                  tryTakeMVar, tryPutMVar, isEmptyMVar+                  tryTakeMVar, tryPutMVar, isEmptyMVar, readMVar,+                  tryReadMVar                 ) import qualified GHC.MVar import GHC.Weak-#endif--#ifdef __GLASGOW_HASKELL__ import GHC.Base-#else-import Prelude-#endif  import Control.Exception.Base  {-|-  This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value-  from the 'MVar', puts it back, and also returns it.  This function-  is atomic only if there are no other producers (i.e. threads calling-  'putMVar') for this 'MVar'.--}-readMVar :: MVar a -> IO a-readMVar m =-  mask_ $ do-    a <- takeMVar m-    putMVar m a-    return a--{-|   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'.@@ -211,6 +190,21 @@     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@@ -234,13 +228,15 @@ modifyMVar m io =   mask $ \restore -> do     a      <- takeMVar m-    (a',b) <- restore (io a) `onException` putMVar m a+    (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 ()@@ -253,22 +249,26 @@ {-|   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 `onException` putMVar m a+    (a',b) <- (io a >>= evaluate) `onException` putMVar m a     putMVar m a'     return b -{-# DEPRECATED addMVarFinalizer "use mkWeakMVar instead" #-}+{-# 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#) f = IO $ \s ->   case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #)

@@ -1,8 +1,6 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP #-}-#ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif+{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}  ----------------------------------------------------------------------------- -- |@@ -19,7 +17,6 @@ -----------------------------------------------------------------------------  module Control.Concurrent.QSem-        {-# DEPRECATED "Control.Concurrent.QSem will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}         ( -- * Simple Quantity Semaphores           QSem,         -- abstract           newQSem,      -- :: Int  -> IO QSem@@ -27,64 +24,107 @@           signalQSem    -- :: QSem -> IO ()         ) where -import Prelude-import Control.Concurrent.MVar-import Control.Exception ( mask_ )-import Data.Typeable--#include "Typeable.h"---- General semaphores are also implemented readily in terms of shared--- @MVar@s, only have to catch the case when the semaphore is tried--- waited on when it is empty (==0). Implement this in the same way as--- shared variables are implemented - maintaining a list of @MVar@s--- representing threads currently waiting. The counter is a shared--- variable, ensuring the mutual exclusion on its access.+import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar+                          , putMVar, newMVar, tryPutMVar)+import Control.Exception+import Data.Maybe --- |A 'QSem' is a simple quantity semaphore, in which the available--- \"quantity\" is always dealt with in units of one.-newtype QSem = QSem (MVar (Int, [MVar ()])) deriving Eq+-- | '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 ()])) -INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")+-- 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 =-    if initial < 0-    then fail "newQSem: Initial quantity must be non-negative"-    else do sem <- newMVar (initial, [])-            return (QSem sem)+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 sem) = mask_ $ do-   (avail,blocked) <- takeMVar sem  -- gain ex. access-   if avail > 0 then-     let avail' = avail-1-     in avail' `seq` putMVar sem (avail',[])-    else do-     b <- newEmptyMVar-      {--        Stuff the reader at the back of the queue,-        so as to preserve waiting order. A signalling-        process then only have to pick the MVar at the-        front of the blocked list.--        The version of waitQSem given in the paper could-        lead to starvation.-      -}-     putMVar sem (0, blocked++[b])-     takeMVar b+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 sem) = mask_ $ do-   (avail,blocked) <- takeMVar sem-   case blocked of-     [] -> let avail' = avail+1-           in avail' `seq` putMVar sem (avail',blocked)+signalQSem (QSem m) =+  uninterruptibleMask_ $ do -- Note [signal uninterruptible]+    r <- takeMVar m+    r' <- signal r+    putMVar m r' -     (b:blocked') -> do-           putMVar sem (0,blocked')-           putMVar b ()+-- 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

@@ -1,8 +1,6 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP #-}-#ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif+{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}  ----------------------------------------------------------------------------- -- |@@ -20,7 +18,6 @@ -----------------------------------------------------------------------------  module Control.Concurrent.QSemN-        {-# DEPRECATED "Control.Concurrent.QSemN will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}         (  -- * General Quantity Semaphores           QSemN,        -- abstract           newQSemN,     -- :: Int   -> IO QSemN@@ -28,55 +25,100 @@           signalQSemN   -- :: QSemN -> Int -> IO ()       ) where -import Prelude--import Control.Concurrent.MVar-import Control.Exception ( mask_ )+import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar+                          , putMVar, newMVar+                          , tryPutMVar, isEmptyMVar) import Data.Typeable--#include "Typeable.h"+import Control.Exception+import Data.Maybe --- |A 'QSemN' is a quantity semaphore, in which the available--- \"quantity\" may be signalled or waited for in arbitrary amounts.-newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())])) deriving Eq+-- | '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 ())]))+  deriving Typeable -INSTANCE_TYPEABLE0(QSemN,qSemNTc,"QSemN")+-- 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 =-    if initial < 0-    then fail "newQSemN: Initial quantity must be non-negative"-    else do sem <- newMVar (initial, [])-            return (QSemN sem)+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 sem) sz = mask_ $ do-  (avail,blocked) <- takeMVar sem   -- gain ex. access-  let remaining = avail - sz-  if remaining >= 0 then-       -- discharging 'sz' still leaves the semaphore-       -- in an 'unblocked' state.-     putMVar sem (remaining,blocked)-   else do-     b <- newEmptyMVar-     putMVar sem (avail, blocked++[(sz,b)])-     takeMVar b+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 sem) n = mask_ $ do-   (avail,blocked)   <- takeMVar sem-   (avail',blocked') <- free (avail+n) blocked-   avail' `seq` putMVar sem (avail',blocked')+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-   free avail []    = return (avail,[])-   free avail ((req,b):blocked)-     | avail >= req = do-        putMVar b ()-        free (avail-req) blocked-     | otherwise    = do-        (avail',blocked') <- free avail blocked-        return (avail',(req,b):blocked')+   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

@@ -1,137 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP #-}-#ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif---------------------------------------------------------------------------------- |--- Module      :  Control.Concurrent.SampleVar--- 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)------ Sample variables-----------------------------------------------------------------------------------module Control.Concurrent.SampleVar-        {-# DEPRECATED "Control.Concurrent.SampleVar will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}-       (-         -- * Sample Variables-         SampleVar,         -- :: type _ =- -         newEmptySampleVar, -- :: IO (SampleVar a)-         newSampleVar,      -- :: a -> IO (SampleVar a)-         emptySampleVar,    -- :: SampleVar a -> IO ()-         readSampleVar,     -- :: SampleVar a -> IO a-         writeSampleVar,    -- :: SampleVar a -> a -> IO ()-         isEmptySampleVar,  -- :: SampleVar a -> IO Bool--       ) where--import Prelude--import Control.Concurrent.MVar--import Control.Exception ( mask_ )--import Data.Functor ( (<$>) )--import Data.Typeable--#include "Typeable.h"---- |--- Sample variables are slightly different from a normal 'MVar':--- ---  * Reading an empty 'SampleVar' causes the reader to block.---    (same as 'takeMVar' on empty 'MVar')--- ---  * Reading a filled 'SampleVar' empties it and returns value.---    (same as 'takeMVar')--- ---  * Writing to an empty 'SampleVar' fills it with a value, and---    potentially, wakes up a blocked reader (same as for 'putMVar' on---    empty 'MVar').------  * Writing to a filled 'SampleVar' overwrites the current value.---    (different from 'putMVar' on full 'MVar'.)--newtype SampleVar a = SampleVar ( MVar ( Int    -- 1  == full-                                                -- 0  == empty-                                                -- <0 no of readers blocked-                                       , MVar a-                                       )-                                )-    deriving (Eq)--INSTANCE_TYPEABLE1(SampleVar,sampleVarTc,"SampleVar")---- |Build a new, empty, 'SampleVar'-newEmptySampleVar :: IO (SampleVar a)-newEmptySampleVar = do-   v <- newEmptyMVar-   SampleVar <$> newMVar (0,v)---- |Build a 'SampleVar' with an initial value.-newSampleVar :: a -> IO (SampleVar a)-newSampleVar a = do-   v <- newMVar a-   SampleVar <$> newMVar (1,v)---- |If the SampleVar is full, leave it empty.  Otherwise, do nothing.-emptySampleVar :: SampleVar a -> IO ()-emptySampleVar (SampleVar v) = mask_ $ do-   s@(readers, var) <- takeMVar v-   if readers > 0 then do-     _ <- takeMVar var-     putMVar v (0,var)-    else-     putMVar v s---- |Wait for a value to become available, then take it and return.-readSampleVar :: SampleVar a -> IO a-readSampleVar (SampleVar svar) = mask_ $ do------ filled => make empty and grab sample--- not filled => try to grab value, empty when read val.----   (readers,val) <- takeMVar svar-   let readers' = readers-1-   readers' `seq` putMVar svar (readers',val)-   takeMVar val---- |Write a value into the 'SampleVar', overwriting any previous value that--- was there.-writeSampleVar :: SampleVar a -> a -> IO ()-writeSampleVar (SampleVar svar) v = mask_ $ do------ filled => overwrite--- not filled => fill, write val----   s@(readers,val) <- takeMVar svar-   case readers of-     1 ->-       swapMVar val v >>-       putMVar svar s-     _ ->-       putMVar val v >>-       let readers' = min 1 (readers+1)-       in readers' `seq` putMVar svar (readers', val)---- | Returns 'True' if the 'SampleVar' is currently empty.------ Note that this function is only useful if you know that no other--- threads can be modifying the state of the 'SampleVar', because--- otherwise the state of the 'SampleVar' may have changed by the time--- you see the result of 'isEmptySampleVar'.----isEmptySampleVar :: SampleVar a -> IO Bool-isEmptySampleVar (SampleVar svar) = do-   (readers, _) <- readMVar svar-   return (readers <= 0)-

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, ExistentialQuantification #-}+{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification #-}  ----------------------------------------------------------------------------- -- |@@ -34,26 +34,18 @@ module Control.Exception (          -- * The Exception type-#ifdef __HUGS__-        SomeException,-#else         SomeException(..),-#endif         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, -#if __GLASGOW_HASKELL__ || __HUGS__         NonTermination(..),         NestedAtomically(..),-#endif-#ifdef __NHC__-        System.ExitCode(), -- instance Exception-#endif-         BlockedIndefinitelyOnMVar(..),         BlockedIndefinitelyOnSTM(..),         Deadlock(..),@@ -68,9 +60,7 @@         throw,         throwIO,         ioError,-#ifdef __GLASGOW_HASKELL__         throwTo,-#endif          -- * Catching Exceptions @@ -109,21 +99,13 @@         -- asynchronous exceptions during a critical region.          mask,-#ifndef __NHC__         mask_,         uninterruptibleMask,         uninterruptibleMask_,         MaskingState(..),         getMaskingState,         allowInterrupt,-#endif -        -- ** (deprecated) Asynchronous exception control--        block,-        unblock,-        blocked,-         -- *** Applying @mask@ to an exception handler          -- $block_handler@@ -149,18 +131,10 @@  import Control.Exception.Base -#ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.IO (unsafeUnmask) import Data.Maybe-#else-import Prelude hiding (catch)-#endif -#ifdef __NHC__-import System (ExitCode())-#endif- -- | You need this when using 'catches'. data Handler a = forall e . Exception e => Handler (e -> IO a) @@ -244,6 +218,8 @@ -- -- When called outside 'mask', or inside 'uninterruptibleMask', this -- function has no effect.+--+-- /Since: 4.4.0.0/ allowInterrupt :: IO () allowInterrupt = unsafeUnmask $ return () @@ -353,12 +329,19 @@ 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@++ * 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@  -}

@@ -1,11 +1,7 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}-#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE NoImplicitPrelude, MagicHash #-} {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif -#include "Typeable.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Control.Exception.Base@@ -23,23 +19,16 @@ module Control.Exception.Base (          -- * The Exception type-#ifdef __HUGS__-        SomeException,-#else         SomeException(..),-#endif         Exception(..),         IOException,         ArithException(..),         ArrayException(..),         AssertionFailed(..),-        AsyncException(..),--#if __GLASGOW_HASKELL__ || __HUGS__+        SomeAsyncException(..), AsyncException(..),+        asyncExceptionToException, asyncExceptionFromException,         NonTermination(..),         NestedAtomically(..),-#endif-         BlockedIndefinitelyOnMVar(..),         BlockedIndefinitelyOnSTM(..),         Deadlock(..),@@ -54,9 +43,7 @@         throwIO,         throw,         ioError,-#ifdef __GLASGOW_HASKELL__         throwTo,-#endif          -- * Catching Exceptions @@ -83,20 +70,12 @@          -- ** Asynchronous exception control         mask,-#ifndef __NHC__         mask_,         uninterruptibleMask,         uninterruptibleMask_,         MaskingState(..),         getMaskingState,-#endif -        -- ** (deprecated) Asynchronous exception control--        block,-        unblock,-        blocked,-         -- * Assertions          assert,@@ -109,16 +88,13 @@          finally, -#ifdef __GLASGOW_HASKELL__         -- * Calls for GHC runtime         recSelError, recConError, irrefutPatError, runtimeError,         nonExhaustiveGuardsError, patError, noMethodBindingError,         absentError,         nonTermination, nestedAtomically,-#endif   ) where -#ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.IO hiding (bracket,finally,onException) import GHC.IO.Exception@@ -126,223 +102,11 @@ import GHC.Show -- import GHC.Exception hiding ( Exception ) import GHC.Conc.Sync-#endif -#ifdef __HUGS__-import Prelude hiding (catch)-import Hugs.Prelude (ExitCode(..))-import Hugs.IOExts (unsafePerformIO)-import Hugs.Exception (SomeException(DynamicException, IOException,-                                     ArithException, ArrayException, ExitException),-                       evaluate, IOException, ArithException, ArrayException)-import qualified Hugs.Exception-#endif- import Data.Dynamic import Data.Either import Data.Maybe -#ifdef __NHC__-import qualified IO as H'98 (catch)-import IO              (bracket,ioError)-import DIOError         -- defn of IOError type-import System          (ExitCode())-import System.IO.Unsafe (unsafePerformIO)-import Unsafe.Coerce    (unsafeCoerce)---- minimum needed for nhc98 to pretend it has Exceptions--{--data Exception   = IOException    IOException-                 | ArithException ArithException-                 | ArrayException ArrayException-                 | AsyncException AsyncException-                 | ExitException  ExitCode-                 deriving Show--}-class ({-Typeable e,-} Show e) => Exception e where-    toException   :: e -> SomeException-    fromException :: SomeException -> Maybe e--data SomeException = forall e . Exception e => SomeException e--INSTANCE_TYPEABLE0(SomeException,someExceptionTc,"SomeException")--instance Show SomeException where-    showsPrec p (SomeException e) = showsPrec p e-instance Exception SomeException where-    toException se = se-    fromException = Just--type IOException = IOError-instance Exception IOError where-    toException                     = SomeException-    fromException (SomeException e) = Just (unsafeCoerce e)--instance Exception ExitCode where-    toException                     = SomeException-    fromException (SomeException e) = Just (unsafeCoerce e)--data ArithException-data ArrayException-data AsyncException-data AssertionFailed-data PatternMatchFail-data NoMethodError-data Deadlock-data BlockedIndefinitelyOnMVar-data BlockedIndefinitelyOnSTM-data ErrorCall-data RecConError-data RecSelError-data RecUpdError-instance Show ArithException-instance Show ArrayException-instance Show AsyncException-instance Show AssertionFailed-instance Show PatternMatchFail-instance Show NoMethodError-instance Show Deadlock-instance Show BlockedIndefinitelyOnMVar-instance Show BlockedIndefinitelyOnSTM-instance Show ErrorCall-instance Show RecConError-instance Show RecSelError-instance Show RecUpdError--catch   :: Exception e-        => IO a         -- ^ The computation to run-        -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised-        -> IO a-catch io h = H'98.catch  io  (h . fromJust . fromException . toException)--throwIO  :: Exception e => e -> IO a-throwIO   = ioError . fromJust . fromException . toException--throw    :: Exception e => e -> a-throw     = unsafePerformIO . throwIO--evaluate :: a -> IO a-evaluate x = x `seq` return x--assert :: Bool -> a -> a-assert True  x = x-assert False _ = throw (toException (UserError "" "Assertion failed"))--mask   :: ((IO a-> IO a) -> IO a) -> IO a-mask action = action restore-    where restore act = act--#endif--#ifdef __HUGS__-class (Typeable e, Show e) => Exception e where-    toException   :: e -> SomeException-    fromException :: SomeException -> Maybe e--    toException e = DynamicException (toDyn e) (flip showsPrec e)-    fromException (DynamicException dyn _) = fromDynamic dyn-    fromException _ = Nothing--INSTANCE_TYPEABLE0(SomeException,someExceptionTc,"SomeException")-INSTANCE_TYPEABLE0(IOException,iOExceptionTc,"IOException")-INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException")-INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException")-INSTANCE_TYPEABLE0(ExitCode,exitCodeTc,"ExitCode")-INSTANCE_TYPEABLE0(ErrorCall,errorCallTc,"ErrorCall")-INSTANCE_TYPEABLE0(AssertionFailed,assertionFailedTc,"AssertionFailed")-INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")-INSTANCE_TYPEABLE0(BlockedIndefinitelyOnMVar,blockedIndefinitelyOnMVarTc,"BlockedIndefinitelyOnMVar")-INSTANCE_TYPEABLE0(BlockedIndefinitelyOnSTM,blockedIndefinitelyOnSTM,"BlockedIndefinitelyOnSTM")-INSTANCE_TYPEABLE0(Deadlock,deadlockTc,"Deadlock")--instance Exception SomeException where-    toException se = se-    fromException = Just--instance Exception IOException where-    toException = IOException-    fromException (IOException e) = Just e-    fromException _ = Nothing--instance Exception ArrayException where-    toException = ArrayException-    fromException (ArrayException e) = Just e-    fromException _ = Nothing--instance Exception ArithException where-    toException = ArithException-    fromException (ArithException e) = Just e-    fromException _ = Nothing--instance Exception ExitCode where-    toException = ExitException-    fromException (ExitException e) = Just e-    fromException _ = Nothing--data ErrorCall = ErrorCall String--instance Show ErrorCall where-    showsPrec _ (ErrorCall err) = showString err--instance Exception ErrorCall where-    toException (ErrorCall s) = Hugs.Exception.ErrorCall s-    fromException (Hugs.Exception.ErrorCall s) = Just (ErrorCall s)-    fromException _ = Nothing--data BlockedIndefinitelyOnMVar = BlockedIndefinitelyOnMVar-data BlockedIndefinitelyOnSTM = BlockedIndefinitelyOnSTM-data Deadlock = Deadlock-data AssertionFailed = AssertionFailed String-data AsyncException-  = StackOverflow-  | HeapOverflow-  | ThreadKilled-  | UserInterrupt-  deriving (Eq, Ord)--instance Show BlockedIndefinitelyOnMVar where-    showsPrec _ BlockedIndefinitelyOnMVar = showString "thread blocked indefinitely"--instance Show BlockedIndefinitely where-    showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"--instance Show Deadlock where-    showsPrec _ Deadlock = showString "<<deadlock>>"--instance Show AssertionFailed where-    showsPrec _ (AssertionFailed err) = showString err--instance Show AsyncException where-    showsPrec _ StackOverflow   = showString "stack overflow"-    showsPrec _ HeapOverflow    = showString "heap overflow"-    showsPrec _ ThreadKilled    = showString "thread killed"-    showsPrec _ UserInterrupt   = showString "user interrupt"--instance Exception BlockedOnDeadMVar-instance Exception BlockedIndefinitely-instance Exception Deadlock-instance Exception AssertionFailed-instance Exception AsyncException--throw :: Exception e => e -> a-throw e = Hugs.Exception.throw (toException e)--throwIO :: Exception e => e -> IO a-throwIO e = Hugs.Exception.throwIO (toException e)-#endif--#ifndef __GLASGOW_HASKELL__--- Dummy definitions for implementations lacking asynchonous exceptions--block   :: IO a -> IO a-block    = id-unblock :: IO a -> IO a-unblock  = id-blocked :: IO Bool-blocked  = return False-#endif- ----------------------------------------------------------------------------- -- Catching exceptions @@ -379,20 +143,11 @@ -- might get a the opposite behaviour. This is ok, because 'catch' is an -- 'IO' computation. ---#ifndef __NHC__ catch   :: Exception e         => IO a         -- ^ The computation to run         -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised         -> IO a-#if __GLASGOW_HASKELL__ catch = catchException-#elif __HUGS__-catch m h = Hugs.Exception.catchException m h'-  where h' e = case fromException e of-            Just e' -> h e'-            Nothing -> throwIO e-#endif-#endif  -- | The function 'catchJust' is like 'catch', but it takes an extra -- argument which is an /exception predicate/, a function which@@ -452,11 +207,6 @@ -- up to the next enclosing exception handler. -- -- >  try a = catch (Right `liftM` a) (return . Left)------ Note that "System.IO.Error" also exports a function called--- 'System.IO.Error.try' with a similar type to 'Control.Exception.try',--- except that it catches only the IO and user families of exceptions--- (as required by the Haskell 98 @IO@ module).  try :: Exception e => IO a -> IO (Either e a) try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))@@ -501,7 +251,6 @@ -- -- > withFile name mode = bracket (openFile name mode) hClose ---#ifndef __NHC__ bracket         :: IO a         -- ^ computation to run first (\"acquire resource\")         -> (a -> IO b)  -- ^ computation to run last (\"release resource\")@@ -513,7 +262,6 @@     r <- restore (thing a) `onException` after a     _ <- after a     return r-#endif  -- | A specialised variant of 'bracket' with just a computation to run -- afterward.@@ -545,31 +293,16 @@     a <- before     restore (thing a) `onException` after a -#if !(__GLASGOW_HASKELL__ || __NHC__)-assert :: Bool -> a -> a-assert True x = x-assert False _ = throw (AssertionFailed "")-#endif- ----- -#if __GLASGOW_HASKELL__ || __HUGS__ -- |A pattern match failed. The @String@ gives information about the -- source location of the pattern.-data PatternMatchFail = PatternMatchFail String-INSTANCE_TYPEABLE0(PatternMatchFail,patternMatchFailTc,"PatternMatchFail")+data PatternMatchFail = PatternMatchFail String deriving Typeable  instance Show PatternMatchFail where     showsPrec _ (PatternMatchFail err) = showString err -#ifdef __HUGS__-instance Exception PatternMatchFail where-    toException (PatternMatchFail err) = Hugs.Exception.PatternMatchFail err-    fromException (Hugs.Exception.PatternMatchFail err) = Just (PatternMatchFail err)-    fromException _ = Nothing-#else instance Exception PatternMatchFail-#endif  ----- @@ -578,40 +311,24 @@ -- multiple constructors, where some fields are in one constructor -- but not another. The @String@ gives information about the source -- location of the record selector.-data RecSelError = RecSelError String-INSTANCE_TYPEABLE0(RecSelError,recSelErrorTc,"RecSelError")+data RecSelError = RecSelError String deriving Typeable  instance Show RecSelError where     showsPrec _ (RecSelError err) = showString err -#ifdef __HUGS__-instance Exception RecSelError where-    toException (RecSelError err) = Hugs.Exception.RecSelError err-    fromException (Hugs.Exception.RecSelError err) = Just (RecSelError err)-    fromException _ = Nothing-#else instance Exception RecSelError-#endif  -----  -- |An uninitialised record field was used. The @String@ gives -- information about the source location where the record was -- constructed.-data RecConError = RecConError String-INSTANCE_TYPEABLE0(RecConError,recConErrorTc,"RecConError")+data RecConError = RecConError String deriving Typeable  instance Show RecConError where     showsPrec _ (RecConError err) = showString err -#ifdef __HUGS__-instance Exception RecConError where-    toException (RecConError err) = Hugs.Exception.RecConError err-    fromException (Hugs.Exception.RecConError err) = Just (RecConError err)-    fromException _ = Nothing-#else instance Exception RecConError-#endif  ----- @@ -620,40 +337,24 @@ -- multiple constructors, where some fields are in one constructor -- but not another. The @String@ gives information about the source -- location of the record update.-data RecUpdError = RecUpdError String-INSTANCE_TYPEABLE0(RecUpdError,recUpdErrorTc,"RecUpdError")+data RecUpdError = RecUpdError String deriving Typeable  instance Show RecUpdError where     showsPrec _ (RecUpdError err) = showString err -#ifdef __HUGS__-instance Exception RecUpdError where-    toException (RecUpdError err) = Hugs.Exception.RecUpdError err-    fromException (Hugs.Exception.RecUpdError err) = Just (RecUpdError err)-    fromException _ = Nothing-#else instance Exception RecUpdError-#endif  -----  -- |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.-data NoMethodError = NoMethodError String-INSTANCE_TYPEABLE0(NoMethodError,noMethodErrorTc,"NoMethodError")+data NoMethodError = NoMethodError String deriving Typeable  instance Show NoMethodError where     showsPrec _ (NoMethodError err) = showString err -#ifdef __HUGS__-instance Exception NoMethodError where-    toException (NoMethodError err) = Hugs.Exception.NoMethodError err-    fromException (Hugs.Exception.NoMethodError err) = Just (NoMethodError err)-    fromException _ = Nothing-#else instance Exception NoMethodError-#endif  ----- @@ -661,27 +362,18 @@ -- 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_TYPEABLE0(NonTermination,nonTerminationTc,"NonTermination")+data NonTermination = NonTermination deriving Typeable  instance Show NonTermination where     showsPrec _ NonTermination = showString "<<loop>>" -#ifdef __HUGS__-instance Exception NonTermination where-    toException NonTermination = Hugs.Exception.NonTermination-    fromException Hugs.Exception.NonTermination = Just NonTermination-    fromException _ = Nothing-#else instance Exception NonTermination-#endif  -----  -- |Thrown when the program attempts to call @atomically@, from the @stm@ -- package, inside another call to @atomically@.-data NestedAtomically = NestedAtomically-INSTANCE_TYPEABLE0(NestedAtomically,nestedAtomicallyTc,"NestedAtomically")+data NestedAtomically = NestedAtomically deriving Typeable  instance Show NestedAtomically where     showsPrec _ NestedAtomically = showString "Control.Concurrent.STM.atomically was nested"@@ -690,9 +382,6 @@  ----- -#endif /* __GLASGOW_HASKELL__ || __HUGS__ */--#ifdef __GLASGOW_HASKELL__ recSelError, recConError, irrefutPatError, runtimeError,   nonExhaustiveGuardsError, patError, noMethodBindingError,   absentError@@ -716,4 +405,3 @@ -- GHC's RTS calls this nestedAtomically :: SomeException nestedAtomically = toException NestedAtomically-#endif

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}+{-# LANGUAGE NoImplicitPrelude #-}  ----------------------------------------------------------------------------- -- |@@ -21,9 +21,9 @@       Functor(fmap)     , Monad((>>=), (>>), return, fail) -    , MonadPlus (   -- class context: Monad-          mzero     -- :: (MonadPlus m) => m a-        , mplus     -- :: (MonadPlus m) => m a -> m a -> m a+    , MonadPlus (+          mzero+        , mplus         )     -- * Functions @@ -32,58 +32,55 @@      -- ** Basic @Monad@ functions -    , mapM          -- :: (Monad m) => (a -> m b) -> [a] -> m [b]-    , mapM_         -- :: (Monad m) => (a -> m b) -> [a] -> m ()-    , forM          -- :: (Monad m) => [a] -> (a -> m b) -> m [b]-    , forM_         -- :: (Monad m) => [a] -> (a -> m b) -> m ()-    , sequence      -- :: (Monad m) => [m a] -> m [a]-    , sequence_     -- :: (Monad m) => [m a] -> m ()-    , (=<<)         -- :: (Monad m) => (a -> m b) -> m a -> m b-    , (>=>)         -- :: (Monad m) => (a -> m b) -> (b -> m c) -> (a -> m c)-    , (<=<)         -- :: (Monad m) => (b -> m c) -> (a -> m b) -> (a -> m c)-    , forever       -- :: (Monad m) => m a -> m b+    , mapM+    , mapM_+    , forM+    , forM_+    , sequence+    , sequence_+    , (=<<)+    , (>=>)+    , (<=<)+    , forever     , void      -- ** Generalisations of list functions -    , join          -- :: (Monad m) => m (m a) -> m a-    , msum          -- :: (MonadPlus m) => [m a] -> m a-    , mfilter       -- :: (MonadPlus m) => (a -> Bool) -> m a -> m a-    , filterM       -- :: (Monad m) => (a -> m Bool) -> [a] -> m [a]-    , mapAndUnzipM  -- :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])-    , zipWithM      -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]-    , zipWithM_     -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()-    , foldM         -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a -    , foldM_        -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m ()-    , replicateM    -- :: (Monad m) => Int -> m a -> m [a]-    , replicateM_   -- :: (Monad m) => Int -> m a -> m ()+    , join+    , msum+    , mfilter+    , filterM+    , mapAndUnzipM+    , zipWithM+    , zipWithM_+    , foldM+    , foldM_+    , replicateM+    , replicateM_      -- ** Conditional execution of monadic expressions -    , guard         -- :: (MonadPlus m) => Bool -> m ()-    , when          -- :: (Monad m) => Bool -> m () -> m ()-    , unless        -- :: (Monad m) => Bool -> m () -> m ()+    , guard+    , when+    , unless      -- ** Monadic lifting operators -    , liftM         -- :: (Monad m) => (a -> b) -> (m a -> m b)-    , liftM2        -- :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)-    , liftM3        -- :: ...-    , liftM4        -- :: ...-    , liftM5        -- :: ...+    , liftM+    , liftM2+    , liftM3+    , liftM4+    , liftM5 -    , ap            -- :: (Monad m) => m (a -> b) -> m a -> m b+    , ap      ) where  import Data.Maybe -#ifdef __GLASGOW_HASKELL__ import GHC.List import GHC.Base-#endif -#ifdef __GLASGOW_HASKELL__ infixr 1 =<<  -- -----------------------------------------------------------------------------@@ -117,8 +114,6 @@ mapM_           :: Monad m => (a -> m b) -> [a] -> m () {-# INLINE mapM_ #-} mapM_ f as      =  sequence_ (map f as)--#endif  /* __GLASGOW_HASKELL__ */  -- ----------------------------------------------------------------------------- -- The MonadPlus class definition

@@ -1,5 +1,4 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP #-}  ----------------------------------------------------------------------------- -- |@@ -19,23 +18,15 @@ -----------------------------------------------------------------------------  module Control.Monad.Fix (-        MonadFix(-           mfix -- :: (a -> m a) -> m a-         ),-        fix     -- :: (a -> a) -> a+        MonadFix(mfix),+        fix   ) where  import Prelude import System.IO import Data.Function (fix)-#ifdef __HUGS__-import Hugs.Prelude (MonadFix(mfix))-#endif-#if defined(__GLASGOW_HASKELL__) import GHC.ST-#endif -#ifndef __HUGS__ -- | Monads having fixed points with a \'knot-tying\' semantics. -- Instances of 'MonadFix' should satisfy the following laws: --@@ -60,7 +51,6 @@         -- output fed back as the input.  Hence @f@ should not be strict,         -- for then @'mfix' f@ would diverge.         mfix :: (a -> m a) -> m a-#endif /* !__HUGS__ */  -- Instances of MonadFix for Prelude monads @@ -85,8 +75,5 @@              where unRight (Right x) = x                    unRight (Left  _) = error "mfix Either: Left" -#if defined(__GLASGOW_HASKELL__) instance MonadFix (ST s) where         mfix = fixST-#endif-

@@ -1,7 +1,4 @@ {-# LANGUAGE Safe #-}-{-# OPTIONS_NHC98 --prelude #-}--- This module deliberately declares orphan instances:-{-# OPTIONS_GHC -fno-warn-orphans #-}  ----------------------------------------------------------------------------- -- |@@ -18,6 +15,7 @@ -- 'Functor' and 'Monad' instances for @(->) r@ and -- 'Functor' instances for @(,) a@ and @'Either' a@. -module Control.Monad.Instances (Functor(..),Monad(..)) where+module Control.Monad.Instances {-# DEPRECATED "This module now contains no instances and will be removed in the future" #-} -- deprecated in 7.8+    (Functor(..),Monad(..)) where  import Prelude

@@ -14,40 +14,22 @@ -- 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,          -- :: (forall s. ST s a) -> a-        fixST,          -- :: (a -> ST s a) -> ST s a+        runST,+        fixST,          -- * Converting 'ST' to 'IO'         RealWorld,              -- abstract-        stToIO,                 -- :: ST RealWorld a -> IO a--        -- * Unsafe Functions-        unsafeInterleaveST,-        unsafeIOToST,-        unsafeSTToIO+        stToIO,     ) where  import Control.Monad.ST.Safe-import qualified Control.Monad.ST.Unsafe as U--{-# DEPRECATED unsafeInterleaveST, unsafeIOToST, unsafeSTToIO-              "Please import from Control.Monad.ST.Unsafe instead; This will be removed in the next release"- #-}--{-# INLINE unsafeInterleaveST #-}-unsafeInterleaveST :: ST s a -> ST s a-unsafeInterleaveST = U.unsafeInterleaveST--{-# INLINE unsafeIOToST #-}-unsafeIOToST :: IO a -> ST s a-unsafeIOToST = U.unsafeIOToST--{-# INLINE unsafeSTToIO #-}-unsafeSTToIO :: ST s a -> IO a-unsafeSTToIO = U.unsafeSTToIO 

@@ -1,5 +1,4 @@ {-# LANGUAGE Unsafe #-}-{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-}  -----------------------------------------------------------------------------@@ -18,54 +17,22 @@ -- ----------------------------------------------------------------------------- --- #hide module Control.Monad.ST.Imp (         -- * The 'ST' Monad         ST,             -- abstract, instance of Functor, Monad, Typeable.-        runST,          -- :: (forall s. ST s a) -> a-        fixST,          -- :: (a -> ST s a) -> ST s a+        runST,+        fixST,          -- * Converting 'ST' to 'IO'         RealWorld,              -- abstract-        stToIO,                 -- :: ST RealWorld a -> IO a+        stToIO,          -- * Unsafe operations-        unsafeInterleaveST,     -- :: ST s a -> ST s a-        unsafeIOToST,           -- :: IO a -> ST s a-        unsafeSTToIO            -- :: ST s a -> IO a+        unsafeInterleaveST,+        unsafeIOToST,+        unsafeSTToIO     ) where -#if !defined(__GLASGOW_HASKELL__)-import Control.Monad.Fix-#endif--#include "Typeable.h"--#if defined(__GLASGOW_HASKELL__) import GHC.ST           ( ST, runST, fixST, unsafeInterleaveST ) import GHC.Base         ( RealWorld ) import GHC.IO           ( stToIO, unsafeIOToST, unsafeSTToIO )-#elif defined(__HUGS__)-import Data.Typeable-import Hugs.ST-import qualified Hugs.LazyST as LazyST-#endif--#if defined(__HUGS__)-INSTANCE_TYPEABLE2(ST,sTTc,"ST")-INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")--fixST :: (a -> ST s a) -> ST s a-fixST f = LazyST.lazyToStrictST (LazyST.fixST (LazyST.strictToLazyST . f))--unsafeInterleaveST :: ST s a -> ST s a-unsafeInterleaveST =-    LazyST.lazyToStrictST . LazyST.unsafeInterleaveST . LazyST.strictToLazyST-#endif--#if !defined(__GLASGOW_HASKELL__)-instance MonadFix (ST s) where-        mfix = fixST-#endif--

@@ -28,24 +28,7 @@         -- * Converting 'ST' To 'IO'         RealWorld,         stToIO,--        -- * Unsafe Functions-        unsafeInterleaveST,-        unsafeIOToST     ) where  import Control.Monad.ST.Lazy.Safe-import qualified Control.Monad.ST.Lazy.Unsafe as U--{-# DEPRECATED unsafeInterleaveST, unsafeIOToST-              "Please import from Control.Monad.ST.Lazy.Unsafe instead; This will be removed in the next release"- #-}--{-# INLINE unsafeInterleaveST #-}-unsafeInterleaveST :: ST s a -> ST s a-unsafeInterleaveST = U.unsafeInterleaveST--{-# INLINE unsafeIOToST #-}-unsafeIOToST :: IO a -> ST s a-unsafeIOToST = U.unsafeIOToST 

@@ -1,5 +1,5 @@ {-# LANGUAGE Unsafe #-}-{-# LANGUAGE CPP, MagicHash, UnboxedTuples, Rank2Types #-}+{-# LANGUAGE MagicHash, UnboxedTuples, RankNTypes #-} {-# OPTIONS_HADDOCK hide #-}  -----------------------------------------------------------------------------@@ -18,7 +18,6 @@ -- ----------------------------------------------------------------------------- --- #hide module Control.Monad.ST.Lazy.Imp (         -- * The 'ST' monad         ST,@@ -44,16 +43,9 @@ import qualified Control.Monad.ST.Safe as ST import qualified Control.Monad.ST.Unsafe as ST -#ifdef __GLASGOW_HASKELL__ import qualified GHC.ST as GHC.ST import GHC.Base-#endif -#ifdef __HUGS__-import Hugs.LazyST-#endif--#ifdef __GLASGOW_HASKELL__ -- | 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@.@@ -111,7 +103,6 @@                    (r,s') = m_r s                 in                    (r,s'))-#endif  instance MonadFix (ST s) where         mfix = fixST@@ -119,7 +110,6 @@ -- --------------------------------------------------------------------------- -- Strict <--> Lazy -#ifdef __GLASGOW_HASKELL__ {-| Convert a strict 'ST' computation into a lazy one.  The strict state thread passed to 'strictToLazyST' is not performed until the result of@@ -140,7 +130,6 @@ 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 #)-#endif  -- | A monad transformer embedding lazy state transformers in the 'IO' -- monad.  The 'RealWorld' parameter indicates that the internal state@@ -152,10 +141,8 @@ -- --------------------------------------------------------------------------- -- Strict <--> Lazy -#ifdef __GLASGOW_HASKELL__ unsafeInterleaveST :: ST s a -> ST s a unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST-#endif  unsafeIOToST :: IO a -> ST s a unsafeIOToST = strictToLazyST . ST.unsafeIOToST

@@ -20,13 +20,13 @@  module Control.Monad.ST.Safe (         -- * The 'ST' Monad-        ST,             -- abstract, instance of Functor, Monad, Typeable.-        runST,          -- :: (forall s. ST s a) -> a-        fixST,          -- :: (a -> ST s a) -> ST s a+        ST,             -- abstract+        runST,+        fixST,          -- * Converting 'ST' to 'IO'         RealWorld,              -- abstract-        stToIO,                 -- :: ST RealWorld a -> IO a+        stToIO,     ) where  import Control.Monad.ST.Imp

@@ -47,6 +47,7 @@     -- 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+    {-# MINIMAL mzip | mzipWith #-}  instance MonadZip [] where     mzip     = zip

@@ -6,7 +6,7 @@ -- 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@@ -19,56 +19,52 @@ -- ----------------------------------------------------------------------------- -module Data.Bits ( +module Data.Bits (   Bits(-    (.&.), (.|.), xor, -- :: a -> a -> a-    complement,        -- :: a -> a-    shift,             -- :: a -> Int -> a-    rotate,            -- :: a -> Int -> a-    bit,               -- :: Int -> a-    setBit,            -- :: a -> Int -> a-    clearBit,          -- :: a -> Int -> a-    complementBit,     -- :: a -> Int -> a-    testBit,           -- :: a -> Int -> Bool-    bitSize,           -- :: a -> Int-    isSigned,          -- :: a -> Bool-    shiftL, shiftR,    -- :: a -> Int -> a-    unsafeShiftL, unsafeShiftR,  -- :: a -> Int -> a-    rotateL, rotateR,  -- :: a -> Int -> a-    popCount           -- :: a -> Int+    (.&.), (.|.), xor,+    complement,+    shift,+    rotate,+    zeroBits,+    bit,+    setBit,+    clearBit,+    complementBit,+    testBit,+    bitSizeMaybe,+    bitSize,+    isSigned,+    shiftL, shiftR,+    unsafeShiftL, unsafeShiftR,+    rotateL, rotateR,+    popCount   ),+  FiniteBits(finiteBitSize),    bitDefault,   testBitDefault,   popCountDefault-  -- instance Bits Int-  -- instance Bits Integer  ) where  -- Defines the @Bits@ class containing bit-based operations. -- See library document for details on the semantics of the -- individual operations. -#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) #include "MachDeps.h"-#endif -#ifdef __GLASGOW_HASKELL__+import Data.Maybe import GHC.Enum import GHC.Num import GHC.Base-#endif -#ifdef __HUGS__-import Hugs.Bits-#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@@ -77,7 +73,7 @@ Minimal complete definition: '.&.', '.|.', 'xor', 'complement', ('shift' or ('shiftL' and 'shiftR')), ('rotate' or ('rotateL' and 'rotateR')), 'bitSize', 'isSigned', 'testBit', 'bit', and 'popCount'.  The latter three can-be implemented using `testBitDefault', 'bitDefault, and 'popCountDefault', if+be implemented using `testBitDefault', 'bitDefault', and 'popCountDefault', if @a@ is also an instance of 'Num'. -} class Eq a => Bits a where@@ -136,7 +132,26 @@                   | i>0  = (x `shift` i) .|. (x `shift` (i-bitSize x))     -} -    -- | @bit i@ is a value with the @i@th bit set and all other bits clear+    -- | '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.+    --+    -- See also 'zeroBits'.     bit               :: Int -> a      -- | @x \`setBit\` i@ is the same as @x .|. bit i@@@ -152,6 +167,14 @@     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'.         -}@@ -182,7 +205,9 @@         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. -}+        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@@ -209,7 +234,9 @@         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. -}+        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@@ -235,27 +262,60 @@     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. -}+        known as the population count or the Hamming weight.++        /Since: 4.5.0.0/ -}     popCount          :: a -> Int +    {-# MINIMAL (.&.), (.|.), xor, complement,+                (shift | (shiftL, shiftR)),+                (rotate | (rotateL, rotateR)),+                bitSize, bitSizeMaybe, isSigned, testBit, bit, popCount #-}++-- |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++-- 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+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+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@@ -263,91 +323,80 @@    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++ instance Bits Int where     {-# INLINE shift #-}     {-# INLINE bit #-}     {-# INLINE testBit #-} -#ifdef __GLASGOW_HASKELL__+    zeroBits = 0+     bit     = bitDefault      testBit = testBitDefault -    (I# x#) .&.   (I# y#)  = I# (word2Int# (int2Word# x# `and#` int2Word# y#))--    (I# x#) .|.   (I# y#)  = I# (word2Int# (int2Word# x# `or#`  int2Word# y#))--    (I# x#) `xor` (I# y#)  = I# (word2Int# (int2Word# x# `xor#` int2Word# y#))--    complement (I# x#)     = I# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))-+    (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#)-        | i# >=# 0#        = I# (x# `iShiftL#` i#)-        | otherwise        = I# (x# `iShiftRA#` negateInt# i#)-    (I# x#) `shiftL` (I# i#) = I# (x# `iShiftL#` 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#) `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# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`-                       (x'# `uncheckedShiftRL#` (wsib -# i'#))))+        I# ((x# `uncheckedIShiftL#` i'#) `orI#` (x# `uncheckedIShiftRL#` (wsib -# i'#)))       where-        !x'# = int2Word# x#-        !i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#))+        !i'# = i# `andI#` (wsib -# 1#)         !wsib = WORD_SIZE_IN_BITS#   {- work around preprocessor problem (??) -}-    bitSize  _             = WORD_SIZE_IN_BITS+    bitSizeMaybe i         = Just (finiteBitSize i)+    bitSize i              = finiteBitSize i      popCount (I# x#) = I# (word2Int# (popCnt# (int2Word# x#))) -#else /* !__GLASGOW_HASKELL__ */--    popCount               = popCountDefault--#ifdef __HUGS__-    (.&.)                  = primAndInt-    (.|.)                  = primOrInt-    xor                    = primXorInt-    complement             = primComplementInt-    shift                  = primShiftInt-    bit                    = primBitInt-    testBit                = primTestInt-    bitSize _              = SIZEOF_HSINT*8-#elif defined(__NHC__)-    (.&.)                  = nhc_primIntAnd-    (.|.)                  = nhc_primIntOr-    xor                    = nhc_primIntXor-    complement             = nhc_primIntCompl-    shiftL                 = nhc_primIntLsh-    shiftR                 = nhc_primIntRsh-    bit                    = bitDefault-    testBit                = testBitDefault-    bitSize _              = 32-#endif /* __NHC__ */--    x `rotate`  i-        | i<0 && 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))--#endif /* !__GLASGOW_HASKELL__ */-     isSigned _             = True -#ifdef __NHC__-foreign import ccall nhc_primIntAnd :: Int -> Int -> Int-foreign import ccall nhc_primIntOr  :: Int -> Int -> Int-foreign import ccall nhc_primIntXor :: Int -> Int -> Int-foreign import ccall nhc_primIntLsh :: Int -> Int -> Int-foreign import ccall nhc_primIntRsh :: Int -> Int -> Int-foreign import ccall nhc_primIntCompl :: Int -> Int-#endif /* __NHC__ */+instance FiniteBits Int where+    finiteBitSize _ = WORD_SIZE_IN_BITS -#if defined(__GLASGOW_HASKELL__) instance Bits Word where     {-# INLINE shift #-}     {-# INLINE bit #-}@@ -359,94 +408,47 @@     complement (W# x#)       = W# (x# `xor#` mb#)         where !(W# mb#) = maxBound     (W# x#) `shift` (I# i#)-        | i# >=# 0#          = W# (x# `shiftL#` i#)-        | otherwise          = W# (x# `shiftRL#` negateInt# i#)-    (W# x#) `shiftL` (I# i#) = W# (x# `shiftL#` 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#) `shiftR` (I# i#)       = W# (x# `shiftRL#` i#)     (W# x#) `unsafeShiftR` (I# i#) = W# (x# `uncheckedShiftRL#` i#)     (W# x#) `rotate` (I# i#)-        | i'# ==# 0# = W# x#+        | isTrue# (i'# ==# 0#) = W# x#         | otherwise  = W# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (wsib -# i'#)))         where-        !i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#))+        !i'# = i# `andI#` (wsib -# 1#)         !wsib = WORD_SIZE_IN_BITS#  {- work around preprocessor problem (??) -}-    bitSize  _               = WORD_SIZE_IN_BITS+    bitSizeMaybe i           = Just (finiteBitSize i)+    bitSize i                = finiteBitSize i     isSigned _               = False     popCount (W# x#)         = I# (word2Int# (popCnt# x#))     bit                      = bitDefault     testBit                  = testBitDefault-#endif +instance FiniteBits Word where+    finiteBitSize _ = WORD_SIZE_IN_BITS+ instance Bits Integer where-#if defined(__GLASGOW_HASKELL__)    (.&.) = andInteger    (.|.) = orInteger    xor = xorInteger    complement = complementInteger    shift x i@(I# i#) | i >= 0    = shiftLInteger x i#                      | otherwise = shiftRInteger x (negateInt# i#)-#else-   -- reduce bitwise binary operations to special cases we can handle--   x .&. y   | x<0 && y<0 = complement (complement x `posOr` complement y)-             | otherwise  = x `posAnd` y-   -   x .|. y   | x<0 || y<0 = complement (complement x `posAnd` complement y)-             | otherwise  = x `posOr` y-   -   x `xor` y | x<0 && y<0 = complement x `posXOr` complement y-             | x<0        = complement (complement x `posXOr` y)-             |        y<0 = complement (x `posXOr` complement y)-             | otherwise  = x `posXOr` y--   -- assuming infinite 2's-complement arithmetic-   complement a = -1 - a-   shift x i | i >= 0    = x * 2^i-             | otherwise = x `div` 2^(-i)-#endif+   testBit x (I# i) = testBitInteger x i +   zeroBits   = 0    bit        = bitDefault-   testBit    = testBitDefault    popCount   = popCountDefault     rotate x i = shift x i   -- since an Integer never wraps around +   bitSizeMaybe _ = Nothing    bitSize _  = error "Data.Bits.bitSize(Integer)"    isSigned _ = True -#if !defined(__GLASGOW_HASKELL__)--- Crude implementation of bitwise operations on Integers: convert them--- to finite lists of Ints (least significant first), zip and convert--- back again.---- posAnd requires at least one argument non-negative--- posOr and posXOr require both arguments non-negative--posAnd, posOr, posXOr :: Integer -> Integer -> Integer-posAnd x y   = fromInts $ zipWith (.&.) (toInts x) (toInts y)-posOr x y    = fromInts $ longZipWith (.|.) (toInts x) (toInts y)-posXOr x y   = fromInts $ longZipWith xor (toInts x) (toInts y)--longZipWith :: (a -> a -> a) -> [a] -> [a] -> [a]-longZipWith f xs [] = xs-longZipWith f [] ys = ys-longZipWith f (x:xs) (y:ys) = f x y:longZipWith f xs ys--toInts :: Integer -> [Int]-toInts n-    | n == 0 = []-    | otherwise = mkInt (n `mod` numInts):toInts (n `div` numInts)-  where mkInt n | n > toInteger(maxBound::Int) = fromInteger (n-numInts)-                | otherwise = fromInteger n--fromInts :: [Int] -> Integer-fromInts = foldr catInt 0-    where catInt d n = (if d<0 then n+1 else n)*numInts + toInteger d--numInts = toInteger (maxBound::Int) - toInteger (minBound::Int) + 1-#endif /* !__GLASGOW_HASKELL__ */- {- 	Note [Constant folding for rotate] 	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The INLINE on the Int instance of rotate enables it to be constant@@ -470,5 +472,5 @@            __DEFAULT -> Main.$wfold (+# ww_sOb 56) (+# wild_XM 1);            10000000 -> ww_sOb          }--} +-} 

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}+{-# LANGUAGE NoImplicitPrelude #-}  ----------------------------------------------------------------------------- -- |@@ -19,24 +19,20 @@    -- * Booleans    Bool(..),    -- ** Operations -   (&&),        -- :: Bool -> Bool -> Bool-   (||),        -- :: Bool -> Bool -> Bool-   not,         -- :: Bool -> Bool-   otherwise,   -- :: Bool+   (&&),+   (||),+   not,+   otherwise,+   bool,   ) where -#ifdef __GLASGOW_HASKELL__ import GHC.Base-#endif -#ifdef __NHC__-import Prelude-import Prelude-  ( Bool(..)-  , (&&)-  , (||)-  , not-  , otherwise-  )-#endif-+-- | Case analysis for the 'Bool' type.+-- @bool a b p@ evaluates to @a@ when @p@ is @False@, and evaluates to @b@+-- when @p@ is @True@.+--+-- /Since: 4.7.0.0/+bool :: a -> a -> Bool -> a+bool f _ False = f+bool _ t True  = t

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}+{-# LANGUAGE NoImplicitPrelude #-}  ----------------------------------------------------------------------------- -- |@@ -36,23 +36,22 @@     , GeneralCategory(..), generalCategory      -- * Case conversion-    , toUpper, toLower, toTitle  -- :: Char -> Char+    , toUpper, toLower, toTitle      -- * Single digit characters-    , digitToInt        -- :: Char -> Int-    , intToDigit        -- :: Int  -> Char+    , digitToInt+    , intToDigit      -- * Numeric representations-    , ord               -- :: Char -> Int-    , chr               -- :: Int  -> Char+    , ord+    , chr      -- * String representations-    , showLitChar       -- :: Char -> ShowS-    , lexLitChar        -- :: ReadS String-    , readLitChar       -- :: ReadS Char +    , showLitChar+    , lexLitChar+    , readLitChar     ) where -#ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.Arr (Ix) import GHC.Char@@ -62,22 +61,7 @@ import GHC.Unicode import GHC.Num import GHC.Enum-#endif -#ifdef __HUGS__-import Hugs.Prelude (Ix)-import Hugs.Char-#endif--#ifdef __NHC__-import Prelude-import Prelude(Char,String)-import Char-import Ix-import NHC.FFI (CInt)-foreign import ccall unsafe "WCsubst.h u_gencat" wgencat :: CInt -> CInt-#endif- -- | 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@@ -89,12 +73,6 @@  | c >= 'A' && c <= 'F' =  ord c - ord 'A' + 10  | otherwise            =  error ("Char.digitToInt: not a digit " ++ show c) -- sigh -#ifndef __GLASGOW_HASKELL__-isAsciiUpper, isAsciiLower :: Char -> Bool-isAsciiLower c          =  c >= 'a' && c <= 'z'-isAsciiUpper c          =  c >= 'A' && c <= 'Z'-#endif- -- | Unicode General Categories (column 2 of the UnicodeData table) -- in the order they are listed in the Unicode standard. @@ -133,12 +111,7 @@  -- | The Unicode general category of the character. generalCategory :: Char -> GeneralCategory-#if defined(__GLASGOW_HASKELL__) || defined(__NHC__) generalCategory c = toEnum $ fromIntegral $ wgencat $ fromIntegral $ ord c-#endif-#ifdef __HUGS__-generalCategory c = toEnum (primUniGenCat c)-#endif  -- derived character classifiers @@ -202,10 +175,4 @@         LineSeparator           -> True         ParagraphSeparator      -> True         _                       -> False--#ifdef __NHC__--- dummy implementation-toTitle :: Char -> Char-toTitle = toUpper-#endif 

@@ -0,0 +1,27 @@+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}++-----------------------------------------------------------------------------+-- |+-- 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+-- <https://ghc.haskell.org/trac/ghc/wiki/Roles Roles wiki page>+--+-- /Since: 4.7.0.0/+-----------------------------------------------------------------------------++module Data.Coerce+        ( -- * Safe coercions+          coerce, Coercible,+        ) where+import GHC.Prim (coerce, Coercible)

@@ -1,8 +1,6 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, DeriveDataTypeable #-}-#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-}-#endif  ----------------------------------------------------------------------------- -- |@@ -23,39 +21,24 @@         -- * Rectangular form           Complex((:+)) -        , realPart      -- :: (RealFloat a) => Complex a -> a-        , imagPart      -- :: (RealFloat a) => Complex a -> a+        , realPart+        , imagPart         -- * Polar form-        , mkPolar       -- :: (RealFloat a) => a -> a -> Complex a-        , cis           -- :: (RealFloat a) => a -> Complex a-        , polar         -- :: (RealFloat a) => Complex a -> (a,a)-        , magnitude     -- :: (RealFloat a) => Complex a -> a-        , phase         -- :: (RealFloat a) => Complex a -> a+        , mkPolar+        , cis+        , polar+        , magnitude+        , phase         -- * Conjugate-        , conjugate     -- :: (RealFloat a) => Complex a -> Complex a--        -- Complex instances:-        ---        --  (RealFloat a) => Eq         (Complex a)-        --  (RealFloat a) => Read       (Complex a)-        --  (RealFloat a) => Show       (Complex a)-        --  (RealFloat a) => Num        (Complex a)-        --  (RealFloat a) => Fractional (Complex a)-        --  (RealFloat a) => Floating   (Complex a)+        , conjugate          )  where  import Prelude  import Data.Typeable-#ifdef __GLASGOW_HASKELL__ import Data.Data (Data)-#endif -#ifdef __HUGS__-import Hugs.Prelude(Num(fromInt), Fractional(fromDouble))-#endif- infix  6  :+  -- -----------------------------------------------------------------------------@@ -69,11 +52,7 @@ data Complex a   = !a :+ !a    -- ^ forms a complex number from its real and imaginary                 -- rectangular components.-# if __GLASGOW_HASKELL__-        deriving (Eq, Show, Read, Data)-# else-        deriving (Eq, Show, Read)-# endif+        deriving (Eq, Show, Read, Data, Typeable)  -- ----------------------------------------------------------------------------- -- Functions over Complex@@ -130,9 +109,6 @@ -- ----------------------------------------------------------------------------- -- Instances of Complex -#include "Typeable.h"-INSTANCE_TYPEABLE1(Complex,complexTc,"Complex")- instance  (RealFloat a) => Num (Complex a)  where     {-# SPECIALISE instance Num (Complex Float) #-}     {-# SPECIALISE instance Num (Complex Double) #-}@@ -144,9 +120,6 @@     signum (0:+0)       =  0     signum z@(x:+y)     =  x/r :+ y/r  where r = magnitude z     fromInteger n       =  fromInteger n :+ 0-#ifdef __HUGS__-    fromInt n           =  fromInt n :+ 0-#endif  instance  (RealFloat a) => Fractional (Complex a)  where     {-# SPECIALISE instance Fractional (Complex Float) #-}@@ -158,9 +131,6 @@                                  d   = x'*x'' + y'*y''      fromRational a      =  fromRational a :+ 0-#ifdef __HUGS__-    fromDouble a        =  fromDouble a :+ 0-#endif  instance  (RealFloat a) => Floating (Complex a) where     {-# SPECIALISE instance Floating (Complex Float) #-}

@@ -1,5 +1,7 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy, FlexibleInstances #-}+{-# LANGUAGE RankNTypes, ScopedTypeVariables, PolyKinds #-}+{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable, TypeOperators,+             GADTs #-}  ----------------------------------------------------------------------------- -- |@@ -32,10 +34,10 @@          -- * The Data class for processing constructor applications         Data(-                gfoldl,         -- :: ... -> a -> c a-                gunfold,        -- :: ... -> Constr -> c a-                toConstr,       -- :: a -> Constr-                dataTypeOf,     -- :: a -> DataType+                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 @@ -50,59 +52,54 @@             ),          -- * Datatype representations-        DataType,       -- abstract, instance of: Show+        DataType,       -- abstract         -- ** Constructors-        mkDataType,     -- :: String   -> [Constr] -> DataType-        mkIntType,      -- :: String -> DataType-        mkFloatType,    -- :: String -> DataType-        mkStringType,   -- :: String -> DataType-        mkCharType,     -- :: String -> DataType-        mkNoRepType,    -- :: String -> DataType-        mkNorepType,    -- :: String -> DataType+        mkDataType,+        mkIntType,+        mkFloatType,+        mkCharType,+        mkNoRepType,         -- ** Observers-        dataTypeName,   -- :: DataType -> String-        DataRep(..),    -- instance of: Eq, Show-        dataTypeRep,    -- :: DataType -> DataRep+        dataTypeName,+        DataRep(..),+        dataTypeRep,         -- ** Convenience functions-        repConstr,      -- :: DataType -> ConstrRep -> Constr-        isAlgType,      -- :: DataType -> Bool-        dataTypeConstrs,-- :: DataType -> [Constr]-        indexConstr,    -- :: DataType -> ConIndex -> Constr-        maxConstrIndex, -- :: DataType -> ConIndex-        isNorepType,    -- :: DataType -> Bool+        repConstr,+        isAlgType,+        dataTypeConstrs,+        indexConstr,+        maxConstrIndex,+        isNorepType,          -- * Data constructor representations-        Constr,         -- abstract, instance of: Eq, Show+        Constr,         -- abstract         ConIndex,       -- alias for Int, start at 1-        Fixity(..),     -- instance of: Eq, Show+        Fixity(..),         -- ** Constructors-        mkConstr,       -- :: DataType -> String -> Fixity -> Constr-        mkIntConstr,    -- :: DataType -> Integer -> Constr-        mkFloatConstr,  -- :: DataType -> Double -> Constr-        mkIntegralConstr,-- :: (Integral a) => DataType -> a -> Constr-        mkRealConstr,   -- :: (Real a) => DataType -> a -> Constr-        mkStringConstr, -- :: DataType -> String  -> Constr-        mkCharConstr,   -- :: DataType -> Char -> Constr+        mkConstr,+        mkIntegralConstr,+        mkRealConstr,+        mkCharConstr,         -- ** Observers-        constrType,     -- :: Constr   -> DataType-        ConstrRep(..),  -- instance of: Eq, Show-        constrRep,      -- :: Constr   -> ConstrRep-        constrFields,   -- :: Constr   -> [String]-        constrFixity,   -- :: Constr   -> Fixity+        constrType,+        ConstrRep(..),+        constrRep,+        constrFields,+        constrFixity,         -- ** Convenience function: algebraic data types-        constrIndex,    -- :: Constr   -> ConIndex+        constrIndex,         -- ** From strings to constructors and vice versa: all data types-        showConstr,     -- :: Constr   -> String-        readConstr,     -- :: DataType -> String -> Maybe Constr+        showConstr,+        readConstr,          -- * Convenience functions: take type constructors apart-        tyconUQname,    -- :: String -> String-        tyconModule,    -- :: String -> String+        tyconUQname,+        tyconModule,          -- * Generic operations defined in terms of 'gunfold'-        fromConstr,     -- :: Constr -> a-        fromConstrB,    -- :: ... -> Constr -> a-        fromConstrM     -- :: Monad m => ... -> Constr -> m a+        fromConstr,+        fromConstrB,+        fromConstrM    ) where @@ -113,33 +110,24 @@  import Data.Typeable import Data.Maybe+import Data.Version( Version(..) ) import Control.Monad  -- 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, ...-#ifdef __GLASGOW_HASKELL__ import GHC.Real( Ratio(..) ) -- So we can give Data instance for Ratio --import GHC.IOBase            -- So we can give Data instance for IO, Handle+import GHC.Prim 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-#else-# ifdef __HUGS__-import Hugs.Prelude( Ratio(..) )-# endif-import Foreign.Ptr-import Foreign.ForeignPtr-import Data.Array-#endif -#include "Typeable.h" -- ------------------------------------------------------------------------------ -- --      The Data class@@ -274,7 +262,7 @@   --   -- The default definition is @'const' 'Nothing'@, which is appropriate   -- for non-unary type constructors.-  dataCast1 :: Typeable1 t+  dataCast1 :: Typeable t             => (forall d. Data d => c (t d))             -> Maybe (c a)   dataCast1 _ = Nothing@@ -285,7 +273,7 @@   --   -- The default definition is @'const' 'Nothing'@, which is appropriate   -- for non-binary type constructors.-  dataCast2 :: Typeable2 t+  dataCast2 :: Typeable t             => (forall d e. (Data d, Data e) => c (t d e))             -> Maybe (c a)   dataCast2 _ = Nothing@@ -584,10 +572,10 @@ repConstr dt cr =       case (dataTypeRep dt, cr) of         (AlgRep cs, AlgConstr i)      -> cs !! (i-1)-        (IntRep,    IntConstr i)      -> mkIntConstr dt i+        (IntRep,    IntConstr i)      -> mkIntegralConstr dt i         (FloatRep,  FloatConstr f)    -> mkRealConstr dt f         (CharRep,   CharConstr c)     -> mkCharConstr dt c-        _ -> error "Data.Data.repConstr"+        _ -> error "Data.Data.repConstr: The given ConstrRep does not fit to the given DataType."   @@ -625,7 +613,9 @@ dataTypeConstrs :: DataType -> [Constr] dataTypeConstrs dt = case datarep dt of                         (AlgRep cons) -> cons-                        _ -> error "Data.Data.dataTypeConstrs"+                        _ -> error $ "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@@ -698,21 +688,27 @@ indexConstr :: DataType -> ConIndex -> Constr indexConstr dt idx = case datarep dt of                         (AlgRep cs) -> cs !! (idx-1)-                        _           -> error "Data.Data.indexConstr"+                        _           -> error $ "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-                    _ -> error "Data.Data.constrIndex"+                    _ -> error $ "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-                        _            -> error "Data.Data.maxConstrIndex"+                        _            -> error $ "Data.Data.maxConstrIndex is not supported for "+                                                 ++ dataTypeName dt +++                                                 ", as it is not an algebraic data type."   @@ -733,17 +729,12 @@ mkFloatType = mkPrimType FloatRep  --- | This function is now deprecated. Please use 'mkCharType' instead.-{-# DEPRECATED mkStringType "Use mkCharType instead" #-}-mkStringType :: String -> DataType-mkStringType = mkCharType- -- | Constructs the 'Char' type mkCharType :: String -> DataType mkCharType = mkPrimType CharRep  --- | Helper for 'mkIntType', 'mkFloatType', 'mkStringType'+-- | Helper for 'mkIntType', 'mkFloatType' mkPrimType :: DataRep -> String -> DataType mkPrimType dr str = DataType                         { tycon   = str@@ -761,41 +752,27 @@                         , confixity = error "Data.Data.confixity"                         } --- | This function is now deprecated. Please use 'mkIntegralConstr' instead.-{-# DEPRECATED mkIntConstr "Use mkIntegralConstr instead" #-}-mkIntConstr :: DataType -> Integer -> Constr-mkIntConstr = mkIntegralConstr- mkIntegralConstr :: (Integral a, Show a) => DataType -> a -> Constr mkIntegralConstr dt i = case datarep dt of                   IntRep -> mkPrimCon dt (show i) (IntConstr (toInteger  i))-                  _ -> error "Data.Data.mkIntegralConstr"---- | This function is now deprecated. Please use 'mkRealConstr' instead.-{-# DEPRECATED mkFloatConstr "Use mkRealConstr instead" #-}-mkFloatConstr :: DataType -> Double -> Constr-mkFloatConstr dt = mkRealConstr dt . toRational+                  _ -> error $ "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))-                    _ -> error "Data.Data.mkRealConstr"---- | This function is now deprecated. Please use 'mkCharConstr' instead.-{-# DEPRECATED mkStringConstr "Use mkCharConstr instead" #-}-mkStringConstr :: DataType -> String -> Constr-mkStringConstr dt str =-  case datarep dt of-    CharRep -> case str of-      [c] -> mkPrimCon dt (show c) (CharConstr c)-      _ -> error "Data.Data.mkStringConstr: input String must contain a single character"-    _ -> error "Data.Data.mkStringConstr"+                    _ -> error $ "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)-                   _ -> error "Data.Data.mkCharConstr"+                   _ -> error $ "Data.Data.mkCharConstr is not supported for "+                                ++ dataTypeName dt +++                                ", as it is not an Char data type."   ------------------------------------------------------------------------------@@ -805,14 +782,6 @@ ------------------------------------------------------------------------------  --- | Deprecated version (misnamed)-{-# DEPRECATED mkNorepType "Use mkNoRepType instead" #-}-mkNorepType :: String -> DataType-mkNorepType str = DataType-                        { tycon   = str-                        , datarep = NoRep-                        }- -- | Constructs a non-representation for a non-presentable type mkNoRepType :: String -> DataType mkNoRepType str = DataType@@ -880,7 +849,9 @@   gunfold _ z c  = case constrIndex c of                      1 -> z False                      2 -> z True-                     _ -> error "Data.Data.gunfold(Bool)"+                     _ -> error $ "Data.Data.gunfold: Constructor "+                                  ++ show c+                                  ++ " is not of type Bool."   dataTypeOf _ = boolDataType  @@ -893,7 +864,8 @@   toConstr x = mkCharConstr charType x   gunfold _ z c = case constrRep c of                     (CharConstr x) -> z x-                    _ -> error "Data.Data.gunfold(Char)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Char."   dataTypeOf _ = charType  @@ -906,7 +878,8 @@   toConstr = mkRealConstr floatType   gunfold _ z c = case constrRep c of                     (FloatConstr x) -> z (realToFrac x)-                    _ -> error "Data.Data.gunfold(Float)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Float."   dataTypeOf _ = floatType  @@ -919,7 +892,8 @@   toConstr = mkRealConstr doubleType   gunfold _ z c = case constrRep c of                     (FloatConstr x) -> z (realToFrac x)-                    _ -> error "Data.Data.gunfold(Double)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Double."   dataTypeOf _ = doubleType  @@ -929,10 +903,11 @@ intType = mkIntType "Prelude.Int"  instance Data Int where-  toConstr x = mkIntConstr intType (fromIntegral x)+  toConstr x = mkIntegralConstr intType x   gunfold _ z c = case constrRep c of                     (IntConstr x) -> z (fromIntegral x)-                    _ -> error "Data.Data.gunfold(Int)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Int."   dataTypeOf _ = intType  @@ -942,10 +917,11 @@ integerType = mkIntType "Prelude.Integer"  instance Data Integer where-  toConstr = mkIntConstr integerType+  toConstr = mkIntegralConstr integerType   gunfold _ z c = case constrRep c of                     (IntConstr x) -> z x-                    _ -> error "Data.Data.gunfold(Integer)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Integer."   dataTypeOf _ = integerType  @@ -955,10 +931,11 @@ int8Type = mkIntType "Data.Int.Int8"  instance Data Int8 where-  toConstr x = mkIntConstr int8Type (fromIntegral x)+  toConstr x = mkIntegralConstr int8Type x   gunfold _ z c = case constrRep c of                     (IntConstr x) -> z (fromIntegral x)-                    _ -> error "Data.Data.gunfold(Int8)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Int8."   dataTypeOf _ = int8Type  @@ -968,10 +945,11 @@ int16Type = mkIntType "Data.Int.Int16"  instance Data Int16 where-  toConstr x = mkIntConstr int16Type (fromIntegral x)+  toConstr x = mkIntegralConstr int16Type x   gunfold _ z c = case constrRep c of                     (IntConstr x) -> z (fromIntegral x)-                    _ -> error "Data.Data.gunfold(Int16)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Int16."   dataTypeOf _ = int16Type  @@ -981,10 +959,11 @@ int32Type = mkIntType "Data.Int.Int32"  instance Data Int32 where-  toConstr x = mkIntConstr int32Type (fromIntegral x)+  toConstr x = mkIntegralConstr int32Type x   gunfold _ z c = case constrRep c of                     (IntConstr x) -> z (fromIntegral x)-                    _ -> error "Data.Data.gunfold(Int32)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Int32."   dataTypeOf _ = int32Type  @@ -994,10 +973,11 @@ int64Type = mkIntType "Data.Int.Int64"  instance Data Int64 where-  toConstr x = mkIntConstr int64Type (fromIntegral x)+  toConstr x = mkIntegralConstr int64Type x   gunfold _ z c = case constrRep c of                     (IntConstr x) -> z (fromIntegral x)-                    _ -> error "Data.Data.gunfold(Int64)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Int64."   dataTypeOf _ = int64Type  @@ -1007,10 +987,11 @@ wordType = mkIntType "Data.Word.Word"  instance Data Word where-  toConstr x = mkIntConstr wordType (fromIntegral x)+  toConstr x = mkIntegralConstr wordType x   gunfold _ z c = case constrRep c of                     (IntConstr x) -> z (fromIntegral x)-                    _ -> error "Data.Data.gunfold(Word)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Word"   dataTypeOf _ = wordType  @@ -1020,10 +1001,11 @@ word8Type = mkIntType "Data.Word.Word8"  instance Data Word8 where-  toConstr x = mkIntConstr word8Type (fromIntegral x)+  toConstr x = mkIntegralConstr word8Type x   gunfold _ z c = case constrRep c of                     (IntConstr x) -> z (fromIntegral x)-                    _ -> error "Data.Data.gunfold(Word8)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Word8."   dataTypeOf _ = word8Type  @@ -1033,10 +1015,11 @@ word16Type = mkIntType "Data.Word.Word16"  instance Data Word16 where-  toConstr x = mkIntConstr word16Type (fromIntegral x)+  toConstr x = mkIntegralConstr word16Type x   gunfold _ z c = case constrRep c of                     (IntConstr x) -> z (fromIntegral x)-                    _ -> error "Data.Data.gunfold(Word16)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Word16."   dataTypeOf _ = word16Type  @@ -1046,10 +1029,11 @@ word32Type = mkIntType "Data.Word.Word32"  instance Data Word32 where-  toConstr x = mkIntConstr word32Type (fromIntegral x)+  toConstr x = mkIntegralConstr word32Type x   gunfold _ z c = case constrRep c of                     (IntConstr x) -> z (fromIntegral x)-                    _ -> error "Data.Data.gunfold(Word32)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Word32."   dataTypeOf _ = word32Type  @@ -1059,10 +1043,11 @@ word64Type = mkIntType "Data.Word.Word64"  instance Data Word64 where-  toConstr x = mkIntConstr word64Type (fromIntegral x)+  toConstr x = mkIntegralConstr word64Type x   gunfold _ z c = case constrRep c of                     (IntConstr x) -> z (fromIntegral x)-                    _ -> error "Data.Data.gunfold(Word64)"+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Word64."   dataTypeOf _ = word64Type  @@ -1313,27 +1298,98 @@  ------------------------------------------------------------------------------ -instance Typeable a => Data (Ptr a) where+instance (Data a, Typeable a) => Data (Ptr a) where   toConstr _   = error "Data.Data.toConstr(Ptr)"   gunfold _ _  = error "Data.Data.gunfold(Ptr)"   dataTypeOf _ = mkNoRepType "GHC.Ptr.Ptr"-+  dataCast1 x  = gcast1 x  ------------------------------------------------------------------------------ -instance Typeable a => Data (ForeignPtr a) where+instance (Data a, Typeable a) => Data (ForeignPtr a) where   toConstr _   = error "Data.Data.toConstr(ForeignPtr)"   gunfold _ _  = error "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 (Typeable a, Data b, Ix a) => Data (Array a b)+instance (Typeable a, Data a, Data b, Ix a) => Data (Array a b)  where   gfoldl f z a = z (listArray (bounds a)) `f` (elems a)   toConstr _   = error "Data.Data.toConstr(Array)"   gunfold _ _  = error "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+                    _ -> error "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+                      _ -> error "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+                      _ -> error "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))+                    _ -> error "Data.Data.gunfold(Version)"+  dataTypeOf _  = versionDataType

@@ -1,8 +1,6 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}-#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif  ----------------------------------------------------------------------------- -- |@@ -33,9 +31,9 @@         Dynamic,        -- abstract, instance of: Show, Typeable          -- * Converting to and from @Dynamic@-        toDyn,          -- :: Typeable a => a -> Dynamic-        fromDyn,        -- :: Typeable a => Dynamic -> a -> a-        fromDynamic,    -- :: Typeable a => Dynamic -> Maybe a+        toDyn,+        fromDyn,+        fromDynamic,                  -- * Applying functions of dynamic type         dynApply,@@ -49,25 +47,10 @@ import Data.Maybe import Unsafe.Coerce -#ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.Show import GHC.Exception-#endif -#ifdef __HUGS__-import Hugs.Prelude-import Hugs.IO-import Hugs.IORef-import Hugs.IOExts-#endif--#ifdef __NHC__-import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)-#endif--#include "Typeable.h"- ------------------------------------------------------------- -- --              The type Dynamic@@ -84,11 +67,8 @@   'Show'ing a value of type 'Dynamic' returns a pretty-printed representation   of the object\'s type; useful for debugging. -}-#ifndef __HUGS__ data Dynamic = Dynamic TypeRep Obj-#endif--INSTANCE_TYPEABLE0(Dynamic,dynamicTc,"Dynamic")+               deriving Typeable  instance Show Dynamic where    -- the instance just prints the type representation.@@ -97,12 +77,9 @@           showsPrec 0 t   .            showString ">>" -#ifdef __GLASGOW_HASKELL__ -- here so that it isn't an orphan: instance Exception Dynamic-#endif -#ifdef __GLASGOW_HASKELL__ type Obj = Any  -- Use GHC's primitive 'Any' type to hold the dynamically typed value.  --@@ -111,9 +88,6 @@  -- 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.-#elif !defined(__HUGS__)-data Obj = Obj-#endif  -- | Converts an arbitrary value into an object of type 'Dynamic'.   --

@@ -1,8 +1,7 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}-#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif+{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, TypeOperators, UndecidableInstances #-}  ----------------------------------------------------------------------------- -- |@@ -20,23 +19,21 @@  module Data.Either (    Either(..),-   either,           -- :: (a -> c) -> (b -> c) -> Either a b -> c-   lefts,            -- :: [Either a b] -> [a]-   rights,           -- :: [Either a b] -> [b]-   partitionEithers, -- :: [Either a b] -> ([a],[b])+   either,+   lefts,+   rights,+   isLeft,+   isRight,+   partitionEithers,  ) where -#include "Typeable.h"--#ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.Show import GHC.Read-#endif  import Data.Typeable+import Data.Type.Equality -#ifdef __GLASGOW_HASKELL__ {- -- just for testing import Test.QuickCheck@@ -53,7 +50,7 @@ hold a correct value (mnemonic: \"right\" also means \"correct\"). -} data  Either a b  =  Left a | Right b-  deriving (Eq, Ord, Read, Show)+  deriving (Eq, Ord, Read, Show, Typeable)  instance Functor (Either a) where     fmap _ (Left x) = Left x@@ -70,10 +67,7 @@ either                  :: (a -> c) -> (b -> c) -> Either a b -> c either f _ (Left x)     =  f x either _ g (Right y)    =  g y-#endif  /* __GLASGOW_HASKELL__ */ -INSTANCE_TYPEABLE2(Either,eitherTc,"Either")- -- | Extracts from a list of 'Either' all the 'Left' elements -- All the 'Left' elements are extracted in order. @@ -96,6 +90,27 @@  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/+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/+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  {- {--------------------------------------------------------------------

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}+{-# LANGUAGE NoImplicitPrelude #-}  ----------------------------------------------------------------------------- -- |@@ -19,7 +19,4 @@    Eq(..),  ) where -#if __GLASGOW_HASKELL__ import GHC.Base-#endif-

@@ -1,9 +1,7 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP #-}-{-# OPTIONS -Wall -fno-warn-unused-binds #-}-#ifndef __NHC__+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-}-#endif+{-# OPTIONS -Wall -fno-warn-unused-binds #-}  ----------------------------------------------------------------------------- -- |@@ -28,7 +26,7 @@ (     div',mod',divMod', -    Fixed,HasResolution(..),+    Fixed(..), HasResolution(..),     showFixed,     E0,Uni,     E1,Deci,@@ -40,16 +38,13 @@ ) where  import Prelude -- necessary to get dependencies right-import Data.Char-import Data.List-#ifndef __NHC__ import Data.Typeable import Data.Data-#endif+import GHC.Read+import Text.ParserCombinators.ReadPrec+import Text.Read.Lex -#ifndef __NHC__ default () -- avoid any defaulting shenanigans-#endif  -- | generalisation of 'div' to any instance of Real div' :: (Real a,Integral b) => a -> a -> b@@ -66,14 +61,9 @@     f = div' n d  -- | The type parameter should be an instance of 'HasResolution'.-newtype Fixed a = MkFixed Integer-#ifndef __NHC__+newtype Fixed a = MkFixed Integer -- ^ /Since: 4.7.0.0/         deriving (Eq,Ord,Typeable)-#else-        deriving (Eq,Ord)-#endif -#ifndef __NHC__ -- 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@@ -85,7 +75,6 @@     gunfold k z _ = k (z MkFixed)     dataTypeOf _ = tyFixed     toConstr _ = conMkFixed-#endif  class HasResolution a where     resolution :: p a -> Integer@@ -159,89 +148,65 @@     maxnum = 10 ^ digits     fracNum = div (d * maxnum) res -readsFixed :: (HasResolution a) => ReadS (Fixed a)-readsFixed = readsSigned-    where readsSigned ('-' : xs) = [ (negate x, rest)-                                   | (x, rest) <- readsUnsigned xs ]-          readsSigned xs = readsUnsigned xs-          readsUnsigned xs = case span isDigit xs of-                             ([], _) -> []-                             (is, xs') ->-                                 let i = fromInteger (read is)-                                 in case xs' of-                                    '.' : xs'' ->-                                        case span isDigit xs'' of-                                        ([], _) -> []-                                        (js, xs''') ->-                                            let j = fromInteger (read js)-                                                l = genericLength js :: Integer-                                            in [(i + (j / (10 ^ l)), xs''')]-                                    _ -> [(i, xs')]- instance (HasResolution a) => Show (Fixed a) where     show = showFixed False  instance (HasResolution a) => Read (Fixed a) where-    readsPrec _ = readsFixed+    readPrec     = readNumber convertFixed+    readListPrec = readListPrecDefault+    readList     = readListDefault +convertFixed :: forall a . HasResolution a => Lexeme -> ReadPrec (Fixed a)+convertFixed (Number n)+ | Just (i, f) <- numberToFixed r n =+    return (fromInteger i + (fromInteger f / (10 ^ r)))+    where r = resolution (undefined :: Fixed a)+convertFixed _ = pfail+ data E0 = E0-#ifndef __NHC__      deriving (Typeable)-#endif instance HasResolution E0 where     resolution _ = 1 -- | resolution of 1, this works the same as Integer type Uni = Fixed E0  data E1 = E1-#ifndef __NHC__      deriving (Typeable)-#endif instance HasResolution E1 where     resolution _ = 10 -- | resolution of 10^-1 = .1 type Deci = Fixed E1  data E2 = E2-#ifndef __NHC__      deriving (Typeable)-#endif instance HasResolution E2 where     resolution _ = 100 -- | resolution of 10^-2 = .01, useful for many monetary currencies type Centi = Fixed E2  data E3 = E3-#ifndef __NHC__      deriving (Typeable)-#endif instance HasResolution E3 where     resolution _ = 1000 -- | resolution of 10^-3 = .001 type Milli = Fixed E3  data E6 = E6-#ifndef __NHC__      deriving (Typeable)-#endif instance HasResolution E6 where     resolution _ = 1000000 -- | resolution of 10^-6 = .000001 type Micro = Fixed E6  data E9 = E9-#ifndef __NHC__      deriving (Typeable)-#endif instance HasResolution E9 where     resolution _ = 1000000000 -- | resolution of 10^-9 = .000000001 type Nano = Fixed E9  data E12 = E12-#ifndef __NHC__      deriving (Typeable)-#endif instance HasResolution E12 where     resolution _ = 1000000000000 -- | resolution of 10^-12 = .000000000001

@@ -1,5 +1,4 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP #-}  ----------------------------------------------------------------------------- -- |@@ -67,22 +66,10 @@ import Control.Monad (MonadPlus(..)) import Data.Maybe (fromMaybe, listToMaybe) import Data.Monoid--#ifdef __NHC__-import Control.Arrow (ArrowZero(..)) -- work around nhc98 typechecker problem-#endif+import Data.Proxy -#ifdef __GLASGOW_HASKELL__ import GHC.Exts (build)-#endif--#if defined(__GLASGOW_HASKELL__) import GHC.Arr-#elif defined(__HUGS__)-import Hugs.Array-#elif defined(__NHC__)-import Array-#endif  -- | Data structures that can be folded. --@@ -132,14 +119,14 @@     -- | Left-associative fold of a structure.     --     -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@-    foldl :: (a -> b -> a) -> a -> t b -> a+    foldl :: (b -> a -> b) -> b -> t a -> b     foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z      -- | Left-associative fold of a structure.     -- but with strict application of the operator.     --     -- @'foldl' f z = 'List.foldl'' f z . 'toList'@-    foldl' :: (a -> b -> a) -> a -> t b -> a+    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 @@ -164,6 +151,7 @@       where         mf Nothing y = Just y         mf (Just x) y = Just (f x y)+    {-# MINIMAL foldMap | foldr #-}  -- instances for Prelude types @@ -181,12 +169,41 @@     foldr1 = Prelude.foldr1     foldl1 = Prelude.foldl1 +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++instance Foldable ((,) a) where+    foldMap f (_, y) = f y++    foldr f z (_, y) = f y z+ instance Ix i => Foldable (Array i) where     foldr f z = Prelude.foldr f z . elems     foldl f z = Prelude.foldl f z . elems     foldr1 f = Prelude.foldr1 f . elems     foldl1 f = Prelude.foldl1 f . elems +instance Foldable Proxy where+    foldMap _ _ = mempty+    {-# INLINE foldMap #-}+    fold _ = mempty+    {-# INLINE fold #-}+    foldr _ z _ = z+    {-# INLINE foldr #-}+    foldl _ z _ = z+    {-# INLINE foldl #-}+    foldl1 _ _ = error "foldl1: Proxy"+    {-# INLINE foldl1 #-}+    foldr1 _ _ = error "foldr1: Proxy"+    {-# INLINE foldr1 #-}++instance Foldable (Const m) where+    foldMap _ _ = mempty+ -- | 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@@ -195,7 +212,7 @@  -- | Monadic fold over the elements of a structure, -- associating to the left, i.e. from left to right.-foldlM :: (Foldable t, Monad m) => (a -> b -> m a) -> a -> t b -> m a+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 @@ -244,11 +261,7 @@ -- | List of elements of a structure. toList :: Foldable t => t a -> [a] {-# INLINE toList #-}-#ifdef __GLASGOW_HASKELL__ toList t = build (\ c n -> foldr c n t)-#else-toList = foldr (:) []-#endif  -- | The concatenation of all the elements of a container of lists. concat :: Foldable t => t [a] -> [a]

@@ -1,5 +1,4 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP #-}  ----------------------------------------------------------------------------- -- |@@ -18,19 +17,25 @@     (       Functor(fmap),       (<$),+      ($>),       (<$>),+      void,     ) where -#ifdef __GLASGOW_HASKELL__+import Control.Monad import GHC.Base (Functor(..))-#else-(<$) :: Functor f => a -> f b -> f a-(<$) =  fmap . const-#endif  infixl 4 <$>  -- | An infix synonym for 'fmap'. (<$>) :: Functor f => (a -> b) -> f a -> f b (<$>) = fmap++infixl 4 $>++-- | Flipped version of '<$'.+--+-- /Since: 4.7.0.0/+($>) :: Functor f => f a -> b -> f b+($>) = flip (<$) 

@@ -1,536 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}-{-# OPTIONS_GHC -funbox-strict-fields -fno-warn-name-shadowing #-}---------------------------------------------------------------------------------- |--- Module      :  Data.HashTable--- Copyright   :  (c) The University of Glasgow 2003--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ An implementation of extensible hash tables, as described in--- Per-Ake Larson, /Dynamic Hash Tables/, CACM 31(4), April 1988,--- pp. 446--457.  The implementation is also derived from the one--- in GHC's runtime system (@ghc\/rts\/Hash.{c,h}@).-----------------------------------------------------------------------------------module Data.HashTable-      {-# DEPRECATED "Data.HashTable will be removed in GHC 7.8. Please use an alternative, e.g. the hashtables package, instead." #-}-      (-        -- * Basic hash table operations-        HashTable, new, newHint, insert, delete, lookup, update,-        -- * Converting to and from lists-        fromList, toList,-        -- * Hash functions-        -- $hash_functions-        hashInt, hashString,-        prime,-        -- * Diagnostics-        longestChain- ) where---- This module is imported by Data.Dynamic, which is pretty low down in the--- module hierarchy, so don't import "high-level" modules--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#else-import Prelude  hiding  ( lookup )-#endif-import Data.Tuple       ( fst )-import Data.Bits-import Data.Maybe-import Data.List        ( maximumBy, length, concat, foldl', partition )-import Data.Int         ( Int32 )--#if defined(__GLASGOW_HASKELL__)-import GHC.Num-import GHC.Real         ( fromIntegral )-import GHC.Show         ( Show(..) )-import GHC.Int          ( Int64 )--import GHC.IO-import GHC.IOArray-import GHC.IORef-#else-import Data.Char        ( ord )-import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )-import System.IO.Unsafe ( unsafePerformIO )-import Data.Int         ( Int64 )-#  if defined(__HUGS__)-import Hugs.IOArray     ( IOArray, newIOArray,-                          unsafeReadIOArray, unsafeWriteIOArray )-#  elif defined(__NHC__)-import NHC.IOExtras     ( IOArray, newIOArray, readIOArray, writeIOArray )-#  endif-#endif-import Control.Monad    ( mapM, mapM_, sequence_ )----------------------------------------------------------------------------iNSTRUMENTED :: Bool-iNSTRUMENTED = False---------------------------------------------------------------------------readHTArray  :: HTArray a -> Int32 -> IO a-writeMutArray :: MutArray a -> Int32 -> a -> IO ()-newMutArray   :: (Int32, Int32) -> a -> IO (MutArray a)-newMutArray = newIOArray-type MutArray a = IOArray Int32 a-type HTArray a = MutArray a-#if defined(DEBUG) || defined(__NHC__)-readHTArray  = readIOArray-writeMutArray = writeIOArray-#else-readHTArray arr i = unsafeReadIOArray arr (fromIntegral i)-writeMutArray arr i x = unsafeWriteIOArray arr (fromIntegral i) x-#endif--data HashTable key val = HashTable {-                                     cmp     :: !(key -> key -> Bool),-                                     hash_fn :: !(key -> Int32),-                                     tab     :: !(IORef (HT key val))-                                   }--- TODO: the IORef should really be an MVar.--data HT key val-  = HT {-        kcount  :: !Int32,              -- Total number of keys.-        bmask   :: !Int32,-        buckets :: !(HTArray [(key,val)])-       }---- --------------------------------------------------------------- Instrumentation for performance tuning---- This ought to be roundly ignored after optimization when--- iNSTRUMENTED=False.---- STRICT version of modifyIORef!-modifyIORef :: IORef a -> (a -> a) -> IO ()-modifyIORef r f = do-  v <- readIORef r-  let z = f v in z `seq` writeIORef r z--data HashData = HD {-  tables :: !Integer,-  insertions :: !Integer,-  lookups :: !Integer,-  totBuckets :: !Integer,-  maxEntries :: !Int32,-  maxChain :: !Int,-  maxBuckets :: !Int32-} deriving (Eq, Show)--{-# NOINLINE hashData #-}-hashData :: IORef HashData-hashData =  unsafePerformIO (newIORef (HD { tables=0, insertions=0, lookups=0,-                                            totBuckets=0, maxEntries=0,-                                            maxChain=0, maxBuckets=tABLE_MIN } ))--instrument :: (HashData -> HashData) -> IO ()-instrument i | iNSTRUMENTED = modifyIORef hashData i-             | otherwise    = return ()--recordNew :: IO ()-recordNew = instrument rec-  where rec hd@HD{ tables=t, totBuckets=b } =-               hd{ tables=t+1, totBuckets=b+fromIntegral tABLE_MIN }--recordIns :: Int32 -> Int32 -> [a] -> IO ()-recordIns i sz bkt = instrument rec-  where rec hd@HD{ insertions=ins, maxEntries=mx, maxChain=mc } =-               hd{ insertions=ins+fromIntegral i, maxEntries=mx `max` sz,-                   maxChain=mc `max` length bkt }--recordResize :: Int32 -> Int32 -> IO ()-recordResize older newer = instrument rec-  where rec hd@HD{ totBuckets=b, maxBuckets=mx } =-               hd{ totBuckets=b+fromIntegral (newer-older),-                   maxBuckets=mx `max` newer }--recordLookup :: IO ()-recordLookup = instrument lkup-  where lkup hd@HD{ lookups=l } = hd{ lookups=l+1 }---- stats :: IO String--- stats =  fmap show $ readIORef hashData---- ------------------------------------------------------------------------------- Sample hash functions---- $hash_functions------ This implementation of hash tables uses the low-order /n/ bits of the hash--- value for a key, where /n/ varies as the hash table grows.  A good hash--- function therefore will give an even distribution regardless of /n/.------ If your keyspace is integrals such that the low-order bits between--- keys are highly variable, then you could get away with using 'fromIntegral'--- as the hash function.------ We provide some sample hash functions for 'Int' and 'String' below.--golden :: Int32-golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32--- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32--- but that has bad mulHi properties (even adding 2^32 to get its inverse)--- Whereas the above works well and contains no hash duplications for--- [-32767..65536]--hashInt32 :: Int32 -> Int32-hashInt32 x = mulHi x golden + x---- | A sample (and useful) hash function for Int and Int32,--- implemented by extracting the uppermost 32 bits of the 64-bit--- result of multiplying by a 33-bit constant.  The constant is from--- Knuth, derived from the golden ratio:------ > golden = round ((sqrt 5 - 1) * 2^32)------ We get good key uniqueness on small inputs--- (a problem with previous versions):---  (length $ group $ sort $ map hashInt [-32767..65536]) == 65536 + 32768----hashInt :: Int -> Int32-hashInt x = hashInt32 (fromIntegral x)---- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply-mulHi :: Int32 -> Int32 -> Int32-mulHi a b = fromIntegral (r `shiftR` 32)-   where r :: Int64-         r = fromIntegral a * fromIntegral b---- | A sample hash function for Strings.  We keep multiplying by the--- golden ratio and adding.  The implementation is:------ > hashString = foldl' f golden--- >   where f m c = fromIntegral (ord c) * magic + hashInt32 m--- >         magic = 0xdeadbeef------ Where hashInt32 works just as hashInt shown above.------ Knuth argues that repeated multiplication by the golden ratio--- will minimize gaps in the hash space, and thus it's a good choice--- for combining together multiple keys to form one.------ Here we know that individual characters c are often small, and this--- produces frequent collisions if we use ord c alone.  A--- particular problem are the shorter low ASCII and ISO-8859-1--- character strings.  We pre-multiply by a magic twiddle factor to--- obtain a good distribution.  In fact, given the following test:------ > testp :: Int32 -> Int--- > testp k = (n - ) . length . group . sort . map hs . take n $ ls--- >   where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']]--- >         hs = foldl' f golden--- >         f m c = fromIntegral (ord c) * k + hashInt32 m--- >         n = 100000------ We discover that testp magic = 0.--hashString :: String -> Int32-hashString = foldl' f golden-   where f m c = fromIntegral (ord c) * magic + hashInt32 m-         magic = 0xdeadbeef---- | A prime larger than the maximum hash table size-prime :: Int32-prime = 33554467---- -------------------------------------------------------------------------------- Parameters--tABLE_MAX :: Int32-tABLE_MAX  = 32 * 1024 * 1024   -- Maximum size of hash table-tABLE_MIN :: Int32-tABLE_MIN  = 8--hLOAD :: Int32-hLOAD = 7                       -- Maximum average load of a single hash bucket--hYSTERESIS :: Int32-hYSTERESIS = 64                 -- entries to ignore in load computation--{- Hysteresis favors long association-list-like behavior for small tables. -}---- -------------------------------------------------------------------------------- Creating a new hash table---- | Creates a new hash table.  The following property should hold for the @eq@--- and @hash@ functions passed to 'new':------ >   eq A B  =>  hash A == hash B----new-  :: (key -> key -> Bool)    -- ^ @eq@: An equality comparison on keys-  -> (key -> Int32)          -- ^ @hash@: A hash function on keys-  -> IO (HashTable key val)  -- ^ Returns: an empty hash table--new cmpr hash = do-  recordNew-  -- make a new hash table with a single, empty, segment-  let mask = tABLE_MIN-1-  bkts <- newMutArray (0,mask) []--  let-    kcnt = 0-    ht = HT {  buckets=bkts, kcount=kcnt, bmask=mask }--  table <- newIORef ht-  return (HashTable { tab=table, hash_fn=hash, cmp=cmpr })--{- -   bitTwiddleSameAs takes as arguments positive Int32s less than maxBound/2 and -   returns the smallest power of 2 that is greater than or equal to the -   argument.-   http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2--}-bitTwiddleSameAs :: Int32 -> Int32-bitTwiddleSameAs v0 = -    let v1 = v0-1-        v2 = v1 .|. (v1`shiftR`1)-        v3 = v2 .|. (v2`shiftR`2)-        v4 = v3 .|. (v3`shiftR`4)-        v5 = v4 .|. (v4`shiftR`8)-        v6 = v5 .|. (v5`shiftR`16)-    in v6+1--{--  powerOver takes as arguments Int32s and returns the smallest power of 2 -  that is greater than or equal to the argument if that power of 2 is -  within [tABLE_MIN,tABLE_MAX]--}-powerOver :: Int32 -> Int32-powerOver n = -    if n <= tABLE_MIN-    then tABLE_MIN-    else if n >= tABLE_MAX-         then tABLE_MAX-         else bitTwiddleSameAs n ---- | Creates a new hash table with the given minimum size.-newHint-  :: (key -> key -> Bool)    -- ^ @eq@: An equality comparison on keys-  -> (key -> Int32)          -- ^ @hash@: A hash function on keys-  -> Int                     -- ^ @minSize@: initial table size-  -> IO (HashTable key val)  -- ^ Returns: an empty hash table--newHint cmpr hash minSize = do-  recordNew-  -- make a new hash table with a single, empty, segment-  let mask = powerOver $ fromIntegral minSize-  bkts <- newMutArray (0,mask) []--  let-    kcnt = 0-    ht = HT {  buckets=bkts, kcount=kcnt, bmask=mask }--  table <- newIORef ht-  return (HashTable { tab=table, hash_fn=hash, cmp=cmpr })---- -------------------------------------------------------------------------------- Inserting a key\/value pair into the hash table---- | Inserts a key\/value mapping into the hash table.------ Note that 'insert' doesn't remove the old entry from the table ---- the behaviour is like an association list, where 'lookup' returns--- the most-recently-inserted mapping for a key in the table.  The--- reason for this is to keep 'insert' as efficient as possible.  If--- you need to update a mapping, then we provide 'update'.----insert :: HashTable key val -> key -> val -> IO ()--insert ht key val =-  updatingBucket CanInsert (\bucket -> ((key,val):bucket, 1, ())) ht key----- --------------------------------------------------------------- The core of the implementation is lurking down here, in findBucket,--- updatingBucket, and expandHashTable.--tooBig :: Int32 -> Int32 -> Bool-tooBig k b = k-hYSTERESIS > hLOAD * b---- index of bucket within table.-bucketIndex :: Int32 -> Int32 -> Int32-bucketIndex mask h = h .&. mask---- find the bucket in which the key belongs.--- returns (key equality, bucket index, bucket)------ This rather grab-bag approach gives enough power to do pretty much--- any bucket-finding thing you might want to do.  We rely on inlining--- to throw away the stuff we don't want.  I'm proud to say that this--- plus updatingBucket below reduce most of the other definitions to a--- few lines of code, while actually speeding up the hashtable--- implementation when compared with a version which does everything--- from scratch.-{-# INLINE findBucket #-}-findBucket :: HashTable key val -> key -> IO (HT key val, Int32, [(key,val)])-findBucket HashTable{ tab=ref, hash_fn=hash} key = do-  table@HT{ buckets=bkts, bmask=b } <- readIORef ref-  let indx = bucketIndex b (hash key)-  bucket <- readHTArray bkts indx-  return (table, indx, bucket)--data Inserts = CanInsert-             | Can'tInsert-             deriving (Eq)---- updatingBucket is the real workhorse of all single-element table--- updates.  It takes a hashtable and a key, along with a function--- describing what to do with the bucket in which that key belongs.  A--- flag indicates whether this function may perform table insertions.--- The function returns the new contents of the bucket, the number of--- bucket entries inserted (negative if entries were deleted), and a--- value which becomes the return value for the function as a whole.--- The table sizing is enforced here, calling out to expandSubTable as--- necessary.---- This function is intended to be inlined and specialized for every--- calling context (eg every provided bucketFn).-{-# INLINE updatingBucket #-}--updatingBucket :: Inserts -> ([(key,val)] -> ([(key,val)], Int32, a)) ->-                  HashTable key val -> key ->-                  IO a-updatingBucket canEnlarge bucketFn-               ht@HashTable{ tab=ref, hash_fn=hash } key = do-  (table@HT{ kcount=k, buckets=bkts, bmask=b },-   indx, bckt) <- findBucket ht key-  (bckt', inserts, result) <- return $ bucketFn bckt-  let k' = k + inserts-      table1 = table { kcount=k' }-  writeMutArray bkts indx bckt'-  table2 <- if canEnlarge == CanInsert && inserts > 0 then do-               recordIns inserts k' bckt'-               if tooBig k' b-                  then expandHashTable hash table1-                  else return table1-            else return table1-  writeIORef ref table2-  return result--expandHashTable :: (key -> Int32) -> HT key val -> IO (HT key val)-expandHashTable hash table@HT{ buckets=bkts, bmask=mask } = do-   let-      oldsize = mask + 1-      newmask = mask + mask + 1-   recordResize oldsize (newmask+1)-   ---   if newmask > tABLE_MAX-1-      then return table-      else do-   ---    newbkts <- newMutArray (0,newmask) []--    let-     splitBucket oldindex = do-       bucket <- readHTArray bkts oldindex-       let (oldb,newb) =-              partition ((oldindex==). bucketIndex newmask . hash . fst) bucket-       writeMutArray newbkts oldindex oldb-       writeMutArray newbkts (oldindex + oldsize) newb-    mapM_ splitBucket [0..mask]--    return ( table{ buckets=newbkts, bmask=newmask } )---- -------------------------------------------------------------------------------- Deleting a mapping from the hash table---- Remove a key from a bucket-deleteBucket :: (key -> Bool) -> [(key,val)] -> ([(key, val)], Int32, ())-deleteBucket _   [] = ([],0,())-deleteBucket del (pair@(k,_):bucket) =-  case deleteBucket del bucket of-    (bucket', dels, _) | del k     -> dels' `seq` (bucket', dels', ())-                       | otherwise -> (pair:bucket', dels, ())-      where dels' = dels - 1---- | Remove an entry from the hash table.-delete :: HashTable key val -> key -> IO ()--delete ht@HashTable{ cmp=eq } key =-  updatingBucket Can'tInsert (deleteBucket (eq key)) ht key---- -------------------------------------------------------------------------------- Updating a mapping in the hash table---- | Updates an entry in the hash table, returning 'True' if there was--- already an entry for this key, or 'False' otherwise.  After 'update'--- there will always be exactly one entry for the given key in the table.------ 'insert' is more efficient than 'update' if you don't care about--- multiple entries, or you know for sure that multiple entries can't--- occur.  However, 'update' is more efficient than 'delete' followed--- by 'insert'.-update :: HashTable key val -> key -> val -> IO Bool--update ht@HashTable{ cmp=eq } key val =-  updatingBucket CanInsert-    (\bucket -> let (bucket', dels, _) = deleteBucket (eq key) bucket-                in  ((key,val):bucket', 1+dels, dels/=0))-    ht key---- -------------------------------------------------------------------------------- Looking up an entry in the hash table---- | Looks up the value of a key in the hash table.-lookup :: HashTable key val -> key -> IO (Maybe val)--lookup ht@HashTable{ cmp=eq } key = do-  recordLookup-  (_, _, bucket) <- findBucket ht key-  let firstHit (k,v) r | eq key k  = Just v-                       | otherwise = r-  return (foldr firstHit Nothing bucket)---- -------------------------------------------------------------------------------- Converting to/from lists---- | Convert a list of key\/value pairs into a hash table.  Equality on keys--- is taken from the Eq instance for the key type.----fromList :: (Eq key) => (key -> Int32) -> [(key,val)] -> IO (HashTable key val)-fromList hash list = do-  table <- new (==) hash-  sequence_ [ insert table k v | (k,v) <- list ]-  return table---- | Converts a hash table to a list of key\/value pairs.----toList :: HashTable key val -> IO [(key,val)]-toList = mapReduce id concat--{-# INLINE mapReduce #-}-mapReduce :: ([(key,val)] -> r) -> ([r] -> r) -> HashTable key val -> IO r-mapReduce m r HashTable{ tab=ref } = do-  HT{ buckets=bckts, bmask=b } <- readIORef ref-  fmap r (mapM (fmap m . readHTArray bckts) [0..b])---- -------------------------------------------------------------------------------- Diagnostics---- | This function is useful for determining whether your hash--- function is working well for your data set.  It returns the longest--- chain of key\/value pairs in the hash table for which all the keys--- hash to the same bucket.  If this chain is particularly long (say,--- longer than 14 elements or so), then it might be a good idea to try--- a different hash function.----longestChain :: HashTable key val -> IO [(key,val)]-longestChain = mapReduce id (maximumBy lengthCmp)-  where lengthCmp (_:x)(_:y) = lengthCmp x y-        lengthCmp []   []    = EQ-        lengthCmp []   _     = LT-        lengthCmp _    []    = GT-

@@ -19,17 +19,17 @@   (          -- * IORefs         IORef,                -- abstract, instance of: Eq, Typeable-        newIORef,             -- :: a -> IO (IORef a)-        readIORef,            -- :: IORef a -> IO a-        writeIORef,           -- :: IORef a -> a -> IO ()-        modifyIORef,          -- :: IORef a -> (a -> a) -> IO ()-        modifyIORef',         -- :: IORef a -> (a -> a) -> IO ()-        atomicModifyIORef,    -- :: IORef a -> (a -> (a,b)) -> IO b-        atomicModifyIORef',   -- :: IORef a -> (a -> (a,b)) -> IO b+        newIORef,+        readIORef,+        writeIORef,+        modifyIORef,+        modifyIORef',+        atomicModifyIORef,+        atomicModifyIORef',         atomicWriteIORef, -#if !defined(__PARALLEL_HASKELL__) && defined(__GLASGOW_HASKELL__)-        mkWeakIORef,          -- :: IORef a -> IO () -> IO (Weak (IORef a))+#if !defined(__PARALLEL_HASKELL__)+        mkWeakIORef, #endif         -- ** Memory Model @@ -37,11 +37,6 @@          ) where -#ifdef __HUGS__-import Hugs.IORef-#endif--#ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.STRef import GHC.IORef hiding (atomicModifyIORef)@@ -49,19 +44,8 @@ #if !defined(__PARALLEL_HASKELL__) import GHC.Weak #endif-#endif /* __GLASGOW_HASKELL__ */ -#ifdef __NHC__-import NHC.IOExtras-    ( IORef-    , newIORef-    , readIORef-    , writeIORef-    , excludeFinalisers-    )-#endif--#if defined(__GLASGOW_HASKELL__) && !defined(__PARALLEL_HASKELL__)+#if !defined(__PARALLEL_HASKELL__) -- |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))@@ -86,6 +70,8 @@ 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@@ -112,25 +98,12 @@ -- Use 'atomicModifyIORef'' or 'atomicWriteIORef' to avoid this problem. -- atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b-#if defined(__GLASGOW_HASKELL__) atomicModifyIORef = GHC.IORef.atomicModifyIORef -#elif defined(__HUGS__)-atomicModifyIORef = plainModifyIORef    -- Hugs has no preemption-  where plainModifyIORef r f = do-                a <- readIORef r-                case f a of (a',b) -> writeIORef r a' >> return b-#elif defined(__NHC__)-atomicModifyIORef r f =-  excludeFinalisers $ do-    a <- readIORef r-    let (a',b) = f a-    writeIORef r a'-    return b-#endif- -- | 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@@ -140,6 +113,8 @@  -- | 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, ()))@@ -175,7 +150,7 @@   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 therad.+  point of view of the current thread.    'atomicModifyIORef' acts as a barrier to reordering.  Multiple   'atomicModifyIORef' operations occur in strict program order.  An

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}+{-# LANGUAGE NoImplicitPrelude #-}  ----------------------------------------------------------------------------- -- |@@ -26,21 +26,8 @@         -- $notes         ) where -#ifdef __GLASGOW_HASKELL__ import GHC.Base ( Int ) import GHC.Int  ( Int8, Int16, Int32, Int64 )-#endif--#ifdef __HUGS__-import Hugs.Int ( Int8, Int16, Int32, Int64 )-#endif--#ifdef __NHC__-import Prelude-import Prelude (Int)-import NHC.FFI (Int8, Int16, Int32, Int64)-import NHC.SizedTypes (Int8, Int16, Int32, Int64)       -- instances of Bits-#endif  {- $notes 

@@ -1,5 +1,4 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP #-}  ----------------------------------------------------------------------------- -- |@@ -21,10 +20,10 @@     (     -- * The 'Ix' class         Ix-          ( range       -- :: (Ix a) => (a,a) -> [a]-          , index       -- :: (Ix a) => (a,a) -> a   -> Int-          , inRange     -- :: (Ix a) => (a,a) -> a   -> Bool-          , rangeSize   -- :: (Ix a) => (a,a) -> Int+          ( range+          , index+          , inRange+          , rangeSize           )     -- Ix instances:     --@@ -64,15 +63,4 @@  -- import Prelude -#ifdef __GLASGOW_HASKELL__ import GHC.Arr-#endif--#ifdef __HUGS__-import Hugs.Prelude( Ix(..) )-#endif--#ifdef __NHC__-import Ix (Ix(..))-#endif-

@@ -17,159 +17,154 @@  module Data.List    (-#ifdef __NHC__-     [] (..)-   ,-#endif-    -- * Basic functions -     (++)              -- :: [a] -> [a] -> [a]-   , head              -- :: [a] -> a-   , last              -- :: [a] -> a-   , tail              -- :: [a] -> [a]-   , init              -- :: [a] -> [a]-   , null              -- :: [a] -> Bool-   , length            -- :: [a] -> Int+     (++)+   , head+   , last+   , tail+   , init+   , null+   , length     -- * List transformations-   , map               -- :: (a -> b) -> [a] -> [b]-   , reverse           -- :: [a] -> [a]+   , map+   , reverse -   , intersperse       -- :: a -> [a] -> [a]-   , intercalate       -- :: [a] -> [[a]] -> [a]-   , transpose         -- :: [[a]] -> [[a]]+   , intersperse+   , intercalate+   , transpose    -   , subsequences      -- :: [a] -> [[a]]-   , permutations      -- :: [a] -> [[a]]+   , subsequences+   , permutations     -- * Reducing lists (folds) -   , foldl             -- :: (a -> b -> a) -> a -> [b] -> a-   , foldl'            -- :: (a -> b -> a) -> a -> [b] -> a-   , foldl1            -- :: (a -> a -> a) -> [a] -> a-   , foldl1'           -- :: (a -> a -> a) -> [a] -> a-   , foldr             -- :: (a -> b -> b) -> b -> [a] -> b-   , foldr1            -- :: (a -> a -> a) -> [a] -> a+   , foldl+   , foldl'+   , foldl1+   , foldl1'+   , foldr+   , foldr1     -- ** Special folds -   , concat            -- :: [[a]] -> [a]-   , concatMap         -- :: (a -> [b]) -> [a] -> [b]-   , and               -- :: [Bool] -> Bool-   , or                -- :: [Bool] -> Bool-   , any               -- :: (a -> Bool) -> [a] -> Bool-   , all               -- :: (a -> Bool) -> [a] -> Bool-   , sum               -- :: (Num a) => [a] -> a-   , product           -- :: (Num a) => [a] -> a-   , maximum           -- :: (Ord a) => [a] -> a-   , minimum           -- :: (Ord a) => [a] -> a+   , concat+   , concatMap+   , and+   , or+   , any+   , all+   , sum+   , product+   , maximum+   , minimum     -- * Building lists     -- ** Scans-   , scanl             -- :: (a -> b -> a) -> a -> [b] -> [a]-   , scanl1            -- :: (a -> a -> a) -> [a] -> [a]-   , scanr             -- :: (a -> b -> b) -> b -> [a] -> [b]-   , scanr1            -- :: (a -> a -> a) -> [a] -> [a]+   , scanl+   , scanl1+   , scanr+   , scanr1     -- ** Accumulating maps-   , mapAccumL         -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])-   , mapAccumR         -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])+   , mapAccumL+   , mapAccumR     -- ** Infinite lists-   , iterate           -- :: (a -> a) -> a -> [a]-   , repeat            -- :: a -> [a]-   , replicate         -- :: Int -> a -> [a]-   , cycle             -- :: [a] -> [a]+   , iterate+   , repeat+   , replicate+   , cycle     -- ** Unfolding-   , unfoldr           -- :: (b -> Maybe (a, b)) -> b -> [a]+   , unfoldr     -- * Sublists     -- ** Extracting sublists-   , take              -- :: Int -> [a] -> [a]-   , drop              -- :: Int -> [a] -> [a]-   , splitAt           -- :: Int -> [a] -> ([a], [a])+   , take+   , drop+   , splitAt -   , takeWhile         -- :: (a -> Bool) -> [a] -> [a]-   , dropWhile         -- :: (a -> Bool) -> [a] -> [a]-   , dropWhileEnd      -- :: (a -> Bool) -> [a] -> [a]-   , span              -- :: (a -> Bool) -> [a] -> ([a], [a])-   , break             -- :: (a -> Bool) -> [a] -> ([a], [a])+   , takeWhile+   , dropWhile+   , dropWhileEnd+   , span+   , break -   , stripPrefix       -- :: Eq a => [a] -> [a] -> Maybe [a]+   , stripPrefix -   , group             -- :: Eq a => [a] -> [[a]]+   , group -   , inits             -- :: [a] -> [[a]]-   , tails             -- :: [a] -> [[a]]+   , inits+   , tails     -- ** Predicates-   , isPrefixOf        -- :: (Eq a) => [a] -> [a] -> Bool-   , isSuffixOf        -- :: (Eq a) => [a] -> [a] -> Bool-   , isInfixOf         -- :: (Eq a) => [a] -> [a] -> Bool+   , isPrefixOf+   , isSuffixOf+   , isInfixOf     -- * Searching lists     -- ** Searching by equality-   , elem              -- :: a -> [a] -> Bool-   , notElem           -- :: a -> [a] -> Bool-   , lookup            -- :: (Eq a) => a -> [(a,b)] -> Maybe b+   , elem+   , notElem+   , lookup     -- ** Searching with a predicate-   , find              -- :: (a -> Bool) -> [a] -> Maybe a-   , filter            -- :: (a -> Bool) -> [a] -> [a]-   , partition         -- :: (a -> Bool) -> [a] -> ([a], [a])+   , find+   , filter+   , partition     -- * Indexing lists    -- | These functions treat a list @xs@ as a indexed collection,    -- with indices ranging from 0 to @'length' xs - 1@. -   , (!!)              -- :: [a] -> Int -> a+   , (!!) -   , elemIndex         -- :: (Eq a) => a -> [a] -> Maybe Int-   , elemIndices       -- :: (Eq a) => a -> [a] -> [Int]+   , elemIndex+   , elemIndices -   , findIndex         -- :: (a -> Bool) -> [a] -> Maybe Int-   , findIndices       -- :: (a -> Bool) -> [a] -> [Int]+   , findIndex+   , findIndices     -- * Zipping and unzipping lists -   , zip               -- :: [a] -> [b] -> [(a,b)]+   , zip    , zip3    , zip4, zip5, zip6, zip7 -   , zipWith           -- :: (a -> b -> c) -> [a] -> [b] -> [c]+   , zipWith    , zipWith3    , zipWith4, zipWith5, zipWith6, zipWith7 -   , unzip             -- :: [(a,b)] -> ([a],[b])+   , unzip    , unzip3    , unzip4, unzip5, unzip6, unzip7     -- * Special lists     -- ** Functions on strings-   , lines             -- :: String   -> [String]-   , words             -- :: String   -> [String]-   , unlines           -- :: [String] -> String-   , unwords           -- :: [String] -> String+   , lines+   , words+   , unlines+   , unwords     -- ** \"Set\" operations -   , nub               -- :: (Eq a) => [a] -> [a]+   , nub -   , delete            -- :: (Eq a) => a -> [a] -> [a]-   , (\\)              -- :: (Eq a) => [a] -> [a] -> [a]+   , delete+   , (\\) -   , union             -- :: (Eq a) => [a] -> [a] -> [a]-   , intersect         -- :: (Eq a) => [a] -> [a] -> [a]+   , union+   , intersect     -- ** Ordered lists-   , sort              -- :: (Ord a) => [a] -> [a]-   , insert            -- :: (Ord a) => a -> [a] -> [a]+   , sort+   , insert     -- * Generalized functions @@ -183,46 +178,40 @@     -- *** User-supplied equality (replacing an @Eq@ context)    -- | The predicate is assumed to define an equivalence.-   , nubBy             -- :: (a -> a -> Bool) -> [a] -> [a]-   , deleteBy          -- :: (a -> a -> Bool) -> a -> [a] -> [a]-   , deleteFirstsBy    -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]-   , unionBy           -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]-   , intersectBy       -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]-   , groupBy           -- :: (a -> a -> Bool) -> [a] -> [[a]]+   , nubBy+   , deleteBy+   , deleteFirstsBy+   , unionBy+   , intersectBy+   , groupBy     -- *** User-supplied comparison (replacing an @Ord@ context)    -- | The function is assumed to define a total ordering.-   , sortBy            -- :: (a -> a -> Ordering) -> [a] -> [a]-   , insertBy          -- :: (a -> a -> Ordering) -> a -> [a] -> [a]-   , maximumBy         -- :: (a -> a -> Ordering) -> [a] -> a-   , minimumBy         -- :: (a -> a -> Ordering) -> [a] -> a+   , sortBy+   , insertBy+   , maximumBy+   , minimumBy     -- ** The \"@generic@\" operations    -- | The prefix \`@generic@\' indicates an overloaded function that    -- is a generalized version of a "Prelude" function. -   , genericLength     -- :: (Integral a) => [b] -> a-   , genericTake       -- :: (Integral a) => a -> [b] -> [b]-   , genericDrop       -- :: (Integral a) => a -> [b] -> [b]-   , genericSplitAt    -- :: (Integral a) => a -> [b] -> ([b], [b])-   , genericIndex      -- :: (Integral a) => [b] -> a -> b-   , genericReplicate  -- :: (Integral a) => a -> b -> [b]+   , genericLength+   , genericTake+   , genericDrop+   , genericSplitAt+   , genericIndex+   , genericReplicate     ) where -#ifdef __NHC__-import Prelude-#endif- import Data.Maybe import Data.Char        ( isSpace ) -#ifdef __GLASGOW_HASKELL__ import GHC.Num import GHC.Real import GHC.List import GHC.Base-#endif  infix 5 \\ -- comment to fool cpp @@ -235,7 +224,8 @@ -- > 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) [] @@ -279,8 +269,7 @@ -- | The 'findIndices' function extends 'findIndex', by returning the -- indices of all elements satisfying the predicate, in ascending order. findIndices      :: (a -> Bool) -> [a] -> [Int]--#if defined(USE_REPORT_PRELUDE) || !defined(__GLASGOW_HASKELL__)+#ifdef USE_REPORT_PRELUDE findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] #else -- Efficient definition@@ -525,13 +514,12 @@      GT -> y : insertBy cmp x ys'      _  -> x : ys -#ifdef __GLASGOW_HASKELL__- -- | 'maximum' returns the maximum value from a list, -- which must be non-empty, finite, and of an ordered type. -- It is a special case of 'Data.List.maximumBy', which allows the -- programmer to supply their own comparison function. maximum                 :: (Ord a) => [a] -> a+{-# NOINLINE [1] maximum #-} maximum []              =  errorEmptyList "maximum" maximum xs              =  foldl1 max xs @@ -552,6 +540,7 @@ -- It is a special case of 'Data.List.minimumBy', which allows the -- programmer to supply their own comparison function. minimum                 :: (Ord a) => [a] -> a+{-# NOINLINE [1] minimum #-} minimum []              =  errorEmptyList "minimum" minimum xs              =  foldl1 min xs @@ -564,8 +553,6 @@ strictMinimum []        =  errorEmptyList "minimum" strictMinimum xs        =  foldl1' min xs -#endif /* __GLASGOW_HASKELL__ */- -- | 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.@@ -591,7 +578,8 @@ -- | 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) => [b] -> i+genericLength           :: (Num i) => [a] -> i+{-# NOINLINE [1] genericLength #-} genericLength []        =  0 genericLength (_:l)     =  1 + genericLength l @@ -623,7 +611,7 @@  -- | 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 -> [b] -> ([b],[b])+genericSplitAt          :: (Integral i) => i -> [a] -> ([a], [a]) genericSplitAt n xs | n <= 0 =  ([],xs) genericSplitAt _ []     =  ([],[]) genericSplitAt n (x:xs) =  (x:xs',xs'') where@@ -631,7 +619,7 @@  -- | The 'genericIndex' function is an overloaded version of '!!', which -- accepts any 'Integral' value as the index.-genericIndex :: (Integral a) => [b] -> a -> b+genericIndex :: (Integral i) => [a] -> i -> a genericIndex (x:_)  0 = x genericIndex (_:xs) n  | n > 0     = genericIndex xs (n-1)@@ -1001,37 +989,34 @@ -- -----------------------------------------------------------------------------  -- | A strict version of 'foldl'.-foldl'           :: (a -> b -> a) -> a -> [b] -> a-#ifdef __GLASGOW_HASKELL__+foldl'           :: (b -> a -> b) -> b -> [a] -> b foldl' f z0 xs0 = lgo z0 xs0     where lgo z []     = z           lgo z (x:xs) = let z' = f z x in z' `seq` lgo z' xs-#else-foldl' f a []     = a-foldl' f a (x:xs) = let a' = f a x in a' `seq` foldl' f a' xs-#endif -#ifdef __GLASGOW_HASKELL__ -- | 'foldl1' is a variant of 'foldl' that has no starting value argument, -- and thus must be applied to non-empty lists. foldl1                  :: (a -> a -> a) -> [a] -> a foldl1 f (x:xs)         =  foldl f x xs foldl1 _ []             =  errorEmptyList "foldl1"-#endif /* __GLASGOW_HASKELL__ */  -- | A strict version of 'foldl1' foldl1'                  :: (a -> a -> a) -> [a] -> a foldl1' f (x:xs)         =  foldl' f x xs foldl1' _ []             =  errorEmptyList "foldl1'" -#ifdef __GLASGOW_HASKELL__ -- ----------------------------------------------------------------------------- -- List sum and product  {-# SPECIALISE sum     :: [Int] -> Int #-} {-# SPECIALISE sum     :: [Integer] -> Integer #-}+{-# INLINABLE sum #-} {-# SPECIALISE product :: [Int] -> Int #-} {-# SPECIALISE product :: [Integer] -> Integer #-}+{-# INLINABLE product #-}+-- We make 'sum' and 'product' inlinable so that we get specialisations+-- at other types.  See, for example, Trac #7507.+ -- | The 'sum' function computes the sum of a finite list of numbers. sum                     :: (Num a) => [a] -> a -- | The 'product' function computes the product of a finite list of numbers.@@ -1057,7 +1042,6 @@ -- characters.  The resulting strings do not contain newlines. lines                   :: String -> [String] lines ""                =  []-#ifdef __GLASGOW_HASKELL__ -- 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).@@ -1068,12 +1052,6 @@                                                     _:s''   -> lines s''))   where     cons ~(h, t)        =  h : t-#else-lines s                 =  let (l, s') = break (== '\n') s-                           in  l : case s' of-                                        []      -> []-                                        (_:s'') -> lines s''-#endif  -- | 'unlines' is an inverse operation to 'lines'. -- It joins lines, after appending a terminating newline to each.@@ -1109,12 +1087,3 @@ unwords [w]             = w unwords (w:ws)          = w ++ ' ' : unwords ws #endif--#else  /* !__GLASGOW_HASKELL__ */--errorEmptyList :: String -> a-errorEmptyList fun =-  error ("Prelude." ++ fun ++ ": empty list")--#endif /* !__GLASGOW_HASKELL__ */-

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}+{-# LANGUAGE NoImplicitPrelude #-}  ----------------------------------------------------------------------------- -- |@@ -17,41 +17,22 @@  module Data.Maybe    (-     Maybe(Nothing,Just)-- instance of: Eq, Ord, Show, Read,-                        --              Functor, Monad, MonadPlus+     Maybe(Nothing,Just) -   , maybe              -- :: b -> (a -> b) -> Maybe a -> b+   , maybe -   , isJust             -- :: Maybe a -> Bool-   , isNothing          -- :: Maybe a -> Bool-   , fromJust           -- :: Maybe a -> a-   , fromMaybe          -- :: a -> Maybe a -> a-   , listToMaybe        -- :: [a] -> Maybe a-   , maybeToList        -- :: Maybe a -> [a]-   , catMaybes          -- :: [Maybe a] -> [a]-   , mapMaybe           -- :: (a -> Maybe b) -> [a] -> [b]+   , isJust+   , isNothing+   , fromJust+   , fromMaybe+   , listToMaybe+   , maybeToList+   , catMaybes+   , mapMaybe    ) where -#ifdef __GLASGOW_HASKELL__ import GHC.Base-#endif -#ifdef __NHC__-import Prelude-import Prelude (Maybe(..), maybe)-import Maybe-    ( isJust-    , isNothing-    , fromJust-    , fromMaybe-    , listToMaybe-    , maybeToList-    , catMaybes-    , mapMaybe-    )-#else--#ifndef __HUGS__ -- --------------------------------------------------------------------------- -- The Maybe type, and instances @@ -92,7 +73,6 @@ maybe :: b -> (a -> b) -> Maybe a -> b maybe n _ Nothing  = n maybe _ f (Just x) = f x-#endif  /* __HUGS__ */  -- | The 'isJust' function returns 'True' iff its argument is of the -- form @Just _@.@@ -146,6 +126,16 @@  case f x of   Nothing -> rs   Just r  -> r:rs+{-# NOINLINE [1] mapMaybe #-} -#endif /* else not __NHC__ */+{-# 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

@@ -1,5 +1,8 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  ----------------------------------------------------------------------------- -- |@@ -36,16 +39,14 @@   ) where  -- Push down the module in the dependency hierarchy.-#if defined(__GLASGOW_HASKELL__) import GHC.Base hiding (Any) import GHC.Enum import GHC.Num import GHC.Read import GHC.Show+import GHC.Generics import Data.Maybe-#else-import Prelude-#endif+import Data.Proxy  {- -- just for testing@@ -92,6 +93,8 @@ infixr 6 <>  -- | An infix synonym for 'mappend'.+--+-- /Since: 4.5.0.0/ (<>) :: Monoid m => m -> m -> m (<>) = mappend {-# INLINE (<>) #-}@@ -142,9 +145,14 @@         EQ `mappend` y = y         GT `mappend` _ = GT +instance Monoid (Proxy s) where+    mempty = Proxy+    mappend _ _ = Proxy+    mconcat _ = Proxy+ -- | The dual of a monoid, obtained by swapping the arguments of 'mappend'. newtype Dual a = Dual { getDual :: a }-        deriving (Eq, Ord, Read, Show, Bounded)+        deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1)  instance Monoid a => Monoid (Dual a) where         mempty = Dual mempty@@ -152,6 +160,7 @@  -- | The monoid of endomorphisms under composition. newtype Endo a = Endo { appEndo :: a -> a }+               deriving (Generic)  instance Monoid (Endo a) where         mempty = Endo id@@ -159,7 +168,7 @@  -- | Boolean monoid under conjunction. newtype All = All { getAll :: Bool }-        deriving (Eq, Ord, Read, Show, Bounded)+        deriving (Eq, Ord, Read, Show, Bounded, Generic)  instance Monoid All where         mempty = All True@@ -167,7 +176,7 @@  -- | Boolean monoid under disjunction. newtype Any = Any { getAny :: Bool }-        deriving (Eq, Ord, Read, Show, Bounded)+        deriving (Eq, Ord, Read, Show, Bounded, Generic)  instance Monoid Any where         mempty = Any False@@ -175,7 +184,7 @@  -- | Monoid under addition. newtype Sum a = Sum { getSum :: a }-        deriving (Eq, Ord, Read, Show, Bounded)+        deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)  instance Num a => Monoid (Sum a) where         mempty = Sum 0@@ -183,7 +192,7 @@  -- | Monoid under multiplication. newtype Product a = Product { getProduct :: a }-        deriving (Eq, Ord, Read, Show, Bounded)+        deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)  instance Num a => Monoid (Product a) where         mempty = Product 1@@ -235,7 +244,7 @@  -- | Maybe monoid returning the leftmost non-Nothing value. newtype First a = First { getFirst :: Maybe a }-        deriving (Eq, Ord, Read, Show)+        deriving (Eq, Ord, Read, Show, Generic, Generic1)  instance Monoid (First a) where         mempty = First Nothing@@ -244,7 +253,7 @@  -- | Maybe monoid returning the rightmost non-Nothing value. newtype Last a = Last { getLast :: Maybe a }-        deriving (Eq, Ord, Read, Show)+        deriving (Eq, Ord, Read, Show, Generic, Generic1)  instance Monoid (Last a) where         mempty = Last Nothing

@@ -0,0 +1,179 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE CPP+           , NoImplicitPrelude+           , OverlappingInstances+           , ScopedTypeVariables+           , FlexibleInstances+  #-}+{-# OPTIONS_GHC -funbox-strict-fields -fno-warn-warnings-deprecations #-}++-- The -XOverlappingInstances flag allows the user to over-ride+-- the instances for Typeable given here.  In particular, we provide an instance+--      instance ... => Typeable (s a) +-- But a user might want to say+--      instance ... => Typeable (MyType a b)++-----------------------------------------------------------------------------+-- |+-- 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+--+-- This module defines the old, kind-monomorphic 'Typeable' class. It is now+-- deprecated; users are recommended to use the kind-polymorphic+-- "Data.Typeable" module instead.+--+-- /Since: 4.7.0.0/+-----------------------------------------------------------------------------++module Data.OldTypeable {-# DEPRECATED "Use Data.Typeable instead" #-} -- deprecated in 7.8+  (++        -- * The Typeable class+        Typeable( typeOf ),     -- :: a -> TypeRep++        -- * Type-safe cast+        cast,                   -- :: (Typeable a, Typeable b) => a -> Maybe b+        gcast,                  -- a generalisation of cast++        -- * Type representations+        TypeRep,        -- abstract, instance of: Eq, Show, Typeable+        showsTypeRep,++        TyCon,          -- abstract, instance of: Eq, Show, Typeable+        tyConString,    -- :: TyCon   -> String+        tyConPackage,   -- :: TyCon   -> String+        tyConModule,    -- :: TyCon   -> String+        tyConName,      -- :: TyCon   -> String++        -- * 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]+        typeRepKey,     -- :: TypeRep -> IO TypeRepKey+        TypeRepKey,     -- abstract, instance of Eq, Ord++        -- * The other Typeable classes+        -- | /Note:/ The general instances are provided for GHC only.+        Typeable1( typeOf1 ),   -- :: t a -> TypeRep+        Typeable2( typeOf2 ),   -- :: t a b -> TypeRep+        Typeable3( typeOf3 ),   -- :: t a b c -> TypeRep+        Typeable4( typeOf4 ),   -- :: t a b c d -> TypeRep+        Typeable5( typeOf5 ),   -- :: t a b c d e -> TypeRep+        Typeable6( typeOf6 ),   -- :: t a b c d e f -> TypeRep+        Typeable7( typeOf7 ),   -- :: t a b c d e f g -> TypeRep+        gcast1,                 -- :: ... => c (t a) -> Maybe (c (t' a))+        gcast2,                 -- :: ... => c (t a b) -> Maybe (c (t' a b))++        -- * Default instances+        -- | /Note:/ These are not needed by GHC, for which these instances+        -- are generated by general instance declarations.+        typeOfDefault,  -- :: (Typeable1 t, Typeable a) => t a -> TypeRep+        typeOf1Default, -- :: (Typeable2 t, Typeable a) => t a b -> TypeRep+        typeOf2Default, -- :: (Typeable3 t, Typeable a) => t a b c -> TypeRep+        typeOf3Default, -- :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep+        typeOf4Default, -- :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep+        typeOf5Default, -- :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep+        typeOf6Default  -- :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep++  ) where++import Data.OldTypeable.Internal hiding (mkTyCon)++import Unsafe.Coerce+import Data.Maybe++import GHC.Base++import GHC.Fingerprint.Type+import GHC.Fingerprint++#include "OldTypeable.h"++{-# DEPRECATED typeRepKey "TypeRep itself is now an instance of Ord" #-} -- deprecated in 7.2+-- | (DEPRECATED) Returns a unique key associated with a 'TypeRep'.+-- This function is deprecated because 'TypeRep' itself is now an+-- instance of 'Ord', so mappings can be made directly with 'TypeRep'+-- as the key.+--+typeRepKey :: TypeRep -> IO TypeRepKey+typeRepKey (TypeRep f _ _) = return (TypeRepKey f)++        -- +        -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,")+        --                                 [fTy,fTy,fTy])+        -- +        -- returns "(Foo,Foo,Foo)"+        --+        -- The TypeRep Show instance promises to print tuple types+        -- correctly. Tuple type constructors are specified by a +        -- sequence of commas, e.g., (mkTyCon ",,,,") returns+        -- the 5-tuple tycon.++newtype TypeRepKey = TypeRepKey Fingerprint+  deriving (Eq,Ord)++----------------- Construction ---------------------++{-# DEPRECATED mkTyCon "either derive Typeable, or use mkTyCon3 instead" #-} -- deprecated in 7.2+-- | Backwards-compatible API+mkTyCon :: String       -- ^ unique string+        -> TyCon        -- ^ A unique 'TyCon' object+mkTyCon name = TyCon (fingerprintString name) "" "" name++-------------------------------------------------------------+--+--              Type-safe cast+--+-------------------------------------------------------------++-- | The type-safe cast operation+cast :: (Typeable a, Typeable b) => a -> Maybe b+cast x = r+       where+         r = if typeOf x == typeOf (fromJust r)+               then Just $ unsafeCoerce x+               else Nothing++-- | A flexible variation parameterised in a type constructor+gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b)+gcast x = r+ where+  r = if typeOf (getArg x) == typeOf (getArg (fromJust r))+        then Just $ unsafeCoerce x+        else Nothing+  getArg :: c x -> x +  getArg = undefined++-- | Cast for * -> *+gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a)) +gcast1 x = r+ where+  r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r))+       then Just $ unsafeCoerce x+       else Nothing+  getArg :: c x -> x +  getArg = undefined++-- | Cast for * -> * -> *+gcast2 :: (Typeable2 t, Typeable2 t') => c (t a b) -> Maybe (c (t' a b)) +gcast2 x = r+ where+  r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r))+       then Just $ unsafeCoerce x+       else Nothing+  getArg :: c x -> x +  getArg = undefined+

@@ -0,0 +1,475 @@+{-# LANGUAGE Unsafe #-}++-----------------------------------------------------------------------------+-- |+-- 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.+--+-- /Since: 4.7.0.0/+-----------------------------------------------------------------------------++{-# LANGUAGE CPP+           , NoImplicitPrelude+           , OverlappingInstances+           , ScopedTypeVariables+           , FlexibleInstances+           , MagicHash+           , DeriveDataTypeable+           , StandaloneDeriving #-}++module Data.OldTypeable.Internal {-# DEPRECATED "Use Data.Typeable.Internal instead" #-} ( -- deprecated in 7.8+    TypeRep(..),+    TyCon(..),+    mkTyCon,+    mkTyCon3,+    mkTyConApp,+    mkAppTy,+    typeRepTyCon,+    typeOfDefault,+    typeOf1Default,+    typeOf2Default,+    typeOf3Default,+    typeOf4Default,+    typeOf5Default,+    typeOf6Default,+    Typeable(..),+    Typeable1(..),+    Typeable2(..),+    Typeable3(..),+    Typeable4(..),+    Typeable5(..),+    Typeable6(..),+    Typeable7(..),+    mkFunTy,+    splitTyConApp,+    funResultTy,+    typeRepArgs,+    showsTypeRep,+    tyConString,+    listTc, funTc+  ) where++import GHC.Base+import GHC.Word+import GHC.Show+import Data.Maybe+import Data.List+import GHC.Num+import GHC.Real+import GHC.IORef+import GHC.IOArray+import GHC.MVar+import GHC.ST           ( ST )+import GHC.STRef        ( STRef )+import GHC.Ptr          ( Ptr, FunPtr )+import GHC.Stable+import GHC.Arr          ( Array, STArray )+import Data.Int++import GHC.Fingerprint.Type+import GHC.Fingerprint++-- | A concrete representation of a (monomorphic) type.  'TypeRep'+-- supports reasonably efficient equality.+data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [TypeRep]++-- Compare keys for equality+instance Eq TypeRep where+  (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2++instance Ord TypeRep where+  (TypeRep k1 _ _) <= (TypeRep k2 _ _) = k1 <= k2++-- | An abstract representation of a type constructor.  'TyCon' objects can+-- be built using 'mkTyCon'.+data TyCon = TyCon {+   tyConHash    :: {-# UNPACK #-} !Fingerprint,+   tyConPackage :: String,+   tyConModule  :: String,+   tyConName    :: String+ }++instance Eq TyCon where+  (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2++instance Ord TyCon where+  (TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2++----------------- Construction --------------------++#include "MachDeps.h"++-- mkTyCon is an internal function to make it easier for GHC to+-- generate derived instances.  GHC precomputes the MD5 hash for the+-- TyCon and passes it as two separate 64-bit values to mkTyCon.  The+-- TyCon for a derived Typeable instance will end up being statically+-- allocated.++#if WORD_SIZE_IN_BITS < 64+mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon+#else+mkTyCon :: Word#   -> Word#   -> String -> String -> String -> TyCon+#endif+mkTyCon high# low# pkg modl name+  = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name++-- | Applies a type constructor to a sequence of types+mkTyConApp  :: TyCon -> [TypeRep] -> TypeRep+mkTyConApp tc@(TyCon tc_k _ _ _) []+  = TypeRep tc_k tc [] -- optimisation: all derived Typeable instances+                       -- end up here, and it helps generate smaller+                       -- code for derived Typeable.+mkTyConApp tc@(TyCon tc_k _ _ _) args+  = TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc args+  where+    arg_ks = [k | TypeRep k _ _ <- args]++-- | A special case of 'mkTyConApp', which applies the function +-- type constructor to a pair of types.+mkFunTy  :: TypeRep -> TypeRep -> TypeRep+mkFunTy f a = mkTyConApp funTc [f,a]++-- | Splits a type constructor application+splitTyConApp :: TypeRep -> (TyCon,[TypeRep])+splitTyConApp (TypeRep _ tc trs) = (tc,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 == funTc && t1 == trArg -> Just t2+      _ -> Nothing++-- | Adds a TypeRep argument to a TypeRep.+mkAppTy :: TypeRep -> TypeRep -> TypeRep+mkAppTy (TypeRep _ tc trs) arg_tr = mkTyConApp tc (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++-- | Builds a 'TyCon' object representing a type constructor.  An+-- implementation of "Data.Typeable" should ensure that the following holds:+--+-- >  A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C'+--++--+mkTyCon3 :: String       -- ^ package name+         -> String       -- ^ module name+         -> String       -- ^ the name of the type constructor+         -> TyCon        -- ^ A unique 'TyCon' object+mkTyCon3 pkg modl name =+  TyCon (fingerprintString (unwords [pkg, modl, name])) pkg modl name++----------------- 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 _ _ args) = args++-- | 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++-------------------------------------------------------------+--+--      The Typeable class and friends+--+-------------------------------------------------------------++{- Note [Memoising typeOf]+~~~~~~~~~~~~~~~~~~~~~~~~~~+IMPORTANT: we don't want to recalculate the type-rep once per+call to the dummy argument.  This is what went wrong in Trac #3245+So we help GHC by manually keeping the 'rep' *outside* the value +lambda, thus+    +    typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep+    typeOfDefault = \_ -> rep+      where+        rep = typeOf1 (undefined :: t a) `mkAppTy` +              typeOf  (undefined :: a)++Notice the crucial use of scoped type variables here!+-}++-- | The class 'Typeable' allows a concrete representation of a type to+-- be calculated.+class Typeable a where+  typeOf :: a -> TypeRep+  -- ^ Takes a value of type @a@ and returns a concrete representation+  -- of that type.  The /value/ of the argument should be ignored by+  -- any instance of 'Typeable', so that it is safe to pass 'undefined' as+  -- the argument.++-- | Variant for unary type constructors+class Typeable1 t where+  typeOf1 :: t a -> TypeRep++-- | For defining a 'Typeable' instance from any 'Typeable1' instance.+typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep+typeOfDefault = \_ -> rep+ where+   rep = typeOf1 (undefined :: t a) `mkAppTy` +         typeOf  (undefined :: a)+   -- Note [Memoising typeOf]++-- | Variant for binary type constructors+class Typeable2 t where+  typeOf2 :: t a b -> TypeRep++-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.+typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep+typeOf1Default = \_ -> rep + where+   rep = typeOf2 (undefined :: t a b) `mkAppTy` +         typeOf  (undefined :: a)+   -- Note [Memoising typeOf]++-- | Variant for 3-ary type constructors+class Typeable3 t where+  typeOf3 :: t a b c -> TypeRep++-- | For defining a 'Typeable2' instance from any 'Typeable3' instance.+typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep+typeOf2Default = \_ -> rep + where+   rep = typeOf3 (undefined :: t a b c) `mkAppTy` +         typeOf  (undefined :: a)+   -- Note [Memoising typeOf]++-- | Variant for 4-ary type constructors+class Typeable4 t where+  typeOf4 :: t a b c d -> TypeRep++-- | For defining a 'Typeable3' instance from any 'Typeable4' instance.+typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep+typeOf3Default = \_ -> rep+ where+   rep = typeOf4 (undefined :: t a b c d) `mkAppTy` +         typeOf  (undefined :: a)+   -- Note [Memoising typeOf]+   +-- | Variant for 5-ary type constructors+class Typeable5 t where+  typeOf5 :: t a b c d e -> TypeRep++-- | For defining a 'Typeable4' instance from any 'Typeable5' instance.+typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep+typeOf4Default = \_ -> rep + where+   rep = typeOf5 (undefined :: t a b c d e) `mkAppTy` +         typeOf  (undefined :: a)+   -- Note [Memoising typeOf]++-- | Variant for 6-ary type constructors+class Typeable6 t where+  typeOf6 :: t a b c d e f -> TypeRep++-- | For defining a 'Typeable5' instance from any 'Typeable6' instance.+typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep+typeOf5Default = \_ -> rep+ where+   rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy` +         typeOf  (undefined :: a)+   -- Note [Memoising typeOf]++-- | Variant for 7-ary type constructors+class Typeable7 t where+  typeOf7 :: t a b c d e f g -> TypeRep++-- | For defining a 'Typeable6' instance from any 'Typeable7' instance.+typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep+typeOf6Default = \_ -> rep+ where+   rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy` +         typeOf  (undefined :: a)+   -- Note [Memoising typeOf]++-- Given a @Typeable@/n/ instance for an /n/-ary type constructor,+-- define the instances for partial applications.+-- Programmers using non-GHC implementations must do this manually+-- for each type constructor.+-- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.)++-- | One Typeable instance for all Typeable1 instances+instance (Typeable1 s, Typeable a)+       => Typeable (s a) where+  typeOf = typeOfDefault++-- | One Typeable1 instance for all Typeable2 instances+instance (Typeable2 s, Typeable a)+       => Typeable1 (s a) where+  typeOf1 = typeOf1Default++-- | One Typeable2 instance for all Typeable3 instances+instance (Typeable3 s, Typeable a)+       => Typeable2 (s a) where+  typeOf2 = typeOf2Default++-- | One Typeable3 instance for all Typeable4 instances+instance (Typeable4 s, Typeable a)+       => Typeable3 (s a) where+  typeOf3 = typeOf3Default++-- | One Typeable4 instance for all Typeable5 instances+instance (Typeable5 s, Typeable a)+       => Typeable4 (s a) where+  typeOf4 = typeOf4Default++-- | One Typeable5 instance for all Typeable6 instances+instance (Typeable6 s, Typeable a)+       => Typeable5 (s a) where+  typeOf5 = typeOf5Default++-- | One Typeable6 instance for all Typeable7 instances+instance (Typeable7 s, Typeable a)+       => Typeable6 (s a) where+  typeOf6 = typeOf6Default++----------------- Showing TypeReps --------------------++instance Show TypeRep where+  showsPrec p (TypeRep _ tycon tys) =+    case tys of+      [] -> showsPrec p tycon+      [x]   | tycon == listTc -> showChar '[' . shows x . showChar ']'+      [a,r] | tycon == funTc  -> showParen (p > 8) $+                                 showsPrec 9 a .+                                 showString " -> " .+                                 showsPrec 8 r+      xs | isTupleTyCon tycon -> showTuple xs+         | otherwise         ->+            showParen (p > 9) $+            showsPrec p tycon . +            showChar ' '      . +            showArgs tys++showsTypeRep :: TypeRep -> ShowS+showsTypeRep = shows++instance Show TyCon where+  showsPrec _ t = showString (tyConName t)++isTupleTyCon :: TyCon -> Bool+isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True+isTupleTyCon _                         = False++-- Some (Show.TypeRep) helpers:++showArgs :: Show a => [a] -> ShowS+showArgs [] = id+showArgs [a] = showsPrec 10 a+showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as ++showTuple :: [TypeRep] -> ShowS+showTuple args = showChar '('+               . (foldr (.) id $ intersperse (showChar ',') +                               $ map (showsPrec 10) args)+               . showChar ')'++listTc :: TyCon+listTc = typeRepTyCon (typeOf [()])++funTc :: TyCon+funTc = mkTyCon3 "ghc-prim" "GHC.Types" "->"++-------------------------------------------------------------+--+--      Instances of the Typeable classes for Prelude types+--+-------------------------------------------------------------++#include "OldTypeable.h"++INSTANCE_TYPEABLE0((),unitTc,"()")+INSTANCE_TYPEABLE1([],listTc,"[]")+INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")+INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")++{-+TODO: Deriving this instance fails with:+libraries/base/Data/Typeable.hs:589:1:+    Can't make a derived instance of `Typeable2 (->)':+      The last argument of the instance must be a data or newtype application+    In the stand-alone deriving instance for `Typeable2 (->)'+-}+instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] }++INSTANCE_TYPEABLE1(IO,ioTc,"IO")++-- Types defined in GHC.MVar+INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )++INSTANCE_TYPEABLE2(Array,arrayTc,"Array")+INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")++INSTANCE_TYPEABLE2(ST,stTc,"ST")+INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")+INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")++INSTANCE_TYPEABLE2((,),pairTc,"(,)")+INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)")+INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)")+INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)")+INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)")+INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)")++INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")+INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")+INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")+INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")++-------------------------------------------------------+--+-- Generate Typeable instances for standard datatypes+--+-------------------------------------------------------++INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")+INSTANCE_TYPEABLE0(Char,charTc,"Char")+INSTANCE_TYPEABLE0(Float,floatTc,"Float")+INSTANCE_TYPEABLE0(Double,doubleTc,"Double")+INSTANCE_TYPEABLE0(Int,intTc,"Int")+INSTANCE_TYPEABLE0(Word,wordTc,"Word" )+INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")+INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")++INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")+INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")+INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")+INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")++INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )+INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")+INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")+INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")++INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")+INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")++{-+TODO: This can't be derived currently:+libraries/base/Data/Typeable.hs:674:1:+    Can't make a derived instance of `Typeable RealWorld':+      The last argument of the instance must be a data or newtype application+    In the stand-alone deriving instance for `Typeable RealWorld'+-}+realWorldTc :: TyCon; \+realWorldTc = mkTyCon3 "ghc-prim" "GHC.Types" "RealWorld"; \+instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }