[project @ 2001-06-28 14:15:04 by simonmar]
authorsimonmar <unknown>
Thu, 28 Jun 2001 14:15:04 +0000 (14:15 +0000)
committersimonmar <unknown>
Thu, 28 Jun 2001 14:15:04 +0000 (14:15 +0000)
First cut of the Haskell Core Libraries
=======================================

NOTE: it's not meant to be a working snapshot.  The code is just here
to look at and so the NHC/Hugs guys can start playing around with it.

There is no build system.  For GHC, the libraries tree is intended to
be grafted onto an existing fptools/ tree, and the Makefile in
libraries/core is a quick hack for that setup.  This won't work at the
moment without the other changes needed in fptools/ghc, which I
haven't committed because they'll cause breakage.  However, with the
changes required these sources build a working Prelude and libraries.

The layout mostly follows the one we agreed on, with one or two minor
changes; in particular the Data/Array layout probably isn't final
(there are several choices here).

The document is in libraries/core/doc as promised.

The cbits stuff is just a copy of ghc/lib/std/cbits and has
GHC-specific stuff in it.  We should really separate the
compiler-specific C support from any compiler-independent C support
there might be.

Don't pay too much attention to the portability or stability status
indicated in the header of each source file at the moment - I haven't
gone through to make sure they're all consistent and make sense.

I'm using non-literate source outside of GHC/.  Hope that's ok with
everyone.

We need to discuss how the build system is going to work...

128 files changed:
libraries/base/Control/Concurrent.hs [new file with mode: 0644]
libraries/base/Control/Concurrent/CVar.hs [new file with mode: 0644]
libraries/base/Control/Concurrent/Chan.hs [new file with mode: 0644]
libraries/base/Control/Concurrent/MVar.hs [new file with mode: 0644]
libraries/base/Control/Concurrent/QSem.hs [new file with mode: 0644]
libraries/base/Control/Concurrent/QSemN.hs [new file with mode: 0644]
libraries/base/Control/Concurrent/SampleVar.hs [new file with mode: 0644]
libraries/base/Control/Exception.hs [new file with mode: 0644]
libraries/base/Control/Monad.hs [new file with mode: 0644]
libraries/base/Control/Monad/Cont.hs [new file with mode: 0644]
libraries/base/Control/Monad/Error.hs [new file with mode: 0644]
libraries/base/Control/Monad/Fix.hs [new file with mode: 0644]
libraries/base/Control/Monad/Identity.hs [new file with mode: 0644]
libraries/base/Control/Monad/List.hs [new file with mode: 0644]
libraries/base/Control/Monad/Monoid.hs [new file with mode: 0644]
libraries/base/Control/Monad/RWS.hs [new file with mode: 0644]
libraries/base/Control/Monad/Reader.hs [new file with mode: 0644]
libraries/base/Control/Monad/ST.hs [new file with mode: 0644]
libraries/base/Control/Monad/ST/Lazy.hs [new file with mode: 0644]
libraries/base/Control/Monad/ST/Strict.hs [new file with mode: 0644]
libraries/base/Control/Monad/State.hs [new file with mode: 0644]
libraries/base/Control/Monad/Trans.hs [new file with mode: 0644]
libraries/base/Control/Monad/Writer.hs [new file with mode: 0644]
libraries/base/Control/Parallel.hs [new file with mode: 0644]
libraries/base/Control/Parallel/Strategies.hs [new file with mode: 0644]
libraries/base/Data/Array.hs [new file with mode: 0644]
libraries/base/Data/Array/Base.hs [new file with mode: 0644]
libraries/base/Data/Array/IArray.hs [new file with mode: 0644]
libraries/base/Data/Array/IO.hs [new file with mode: 0644]
libraries/base/Data/Array/MArray.hs [new file with mode: 0644]
libraries/base/Data/Array/ST.hs [new file with mode: 0644]
libraries/base/Data/Array/Unboxed.hs [new file with mode: 0644]
libraries/base/Data/Bits.hs [new file with mode: 0644]
libraries/base/Data/Bool.hs [new file with mode: 0644]
libraries/base/Data/Char.hs [new file with mode: 0644]
libraries/base/Data/Complex.hs [new file with mode: 0644]
libraries/base/Data/Dynamic.hs [new file with mode: 0644]
libraries/base/Data/Either.hs [new file with mode: 0644]
libraries/base/Data/IORef.hs [new file with mode: 0644]
libraries/base/Data/Int.hs [new file with mode: 0644]
libraries/base/Data/Ix.hs [new file with mode: 0644]
libraries/base/Data/List.hs [new file with mode: 0644]
libraries/base/Data/Maybe.hs [new file with mode: 0644]
libraries/base/Data/PackedString.hs [new file with mode: 0644]
libraries/base/Data/Ratio.hs [new file with mode: 0644]
libraries/base/Data/STRef.hs [new file with mode: 0644]
libraries/base/Data/Word.hs [new file with mode: 0644]
libraries/base/Debug/Trace.hs [new file with mode: 0644]
libraries/base/Foreign.hs [new file with mode: 0644]
libraries/base/Foreign/C.hs [new file with mode: 0644]
libraries/base/Foreign/C/Error.hs [new file with mode: 0644]
libraries/base/Foreign/C/String.hs [new file with mode: 0644]
libraries/base/Foreign/C/Types.hs [new file with mode: 0644]
libraries/base/Foreign/C/TypesISO.hs [new file with mode: 0644]
libraries/base/Foreign/ForeignPtr.hs [new file with mode: 0644]
libraries/base/Foreign/Marshal/Alloc.hs [new file with mode: 0644]
libraries/base/Foreign/Marshal/Array.hs [new file with mode: 0644]
libraries/base/Foreign/Marshal/Error.hs [new file with mode: 0644]
libraries/base/Foreign/Marshal/Utils.hs [new file with mode: 0644]
libraries/base/Foreign/Ptr.hs [new file with mode: 0644]
libraries/base/Foreign/StablePtr.hs [new file with mode: 0644]
libraries/base/Foreign/Storable.hs [new file with mode: 0644]
libraries/base/GHC/Arr.lhs [new file with mode: 0644]
libraries/base/GHC/Base.lhs [new file with mode: 0644]
libraries/base/GHC/ByteArr.lhs [new file with mode: 0644]
libraries/base/GHC/Conc.lhs [new file with mode: 0644]
libraries/base/GHC/Dynamic.lhs [new file with mode: 0644]
libraries/base/GHC/Enum.lhs [new file with mode: 0644]
libraries/base/GHC/Err.hi-boot [new file with mode: 0644]
libraries/base/GHC/Err.lhs [new file with mode: 0644]
libraries/base/GHC/Exception.lhs [new file with mode: 0644]
libraries/base/GHC/Float.lhs [new file with mode: 0644]
libraries/base/GHC/Handle.hsc [new file with mode: 0644]
libraries/base/GHC/IO.hsc [new file with mode: 0644]
libraries/base/GHC/IOBase.lhs [new file with mode: 0644]
libraries/base/GHC/Int.lhs [new file with mode: 0644]
libraries/base/GHC/List.lhs [new file with mode: 0644]
libraries/base/GHC/Main.lhs [new file with mode: 0644]
libraries/base/GHC/Maybe.lhs [new file with mode: 0644]
libraries/base/GHC/Num.hi-boot [new file with mode: 0644]
libraries/base/GHC/Num.lhs [new file with mode: 0644]
libraries/base/GHC/Pack.lhs [new file with mode: 0644]
libraries/base/GHC/Posix.hsc [new file with mode: 0644]
libraries/base/GHC/Prim.hi-boot [new file with mode: 0644]
libraries/base/GHC/Ptr.lhs [new file with mode: 0644]
libraries/base/GHC/Read.lhs [new file with mode: 0644]
libraries/base/GHC/Real.lhs [new file with mode: 0644]
libraries/base/GHC/ST.lhs [new file with mode: 0644]
libraries/base/GHC/STRef.lhs [new file with mode: 0644]
libraries/base/GHC/Show.lhs [new file with mode: 0644]
libraries/base/GHC/Stable.lhs [new file with mode: 0644]
libraries/base/GHC/Storable.lhs [new file with mode: 0644]
libraries/base/GHC/TopHandler.lhs [new file with mode: 0644]
libraries/base/GHC/Tup.lhs [new file with mode: 0644]
libraries/base/GHC/Weak.lhs [new file with mode: 0644]
libraries/base/GHC/Word.lhs [new file with mode: 0644]
libraries/base/Main.hi-boot [new file with mode: 0644]
libraries/base/Makefile [new file with mode: 0644]
libraries/base/Prelude.hs [new file with mode: 0644]
libraries/base/System/CPUTime.hsc [new file with mode: 0644]
libraries/base/System/Cmd.hsc [new file with mode: 0644]
libraries/base/System/Environment.hs [new file with mode: 0644]
libraries/base/System/Exit.hs [new file with mode: 0644]
libraries/base/System/IO.hs [new file with mode: 0644]
libraries/base/System/IO/Directory.hsc [new file with mode: 0644]
libraries/base/System/IO/Unsafe.hs [new file with mode: 0644]
libraries/base/System/Info.hs [new file with mode: 0644]
libraries/base/System/Locale.hs [new file with mode: 0644]
libraries/base/System/Mem/StableName.hs [new file with mode: 0644]
libraries/base/System/Mem/Weak.hs [new file with mode: 0644]
libraries/base/System/Random.hs [new file with mode: 0644]
libraries/base/System/Time.hsc [new file with mode: 0644]
libraries/base/Text/Read.hs [new file with mode: 0644]
libraries/base/Text/Show.hs [new file with mode: 0644]
libraries/base/Text/Show/Functions.hs [new file with mode: 0644]
libraries/base/cbits/Makefile [new file with mode: 0644]
libraries/base/cbits/errno.c [new file with mode: 0644]
libraries/base/cbits/inputReady.c [new file with mode: 0644]
libraries/base/cbits/lockFile.c [new file with mode: 0644]
libraries/base/cbits/system.c [new file with mode: 0644]
libraries/base/cbits/writeError.c [new file with mode: 0644]
libraries/base/doc/libraries.sgml [new file with mode: 0644]
libraries/base/include/CTypes.h [new file with mode: 0644]
libraries/base/include/Dynamic.h [new file with mode: 0644]
libraries/base/include/HsCore.h [new file with mode: 0644]
libraries/base/include/PackedString.h [new file with mode: 0644]
libraries/base/include/ghc_errno.h [new file with mode: 0644]
libraries/base/include/lockFile.h [new file with mode: 0644]

diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs
new file mode 100644 (file)
index 0000000..033f2cc
--- /dev/null
@@ -0,0 +1,199 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Concurrent
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Concurrent.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+--
+-- A common interface to a collection of useful concurrency
+-- abstractions.
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent
+       ( module Control.Concurrent.Chan
+       , module Control.Concurrent.CVar
+       , module Control.Concurrent.MVar
+       , module Control.Concurrent.QSem
+       , module Control.Concurrent.QSemN
+       , module Control.Concurrent.SampleVar
+
+#ifdef __HUGS__
+       , forkIO        -- :: IO () -> IO ()
+#elif defined(__GLASGOW_HASKELL__)
+        , ThreadId
+
+       -- Forking and suchlike
+       , myThreadId    -- :: IO ThreadId
+       , killThread    -- :: ThreadId -> IO ()
+       , throwTo       -- :: ThreadId -> Exception -> IO ()
+#endif
+       , par           -- :: a -> b -> b
+       , seq           -- :: a -> b -> b
+#ifdef __GLASGOW_HASKELL__
+       , fork          -- :: a -> b -> b
+#endif
+       , yield         -- :: IO ()
+
+#ifdef __GLASGOW_HASKELL__
+       , threadDelay           -- :: Int -> IO ()
+       , threadWaitRead        -- :: Int -> IO ()
+       , threadWaitWrite       -- :: Int -> IO ()
+#endif
+
+        -- merging of streams
+       , mergeIO       -- :: [a]   -> [a] -> IO [a]
+       , nmergeIO      -- :: [[a]] -> IO [a]
+    ) where
+
+import Prelude
+
+import Control.Exception as Exception
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Conc
+import GHC.TopHandler   ( reportStackOverflow, reportError )
+import GHC.IOBase      ( IO(..) )
+import GHC.IOBase      ( unsafePerformIO , unsafeInterleaveIO )
+import GHC.Base                ( fork# )
+import GHC.Prim                ( Addr#, unsafeCoerce# )
+#endif
+
+#ifdef __HUGS__
+import IOExts ( unsafeInterleaveIO, unsafePerformIO )
+import ConcBase
+#endif
+
+import Control.Concurrent.MVar
+import Control.Concurrent.CVar
+import Control.Concurrent.Chan
+import Control.Concurrent.QSem
+import Control.Concurrent.QSemN
+import Control.Concurrent.SampleVar
+
+#ifdef __GLASGOW_HASKELL__
+infixr 0 `fork`
+#endif
+
+-- Thread Ids, specifically the instances of Eq and Ord for these things.
+-- The ThreadId type itself is defined in std/PrelConc.lhs.
+
+-- Rather than define a new primitve, we use a little helper function
+-- cmp_thread in the RTS.
+
+#ifdef __GLASGOW_HASKELL__
+foreign import ccall "cmp_thread" unsafe cmp_thread :: Addr# -> Addr# -> Int
+-- Returns -1, 0, 1
+
+cmpThread :: ThreadId -> ThreadId -> Ordering
+cmpThread (ThreadId t1) (ThreadId t2) = 
+   case cmp_thread (unsafeCoerce# t1) (unsafeCoerce# t2) of
+      -1 -> LT
+      0  -> EQ
+      _  -> GT -- must be 1
+
+instance Eq ThreadId where
+   t1 == t2 = 
+      case t1 `cmpThread` t2 of
+         EQ -> True
+         _  -> False
+
+instance Ord ThreadId where
+   compare = cmpThread
+
+forkIO :: IO () -> IO ThreadId
+forkIO action = IO $ \ s -> 
+   case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
+ where
+  action_plus = Exception.catch action childHandler
+
+childHandler :: Exception -> IO ()
+childHandler err = Exception.catch (real_handler err) childHandler
+
+real_handler :: Exception -> IO ()
+real_handler ex =
+  case ex of
+       -- ignore thread GC and killThread exceptions:
+       BlockedOnDeadMVar            -> return ()
+       AsyncException ThreadKilled  -> return ()
+
+       -- report all others:
+       AsyncException StackOverflow -> reportStackOverflow False
+       ErrorCall s -> reportError False s
+       other       -> reportError False (showsPrec 0 other "\n")
+
+{-# INLINE fork #-}
+fork :: a -> b -> b
+fork x y = unsafePerformIO (forkIO (x `seq` return ())) `seq` y
+
+#endif /* __GLASGOW_HASKELL__ */
+
+
+max_buff_size :: Int
+max_buff_size = 1
+
+mergeIO :: [a] -> [a] -> IO [a]
+nmergeIO :: [[a]] -> IO [a]
+
+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)
diff --git a/libraries/base/Control/Concurrent/CVar.hs b/libraries/base/Control/Concurrent/CVar.hs
new file mode 100644 (file)
index 0000000..8e16596
--- /dev/null
@@ -0,0 +1,57 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Concurrent.CVar
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: CVar.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+--
+-- Channel variables are one-element channels.
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.CVar
+       ( -- abstract
+         CVar
+       , newCVar       -- :: IO (CVar a)
+       , writeCVar     -- :: CVar a -> a -> IO ()
+       , readCVar      -- :: CVar a -> IO a
+       ) where
+
+import Prelude
+
+import Control.Concurrent.MVar
+
+-- @MVars@ provide the basic mechanisms for synchronising access to a
+-- shared resource. @CVars@, or channel variables, provide an abstraction
+-- that guarantee that the producer is not allowed to run riot, but
+-- enforces the interleaved access to the channel variable,i.e., a
+-- producer is forced to wait up for a consumer to remove the previous
+-- value before it can deposit a new one in the @CVar@.
+
+data CVar a
+ = CVar (MVar a)     -- prod -> cons
+        (MVar ())    -- cons -> prod
+
+newCVar :: IO (CVar a)
+newCVar 
+ = newEmptyMVar >>= \ datum ->
+   newMVar ()   >>= \ ack ->
+   return (CVar datum ack)
+
+writeCVar :: CVar a -> a -> IO ()
+
+writeCVar (CVar datum ack) val
+ = takeMVar ack      >> 
+   putMVar datum val >>
+   return ()
+
+readCVar :: CVar a -> IO a
+readCVar (CVar datum ack)
+ = takeMVar datum >>= \ val ->
+   putMVar ack () >> 
+   return val
diff --git a/libraries/base/Control/Concurrent/Chan.hs b/libraries/base/Control/Concurrent/Chan.hs
new file mode 100644 (file)
index 0000000..29423e1
--- /dev/null
@@ -0,0 +1,119 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Concurrent.Chan
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Chan.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Standard, unbounded channel abstraction.
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.Chan
+       ( Chan                  -- abstract
+
+         -- creator
+       , newChan               -- :: IO (Chan a)
+
+         -- operators
+       , 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
+
+         -- stream interface
+       , getChanContents       -- :: Chan a -> IO [a]
+       , writeList2Chan        -- :: Chan a -> [a] -> IO ()
+
+       ) where
+
+import Prelude
+
+import System.IO.Unsafe                ( unsafeInterleaveIO )
+import Control.Concurrent.MVar
+
+-- A channel is represented by two @MVar@s keeping track of the two ends
+-- of the channel contents,i.e.,  the read- and write ends. Empty @MVar@s
+-- are used to handle consumers trying to read from an empty channel.
+
+data Chan a
+ = Chan (MVar (Stream a))
+        (MVar (Stream a))
+
+type Stream a = MVar (ChItem a)
+
+data ChItem a = ChItem a (Stream a)
+
+-- See the Concurrent Haskell paper for a diagram explaining the
+-- how the different channel operations proceed.
+
+-- @newChan@ sets up the read and write end of a channel by initialising
+-- these two @MVar@s with an empty @MVar@.
+
+newChan :: IO (Chan a)
+newChan = do
+   hole  <- newEmptyMVar
+   read  <- newMVar hole
+   write <- newMVar hole
+   return (Chan read write)
+
+-- To put an element on a channel, a new hole at the write end is created.
+-- What was previously the empty @MVar@ at the back of the channel is then
+-- filled in with a new stream element holding the entered value and the
+-- new hole.
+
+writeChan :: Chan a -> a -> IO ()
+writeChan (Chan _read write) val = do
+  new_hole <- newEmptyMVar
+  modifyMVar_ write $ \old_hole -> do
+    putMVar old_hole (ChItem val new_hole)
+    return new_hole
+
+readChan :: Chan a -> IO a
+readChan (Chan read _write) = do
+  modifyMVar read $ \read_end -> do
+    (ChItem val new_read_end) <- readMVar read_end
+       -- Use readMVar here, not takeMVar,
+       -- else dupChan doesn't work
+    return (new_read_end, val)
+
+dupChan :: Chan a -> IO (Chan a)
+dupChan (Chan _read write) = do
+   hole     <- readMVar write
+   new_read <- newMVar hole
+   return (Chan new_read write)
+
+unGetChan :: Chan a -> a -> IO ()
+unGetChan (Chan read _write) val = do
+   new_read_end <- newEmptyMVar
+   modifyMVar_ read $ \read_end -> do
+     putMVar new_read_end (ChItem val read_end)
+     return new_read_end
+
+isEmptyChan :: Chan a -> IO Bool
+isEmptyChan (Chan read write) = do
+   withMVar read $ \r -> do
+     w <- readMVar write
+     let eq = r == w
+     eq `seq` return eq
+
+-- Operators for interfacing with functional streams.
+
+getChanContents :: Chan a -> IO [a]
+getChanContents ch
+  = unsafeInterleaveIO (do
+       x  <- readChan ch
+       xs <- getChanContents ch
+       return (x:xs)
+    )
+
+-------------
+writeList2Chan :: Chan a -> [a] -> IO ()
+writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)
diff --git a/libraries/base/Control/Concurrent/MVar.hs b/libraries/base/Control/Concurrent/MVar.hs
new file mode 100644 (file)
index 0000000..7832c2e
--- /dev/null
@@ -0,0 +1,95 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Concurrent.MVar
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: MVar.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- MVars: Synchronising variables
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.MVar
+       ( MVar          -- abstract
+       , newEmptyMVar  -- :: IO (MVar a)
+       , newMVar       -- :: a -> IO (MVar a)
+       , takeMVar      -- :: MVar a -> IO a
+       , putMVar       -- :: MVar a -> a -> IO ()
+       , readMVar      -- :: MVar a -> IO a
+       , swapMVar      -- :: MVar a -> a -> IO a
+       , tryTakeMVar   -- :: MVar a -> IO (Maybe a)
+       , tryPutMVar    -- :: MVar a -> a -> IO Bool
+       , isEmptyMVar   -- :: MVar a -> IO Bool
+       , withMVar      -- :: MVar a -> (a -> IO b) -> IO b
+       , modifyMVar_   -- :: MVar a -> (a -> IO a) -> IO ()
+       , modifyMVar    -- :: MVar a -> (a -> IO (a,b)) -> IO b
+       , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
+    ) where
+
+#ifdef __HUGS__
+import ConcBase        ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
+                 tryTakeMVar, tryPutMVar, isEmptyMVar,
+                  readMVar, swapMVar,
+               )
+import Prelude hiding( catch )
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Conc        ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
+                 tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer
+               )
+#endif
+
+import Control.Exception as Exception
+
+#ifdef __HUGS__
+-- This is as close as Hugs gets to providing throw
+throw :: Exception -> IO a
+throw = throwIO
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+readMVar :: MVar a -> IO a
+readMVar m =
+  block $ do
+    a <- takeMVar m
+    putMVar m a
+    return a
+
+swapMVar :: MVar a -> a -> IO a
+swapMVar mvar new = modifyMVar mvar (\old -> return (new,old))
+#endif
+
+-- put back the same value, return something
+withMVar :: MVar a -> (a -> IO b) -> IO b
+withMVar m io = 
+  block $ do
+    a <- takeMVar m
+    b <- Exception.catch (unblock (io a))
+           (\e -> do putMVar m a; throw e)
+    putMVar m a
+    return b
+
+-- put back a new value, return ()
+modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
+modifyMVar_ m io = 
+  block $ do
+    a  <- takeMVar m
+    a' <- Exception.catch (unblock (io a))
+           (\e -> do putMVar m a; throw e)
+    putMVar m a'
+
+-- put back a new value, return something
+modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
+modifyMVar m io = 
+  block $ do
+    a      <- takeMVar m
+    (a',b) <- Exception.catch (unblock (io a))
+               (\e -> do putMVar m a; throw e)
+    putMVar m a'
+    return b
diff --git a/libraries/base/Control/Concurrent/QSem.hs b/libraries/base/Control/Concurrent/QSem.hs
new file mode 100644 (file)
index 0000000..6ffba7d
--- /dev/null
@@ -0,0 +1,67 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Concurrent.QSem
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: QSem.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- General semaphores
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.QSem
+       ( QSem,         -- abstract
+         newQSem,      -- :: Int  -> IO QSem
+         waitQSem,     -- :: QSem -> IO ()
+         signalQSem    -- :: QSem -> IO ()
+       ) where
+
+import Control.Concurrent.MVar
+
+-- 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.
+
+newtype QSem = QSem (MVar (Int, [MVar ()]))
+
+newQSem :: Int -> IO QSem
+newQSem init = do
+   sem <- newMVar (init,[])
+   return (QSem sem)
+
+waitQSem :: QSem -> IO ()
+waitQSem (QSem sem) = do
+   (avail,blocked) <- takeMVar sem  -- gain ex. access
+   if avail > 0 then
+     putMVar sem (avail-1,[])
+    else do
+     block <- 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++[block])
+     takeMVar block
+
+signalQSem :: QSem -> IO ()
+signalQSem (QSem sem) = do
+   (avail,blocked) <- takeMVar sem
+   case blocked of
+     [] -> putMVar sem (avail+1,[])
+
+     (block:blocked') -> do
+          putMVar sem (0,blocked')
+          putMVar block ()
diff --git a/libraries/base/Control/Concurrent/QSemN.hs b/libraries/base/Control/Concurrent/QSemN.hs
new file mode 100644 (file)
index 0000000..da5aa44
--- /dev/null
@@ -0,0 +1,60 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Concurrent.QSemN
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: QSemN.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Quantity semaphores
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.QSemN
+       ( QSemN,        -- abstract
+         newQSemN,     -- :: Int   -> IO QSemN
+         waitQSemN,    -- :: QSemN -> Int -> IO ()
+         signalQSemN   -- :: QSemN -> Int -> IO ()
+      ) where
+
+import Prelude
+
+import Control.Concurrent.MVar
+
+newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())]))
+
+newQSemN :: Int -> IO QSemN 
+newQSemN init = do
+   sem <- newMVar (init,[])
+   return (QSemN sem)
+
+waitQSemN :: QSemN -> Int -> IO ()
+waitQSemN (QSemN sem) sz = do
+  (avail,blocked) <- takeMVar sem   -- gain ex. access
+  if (avail - sz) >= 0 then
+       -- discharging 'sz' still leaves the semaphore
+       -- in an 'unblocked' state.
+     putMVar sem (avail-sz,[])
+   else do
+     block <- newEmptyMVar
+     putMVar sem (avail, blocked++[(sz,block)])
+     takeMVar block
+
+signalQSemN :: QSemN -> Int  -> IO ()
+signalQSemN (QSemN sem) n = do
+   (avail,blocked)   <- takeMVar sem
+   (avail',blocked') <- free (avail+n) blocked
+   putMVar sem (avail',blocked')
+ where
+   free avail []    = return (avail,[])
+   free avail ((req,block):blocked)
+     | avail >= req = do
+       putMVar block ()
+       free (avail-req) blocked
+     | otherwise    = do
+       (avail',blocked') <- free avail blocked
+        return (avail',(req,block):blocked')
diff --git a/libraries/base/Control/Concurrent/SampleVar.hs b/libraries/base/Control/Concurrent/SampleVar.hs
new file mode 100644 (file)
index 0000000..e3d3341
--- /dev/null
@@ -0,0 +1,98 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Concurrent.SampleVar
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: SampleVar.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Sample variables
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.SampleVar
+       (
+         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 ()
+
+       ) where
+
+import Prelude
+
+import Control.Concurrent.MVar
+
+-- 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.)
+
+type SampleVar a
+ = MVar (Int,          -- 1  == full
+                       -- 0  == empty
+                       -- <0 no of readers blocked
+          MVar a)
+
+-- Initally, a SampleVar is empty/unfilled.
+
+newEmptySampleVar :: IO (SampleVar a)
+newEmptySampleVar = do
+   v <- newEmptyMVar
+   newMVar (0,v)
+
+newSampleVar :: a -> IO (SampleVar a)
+newSampleVar a = do
+   v <- newEmptyMVar
+   putMVar v a
+   newMVar (1,v)
+
+emptySampleVar :: SampleVar a -> IO ()
+emptySampleVar v = do
+   (readers, var) <- takeMVar v
+   if readers >= 0 then
+     putMVar v (0,var)
+    else
+     putMVar v (readers,var)
+
+--
+-- filled => make empty and grab sample
+-- not filled => try to grab value, empty when read val.
+--
+readSampleVar :: SampleVar a -> IO a
+readSampleVar svar = do
+   (readers,val) <- takeMVar svar
+   putMVar svar (readers-1,val)
+   takeMVar val
+
+--
+-- filled => overwrite
+-- not filled => fill, write val
+--
+writeSampleVar :: SampleVar a -> a -> IO ()
+writeSampleVar svar v = do
+   (readers,val) <- takeMVar svar
+   case readers of
+     1 -> 
+       swapMVar val v >> 
+       putMVar svar (1,val)
+     _ -> 
+       putMVar val v >> 
+       putMVar svar (min 1 (readers+1), val)
diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs
new file mode 100644 (file)
index 0000000..444ac87
--- /dev/null
@@ -0,0 +1,226 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Exception
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Exception.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+--
+-- The External API for exceptions.  The functions provided in this
+-- module allow catching of exceptions in the IO monad.
+--
+-----------------------------------------------------------------------------
+
+module Control.Exception (
+
+       Exception(..),          -- instance Eq, Ord, Show, Typeable
+       IOException,            -- instance Eq, Ord, Show, Typeable
+       ArithException(..),     -- instance Eq, Ord, Show, Typeable
+       ArrayException(..),     -- instance Eq, Ord, Show, Typeable
+       AsyncException(..),     -- instance Eq, Ord, Show, Typeable
+
+       try,       -- :: IO a -> IO (Either Exception a)
+       tryJust,   -- :: (Exception -> Maybe b) -> a    -> IO (Either b a)
+
+       catch,     -- :: IO a -> (Exception -> IO a) -> IO a
+       catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
+
+       evaluate,  -- :: a -> IO a
+
+       -- Exception predicates (for catchJust, tryJust)
+
+       ioErrors,               -- :: Exception -> Maybe IOError
+       arithExceptions,        -- :: Exception -> Maybe ArithException
+       errorCalls,             -- :: Exception -> Maybe String
+       dynExceptions,          -- :: Exception -> Maybe Dynamic
+       assertions,             -- :: Exception -> Maybe String
+       asyncExceptions,        -- :: Exception -> Maybe AsyncException
+       userErrors,             -- :: Exception -> Maybe String
+
+       -- Throwing exceptions
+
+       throw,          -- :: Exception -> a
+#ifndef __STGHUGS__
+       -- for now
+       throwTo,        -- :: ThreadId -> Exception -> a
+#endif
+
+       -- Dynamic exceptions
+
+       throwDyn,       -- :: Typeable ex => ex -> b
+       throwDynTo,     -- :: Typeable ex => ThreadId -> ex -> b
+       catchDyn,       -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a
+       
+       -- Async exception control
+
+        block,          -- :: IO a -> IO a
+        unblock,        -- :: IO a -> IO a
+
+       -- Assertions
+
+       -- for now
+       assert,         -- :: Bool -> a -> a
+
+       -- Utilities
+
+       finally,        -- :: IO a -> IO b -> IO b
+
+       bracket,        -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()
+       bracket_,       -- :: IO a -> IO b -> IO c -> IO ()
+
+  ) where
+
+#ifdef __GLASGOW_HASKELL__
+import Prelude                 hiding (catch)
+import GHC.Prim                ( assert )
+import GHC.Exception   hiding (try, catch, bracket, bracket_)
+import GHC.Conc                ( throwTo, ThreadId )
+import GHC.IOBase      ( IO(..) )
+#endif
+
+#ifdef __HUGS__
+import Prelude hiding ( catch )
+import PrelPrim        ( catchException 
+               , Exception(..)
+               , throw
+               , ArithException(..)
+               , AsyncException(..)
+               , assert
+               )
+#endif
+
+import Data.Dynamic
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
+INSTANCE_TYPEABLE0(IOException,ioExceptionTc,"IOException")
+INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException")
+INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException")
+INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")
+
+-----------------------------------------------------------------------------
+-- Catching exceptions
+
+-- PrelException defines 'catchException' for us.
+
+catch :: IO a -> (Exception -> IO a) -> IO a
+catch =  catchException
+
+catchJust :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
+catchJust p a handler = catch a handler'
+  where handler' e = case p e of 
+                       Nothing -> throw e
+                       Just b  -> handler b
+
+-----------------------------------------------------------------------------
+-- evaluate
+
+evaluate :: a -> IO a
+evaluate a = a `seq` return a
+
+-----------------------------------------------------------------------------
+-- 'try' and variations.
+
+try :: IO a -> IO (Either Exception a)
+try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))
+
+tryJust :: (Exception -> Maybe b) -> IO a -> IO (Either b a)
+tryJust p a = do
+  r <- try a
+  case r of
+       Right v -> return (Right v)
+       Left  e -> case p e of
+                       Nothing -> throw e
+                       Just b  -> return (Left b)
+
+-----------------------------------------------------------------------------
+-- Dynamic exception types.  Since one of the possible kinds of exception
+-- is a dynamically typed value, we can effectively have polymorphic
+-- exceptions.
+
+-- throwDyn will raise any value as an exception, provided it is in the
+-- Typeable class (see Dynamic.lhs).  
+
+-- catchDyn will catch any exception of a given type (determined by the
+-- handler function).  Any raised exceptions that don't match are
+-- re-raised.
+
+throwDyn :: Typeable exception => exception -> b
+throwDyn exception = throw (DynException (toDyn exception))
+
+throwDynTo :: Typeable exception => ThreadId -> exception -> IO ()
+throwDynTo t exception = throwTo t (DynException (toDyn exception))
+
+catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a
+catchDyn m k = catchException m handle
+  where handle ex = case ex of
+                          (DynException dyn) ->
+                               case fromDynamic dyn of
+                                   Just exception  -> k exception
+                                   Nothing -> throw ex
+                          _ -> throw ex
+
+-----------------------------------------------------------------------------
+-- Exception Predicates
+
+ioErrors               :: Exception -> Maybe IOError
+arithExceptions        :: Exception -> Maybe ArithException
+errorCalls             :: Exception -> Maybe String
+dynExceptions          :: Exception -> Maybe Dynamic
+assertions             :: Exception -> Maybe String
+asyncExceptions        :: Exception -> Maybe AsyncException
+userErrors             :: Exception -> Maybe String
+
+ioErrors e@(IOException _) = Just e
+ioErrors _ = Nothing
+
+arithExceptions (ArithException e) = Just e
+arithExceptions _ = Nothing
+
+errorCalls (ErrorCall e) = Just e
+errorCalls _ = Nothing
+
+assertions (AssertionFailed e) = Just e
+assertions _ = Nothing
+
+dynExceptions (DynException e) = Just e
+dynExceptions _ = Nothing
+
+asyncExceptions (AsyncException e) = Just e
+asyncExceptions _ = Nothing
+
+userErrors (UserError e) = Just e
+userErrors _ = Nothing
+
+-----------------------------------------------------------------------------
+-- Some Useful Functions
+
+bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
+bracket before after thing =
+  block (do
+    a <- before 
+    r <- catch 
+          (unblock (thing a))
+          (\e -> do { after a; throw e })
+    after a
+    return r
+ )
+   
+-- finally is an instance of bracket, but it's quite common
+-- so we give the specialised version for efficiency.
+finally :: IO a -> IO b -> IO a
+a `finally` sequel =
+  block (do
+    r <- catch 
+            (unblock a)
+            (\e -> do { sequel; throw e })
+    sequel
+    return r
+  )
+
+bracket_ :: IO a -> IO b -> IO c -> IO c
+bracket_ before after thing = bracket before (const after) (const thing)
diff --git a/libraries/base/Control/Monad.hs b/libraries/base/Control/Monad.hs
new file mode 100644 (file)
index 0000000..d2e9908
--- /dev/null
@@ -0,0 +1,160 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- $Id: Monad.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad
+    ( MonadPlus (   -- class context: Monad
+         mzero     -- :: (MonadPlus m) => m a
+       , mplus     -- :: (MonadPlus m) => m a -> m a -> m a
+       )
+    , join          -- :: (Monad m) => m (m a) -> m a
+    , guard         -- :: (MonadPlus m) => Bool -> m ()
+    , when          -- :: (Monad m) => Bool -> m () -> m ()
+    , unless        -- :: (Monad m) => Bool -> m () -> m ()
+    , ap            -- :: (Monad m) => m (a -> b) -> m a -> m b
+    , msum          -- :: (MonadPlus m) => [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 
+    
+    , liftM         -- :: (Monad m) => (a -> b) -> (m a -> m b)
+    , liftM2        -- :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)
+    , liftM3        -- :: ...
+    , liftM4        -- :: ...
+    , liftM5        -- :: ...
+
+    , Monad((>>=), (>>), return, fail)
+    , Functor(fmap)
+
+    , mapM          -- :: (Monad m) => (a -> m b) -> [a] -> m [b]
+    , mapM_         -- :: (Monad m) => (a -> m b) -> [a] -> m ()
+    , sequence      -- :: (Monad m) => [m a] -> m [a]
+    , sequence_     -- :: (Monad m) => [m a] -> m ()
+    , (=<<)         -- :: (Monad m) => (a -> m b) -> m a -> m b
+    ) where
+
+import Data.Maybe
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.List
+import GHC.Base
+#endif
+
+infixr 1 =<<
+
+-- -----------------------------------------------------------------------------
+-- Prelude monad functions
+
+{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-}
+(=<<)           :: Monad m => (a -> m b) -> m a -> m b
+f =<< x                = x >>= f
+
+sequence       :: Monad m => [m a] -> m [a] 
+{-# INLINE sequence #-}
+sequence ms = foldr k (return []) ms
+           where
+             k m m' = do { x <- m; xs <- m'; return (x:xs) }
+
+sequence_        :: Monad m => [m a] -> m () 
+{-# INLINE sequence_ #-}
+sequence_ ms     =  foldr (>>) (return ()) ms
+
+mapM            :: Monad m => (a -> m b) -> [a] -> m [b]
+{-# INLINE mapM #-}
+mapM f as       =  sequence (map f as)
+
+mapM_           :: Monad m => (a -> m b) -> [a] -> m ()
+{-# INLINE mapM_ #-}
+mapM_ f as      =  sequence_ (map f as)
+
+-- -----------------------------------------------------------------------------
+-- Monadic classes: MonadPlus
+
+class Monad m => MonadPlus m where
+   mzero :: m a
+   mplus :: m a -> m a -> m a
+
+instance MonadPlus [] where
+   mzero = []
+   mplus = (++)
+
+instance MonadPlus Maybe where
+   mzero = Nothing
+
+   Nothing `mplus` ys  = ys
+   xs      `mplus` _ys = xs
+
+-- -----------------------------------------------------------------------------
+-- Functions mandated by the Prelude
+
+guard           :: (MonadPlus m) => Bool -> m ()
+guard True      =  return ()
+guard False     =  mzero
+
+-- This subsumes the list-based filter function.
+
+filterM          :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
+filterM _ []     =  return []
+filterM p (x:xs) =  do
+   flg <- p x
+   ys  <- filterM p xs
+   return (if flg then x:ys else ys)
+
+-- This subsumes the list-based concat function.
+
+msum        :: MonadPlus m => [m a] -> m a
+{-# INLINE msum #-}
+msum        =  foldr mplus mzero
+
+-- -----------------------------------------------------------------------------
+-- Other monad functions
+
+join              :: (Monad m) => m (m a) -> m a
+join x            =  x >>= id
+
+mapAndUnzipM      :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
+mapAndUnzipM f xs =  sequence (map f xs) >>= return . unzip
+
+zipWithM          :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
+zipWithM f xs ys  =  sequence (zipWith f xs ys)
+
+zipWithM_         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()
+zipWithM_ f xs ys =  sequence_ (zipWith f xs ys)
+
+foldM             :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
+foldM _ a []      =  return a
+foldM f a (x:xs)  =  f a x >>= \fax -> foldM f fax xs
+
+unless            :: (Monad m) => Bool -> m () -> m ()
+unless p s        =  if p then return () else s
+
+when              :: (Monad m) => Bool -> m () -> m ()
+when p s          =  if p then s else return ()
+
+ap                :: (Monad m) => m (a -> b) -> m a -> m b
+ap                =  liftM2 id
+
+liftM   :: (Monad m) => (a1 -> r) -> m a1 -> m r
+liftM2  :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
+liftM3  :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
+liftM4  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
+liftM5  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
+
+liftM f m1              = do { x1 <- m1; return (f x1) }
+liftM2 f m1 m2          = do { x1 <- m1; x2 <- m2; return (f x1 x2) }
+liftM3 f m1 m2 m3       = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) }
+liftM4 f m1 m2 m3 m4    = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) }
+liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) }
diff --git a/libraries/base/Control/Monad/Cont.hs b/libraries/base/Control/Monad/Cont.hs
new file mode 100644 (file)
index 0000000..541f6a6
--- /dev/null
@@ -0,0 +1,122 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.Cont
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Cont.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Continuation monads.
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.Cont (
+       MonadCont(..),
+       Cont(..),
+       runCont,
+       mapCont,
+       withCont,
+       ContT(..),
+       runContT,
+       mapContT,
+       withContT,
+       module Control.Monad,
+       module Control.Monad.Trans,
+  ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.State
+import Control.Monad.RWS
+
+class (Monad m) => MonadCont m where
+       callCC :: ((a -> m b) -> m a) -> m a
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable continuation monad
+
+newtype Cont r a = Cont { runCont :: (a -> r) -> r }
+
+instance Functor (Cont r) where
+       fmap f m = Cont $ \c -> runCont m (c . f)
+
+instance Monad (Cont r) where
+       return a = Cont ($ a)
+       m >>= k  = Cont $ \c -> runCont m $ \a -> runCont (k a) c
+
+instance MonadCont (Cont r) where
+       callCC f = Cont $ \c -> runCont (f (\a -> Cont $ \_ -> c a)) c
+
+mapCont :: (r -> r) -> Cont r a -> Cont r a
+mapCont f m = Cont $ f . runCont m
+
+withCont :: ((b -> r) -> (a -> r)) -> Cont r a -> Cont r b
+withCont f m = Cont $ runCont m . f
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable continuation monad, with an inner monad
+
+newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r }
+
+instance (Monad m) => Functor (ContT r m) where
+       fmap f m = ContT $ \c -> runContT m (c . f)
+
+instance (Monad m) => Monad (ContT r m) where
+       return a = ContT ($ a)
+       m >>= k  = ContT $ \c -> runContT m (\a -> runContT (k a) c)
+
+instance (Monad m) => MonadCont (ContT r m) where
+       callCC f = ContT $ \c -> runContT (f (\a -> ContT $ \_ -> c a)) c
+
+instance MonadTrans (ContT r) where
+       lift m = ContT (m >>=)
+
+instance (MonadIO m) => MonadIO (ContT r m) where
+       liftIO = lift . liftIO
+
+instance (MonadReader r' m) => MonadReader r' (ContT r m) where
+       ask       = lift ask
+       local f m = ContT $ \c -> do
+               r <- ask
+               local f (runContT m (local (const r) . c))
+
+instance (MonadState s m) => MonadState s (ContT r m) where
+       get = lift get
+       put = lift . put
+
+-- -----------------------------------------------------------------------------
+-- MonadCont instances for other monad transformers
+
+instance (MonadCont m) => MonadCont (ReaderT r m) where
+       callCC f = ReaderT $ \r ->
+               callCC $ \c ->
+               runReaderT (f (\a -> ReaderT $ \_ -> c a)) r
+
+instance (MonadCont m) => MonadCont (StateT s m) where
+       callCC f = StateT $ \s ->
+               callCC $ \c ->
+               runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s
+
+instance (Monoid w, MonadCont m) => MonadCont (WriterT w m) where
+       callCC f = WriterT $
+               callCC $ \c ->
+               runWriterT (f (\a -> WriterT $ c (a, mempty)))
+
+instance (Monoid w, MonadCont m) => MonadCont (RWST r w s m) where
+       callCC f = RWST $ \r s ->
+               callCC $ \c ->
+               runRWST (f (\a -> RWST $ \_ s' -> c (a, s', mempty))) r s
+
+mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a
+mapContT f m = ContT $ f . runContT m
+
+withContT :: ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b
+withContT f m = ContT $ runContT m . f
diff --git a/libraries/base/Control/Monad/Error.hs b/libraries/base/Control/Monad/Error.hs
new file mode 100644 (file)
index 0000000..979ae35
--- /dev/null
@@ -0,0 +1,224 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.Error
+-- Copyright   :  (c) Michael Weber <michael.weber@post.rwth-aachen.de>, 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (reqruires multi-param type classes)
+--
+-- $Id: Error.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Error monad.
+--
+-- Rendered by Michael Weber <michael.weber@post.rwth-aachen.de>,
+--     inspired by the Haskell Monad Template Library from
+--      \A[HREF="http://www.cse.ogi.edu/~andy"]{Andy Gill}}
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.Error (
+       Error(..),
+       MonadError(..),
+       ErrorT(..),
+       runErrorT,
+       mapErrorT,
+       module Control.Monad,
+       module Control.Monad.Fix,
+       module Control.Monad.Trans,
+  ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.Trans
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.State
+import Control.Monad.RWS
+import Control.Monad.Cont
+
+import System.IO
+
+-- ---------------------------------------------------------------------------
+-- class MonadError
+--
+--    throws an exception inside the monad and thus interrupts
+--    normal execution order, until an error handler is reached}
+--
+--    catches an exception inside the monad (that was previously
+--    thrown by throwError
+
+class Error a where
+       noMsg  :: a
+       strMsg :: String -> a
+
+       noMsg    = strMsg ""
+       strMsg _ = noMsg
+
+instance Error [Char] where
+       noMsg  = ""
+       strMsg = id
+
+instance Error IOError where
+       strMsg = userError
+
+class (Monad m) => MonadError e m | m -> e where
+       throwError :: e -> m a
+       catchError :: m a -> (e -> m a) -> m a
+
+instance MonadPlus IO where
+       mzero       = ioError (userError "mzero")
+       m `mplus` n = m `catch` \_ -> n
+
+instance MonadError IOError IO where
+       throwError = ioError
+       catchError = catch
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable error monad
+
+instance Functor (Either e) where
+       fmap _ (Left  l) = Left  l
+       fmap f (Right r) = Right (f r)
+
+instance (Error e) => Monad (Either e) where
+       return        = Right
+       Left  l >>= _ = Left l
+       Right r >>= k = k r
+       fail msg      = Left (strMsg msg)
+
+instance (Error e) => MonadPlus (Either e) where
+       mzero            = Left noMsg
+       Left _ `mplus` n = n
+       m      `mplus` _ = m
+
+instance (Error e) => MonadFix (Either e) where
+       mfix f = let
+               a = f $ case a of
+                       Right r -> r
+                       _       -> error "empty mfix argument"
+               in a
+
+instance (Error e) => MonadError e (Either e) where
+       throwError             = Left
+       Left  l `catchError` h = h l
+       Right r `catchError` _ = Right r
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable error monad, with an inner monad
+
+newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }
+
+-- The ErrorT Monad structure is parameterized over two things:
+--     * e - The error type.
+--     * m - The inner monad.
+
+-- Here are some examples of use:
+--
+--   type ErrorWithIO e a = ErrorT e IO a
+--     ==> ErrorT (IO (Either e a))
+--
+--   type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a
+--     ==> ErrorT (StateT s IO (Either e a))
+--     ==> ErrorT (StateT (s -> IO (Either e a,s)))
+--
+
+instance (Monad m) => Functor (ErrorT e m) where
+       fmap f m = ErrorT $ do
+               a <- runErrorT m
+               case a of
+                       Left  l -> return (Left  l)
+                       Right r -> return (Right (f r))
+
+instance (Monad m, Error e) => Monad (ErrorT e m) where
+       return a = ErrorT $ return (Right a)
+       m >>= k  = ErrorT $ do
+               a <- runErrorT m
+               case a of
+                       Left  l -> return (Left l)
+                       Right r -> runErrorT (k r)
+       fail msg = ErrorT $ return (Left (strMsg msg))
+
+instance (Monad m, Error e) => MonadPlus (ErrorT e m) where
+       mzero       = ErrorT $ return (Left noMsg)
+       m `mplus` n = ErrorT $ do
+               a <- runErrorT m
+               case a of
+                       Left  _ -> runErrorT n
+                       Right r -> return (Right r)
+
+instance (MonadFix m, Error e) => MonadFix (ErrorT e m) where
+       mfix f = ErrorT $ mfix $ \a -> runErrorT $ f $ case a of
+               Right r -> r
+               _       -> error "empty mfix argument"
+
+instance (Monad m, Error e) => MonadError e (ErrorT e m) where
+       throwError l     = ErrorT $ return (Left l)
+       m `catchError` h = ErrorT $ do
+               a <- runErrorT m
+               case a of
+                       Left  l -> runErrorT (h l)
+                       Right r -> return (Right r)
+
+instance (Error e) => MonadTrans (ErrorT e) where
+       lift m = ErrorT $ do
+               a <- m
+               return (Right a)
+
+instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
+       liftIO = lift . liftIO
+
+instance (Error e, MonadReader r m) => MonadReader r (ErrorT e m) where
+       ask       = lift ask
+       local f m = ErrorT $ local f (runErrorT m)
+
+instance (Error e, MonadWriter w m) => MonadWriter w (ErrorT e m) where
+       tell     = lift . tell
+       listen m = ErrorT $ do
+               (a, w) <- listen (runErrorT m)
+               return $ case a of
+                       Left  l -> Left  l
+                       Right r -> Right (r, w)
+       pass   m = ErrorT $ pass $ do
+               a <- runErrorT m
+               return $ case a of
+                       Left  l      -> (Left  l, id)
+                       Right (r, f) -> (Right r, f)
+
+instance (Error e, MonadState s m) => MonadState s (ErrorT e m) where
+       get = lift get
+       put = lift . put
+
+instance (Error e, MonadCont m) => MonadCont (ErrorT e m) where
+       callCC f = ErrorT $
+               callCC $ \c ->
+               runErrorT (f (\a -> ErrorT $ c (Right a)))
+
+mapErrorT :: (m (Either e a) -> n (Either e' b)) -> ErrorT e m a -> ErrorT e' n b
+mapErrorT f m = ErrorT $ f (runErrorT m)
+
+-- ---------------------------------------------------------------------------
+-- MonadError instances for other monad transformers
+
+instance (MonadError e m) => MonadError e (ReaderT r m) where
+       throwError       = lift . throwError
+       m `catchError` h = ReaderT $ \r -> runReaderT m r
+               `catchError` \e -> runReaderT (h e) r
+
+instance (Monoid w, MonadError e m) => MonadError e (WriterT w m) where
+       throwError       = lift . throwError
+       m `catchError` h = WriterT $ runWriterT m
+               `catchError` \e -> runWriterT (h e)
+
+instance (MonadError e m) => MonadError e (StateT s m) where
+       throwError       = lift . throwError
+       m `catchError` h = StateT $ \s -> runStateT m s
+               `catchError` \e -> runStateT (h e) s
+
+instance (Monoid w, MonadError e m) => MonadError e (RWST r w s m) where
+       throwError       = lift . throwError
+       m `catchError` h = RWST $ \r s -> runRWST m r s
+               `catchError` \e -> runRWST (h e) r s
diff --git a/libraries/base/Control/Monad/Fix.hs b/libraries/base/Control/Monad/Fix.hs
new file mode 100644 (file)
index 0000000..a596f44
--- /dev/null
@@ -0,0 +1,55 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.Fix
+-- Copyright   :  (c) Andy Gill 2001,
+--               (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (reqruires multi-param type classes)
+--
+-- $Id: Fix.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Fix monad.
+--
+--       Inspired by the paper:
+--       \em{Functional Programming with Overloading and
+--           Higher-Order Polymorphism},
+--         \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+--               Advanced School of Functional Programming, 1995.}
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.Fix (
+       MonadFix(
+          mfix -- :: (a -> m a) -> m a
+         ),
+       fix     -- :: (a -> a) -> a
+  ) where
+
+import Prelude
+
+import System.IO
+import Control.Monad.ST
+
+
+fix :: (a -> a) -> a
+fix f = let x = f x in x
+
+class (Monad m) => MonadFix m where
+       mfix :: (a -> m a) -> m a
+
+-- Perhaps these should live beside (the ST & IO) definition.
+instance MonadFix IO where
+       mfix = fixIO
+
+instance MonadFix (ST s) where
+       mfix = fixST
+
+instance MonadFix Maybe where
+       mfix f = let
+               a = f $ case a of
+                       Just x -> x
+                       _      -> error "empty mfix argument"
+               in a
diff --git a/libraries/base/Control/Monad/Identity.hs b/libraries/base/Control/Monad/Identity.hs
new file mode 100644 (file)
index 0000000..aee6f03
--- /dev/null
@@ -0,0 +1,63 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.Identity
+-- Copyright   :  (c) Andy Gill 2001,
+--               (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- $Id: Identity.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Identity monad.
+--
+--       Inspired by the paper:
+--       \em{Functional Programming with Overloading and
+--           Higher-Order Polymorphism},
+--         \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+--               Advanced School of Functional Programming, 1995.}
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.Identity (
+       Identity(..),
+       runIdentity,
+       module Control.Monad,
+       module Control.Monad.Fix,
+   ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Fix
+
+-- ---------------------------------------------------------------------------
+-- Identity wrapper
+--
+--     Abstraction for wrapping up a object.
+--     If you have an monadic function, say:
+--
+--         example :: Int -> IdentityMonad Int
+--         example x = return (x*x)
+--
+--      you can "run" it, using
+--
+--       Main> runIdentity (example 42)
+--       1764 :: Int
+
+newtype Identity a = Identity { runIdentity :: a }
+
+-- ---------------------------------------------------------------------------
+-- Identity instances for Functor and Monad
+
+instance Functor Identity where
+       fmap f m = Identity (f (runIdentity m))
+
+instance Monad Identity where
+       return a = Identity a
+       m >>= k  = k (runIdentity m)
+
+instance MonadFix Identity where
+       mfix f = Identity (fix (runIdentity . f))
diff --git a/libraries/base/Control/Monad/List.hs b/libraries/base/Control/Monad/List.hs
new file mode 100644 (file)
index 0000000..e6c7daa
--- /dev/null
@@ -0,0 +1,87 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.List
+-- Copyright   :  (c) Andy Gill 2001,
+--               (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable ( requires mulit-parameter type classes )
+--
+-- $Id: List.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The List monad.
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.List (
+       ListT(..),
+       runListT,
+       mapListT,
+       module Control.Monad,
+       module Control.Monad.Trans,
+  ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Cont
+import Control.Monad.Error
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable list monad, with an inner monad
+
+newtype ListT m a = ListT { runListT :: m [a] }
+
+instance (Monad m) => Functor (ListT m) where
+       fmap f m = ListT $ do
+               a <- runListT m
+               return (map f a)
+
+instance (Monad m) => Monad (ListT m) where
+       return a = ListT $ return [a]
+       m >>= k  = ListT $ do
+               a <- runListT m
+               b <- mapM (runListT . k) a
+               return (concat b)
+       fail _ = ListT $ return []
+
+instance (Monad m) => MonadPlus (ListT m) where
+       mzero       = ListT $ return []
+       m `mplus` n = ListT $ do
+               a <- runListT m
+               b <- runListT n
+               return (a ++ b)
+
+instance MonadTrans ListT where
+       lift m = ListT $ do
+               a <- m
+               return [a]
+
+instance (MonadIO m) => MonadIO (ListT m) where
+       liftIO = lift . liftIO
+
+instance (MonadReader s m) => MonadReader s (ListT m) where
+       ask       = lift ask
+       local f m = ListT $ local f (runListT m)
+
+instance (MonadState s m) => MonadState s (ListT m) where
+       get = lift get
+       put = lift . put
+
+instance (MonadCont m) => MonadCont (ListT m) where
+       callCC f = ListT $
+               callCC $ \c ->
+               runListT (f (\a -> ListT $ c [a]))
+
+instance (MonadError e m) => MonadError e (ListT m) where
+       throwError       = lift . throwError
+       m `catchError` h = ListT $ runListT m
+               `catchError` \e -> runListT (h e)
+
+mapListT :: (m [a] -> n [b]) -> ListT m a -> ListT n b
+mapListT f m = ListT $ f (runListT m)
diff --git a/libraries/base/Control/Monad/Monoid.hs b/libraries/base/Control/Monad/Monoid.hs
new file mode 100644 (file)
index 0000000..e81b2be
--- /dev/null
@@ -0,0 +1,58 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.Monoid
+-- Copyright   :  (c) Andy Gill 2001,
+--               (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable ( requires mulit-parameter type classes )
+--
+-- $Id: Monoid.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Declaration of the Monoid class,and instances for list and functions
+--
+--       Inspired by the paper
+--       \em{Functional Programming with Overloading and
+--           Higher-Order Polymorphism},
+--         \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+--               Advanced School of Functional Programming, 1995.}
+-----------------------------------------------------------------------------
+
+module Control.Monad.Monoid (
+       Monoid(..)
+  ) where
+
+import Prelude
+
+-- ---------------------------------------------------------------------------
+-- The Monoid class
+
+class Monoid a where
+       mempty  :: a
+       mappend :: a -> a -> a
+       mconcat :: [a] -> a
+
+-- Now the default for mconcat.  For most types, this
+-- default will be used, but is included in the class definition so
+-- that optimized version of mconcat can be provided
+-- for specific types.
+
+       mconcat = foldr mappend mempty
+
+-- Monoid instances.
+
+instance Monoid [a] where
+       mempty  = []
+       mappend = (++)
+
+instance Monoid (a -> a) where
+       mempty  = id
+       mappend = (.)
+
+instance Monoid () where
+       -- Should it be strict?
+       mempty        = ()
+       _ `mappend` _ = ()
+       mconcat _     = ()
diff --git a/libraries/base/Control/Monad/RWS.hs b/libraries/base/Control/Monad/RWS.hs
new file mode 100644 (file)
index 0000000..26d624d
--- /dev/null
@@ -0,0 +1,170 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.RWS
+-- Copyright   :  (c) Andy Gill 2001,
+--               (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable ( requires mulit-parameter type classes,
+--                              requires functional dependencies )
+--
+-- $Id: RWS.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Declaration of the MonadRWS class.
+--
+--       Inspired by the paper
+--       \em{Functional Programming with Overloading and
+--           Higher-Order Polymorphism},
+--         \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+--               Advanced School of Functional Programming, 1995.}
+-----------------------------------------------------------------------------
+
+module Control.Monad.RWS (
+       RWS(..),
+       runRWS,
+       evalRWS,
+       execRWS,
+       mapRWS,
+       withRWS,
+       RWST(..),
+       runRWST,
+       evalRWST,
+       execRWST,
+       mapRWST,
+       withRWST,
+       module Control.Monad,
+       module Control.Monad.Fix,
+       module Control.Monad.Trans,
+       module Control.Monad.Reader,
+       module Control.Monad.Writer,
+       module Control.Monad.State,
+  ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Monoid
+import Control.Monad.Fix
+import Control.Monad.Trans
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.State
+
+
+newtype RWS r w s a = RWS { runRWS :: r -> s -> (a, s, w) }
+
+instance Functor (RWS r w s) where
+       fmap f m = RWS $ \r s -> let
+               (a, s', w) = runRWS m r s
+               in (f a, s', w)
+
+instance (Monoid w) => Monad (RWS r w s) where
+       return a = RWS $ \_ s -> (a, s, mempty)
+       m >>= k  = RWS $ \r s -> let
+               (a, s',  w)  = runRWS m r s
+               (b, s'', w') = runRWS (k a) r s'
+               in (b, s'', w `mappend` w')
+
+instance (Monoid w) => MonadFix (RWS r w s) where
+       mfix f = RWS $ \r s -> let (a, s', w) = runRWS (f a) r s in (a, s', w)
+
+instance (Monoid w) => MonadReader r (RWS r w s) where
+       ask       = RWS $ \r s -> (r, s, mempty)
+       local f m = RWS $ \r s -> runRWS m (f r) s
+
+instance (Monoid w) => MonadWriter w (RWS r w s) where
+       tell   w = RWS $ \_ s -> ((), s, w)
+       listen m = RWS $ \r s -> let
+               (a, s', w) = runRWS m r s
+               in ((a, w), s', w)
+       pass   m = RWS $ \r s -> let
+               ((a, f), s', w) = runRWS m r s
+               in (a, s', f w)
+
+instance (Monoid w) => MonadState s (RWS r w s) where
+       get   = RWS $ \_ s -> (s, s, mempty)
+       put s = RWS $ \_ _ -> ((), s, mempty)
+
+
+evalRWS :: RWS r w s a -> r -> s -> (a, w)
+evalRWS m r s = let
+    (a, _, w) = runRWS m r s
+    in (a, w)
+
+execRWS :: RWS r w s a -> r -> s -> (s, w)
+execRWS m r s = let
+    (_, s', w) = runRWS m r s
+    in (s', w)
+
+mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b
+mapRWS f m = RWS $ \r s -> f (runRWS m r s)
+
+withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a
+withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s)
+
+
+newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }
+
+instance (Monad m) => Functor (RWST r w s m) where
+       fmap f m = RWST $ \r s -> do
+               (a, s', w) <- runRWST m r s
+               return (f a, s', w)
+
+instance (Monoid w, Monad m) => Monad (RWST r w s m) where
+       return a = RWST $ \_ s -> return (a, s, mempty)
+       m >>= k  = RWST $ \r s -> do
+               (a, s', w)  <- runRWST m r s
+               (b, s'',w') <- runRWST (k a) r s'
+               return (b, s'', w `mappend` w')
+       fail msg = RWST $ \_ _ -> fail msg
+
+instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
+       mzero       = RWST $ \_ _ -> mzero
+       m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s
+
+instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
+       mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
+
+instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where
+       ask       = RWST $ \r s -> return (r, s, mempty)
+       local f m = RWST $ \r s -> runRWST m (f r) s
+
+instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where
+       tell   w = RWST $ \_ s -> return ((),s,w)
+       listen m = RWST $ \r s -> do
+               (a, s', w) <- runRWST m r s
+               return ((a, w), s', w)
+       pass   m = RWST $ \r s -> do
+               ((a, f), s', w) <- runRWST m r s
+               return (a, s', f w)
+
+instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where
+       get   = RWST $ \_ s -> return (s, s, mempty)
+       put s = RWST $ \_ _ -> return ((), s, mempty)
+
+instance (Monoid w) => MonadTrans (RWST r w s) where
+       lift m = RWST $ \_ s -> do
+               a <- m
+               return (a, s, mempty)
+
+instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
+       liftIO = lift . liftIO
+
+
+evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)
+evalRWST m r s = do
+    (a, _, w) <- runRWST m r s
+    return (a, w)
+
+execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)
+execRWST m r s = do
+    (_, s', w) <- runRWST m r s
+    return (s', w)
+
+mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
+mapRWST f m = RWST $ \r s -> f (runRWST m r s)
+
+withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a
+withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)
diff --git a/libraries/base/Control/Monad/Reader.hs b/libraries/base/Control/Monad/Reader.hs
new file mode 100644 (file)
index 0000000..d03c446
--- /dev/null
@@ -0,0 +1,143 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.Reader
+-- Copyright   :  (c) Andy Gill 2001,
+--               (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable ( requires mulit-parameter type classes,
+--                              requires functional dependencies )
+--
+-- $Id: Reader.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Declaration of the Monoid class,and instances for list and functions
+--
+--       Inspired by the paper
+--       \em{Functional Programming with Overloading and
+--           Higher-Order Polymorphism},
+--         \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+--               Advanced School of Functional Programming, 1995.}
+-----------------------------------------------------------------------------
+
+module Control.Monad.Reader (
+       MonadReader(..),
+       asks,
+       Reader(..),
+       runReader,
+       mapReader,
+       withReader,
+       ReaderT(..),
+       runReaderT,
+       mapReaderT,
+       withReaderT,
+       module Control.Monad,
+       module Control.Monad.Fix,
+       module Control.Monad.Trans,
+       ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.Trans
+
+-- ----------------------------------------------------------------------------
+-- class MonadReader
+--  asks for the internal (non-mutable) state.
+
+class (Monad m) => MonadReader r m | m -> r where
+       ask   :: m r
+       local :: (r -> r) -> m a -> m a
+
+-- This allows you to provide a projection function.
+
+asks :: (MonadReader r m) => (r -> a) -> m a
+asks f = do
+       r <- ask
+       return (f r)
+
+-- ----------------------------------------------------------------------------
+-- The partially applied function type is a simple reader monad
+
+instance Functor ((->) r) where
+       fmap = (.)
+
+instance Monad ((->) r) where
+       return  = const
+       m >>= k = \r -> k (m r) r
+
+instance MonadFix ((->) r) where
+       mfix f = \r -> let a = f a r in a
+
+instance MonadReader r ((->) r) where
+       ask       = id
+       local f m = m . f
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable reader monad
+
+newtype Reader r a = Reader { runReader :: r -> a }
+
+instance Functor (Reader r) where
+       fmap f m = Reader $ \r -> f (runReader m r)
+
+instance Monad (Reader r) where
+       return a = Reader $ \_ -> a
+       m >>= k  = Reader $ \r -> runReader (k (runReader m r)) r
+
+instance MonadFix (Reader r) where
+       mfix f = Reader $ \r -> let a = runReader (f a) r in a
+
+instance MonadReader r (Reader r) where
+       ask       = Reader id
+       local f m = Reader $ runReader m . f
+
+mapReader :: (a -> b) -> Reader r a -> Reader r b
+mapReader f m = Reader $ f . runReader m
+
+-- This is a more general version of local.
+
+withReader :: (r' -> r) -> Reader r a -> Reader r' a
+withReader f m = Reader $ runReader m . f
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable reader monad, with an inner monad
+
+newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }
+
+instance (Monad m) => Functor (ReaderT r m) where
+       fmap f m = ReaderT $ \r -> do
+               a <- runReaderT m r
+               return (f a)
+
+instance (Monad m) => Monad (ReaderT r m) where
+       return a = ReaderT $ \_ -> return a
+       m >>= k  = ReaderT $ \r -> do
+               a <- runReaderT m r
+               runReaderT (k a) r
+       fail msg = ReaderT $ \_ -> fail msg
+
+instance (MonadPlus m) => MonadPlus (ReaderT r m) where
+       mzero       = ReaderT $ \_ -> mzero
+       m `mplus` n = ReaderT $ \r -> runReaderT m r `mplus` runReaderT n r
+
+instance (MonadFix m) => MonadFix (ReaderT r m) where
+       mfix f = ReaderT $ \r -> mfix $ \a -> runReaderT (f a) r
+
+instance (Monad m) => MonadReader r (ReaderT r m) where
+       ask       = ReaderT return
+       local f m = ReaderT $ \r -> runReaderT m (f r)
+
+instance MonadTrans (ReaderT r) where
+       lift m = ReaderT $ \_ -> m
+
+instance (MonadIO m) => MonadIO (ReaderT r m) where
+       liftIO = lift . liftIO
+
+mapReaderT :: (m a -> n b) -> ReaderT w m a -> ReaderT w n b
+mapReaderT f m = ReaderT $ f . runReaderT m
+
+withReaderT :: (r' -> r) -> ReaderT r m a -> ReaderT r' m a
+withReaderT f m = ReaderT $ runReaderT m . f
diff --git a/libraries/base/Control/Monad/ST.hs b/libraries/base/Control/Monad/ST.hs
new file mode 100644 (file)
index 0000000..6cbae95
--- /dev/null
@@ -0,0 +1,53 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.ST
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: ST.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The State Transformer Monad, ST
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.ST
+      (
+       ST                  -- abstract, instance of Functor, Monad, Typeable.
+      , runST              -- :: (forall s. ST s a) -> a
+      , fixST              -- :: (a -> ST s a) -> ST s a
+      , unsafeInterleaveST  -- :: ST s a -> ST s a
+
+      , unsafeIOToST       -- :: IO a -> ST s a
+
+      , RealWorld          -- abstract
+      , stToIO             -- :: ST RealWorld a -> IO a
+      ) where
+
+import Prelude
+
+import Data.Dynamic
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.ST
+import GHC.Prim                ( unsafeCoerce#, RealWorld )
+import GHC.IOBase      ( IO(..), stToIO )
+
+unsafeIOToST        :: IO a -> ST s a
+unsafeIOToST (IO io) = ST $ \ s ->
+    case ((unsafeCoerce# io) s) of
+      (#  new_s, a #) -> unsafeCoerce# (STret new_s a)
+#endif
+
+-- ---------------------------------------------------------------------------
+-- Typeable instance
+
+sTTc :: TyCon
+sTTc = mkTyCon "ST"
+
+instance (Typeable a, Typeable b) => Typeable (ST a b) where
+  typeOf st = mkAppTy sTTc [typeOf ((undefined :: ST a b -> a) st),
+                           typeOf ((undefined :: ST a b -> b) st)]
diff --git a/libraries/base/Control/Monad/ST/Lazy.hs b/libraries/base/Control/Monad/ST/Lazy.hs
new file mode 100644 (file)
index 0000000..24b396d
--- /dev/null
@@ -0,0 +1,247 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.ST.Lazy
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- $Id: Lazy.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- This module presents an identical interface to Control.Monad.ST,
+-- but the underlying implementation of the state thread is lazy.
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.ST.Lazy (
+       ST,
+
+       runST,
+       unsafeInterleaveST,
+       fixST,
+
+       STRef.STRef,
+       newSTRef, readSTRef, writeSTRef,
+
+       STArray.STArray,
+       newSTArray, readSTArray, writeSTArray, boundsSTArray, 
+       thawSTArray, freezeSTArray, unsafeFreezeSTArray, 
+#ifdef __GLASGOW_HASKELL__
+-- no 'good' reason, just doesn't support it right now.
+        unsafeThawSTArray,
+#endif
+
+       ST.unsafeIOToST, ST.stToIO,
+
+       strictToLazyST, lazyToStrictST
+    ) where
+
+import Prelude
+
+import qualified Data.STRef as STRef
+import Data.Array
+
+#ifdef __GLASGOW_HASKELL__
+import qualified Control.Monad.ST as ST
+import qualified GHC.Arr as STArray
+import qualified GHC.ST
+import GHC.Base        ( ($), ()(..) )
+import Control.Monad
+import Data.Ix
+import GHC.Prim
+#endif
+
+#ifdef __HUGS__
+import qualified ST
+import Monad
+import Ix
+import Array
+import PrelPrim ( unST 
+                , mkST 
+                , PrimMutableArray
+                , PrimArray
+                , primNewArray
+                , primReadArray
+                , primWriteArray
+                , primUnsafeFreezeArray
+                , primSizeMutableArray
+                , primSizeArray
+                , primIndexArray
+                )
+#endif
+
+
+#ifdef __GLASGOW_HASKELL__
+newtype ST s a = ST (State s -> (a, State s))
+data State s = S# (State# s)
+#endif
+
+#ifdef __HUGS__
+newtype ST s a = ST (s -> (a,s))
+#endif
+
+instance Functor (ST s) where
+    fmap f m = ST $ \ s ->
+      let 
+       ST m_a = m
+       (r,new_s) = m_a s
+      in
+      (f r,new_s)
+
+instance Monad (ST s) where
+
+        return a = ST $ \ s -> (a,s)
+        m >> k   =  m >>= \ _ -> k
+       fail s   = error s
+
+        (ST m) >>= k
+         = ST $ \ s ->
+           let
+             (r,new_s) = m s
+             ST k_a = k r
+           in
+           k_a new_s
+
+
+#ifdef __GLASGOW_HASKELL__
+{-# NOINLINE runST #-}
+runST :: (forall s. ST s a) -> a
+runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r
+#endif
+
+#ifdef __HUGS__
+runST :: (__forall s. ST s a) -> a
+runST st = case st of ST the_st -> let (r,_) = the_st realWorld in r
+       where realWorld = error "runST: entered the RealWorld"
+#endif
+
+fixST :: (a -> ST s a) -> ST s a
+fixST m = ST (\ s -> 
+               let 
+                  ST m_r = m r
+                  (r,s)  = m_r s
+               in
+                  (r,s))
+
+-- ---------------------------------------------------------------------------
+-- Variables
+
+newSTRef   :: a -> ST s (STRef.STRef s a)
+readSTRef  :: STRef.STRef s a -> ST s a
+writeSTRef :: STRef.STRef s a -> a -> ST s ()
+
+newSTRef   = strictToLazyST . STRef.newSTRef
+readSTRef  = strictToLazyST . STRef.readSTRef
+writeSTRef r a = strictToLazyST (STRef.writeSTRef r a)
+
+-- --------------------------------------------------------------------------
+-- Arrays
+
+newSTArray         :: Ix ix => (ix,ix) -> elt -> ST s (STArray.STArray s ix elt)
+readSTArray        :: Ix ix => STArray.STArray s ix elt -> ix -> ST s elt 
+writeSTArray       :: Ix ix => STArray.STArray s ix elt -> ix -> elt -> ST s () 
+boundsSTArray       :: Ix ix => STArray.STArray s ix elt -> (ix, ix)  
+thawSTArray        :: Ix ix => Array ix elt -> ST s (STArray.STArray s ix elt)
+freezeSTArray      :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt)
+unsafeFreezeSTArray :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt)
+
+#ifdef __GLASGOW_HASKELL__
+
+newSTArray ixs init    = strictToLazyST (STArray.newSTArray ixs init)
+
+readSTArray arr ix      = strictToLazyST (STArray.readSTArray arr ix)
+writeSTArray arr ix v   = strictToLazyST (STArray.writeSTArray arr ix v)
+boundsSTArray arr       = STArray.boundsSTArray arr
+thawSTArray arr                = strictToLazyST (STArray.thawSTArray arr)
+freezeSTArray arr       = strictToLazyST (STArray.freezeSTArray arr)
+unsafeFreezeSTArray arr = strictToLazyST (STArray.unsafeFreezeSTArray arr)
+unsafeThawSTArray arr   = strictToLazyST (STArray.unsafeThawSTArray arr)
+#endif
+
+
+#ifdef __HUGS__
+newSTArray ixs elt = do
+  { arr <- strictToLazyST (primNewArray (rangeSize ixs) elt)
+  ; return (STArray ixs arr)
+  }
+
+boundsSTArray (STArray ixs arr)        = ixs
+readSTArray   (STArray ixs arr) ix     
+       = strictToLazyST (primReadArray arr (index ixs ix))
+writeSTArray  (STArray ixs arr) ix elt 
+       = strictToLazyST (primWriteArray arr (index ixs ix) elt)
+freezeSTArray (STArray ixs arr)        = do
+  { arr' <- strictToLazyST (primFreezeArray arr)
+  ; return (Array ixs arr')
+  }
+
+unsafeFreezeSTArray (STArray ixs arr)  = do 
+  { arr' <- strictToLazyST (primUnsafeFreezeArray arr)
+  ; return (Array ixs arr')
+  }
+
+thawSTArray (Array ixs arr) = do
+  { arr' <- strictToLazyST (primThawArray arr)
+  ; return (STArray ixs arr')
+  }
+
+primFreezeArray :: PrimMutableArray s a -> ST.ST s (PrimArray a)
+primFreezeArray arr = do
+  { let n = primSizeMutableArray arr
+  ; arr' <- primNewArray n arrEleBottom
+  ; mapM_ (copy arr arr') [0..n-1]
+  ; primUnsafeFreezeArray arr'
+  }
+ where
+  copy arr arr' i = do { x <- primReadArray arr i; primWriteArray arr' i x }
+  arrEleBottom = error "primFreezeArray: panic"
+
+primThawArray :: PrimArray a -> ST.ST s (PrimMutableArray s a)
+primThawArray arr = do
+  { let n = primSizeArray arr
+  ; arr' <- primNewArray n arrEleBottom
+  ; mapM_ (copy arr arr') [0..n-1]
+  ; return arr'
+  }
+ where
+  copy arr arr' i = primWriteArray arr' i (primIndexArray arr i)
+  arrEleBottom = error "primFreezeArray: panic"
+#endif
+
+-- ---------------------------------------------------------------------------
+-- Strict <--> Lazy
+
+#ifdef __GLASGOW_HASKELL__
+strictToLazyST :: ST.ST s a -> ST s a
+strictToLazyST m = ST $ \s ->
+        let 
+          pr = case s of { S# s# -> GHC.ST.liftST m s# }
+          r  = case pr of { GHC.ST.STret _ v -> v }
+          s' = case pr of { GHC.ST.STret s2# _ -> S# s2# }
+       in
+       (r, s')
+
+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
+
+#ifdef __HUGS__
+strictToLazyST :: ST.ST s a -> ST s a
+strictToLazyST m = ST $ \s ->
+        let 
+          pr = unST m s
+          r  = fst pr
+          s' = snd pr
+       in
+       (r, s')
+
+
+lazyToStrictST :: ST s a -> ST.ST s a
+lazyToStrictST (ST m) = mkST $ m
+#endif
+
+unsafeInterleaveST :: ST s a -> ST s a
+unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST
diff --git a/libraries/base/Control/Monad/ST/Strict.hs b/libraries/base/Control/Monad/ST/Strict.hs
new file mode 100644 (file)
index 0000000..927c462
--- /dev/null
@@ -0,0 +1,22 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.ST.Strict
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- $Id: Strict.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The strict ST monad (identical to Control.Monad.ST)
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.ST.Strict (
+       module Control.Monad.ST
+  ) where
+
+import Prelude
+import Control.Monad.ST
diff --git a/libraries/base/Control/Monad/State.hs b/libraries/base/Control/Monad/State.hs
new file mode 100644 (file)
index 0000000..b28d027
--- /dev/null
@@ -0,0 +1,227 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.State
+-- Copyright   :  (c) Andy Gill 2001,
+--               (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable ( requires mulit-parameter type classes,
+--                              requires functional dependencies )
+--
+-- $Id: State.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- State monads.
+--
+--       Inspired by the paper
+--       \em{Functional Programming with Overloading and
+--           Higher-Order Polymorphism},
+--         \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+--               Advanced School of Functional Programming, 1995.}
+-----------------------------------------------------------------------------
+
+module Control.Monad.State (
+       MonadState(..),
+       modify,
+       gets,
+       State(..),
+       runState,
+       evalState,
+       execState,
+       mapState,
+       withState,
+       StateT(..),
+       runStateT,
+       evalStateT,
+       execStateT,
+       mapStateT,
+       withStateT,
+       module Control.Monad,
+       module Control.Monad.Fix,
+       module Control.Monad.Trans,
+  ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.Trans
+import Control.Monad.Reader
+import Control.Monad.Writer
+
+-- ---------------------------------------------------------------------------
+-- MonadState class
+--
+--  get: returns the state from the internals of the monad.
+--  put: changes (replaces) the state inside the monad.
+
+class (Monad m) => MonadState s m | m -> s where
+       get :: m s
+       put :: s -> m ()
+
+-- Monadic state transformer.
+--
+--      Maps an old state to a new state inside a state monad.
+--      The old state is thrown away.}
+--
+--       Main> :t modify ((+1) :: Int -> Int)
+--       modify (...) :: (MonadState Int a) => a ()
+--
+--     This says that modify (+1) acts over any
+--     Monad that is a member of the MonadState class,
+--     with an Int state.
+
+modify :: (MonadState s m) => (s -> s) -> m ()
+modify f = do
+       s <- get
+       put (f s)
+
+-- Get part of the state
+--
+--     gets specific component of the state,
+--     using a projection function supplied.
+       
+gets :: (MonadState s m) => (s -> a) -> m a
+gets f = do
+       s <- get
+       return (f s)
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable state monad
+
+newtype State s a = State { runState :: s -> (a, s) }
+
+-- The State Monad structure is paramterized over just the state.
+
+instance Functor (State s) where
+       fmap f m = State $ \s -> let
+               (a, s') = runState m s
+               in (f a, s')
+
+instance Monad (State s) where
+       return a = State $ \s -> (a, s)
+       m >>= k  = State $ \s -> let
+               (a, s') = runState m s
+               in runState (k a) s'
+
+instance MonadFix (State s) where
+       mfix f = State $ \s -> let (a, s') = runState (f a) s in (a, s')
+
+instance MonadState s (State s) where
+       get   = State $ \s -> (s, s)
+       put s = State $ \_ -> ((), s)
+
+
+evalState :: State s a -> s -> a
+evalState m s = fst (runState m s)
+
+execState :: State s a -> s -> s
+execState m s = snd (runState m s)
+
+mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
+mapState f m = State $ f . runState m
+
+withState :: (s -> s) -> State s a -> State s a
+withState f m = State $ runState m . f
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable state monad, with an inner monad
+
+newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
+
+--The StateT Monad structure is parameterized over two things:
+--
+--   * s - The state.
+--   * m - The inner monad.
+
+-- Here are some examples of use:
+
+-- (Parser from ParseLib with Hugs)
+--   type Parser a = StateT String [] a
+--      ==> StateT (String -> [(a,String)])
+-- For example, item can be written as:
+--     item = do (x:xs) <- get
+--               put xs
+--               return x
+
+--   type BoringState s a = StateT s Indentity a
+--     ==> StateT (s -> Identity (a,s))
+--
+--   type StateWithIO s a = StateT s IO a
+--     ==> StateT (s -> IO (a,s))
+--
+--   type StateWithErr s a = StateT s Maybe a
+--     ==> StateT (s -> Maybe (a,s))
+
+instance (Monad m) => Functor (StateT s m) where
+       fmap f m = StateT $ \s -> do
+               (x, s') <- runStateT m s
+               return (f x, s')
+
+instance (Monad m) => Monad (StateT s m) where
+       return a = StateT $ \s -> return (a, s)
+       m >>= k  = StateT $ \s -> do
+               (a, s') <- runStateT m s
+               runStateT (k a) s'
+       fail str = StateT $ \_ -> fail str
+
+instance (MonadPlus m) => MonadPlus (StateT s m) where
+       mzero       = StateT $ \_ -> mzero
+       m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s
+
+instance (MonadFix m) => MonadFix (StateT s m) where
+       mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s
+
+instance (Monad m) => MonadState s (StateT s m) where
+       get   = StateT $ \s -> return (s, s)
+       put s = StateT $ \_ -> return ((), s)
+
+instance MonadTrans (StateT s) where
+       lift m = StateT $ \s -> do
+               a <- m
+               return (a, s)
+
+instance (MonadIO m) => MonadIO (StateT s m) where
+       liftIO = lift . liftIO
+
+instance (MonadReader r m) => MonadReader r (StateT s m) where
+       ask       = lift ask
+       local f m = StateT $ \s -> local f (runStateT m s)
+
+instance (MonadWriter w m) => MonadWriter w (StateT s m) where
+       tell     = lift . tell
+       listen m = StateT $ \s -> do
+               ((a, s'), w) <- listen (runStateT m s)
+               return ((a, w), s')
+       pass   m = StateT $ \s -> pass $ do
+               ((a, f), s') <- runStateT m s
+               return ((a, s'), f)
+
+
+evalStateT :: (Monad m) => StateT s m a -> s -> m a
+evalStateT m s = do
+       (a, _) <- runStateT m s
+       return a
+
+execStateT :: (Monad m) => StateT s m a -> s -> m s
+execStateT m s = do
+       (_, s') <- runStateT m s
+       return s'
+
+mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
+mapStateT f m = StateT $ f . runStateT m
+
+withStateT :: (s -> s) -> StateT s m a -> StateT s m a
+withStateT f m = StateT $ runStateT m . f
+
+-- ---------------------------------------------------------------------------
+-- MonadState instances for other monad transformers
+
+instance (MonadState s m) => MonadState s (ReaderT r m) where
+       get = lift get
+       put = lift . put
+
+instance (Monoid w, MonadState s m) => MonadState s (WriterT w m) where
+       get = lift get
+       put = lift . put
diff --git a/libraries/base/Control/Monad/Trans.hs b/libraries/base/Control/Monad/Trans.hs
new file mode 100644 (file)
index 0000000..3766021
--- /dev/null
@@ -0,0 +1,46 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.Trans
+-- Copyright   :  (c) Andy Gill 2001,
+--               (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- $Id: Trans.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The MonadTrans class.
+--
+--       Inspired by the paper
+--       \em{Functional Programming with Overloading and
+--           Higher-Order Polymorphism},
+--         \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+--               Advanced School of Functional Programming, 1995.}
+-----------------------------------------------------------------------------
+
+module Control.Monad.Trans (
+       MonadTrans(..),
+       MonadIO(..),  
+  ) where
+
+import Prelude
+
+import System.IO
+
+-- ---------------------------------------------------------------------------
+-- MonadTrans class
+--
+-- Monad to facilitate stackable Monads.
+-- Provides a way of digging into an outer
+-- monad, giving access to (lifting) the inner monad.
+
+class MonadTrans t where
+       lift :: Monad m => m a -> t m a
+
+class (Monad m) => MonadIO m where
+       liftIO :: IO a -> m a
+
+instance MonadIO IO where
+       liftIO = id
diff --git a/libraries/base/Control/Monad/Writer.hs b/libraries/base/Control/Monad/Writer.hs
new file mode 100644 (file)
index 0000000..96df130
--- /dev/null
@@ -0,0 +1,170 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Monad.Writer
+-- Copyright   :  (c) Andy Gill 2001,
+--               (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable ( requires mulit-parameter type classes,
+--                              requires functional dependencies )
+--
+-- $Id: Writer.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The MonadWriter class.
+--
+--       Inspired by the paper
+--       \em{Functional Programming with Overloading and
+--           Higher-Order Polymorphism},
+--         \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+--               Advanced School of Functional Programming, 1995.}
+-----------------------------------------------------------------------------
+
+module Control.Monad.Writer (
+       MonadWriter(..),
+       listens,
+       censor,
+       Writer(..),
+       runWriter,
+       execWriter,
+       mapWriter,
+       WriterT(..),
+       runWriterT,
+       execWriterT,
+       mapWriterT,
+       module Control.Monad,
+       module Control.Monad.Monoid,
+       module Control.Monad.Fix,
+       module Control.Monad.Trans,
+  ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Monoid
+import Control.Monad.Fix
+import Control.Monad.Trans
+import Control.Monad.Reader
+
+-- ---------------------------------------------------------------------------
+-- MonadWriter class
+--
+-- tell is like tell on the MUD's it shouts to monad
+-- what you want to be heard. The monad carries this 'packet'
+-- upwards, merging it if needed (hence the Monoid requirement)}
+--
+-- listen listens to a monad acting, and returns what the monad "said".
+--
+-- pass lets you provide a writer transformer which changes internals of
+-- the written object.
+
+class (Monoid w, Monad m) => MonadWriter w m | m -> w where
+       tell   :: w -> m ()
+       listen :: m a -> m (a, w)
+       pass   :: m (a, w -> w) -> m a
+
+listens :: (MonadWriter w m) => (w -> w) -> m a -> m (a, w)
+listens f m = do
+       (a, w) <- listen m
+       return (a, f w)
+
+censor :: (MonadWriter w m) => (w -> w) -> m a -> m a
+censor f m = pass $ do
+       a <- m
+       return (a, f)
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable writer monad
+
+newtype Writer w a = Writer { runWriter :: (a, w) }
+
+
+instance Functor (Writer w) where
+       fmap f m = Writer $ let (a, w) = runWriter m in (f a, w)
+
+instance (Monoid w) => Monad (Writer w) where
+       return a = Writer (a, mempty)
+       m >>= k  = Writer $ let
+               (a, w)  = runWriter m
+               (b, w') = runWriter (k a)
+               in (b, w `mappend` w')
+
+instance (Monoid w) => MonadFix (Writer w) where
+       mfix m = Writer $ let (a, w) = runWriter (m a) in (a, w)
+
+instance (Monoid w) => MonadWriter w (Writer w) where
+       tell   w = Writer ((), w)
+       listen m = Writer $ let (a, w) = runWriter m in ((a, w), w)
+       pass   m = Writer $ let ((a, f), w) = runWriter m in (a, f w)
+
+
+execWriter :: Writer w a -> w
+execWriter m = snd (runWriter m)
+
+mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
+mapWriter f m = Writer $ f (runWriter m)
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable writer monad, with an inner monad
+
+newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }
+
+
+instance (Monad m) => Functor (WriterT w m) where
+       fmap f m = WriterT $ do
+               (a, w) <- runWriterT m
+               return (f a, w)
+
+instance (Monoid w, Monad m) => Monad (WriterT w m) where
+       return a = WriterT $ return (a, mempty)
+       m >>= k  = WriterT $ do
+               (a, w)  <- runWriterT m
+               (b, w') <- runWriterT (k a)
+               return (b, w `mappend` w')
+       fail msg = WriterT $ fail msg
+
+instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where
+       mzero       = WriterT mzero
+       m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n
+
+instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where
+       mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a)
+
+instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where
+       tell   w = WriterT $ return ((), w)
+       listen m = WriterT $ do
+               (a, w) <- runWriterT m
+               return ((a, w), w)
+       pass   m = WriterT $ do
+               ((a, f), w) <- runWriterT m
+               return (a, f w)
+
+instance (Monoid w) => MonadTrans (WriterT w) where
+       lift m = WriterT $ do
+               a <- m
+               return (a, mempty)
+
+instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where
+       liftIO = lift . liftIO
+
+instance (Monoid w, MonadReader r m) => MonadReader r (WriterT w m) where
+       ask       = lift ask
+       local f m = WriterT $ local f (runWriterT m)
+
+
+execWriterT :: Monad m => WriterT w m a -> m w
+execWriterT m = do
+       (_, w) <- runWriterT m
+       return w
+
+mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
+mapWriterT f m = WriterT $ f (runWriterT m)
+
+-- ---------------------------------------------------------------------------
+-- MonadWriter instances for other monad transformers
+
+instance (MonadWriter w m) => MonadWriter w (ReaderT r m) where
+       tell     = lift . tell
+       listen m = ReaderT $ \w -> listen (runReaderT m w)
+       pass   m = ReaderT $ \w -> pass   (runReaderT m w)
diff --git a/libraries/base/Control/Parallel.hs b/libraries/base/Control/Parallel.hs
new file mode 100644 (file)
index 0000000..1d6a126
--- /dev/null
@@ -0,0 +1,62 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Parallel
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Parallel.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+--
+-- Parallel Constructs
+--
+-----------------------------------------------------------------------------
+
+module Control.Parallel (
+          par, seq -- re-exported
+#if defined(__GRANSIM__)
+       , parGlobal, parLocal, parAt, parAtAbs, parAtRel, parAtForNow     
+#endif
+    ) where
+
+import Prelude
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Conc        ( par )
+#endif
+
+#if defined(__GRANSIM__)
+import PrelBase
+import PrelErr   ( parError )
+import PrelGHC   ( parGlobal#, parLocal#, parAt#, parAtAbs#, parAtRel#, parAtForNow# )
+
+{-# INLINE parGlobal #-}
+{-# INLINE parLocal #-}
+{-# INLINE parAt #-}
+{-# INLINE parAtAbs #-}
+{-# INLINE parAtRel #-}
+{-# INLINE parAtForNow #-}
+parGlobal   :: Int -> Int -> Int -> Int -> a -> b -> b
+parLocal    :: Int -> Int -> Int -> Int -> a -> b -> b
+parAt      :: Int -> Int -> Int -> Int -> a -> b -> c -> c
+parAtAbs    :: Int -> Int -> Int -> Int -> Int -> a -> b -> b
+parAtRel    :: Int -> Int -> Int -> Int -> Int -> a -> b -> b
+parAtForNow :: Int -> Int -> Int -> Int -> a -> b -> c -> c
+
+parGlobal (I# w) (I# g) (I# s) (I# p) x y = case (parGlobal# x w g s p y) of { 0# -> parError; _ -> y }
+parLocal  (I# w) (I# g) (I# s) (I# p) x y = case (parLocal#  x w g s p y) of { 0# -> parError; _ -> y }
+
+parAt       (I# w) (I# g) (I# s) (I# p) v x y = case (parAt#       x v w g s p y) of { 0# -> parError; _ -> y }
+parAtAbs    (I# w) (I# g) (I# s) (I# p) (I# q) x y = case (parAtAbs#  x q w g s p y) of { 0# -> parError; _ -> y }
+parAtRel    (I# w) (I# g) (I# s) (I# p) (I# q) x y = case (parAtRel#  x q w g s p y) of { 0# -> parError; _ -> y }
+parAtForNow (I# w) (I# g) (I# s) (I# p) v x y = case (parAtForNow# x v w g s p y) of { 0# -> parError; _ -> y }
+
+#endif
+
+-- Maybe parIO and the like could be added here later.
+#ifndef __GLASGOW_HASKELL__
+-- For now, Hugs does not support par properly.
+par a b = b
+#endif
diff --git a/libraries/base/Control/Parallel/Strategies.hs b/libraries/base/Control/Parallel/Strategies.hs
new file mode 100644 (file)
index 0000000..cad9aa3
--- /dev/null
@@ -0,0 +1,964 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Control.Parallel.Strategies
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Strategies.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Parallel strategy combinators
+--
+-----------------------------------------------------------------------------
+
+{-
+Time-stamp: <Wed Mar 21 2001 00:45:34 Stardate: [-30]6360.15 hwloidl>
+$Id: Strategies.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+
+This module defines parallel strategy combinators
+
+       Phil Trinder, Hans-Wolfgang Loidl, Kevin Hammond et al. 
+
+       Based on Version VII (1/5/96) `Strategies96' of type a -> ()
+
+Author:    $Author: simonmar $
+Date:      $Date: 2001/06/28 14:15:02 $
+Revision:  $Revision: 1.1 $
+Source:    $Source: /srv/cvs/cvs.haskell.org/fptools/libraries/base/Control/Parallel/Strategies.hs,v $
+State:     $State: Exp $
+
+This module defines evaluation strategies for controlling the parallel
+evaluation of non-strict programs. They provide a clean separation between
+algorithmic and behavioural code.
+
+The functions described here, and their use is documented in
+
+"Algorithm + Strategy = Parallelism", 
+P.W. Trinder, K. Hammond, H-W. Loidl, S.L. Peyton Jones 
+In Journal of Functional Programming 8(1):23--60, January 1998.
+URL: http://www.cee.hw.ac.uk/~dsg/gph/papers/ps/strategies.ps.gz
+
+This module supports Haskell 1.2, Haskell 1.4 and Haskell98.
+The distinction is made based on the __HASKELL1__ CPP variable. 
+Parts of the module could be rewritten using constructor classes.
+
+-----------------------------------------------------------------------------
+The history of the Strategies module:
+
+Changelog:
+$Log: Strategies.hs,v $
+Revision 1.1  2001/06/28 14:15:02  simonmar
+First cut of the Haskell Core Libraries
+=======================================
+
+NOTE: it's not meant to be a working snapshot.  The code is just here
+to look at and so the NHC/Hugs guys can start playing around with it.
+
+There is no build system.  For GHC, the libraries tree is intended to
+be grafted onto an existing fptools/ tree, and the Makefile in
+libraries/core is a quick hack for that setup.  This won't work at the
+moment without the other changes needed in fptools/ghc, which I
+haven't committed because they'll cause breakage.  However, with the
+changes required these sources build a working Prelude and libraries.
+
+The layout mostly follows the one we agreed on, with one or two minor
+changes; in particular the Data/Array layout probably isn't final
+(there are several choices here).
+
+The document is in libraries/core/doc as promised.
+
+The cbits stuff is just a copy of ghc/lib/std/cbits and has
+GHC-specific stuff in it.  We should really separate the
+compiler-specific C support from any compiler-independent C support
+there might be.
+
+Don't pay too much attention to the portability or stability status
+indicated in the header of each source file at the moment - I haven't
+gone through to make sure they're all consistent and make sense.
+
+I'm using non-literate source outside of GHC/.  Hope that's ok with
+everyone.
+
+We need to discuss how the build system is going to work...
+
+Revision 1.3  2001/03/22 03:51:12  hwloidl
+                                                  -*- outline -*-
+Time-stamp: <Thu Mar 22 2001 03:50:16 Stardate: [-30]6365.79 hwloidl>
+
+This commit covers changes in GHC to get GUM (way=mp) and GUM/GdH (way=md)
+working. It is a merge of my working version of GUM, based on GHC 4.06,
+with GHC 4.11. Almost all changes are in the RTS (see below).
+
+GUM is reasonably stable, we used the 4.06 version in large-ish programs for
+recent papers. Couple of things I want to change, but nothing urgent.
+GUM/GdH has just been merged and needs more testing. Hope to do that in the
+next weeks. It works in our working build but needs tweaking to run.
+GranSim doesn't work yet (*sigh*). Most of the code should be in, but needs
+more debugging.
+
+ToDo: I still want to make the following minor modifications before the release
+- Better wrapper skript for parallel execution [ghc/compiler/main]
+- Update parallel docu: started on it but it's minimal [ghc/docs/users_guide]
+- Clean up [nofib/parallel]: it's a real mess right now (*sigh*)
+- Update visualisation tools (minor things only IIRC) [ghc/utils/parallel]
+- Add a Klingon-English glossary
+
+* RTS:
+
+Almost all changes are restricted to ghc/rts/parallel and should not
+interfere with the rest. I only comment on changes outside the parallel
+dir:
+
+- Several changes in Schedule.c (scheduling loop; createThreads etc);
+  should only affect parallel code
+- Added ghc/rts/hooks/ShutdownEachPEHook.c
+- ghc/rts/Linker.[ch]: GUM doesn't know about Stable Names (ifdefs)!!
+- StgMiscClosures.h: END_TSO_QUEUE etc now defined here (from StgMiscClosures.hc)
+                     END_ECAF_LIST was missing a leading stg_
+- SchedAPI.h: taskStart now defined in here; it's only a wrapper around
+              scheduleThread now, but might use some init, shutdown later
+- RtsAPI.h: I have nuked the def of rts_evalNothing
+
+* Compiler:
+
+- ghc/compiler/main/DriverState.hs
+  added PVM-ish flags to the parallel way
+  added new ways for parallel ticky profiling and distributed exec
+
+- ghc/compiler/main/DriverPipeline.hs
+  added a fct run_phase_MoveBinary which is called with way=mp after linking;
+  it moves the bin file into a PVM dir and produces a wrapper script for
+  parallel execution
+  maybe cleaner to add a MoveBinary phase in DriverPhases.hs but this way
+  it's less intrusive and MoveBinary makes probably only sense for mp anyway
+
+* Nofib:
+
+- nofib/spectral/Makefile, nofib/real/Makefile, ghc/tests/programs/Makefile:
+  modified to skip some tests if HWL_NOFIB_HACK is set; only tmp to record
+  which test prgs cause problems in my working build right now
+
+Revision 1.2  2000/11/18 02:13:11  hwloidl
+Now provides explicit def of seq (rather than just re-exporting).
+Required by the current version of the compiler.
+
+Revision 1.1  2000/01/14 13:34:32  hwloidl
+Module for specifying (parallel) behavioural code.
+
+Revision 1.9  1997/10/01 00:27:19  hwloidl
+Type of par and seq changed to Done -> Done -> Done with Done = ()
+Works for Haskell 1.2 as well as Haskell 1.4 (checks the CPP variable
+__HASKELL1__ to distinguish setups).
+Fixed precedences for par and seq for Haskell 1.4 (stronger than using).
+New infix operators >| and >|| as aliases for par and seq as strategy
+combinators.
+
+Revision 1.8  1997/05/20 21:13:22  hwloidl
+Revised to use `demanding` and `sparking` (final JFP paper version)
+
+Revision 1.7  1997/04/02 21:26:21  hwloidl
+Minor changes in documentation, none in the code.
+
+
+revision 1.5
+Version VII.1; Strategies96; Type: a -> ()
+Minor changes to previous version.
+CPP flags now separate GUM from GranSim version.
+Infix declaration for `using` (important for e.g. quicksort where the old
+version puts parentheses in the wrong way).
+Moer instances for NFData and markStartegies (in GranSim setup only).
+
+revision 1.4
+Version VII; Strategies96; Type: a -> ()
+The type has changed again; with the old type it's not possible to describe
+all the strategies we want (for example seqPair r0 rnf which should not
+evaluate the first component of the pair at all). The () type acts as info
+that the strategy has been applied.
+The function `using` is used as inverse strategy application i.e.
+on top level we usually have something like res `using` strat where ...
+The markStrategy hack is included in this version: it attaches an Int value
+to the currently running strategy (this can be inherited by all sub-strats)
+It doesn't model the jumps between evaluating producer and consumer properly
+(for that something like cost centers would be necessary).
+
+revision 1.3
+Version VI (V-based); Strategies95; Type: a -> a
+Now uses library modules like FiniteMap with strategies in there.
+CPP flags for using the same module with GUM and GranSim.
+A few new strategies.
+
+revision 1.2
+Version V; Strategies95; Type: a -> a
+The type of Strategies has changed from a -> () to a -> a
+All strategies and instances of NFData have been redefined accordingly.
+This branch started off after discussions between PWT, SLPJ and HWL in
+mid Nov (start of development of the actual module: 10/1/96)
+
+revision 1.1 Initial revision
+-----------------------------------------------------------------------------
+-- To use fakeinfo first replace all %%$ by \@ 
+-- If you have fakeinfo makers in the file you need a slightly modified 
+-- version of the lit-deatify script (called by lit2pgm). You get that 
+-- version on Suns and Alphas in Glasgow by using 
+--  \tr{lit2pgm -H "${HOME}/bin/`hw_os`"}
+-- in your Makefile
+-----------------------------------------------------------------------------
+
+--@node Evaluation Strategies, , ,
+--@chapter Evaluation Strategies
+
+--@menu
+--* Imports and infix declarations::  
+--* Strategy Type and Application::  
+--* Basic Strategies::         
+--* Strategic Function Application::  
+--* Marking a Strategy::       
+--* Strategy Instances::       
+--* Lolita-specific Strategies::  
+--@end menu
+
+--@node Imports and infix declarations, Strategy Type and Application, Evaluation Strategies, Evaluation Strategies
+--@section Imports and infix declarations
+
+> module Strategies(
+>#if (__HASKELL1__>=4)
+>                   module Strategies,
+>                   module Parallel
+>#else
+>                   Strategies..
+>#endif
+>                  ) where
+>
+>#if defined(GRAN) && !(__HASKELL1__>=4)
+> import PreludeGlaST                        -- only needed for markStrat
+>#endif
+>#if (__HASKELL1__>=4)
+
+<> import Prelude hiding (seq)
+<> import qualified Parallel
+
+> import Parallel
+
+>#else
+> import Parallel renaming (par to par_from_Parallel, seq to seq_from_Parallel)
+>#endif
+
+>#if (__HASKELL1__>=4)
+> import Ix
+> import Array
+>#endif
+
+>#if defined(PAR_GRAN_LIST)
+> import QSort -- tmp (only for parGranList)
+>#endif
+
+I lifted the precedence of @par@ and @seq@ by one level to make @using@ the 
+combinator with the weakest precedence.
+Oooops, there seems to be a bug in ghc 0.29 prohibiting another infix 
+declaration of @par@ and @seq@ despite renaming the imported versions.
+
+>#if (__HASKELL1__>=4)
+
+<> infixr 2 `par`           -- was: 0
+<> infixr 3 `seq`           -- was: 1 
+
+>#else
+> infixr 0 `par`           -- was: 0
+> infixr 1 `seq`           -- was: 1 
+>#endif
+
+> infixl 0 `using`,`demanding`,`sparking`              -- weakest precedence!
+
+> infixr 2 >||                -- another name for par
+> infixr 3 >|                 -- another name for seq
+> infixl 6 $||, $|            -- strategic function application (seq and par)
+> infixl 9 .|, .||, -|, -||   -- strategic (inverse) function composition
+
+> strategy_version = "$Revision: 1.1 $"
+> strategy_id = "$Id: Strategies.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $"
+
+------------------------------------------------------------------------------
+                       Strategy Type, Application and Semantics              
+------------------------------------------------------------------------------
+--@node Strategy Type and Application, Basic Strategies, Imports and infix declarations, Evaluation Strategies
+--@section Strategy Type and Application
+
+--@cindex Strategy
+
+> type Done = ()
+> type Strategy a = a -> Done
+
+A strategy takes a value and returns a dummy `done' value to indicate that
+the specifed evaluation has been performed.
+
+The basic combinators for strategies are @par@ and @seq@ but with types that 
+indicate that they only combine the results of a strategy application. 
+
+NB: This version can be used with Haskell 1.4 (GHC 2.05 and beyond), *but*
+    you won't get strategy checking on seq (only on par)!
+
+The infix fcts >| and >|| are alternative names for `seq` and `par`.
+With the introduction of a Prelude function `seq` separating the Prelude 
+function from the Strategy function becomes a pain. The notation also matches
+the notation for strategic function application.
+
+--@cindex par
+--@cindex seq
+--@cindex >|
+--@cindex >||
+
+>#if (__HASKELL1__>=4)
+
+par and seq have the same types as before; >| and >|| are more specific
+and can only be used when composing strategies.
+
+<> par :: Done -> Done -> Done 
+<> par = Parallel.par
+<> seq :: a -> b -> b      -- that's the real type of seq defined in Prelude
+<> seq = Parallel.seq
+
+> (>|), (>||) :: Done -> Done -> Done 
+> {-# INLINE (>|) #-}
+> {-# INLINE (>||) #-}
+> (>|) = Prelude.seq
+> (>||) = Parallel.par
+>#else
+> par, seq, (>|), (>||) :: Done -> Done -> Done 
+> par = par_from_Parallel
+> seq = seq_from_Parallel
+> {-# INLINE (>|) #-}
+> {-# INLINE (>||) #-}
+> (>|) = seq
+> (>||) = par
+>#endif
+
+--@cindex using
+
+> using :: a -> Strategy a -> a
+>#if (__HASKELL1__>=4)
+> using x s = s x `seq` x
+>#else
+> using x s = s x `seq_from_Parallel` x
+>#endif
+
+using takes a strategy and a value, and applies the strategy to the
+value before returning the value. Used to express data-oriented parallelism
+
+x `using` s is a projection on x, i.e. both
+
+  a retraction: x `using` s [ x
+                           -
+  and idempotent: (x `using` s) `using` s = x `using` s
+
+demanding and sparking are used to express control-oriented
+parallelism. Their second argument is usually a sequence of strategy
+applications combined `par` and `seq`. Sparking should only be used
+with a singleton sequence as it is not necessarily excuted
+
+--@cindex demanding
+--@cindex sparking
+
+> demanding, sparking :: a -> Done -> a
+>#if (__HASKELL1__>=4)
+> demanding = flip Parallel.seq
+> sparking  = flip Parallel.par
+>#else
+> demanding = flip seq_from_Parallel
+> sparking  = flip par_from_Parallel
+>#endif
+
+sPar and sSeq have been superceded by sparking and demanding: replace 
+  e `using` sPar x     with    e `sparking`  x 
+  e `using` sSeq x     with    e `demanding` x
+
+<sPar is a strategy corresponding to par. i.e. x `par` e <=> e `using` sPar x
+<
+<> sPar :: a -> Strategy b
+<> sPar x y = x `par` ()
+<
+<sSeq is a strategy corresponding to seq. i.e. x `seq` e <=> e `using` sSeq x
+<
+<> sSeq :: a -> Strategy b
+<> sSeq x y = x `seq` ()
+
+-----------------------------------------------------------------------------
+                       Basic Strategies                                     
+-----------------------------------------------------------------------------
+--@node Basic Strategies, Strategic Function Application, Strategy Type and Application, Evaluation Strategies
+--@section Basic Strategies
+
+r0 performs *no* evaluation on its argument.
+
+--@cindex r0
+
+> r0 :: Strategy a 
+> r0 x = ()
+
+rwhnf reduces its argument to weak head normal form.
+
+--@cindex rwhnf
+--@cindex rnf
+--@cindex NFData
+
+>#if defined(__HASKELL98__)
+> rwhnf :: Strategy a 
+> rwhnf x = x `seq` ()  
+>#elif (__HASKELL1__==4)
+> rwhnf :: Eval a => Strategy a 
+> rwhnf x = x `seq` ()  
+>#else
+> rwhnf :: Strategy a 
+> rwhnf x = x `seq_from_Parallel` ()  
+>#endif
+
+>#if defined(__HASKELL98__)
+> class NFData a where
+>#elif (__HASKELL1__>=4)
+> class Eval a => NFData a where
+>#else
+> class NFData a where
+>#endif
+>   -- rnf reduces its argument to (head) normal form
+>   rnf :: Strategy a
+>   -- Default method. Useful for base types. A specific method is necessay for
+>   -- constructed types
+>   rnf = rwhnf
+>
+> class (NFData a, Integral a) => NFDataIntegral a
+> class (NFData a, Ord a) => NFDataOrd a
+
+------------------------------------------------------------------------------
+                        Strategic Function Application
+------------------------------------------------------------------------------
+--@node Strategic Function Application, Marking a Strategy, Basic Strategies, Evaluation Strategies
+--@section Strategic Function Application
+
+The two  infix functions @$|@   and @$||@  perform sequential and  parallel
+function application, respectively. They  are parameterised with a strategy
+that is applied to the argument of the  function application.  This is very
+handy when  writing  pipeline parallelism  as  a sequence of  @$@, @$|@ and
+@$||@'s. There is no  need of naming intermediate values  in this case. The
+separation  of algorithm from strategy  is  achieved by allowing strategies
+only as second arguments to @$|@ and @$||@.
+
+--@cindex $|
+--@cindex $||
+
+> ($|), ($||) :: (a -> b) -> Strategy a -> a -> b
+
+<> f $| s  = \ x -> f x `using` \ _ -> s x `seq` ()
+<> f $|| s = \ x -> f x `using` \ _ -> s x `par` ()
+
+> f $| s  = \ x -> f x `demanding` s x
+> f $|| s = \ x -> f x `sparking`  s x
+
+The same thing for function composition (.| and .||) and inverse function
+composition (-| and -||) for those who read their programs from left to 
+right.
+
+--@cindex .|
+--@cindex .||
+--@cindex -|
+--@cindex -||
+
+> (.|), (.||) :: (b -> c) -> Strategy b -> (a -> b) -> (a -> c)
+> (-|), (-||) :: (a -> b) -> Strategy b -> (b -> c) -> (a -> c)
+
+> (.|) f s g = \ x -> let  gx = g x 
+>                     in   f gx `demanding` s gx
+> (.||) f s g = \ x -> let  gx = g x 
+>                      in   f gx `sparking` s gx
+
+> (-|) f s g = \ x -> let  fx = f x 
+>                     in   g fx `demanding` s fx
+> (-||) f s g = \ x -> let  fx = f x 
+>                      in   g fx `sparking` s fx 
+
+------------------------------------------------------------------------------
+                       Marking a Strategy
+------------------------------------------------------------------------------
+--@node Marking a Strategy, Strategy Instances, Strategic Function Application, Evaluation Strategies
+--@section Marking a Strategy
+
+Marking a strategy.
+
+Actually, @markStrat@  sticks a label @n@  into the sparkname  field of the
+thread executing strategy @s@. Together with a runtime-system that supports
+propagation of sparknames to the children this means that this strategy and
+all its children have  the sparkname @n@ (if the  static sparkname field in
+the @parGlobal@ annotation contains the value 1). Note, that the @SN@ field
+of starting the marked strategy itself contains the sparkname of the parent
+thread. The END event contains @n@ as sparkname.
+
+--@cindex markStrat
+
+>#if defined(GRAN) && !(__HASKELL1__>=4)
+> markStrat :: Int -> Strategy a -> Strategy a 
+> markStrat n s x = unsafePerformPrimIO (
+>      _casm_ ``%r = set_sparkname(CurrentTSO, %0);'' n `thenPrimIO` \ z ->
+>      returnPrimIO (s x))
+>#endif
+
+-----------------------------------------------------------------------------
+                       Strategy Instances and Functions                     
+-----------------------------------------------------------------------------
+--@node Strategy Instances, Lolita-specific Strategies, Marking a Strategy, Evaluation Strategies
+--@section Strategy Instances
+-----------------------------------------------------------------------------
+                       Tuples
+-----------------------------------------------------------------------------
+--@menu
+--* Tuples::                   
+--* Numbers::                  
+--* Characters::               
+--* Booleans::                 
+--* Unit::                     
+--* Lists::                    
+--* Arrays::                   
+--@end menu
+
+--@node Tuples, Numbers, Strategy Instances, Strategy Instances
+--@subsection Tuples
+
+We currently support up to 9-tuples. If you need longer tuples you have to 
+add the instance explicitly to your program.
+
+> instance (NFData a, NFData b) => NFData (a,b) where
+>   rnf (x,y) = rnf x `seq` rnf y
+
+> instance (NFData a, NFData b, NFData c) => NFData (a,b,c) where
+>   rnf (x,y,z) = rnf x `seq` rnf y `seq` rnf z 
+
+> instance (NFData a, NFData b, NFData c, NFData d) => NFData (a,b,c,d) where
+>   rnf (x1,x2,x3,x4) = rnf x1 `seq` 
+>                      rnf x2 `seq` 
+>                      rnf x3 `seq` 
+>                      rnf x4 
+
+> -- code automatically inserted by `hwl-insert-NFData-n-tuple'
+> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5) => 
+>          NFData (a1, a2, a3, a4, a5) where
+>   rnf (x1, x2, x3, x4, x5) =
+>                   rnf x1 `seq`
+>                   rnf x2 `seq`
+>                   rnf x3 `seq`
+>                   rnf x4 `seq`
+>                   rnf x5
+
+> -- code automatically inserted by `hwl-insert-NFData-n-tuple'
+> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6) => 
+>          NFData (a1, a2, a3, a4, a5, a6) where
+>   rnf (x1, x2, x3, x4, x5, x6) =
+>                   rnf x1 `seq`
+>                   rnf x2 `seq`
+>                   rnf x3 `seq`
+>                   rnf x4 `seq`
+>                   rnf x5 `seq`
+>                   rnf x6
+
+> -- code automatically inserted by `hwl-insert-NFData-n-tuple'
+> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7) => 
+>          NFData (a1, a2, a3, a4, a5, a6, a7) where
+>   rnf (x1, x2, x3, x4, x5, x6, x7) =
+>                   rnf x1 `seq`
+>                   rnf x2 `seq`
+>                   rnf x3 `seq`
+>                   rnf x4 `seq`
+>                   rnf x5 `seq`
+>                   rnf x6 `seq`
+>                   rnf x7
+
+> -- code automatically inserted by `hwl-insert-NFData-n-tuple'
+> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8) => 
+>          NFData (a1, a2, a3, a4, a5, a6, a7, a8) where
+>   rnf (x1, x2, x3, x4, x5, x6, x7, x8) =
+>                   rnf x1 `seq`
+>                   rnf x2 `seq`
+>                   rnf x3 `seq`
+>                   rnf x4 `seq`
+>                   rnf x5 `seq`
+>                   rnf x6 `seq`
+>                   rnf x7 `seq`
+>                   rnf x8
+
+> -- code automatically inserted by `hwl-insert-NFData-n-tuple'
+> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9) => 
+>          NFData (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
+>   rnf (x1, x2, x3, x4, x5, x6, x7, x8, x9) =
+>                   rnf x1 `seq`
+>                   rnf x2 `seq`
+>                   rnf x3 `seq`
+>                   rnf x4 `seq`
+>                   rnf x5 `seq`
+>                   rnf x6 `seq`
+>                   rnf x7 `seq`
+>                   rnf x8 `seq`
+>                   rnf x9
+
+--@cindex seqPair
+
+> seqPair :: Strategy a -> Strategy b -> Strategy (a,b)
+> seqPair strata stratb (x,y) = strata x `seq` stratb y 
+
+--@cindex parPair
+
+> parPair :: Strategy a -> Strategy b -> Strategy (a,b)
+> parPair strata stratb (x,y) = strata x `par` stratb y `par` ()
+
+The reason for the  second `par` is so that the strategy terminates 
+quickly. This is important if the strategy is used as the 1st argument of a seq
+
+--@cindex seqTriple
+
+> seqTriple :: Strategy a -> Strategy b -> Strategy c -> Strategy (a,b,c)
+> seqTriple strata stratb stratc p@(x,y,z) = 
+>   strata x `seq` 
+>   stratb y `seq`
+>   stratc z 
+
+--@cindex parTriple
+
+> parTriple :: Strategy a -> Strategy b -> Strategy c -> Strategy (a,b,c)
+> parTriple strata stratb stratc (x,y,z) = 
+>   strata x `par` 
+>   stratb y `par` 
+>   stratc z `par`
+>   ()
+
+-----------------------------------------------------------------------------
+                       Numbers                                              
+-----------------------------------------------------------------------------
+--@node Numbers, Characters, Tuples, Strategy Instances
+--@subsection Numbers
+
+Weak head normal form and normal form are identical for integers, so the 
+default rnf is sufficient. 
+
+> instance NFData Int 
+> instance NFData Integer
+> instance NFData Float
+> instance NFData Double
+
+> instance NFDataIntegral Int
+> instance NFDataOrd Int
+
+Rational and complex numbers.
+
+>#if !(__HASKELL1__>=4)
+> instance (NFData a) => NFData (Ratio a) where
+>   rnf (x:%y) = rnf x `seq` 
+>                rnf y `seq`
+>                ()
+
+> instance (NFData a) => NFData (Complex a) where
+>   rnf (x:+y) = rnf x `seq` 
+>               rnf y `seq`
+>                ()
+>#endif
+
+-----------------------------------------------------------------------------
+                       Characters                                            
+-----------------------------------------------------------------------------
+--@node Characters, Booleans, Numbers, Strategy Instances
+--@subsection Characters
+
+> instance NFData Char
+
+-----------------------------------------------------------------------------
+                       Bools
+-----------------------------------------------------------------------------
+--@node Booleans, Unit, Characters, Strategy Instances
+--@subsection Booleans
+
+> instance NFData Bool
+
+-----------------------------------------------------------------------------
+                       Unit                                                 
+-----------------------------------------------------------------------------
+--@node Unit, Lists, Booleans, Strategy Instances
+--@subsection Unit
+
+> instance NFData ()
+
+-----------------------------------------------------------------------------
+                       Lists                                               
+----------------------------------------------------------------------------
+--@node Lists, Arrays, Unit, Strategy Instances
+--@subsection Lists
+
+> instance NFData a => NFData [a] where
+>   rnf [] = ()
+>   rnf (x:xs) = rnf x `seq` rnf xs
+
+--@menu
+--* Parallel Strategies for Lists::  
+--* Sequential Strategies for Lists::  
+--@end menu
+
+----------------------------------------------------------------------------
+                        Lists: Parallel Strategies
+----------------------------------------------------------------------------
+--@node Parallel Strategies for Lists, Sequential Strategies for Lists, Lists, Lists
+--@subsubsection Parallel Strategies for Lists
+
+Applies a strategy to every element of a list in parallel
+
+--@cindex parList
+
+> parList :: Strategy a -> Strategy [a]
+> parList strat []     = ()
+> parList strat (x:xs) = strat x `par` (parList strat xs)
+
+Applies a strategy to the first  n elements of a list  in parallel
+
+--@cindex parListN
+
+> parListN :: (Integral b) => b -> Strategy a -> Strategy [a]
+> parListN n strat []     = ()
+> parListN 0 strat xs     = ()
+> parListN n strat (x:xs) = strat x `par` (parListN (n-1) strat xs)
+
+Evaluates N elements of the spine of the argument list and applies
+`strat' to the Nth element (if there is one) in parallel with the
+result. e.g. parListNth 2 [e1, e2, e3] evaluates e2
+
+--@cindex parListNth
+
+> parListNth :: Int -> Strategy a -> Strategy [a]
+> parListNth n strat xs 
+>   | null rest = ()
+>   | otherwise = strat (head rest) `par` ()
+>   where
+>     rest = drop n xs
+
+parListChunk sequentially applies a strategy to chunks
+(sub-sequences) of a list in parallel. Useful to increase grain size
+
+--@cindex parListChunk
+
+> parListChunk :: Int -> Strategy a -> Strategy [a]
+> parListChunk n strat [] = ()
+> parListChunk n strat xs = seqListN n strat xs `par` 
+>                          parListChunk n strat (drop n xs)
+
+parMap applies a function to each element of the argument list in
+parallel.  The result of the function is evaluated using `strat'
+
+--@cindex parMap
+
+> parMap :: Strategy b -> (a -> b) -> [a] -> [b]
+> parMap strat f xs    = map f xs `using` parList strat
+
+parFlatMap uses parMap to apply a list-valued function to each
+element of the argument list in parallel.  The result of the function
+is evaluated using `strat'
+
+--@cindex parFlatMap
+
+> parFlatMap :: Strategy [b] -> (a -> [b]) -> [a] -> [b]
+> parFlatMap strat f xs = concat (parMap strat f xs)
+
+parZipWith zips together two lists with a function z in parallel
+
+--@cindex parZipWith
+
+> parZipWith :: Strategy c -> (a -> b -> c) -> [a] -> [b] -> [c]
+> parZipWith strat z as bs = 
+>   zipWith z as bs `using` parList strat
+
+----------------------------------------------------------------------------
+                        Lists: Sequential Strategies
+----------------------------------------------------------------------------
+--@node Sequential Strategies for Lists,  , Parallel Strategies for Lists, Lists
+--@subsubsection Sequential Strategies for Lists
+
+Sequentially applies a strategy to each element of a list
+
+--@cindex seqList
+
+> seqList :: Strategy a -> Strategy [a]
+> seqList strat []     = ()
+> seqList strat (x:xs) = strat x `seq` (seqList strat xs)
+
+Sequentially applies a strategy to the first  n elements of a list
+
+--@cindex seqListN
+
+> seqListN :: (Integral a) => a -> Strategy b -> Strategy [b]
+> seqListN n strat []     = ()
+> seqListN 0 strat xs     = ()
+> seqListN n strat (x:xs) = strat x `seq` (seqListN (n-1) strat xs)
+
+seqListNth applies a strategy to the Nth element of it's argument
+(if there is one) before returning the result. e.g. seqListNth 2 [e1,
+e2, e3] evaluates e2
+
+--@cindex seqListNth
+
+>#if (__HASKELL1__>=4)
+> seqListNth :: Int -> Strategy b -> Strategy [b]
+>#else
+> seqListNth :: (Integral a) => a -> Strategy b -> Strategy [b]
+>#endif
+> seqListNth n strat xs 
+>   | null rest = ()
+>   | otherwise = strat (head rest) 
+>   where
+>     rest = drop n xs
+
+Parallel n-buffer function added for the revised version of the strategies
+paper. @parBuffer@ supersedes the older @fringeList@. It has the same
+semantics.
+
+--@cindex parBuffer
+
+> parBuffer :: Int -> Strategy a -> [a] -> [a]
+> parBuffer n s xs = 
+>   return xs (start n xs)
+>   where
+>     return (x:xs) (y:ys) = (x:return xs ys) `sparking` s y
+>     return xs     []     = xs
+>
+>     start n []     = []
+>     start 0 ys     = ys
+>     start n (y:ys) = start (n-1) ys `sparking` s y
+
+fringeList implements a `rolling buffer' of length n, i.e.applies a
+strategy to the nth element of list when the head is demanded. More
+precisely:
+
+   semantics:         fringeList n s = id :: [b] -> [b]
+   dynamic behaviour: evalutates the nth element of the list when the
+                     head is demanded.
+   
+The idea is to provide a `rolling buffer' of length n.
+
+--@cindex fringeList
+
+<> fringeList :: (Integral a) => a -> Strategy b -> [b] -> [b]
+<> fringeList n strat [] = []
+<> fringeList n strat (r:rs) = 
+<>   seqListNth n strat rs `par`
+<>   r:fringeList n strat rs
+
+------------------------------------------------------------------------------
+                       Arrays
+------------------------------------------------------------------------------
+--@node Arrays,  , Lists, Strategy Instances
+--@subsection Arrays
+
+> instance (Ix a, NFData a, NFData b) => NFData (Array a b) where
+>   rnf x = rnf (bounds x) `seq` seqList rnf (elems x) `seq` ()
+
+Apply a strategy to all elements of an array in parallel. This can be done 
+either in sequentially or in parallel (same as with lists, really).
+
+> seqArr :: (Ix b) => Strategy a -> Strategy (Array b a)
+> seqArr s arr = seqList s (elems arr)
+
+> parArr :: (Ix b) => Strategy a -> Strategy (Array b a)
+> parArr s arr = parList s (elems arr)
+
+Associations maybe useful even withou mentioning Arrays.
+
+See: .../lib/prelude/TyArrays.hs:
+data  Assoc a b =  a := b  deriving ()
+
+>#if (__HASKELL1__<4)
+> instance (NFData a, NFData b) => NFData (Assoc a b) where
+>   rnf (x := y) = rnf x `seq` rnf y `seq` ()
+>#endif
+
+------------------------------------------------------------------------------
+                       Some strategies specific for Lolita     
+------------------------------------------------------------------------------
+--@node Lolita-specific Strategies, Index, Strategy Instances, Evaluation Strategies
+--@section Lolita-specific Strategies
+
+The following is useful in mergePenGroups
+
+--@cindex fstPairFstList
+
+> fstPairFstList :: (NFData a) => Strategy [(a,b)]
+> fstPairFstList = seqListN 1 (seqPair rwhnf r0)
+
+Some HACKs for Lolita. AFAIK force is just another name for our rnf and
+sforce is a shortcut (definition here is identical to the one in Force.lhs)
+
+> force :: (NFData a) => a -> a 
+> sforce :: (NFData a) => a -> b -> b
+
+Same as definition below
+
+<> force x = rnf x `seq` x
+
+> force = id $| rnf
+>#if (__HASKELL1__>=4)
+> sforce x y = force x `seq` y
+>#else
+> sforce x y = force x `seq_from_Parallel` y
+>#endif
+
+--@node Bowing-alg specific strategies
+--@section Bowing-alg specific strategies
+
+NB: this strategy currently needs the quicksort implementation from the hbc syslib 
+
+>#if defined(PAR_GRAN_LIST)
+> parGranList :: Strategy a -> (a -> Int) -> [a] -> Strategy [a]
+> parGranList s gran_estim l_in = \ l_out ->
+>   parListByIdx s l_out $
+>   sortedIdx gran_list (sortLe ( \ (i,_) (j,_) -> i>j) gran_list)
+>   where -- spark list elems of l in the order specified by  (i:idxs)
+>        parListByIdx s l [] = ()
+>        parListByIdx s l (i:idxs) = parListByIdx s l idxs `sparking` s (l!!i)
+>        -- get the index of y in the list
+>        idx y [] = error "idx: x not in l"
+>        idx y ((x,_):xs) | y==x      = 0
+>                        | otherwise = (idx y xs)+1
+>        -- the `schedule' for sparking: list of indices of sorted input list
+>        sortedIdx l idxs = [ idx x l | (x,_) <- idxs ]
+>        -- add granularity info to elems of the input list
+>        gran_list = map (\ l -> (gran_estim l, l)) l_in  
+>#endif
+
+--@node Index,  , Lolita-specific Strategies, Evaluation Strategies
+--@section Index
+
+--@index
+--* $|::  @cindex\s-+$|
+--* $||::  @cindex\s-+$||
+--* -|::  @cindex\s-+-|
+--* -||::  @cindex\s-+-||
+--* .|::  @cindex\s-+.|
+--* .||::  @cindex\s-+.||
+--* NFData::  @cindex\s-+NFData
+--* Strategy::  @cindex\s-+Strategy
+--* demanding::  @cindex\s-+demanding
+--* fringeList::  @cindex\s-+fringeList
+--* fstPairFstList::  @cindex\s-+fstPairFstList
+--* markStrat::  @cindex\s-+markStrat
+--* parBuffer::  @cindex\s-+parBuffer
+--* parFlatMap::  @cindex\s-+parFlatMap
+--* parList::  @cindex\s-+parList
+--* parListChunk::  @cindex\s-+parListChunk
+--* parListN::  @cindex\s-+parListN
+--* parListNth::  @cindex\s-+parListNth
+--* parMap::  @cindex\s-+parMap
+--* parPair::  @cindex\s-+parPair
+--* parTriple::  @cindex\s-+parTriple
+--* parZipWith::  @cindex\s-+parZipWith
+--* r0::  @cindex\s-+r0
+--* rnf::  @cindex\s-+rnf
+--* rwhnf::  @cindex\s-+rwhnf
+--* seqList::  @cindex\s-+seqList
+--* seqListN::  @cindex\s-+seqListN
+--* seqListNth::  @cindex\s-+seqListNth
+--* seqPair::  @cindex\s-+seqPair
+--* seqTriple::  @cindex\s-+seqTriple
+--* sparking::  @cindex\s-+sparking
+--* using::  @cindex\s-+using
+--@end index
diff --git a/libraries/base/Data/Array.hs b/libraries/base/Data/Array.hs
new file mode 100644 (file)
index 0000000..c13cc91
--- /dev/null
@@ -0,0 +1,145 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Array 
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- $Id: Array.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Basic non-strict arrays.
+--
+-----------------------------------------------------------------------------
+
+module  Data.Array 
+
+    ( 
+      module Data.Ix           -- export all of Ix 
+    , Array                    -- Array type is abstract
+
+    , array        -- :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
+    , listArray     -- :: (Ix a) => (a,a) -> [b] -> Array a b
+    , (!)           -- :: (Ix a) => Array a b -> a -> b
+    , bounds        -- :: (Ix a) => Array a b -> (a,a)
+    , indices       -- :: (Ix a) => Array a b -> [a]
+    , elems         -- :: (Ix a) => Array a b -> [b]
+    , assocs        -- :: (Ix a) => Array a b -> [(a,b)]
+    , accumArray    -- :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b
+    , (//)          -- :: (Ix a) => Array a b -> [(a,b)] -> Array a b
+    , accum         -- :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b
+    , ixmap         -- :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a b
+
+    -- Array instances:
+    --
+    --   Ix a => Functor (Array a)
+    --   (Ix a, Eq b)  => Eq   (Array a b)
+    --   (Ix a, Ord b) => Ord  (Array a b)
+    --   (Ix a, Show a, Show b) => Show (Array a b)
+    --   (Ix a, Read a, Read b) => Read (Array a b)
+    -- 
+
+    -- Implementation checked wrt. Haskell 98 lib report, 1/99.
+
+    ) where
+
+import Data.Dynamic
+
+#ifdef __GLASGOW_HASKELL__
+import Data.Ix
+import GHC.Arr         -- Most of the hard work is done here
+import GHC.Err         ( undefined )
+#endif
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
+
+#ifdef __HUGS__
+       ------------ HUGS (rest of file) --------------------
+import PrelPrim ( PrimArray
+               , runST
+               , primNewArray
+               , primWriteArray
+               , primReadArray
+               , primUnsafeFreezeArray
+               , primIndexArray
+               )
+import Ix
+import List( (\\) )
+
+infixl 9  !, //
+
+-- -----------------------------------------------------------------------------
+-- The Array type
+
+data Array ix elt = Array (ix,ix) (PrimArray elt)
+
+array :: Ix a => (a,a) -> [(a,b)] -> Array a b
+array ixs@(ix_start, ix_end) ivs = runST (do
+  { mut_arr <- primNewArray (rangeSize ixs) arrEleBottom
+  ; mapM_ (\ (i,v) -> primWriteArray mut_arr (index ixs i) v) ivs 
+  ; arr <- primUnsafeFreezeArray mut_arr
+  ; return (Array ixs arr)
+  }
+  )
+ where
+  arrEleBottom = error "(Array.!): undefined array element"
+
+listArray               :: Ix a => (a,a) -> [b] -> Array a b
+listArray b vs          =  array b (zipWith (\ a b -> (a,b)) (range b) vs)
+
+(!)                    :: Ix a => Array a b -> a -> b
+(Array bounds arr) ! i  = primIndexArray arr (index bounds i)
+
+bounds                  :: Ix a => Array a b -> (a,a)
+bounds (Array b _)      =  b
+
+indices           :: Ix a => Array a b -> [a]
+indices                  = range . bounds
+
+elems             :: Ix a => Array a b -> [b]
+elems a           =  [a!i | i <- indices a]
+
+assocs           :: Ix a => Array a b -> [(a,b)]
+assocs a          =  [(i, a!i) | i <- indices a]
+
+(//)              :: Ix a => Array a b -> [(a,b)] -> Array a b
+(//) a us           =  array (bounds a)
+                        ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]]
+                         ++ us)
+
+accum             :: Ix a => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b
+accum f           =  foldl (\a (i,v) -> a // [(i,f (a!i) v)])
+
+accumArray        :: Ix a => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b
+accumArray f z b  =  accum f (array b [(i,z) | i <- range b])
+
+ixmap            :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c
+ixmap b f a       =  array b [(i, a ! f i) | i <- range b]
+
+
+instance (Ix a) => Functor (Array a) where
+    fmap f a = array (bounds a) [(i, f(a!i)) | i <- indices a]
+
+instance (Ix a, Eq b) => Eq (Array a b) where
+    a == a'   =   assocs a == assocs a'
+
+instance (Ix a, Ord b) => Ord (Array a b) where
+    a <= a'   =   assocs a <= assocs a'
+
+
+instance  (Ix a, Show a, Show b) => Show (Array a b)  where
+    showsPrec p a = showParen (p > 9) (
+                   showString "array " .
+                   shows (bounds a) . showChar ' ' .
+                   shows (assocs a)                  )
+
+instance  (Ix a, Read a, Read b) => Read (Array a b)  where
+    readsPrec p = readParen (p > 9)
+            (\r -> [(array b as, u) | ("array",s) <- lex r,
+                                      (b,t)       <- reads s,
+                                      (as,u)      <- reads t   ])
+#endif /* __HUGS__ */
diff --git a/libraries/base/Data/Array/Base.hs b/libraries/base/Data/Array/Base.hs
new file mode 100644 (file)
index 0000000..7821876
--- /dev/null
@@ -0,0 +1,1163 @@
+{-# OPTIONS -monly-3-regs #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Array.Base
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Base.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Basis for IArray and MArray.  Not intended for external consumption;
+-- use IArray or MArray instead.
+--
+-----------------------------------------------------------------------------
+
+module Data.Array.Base where
+
+import Prelude
+
+import Data.Ix         ( Ix, range, index, rangeSize )
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Arr         ( STArray, unsafeIndex )
+import qualified GHC.Arr
+import GHC.ST          ( ST(..), runST )
+import GHC.Base
+import GHC.Word                ( Word(..) )
+import GHC.Ptr         ( Ptr(..), FunPtr(..) )
+import GHC.Float       ( Float(..), Double(..) )
+import GHC.Stable      ( StablePtr(..) )
+import GHC.Int         ( Int8(..),  Int16(..),  Int32(..),  Int64(..) )
+import GHC.Word                ( Word8(..), Word16(..), Word32(..), Word64(..) )
+#endif
+
+import Data.Dynamic
+#include "Dynamic.h"
+
+-----------------------------------------------------------------------------
+-- Class of immutable arrays
+
+class HasBounds a where
+    bounds :: Ix i => a i e -> (i,i)
+
+class HasBounds a => IArray a e where
+    unsafeArray      :: Ix i => (i,i) -> [(Int, e)] -> a i e
+    unsafeAt         :: Ix i => a i e -> Int -> e
+    unsafeReplace    :: Ix i => a i e -> [(Int, e)] -> a i e
+    unsafeAccum      :: Ix i => (e -> e' -> e) -> a i e -> [(Int, e')] -> a i e
+    unsafeAccumArray :: Ix i => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> a i e
+
+    unsafeReplace arr ies = runST (unsafeReplaceST arr ies >>= unsafeFreeze)
+    unsafeAccum f arr ies = runST (unsafeAccumST f arr ies >>= unsafeFreeze)
+    unsafeAccumArray f e lu ies = runST (unsafeAccumArrayST f e lu ies >>= unsafeFreeze)
+
+{-# INLINE unsafeReplaceST #-}
+unsafeReplaceST :: (IArray a e, Ix i) => a i e -> [(Int, e)] -> ST s (STArray s i e)
+unsafeReplaceST arr ies = do
+    marr <- thaw arr
+    sequence_ [unsafeWrite marr i e | (i, e) <- ies]
+    return marr
+
+{-# INLINE unsafeAccumST #-}
+unsafeAccumST :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(Int, e')] -> ST s (STArray s i e)
+unsafeAccumST f arr ies = do
+    marr <- thaw arr
+    sequence_ [do
+        old <- unsafeRead marr i
+        unsafeWrite marr i (f old new)
+        | (i, new) <- ies]
+    return marr
+
+{-# INLINE unsafeAccumArrayST #-}
+unsafeAccumArrayST :: Ix i => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (STArray s i e)
+unsafeAccumArrayST f e (l,u) ies = do
+    marr <- newArray (l,u) e
+    sequence_ [do
+        old <- unsafeRead marr i
+        unsafeWrite marr i (f old new)
+        | (i, new) <- ies]
+    return marr
+
+{-# INLINE array #-}
+array :: (IArray a e, Ix i) => (i,i) -> [(i, e)] -> a i e
+array (l,u) ies = unsafeArray (l,u) [(index (l,u) i, e) | (i, e) <- ies]
+
+-- Since unsafeFreeze is not guaranteed to be only a cast, we will
+-- use unsafeArray and zip instead of a specialized loop to implement
+-- listArray, unlike Array.listArray, even though it generates some
+-- unnecessary heap allocation. Will use the loop only when we have
+-- fast unsafeFreeze, namely for Array and UArray (well, they cover
+-- almost all cases).
+
+{-# INLINE listArray #-}
+listArray :: (IArray a e, Ix i) => (i,i) -> [e] -> a i e
+listArray (l,u) es = unsafeArray (l,u) (zip [0 .. rangeSize (l,u) - 1] es)
+
+{-# INLINE listArrayST #-}
+listArrayST :: Ix i => (i,i) -> [e] -> ST s (STArray s i e)
+listArrayST (l,u) es = do
+    marr <- newArray_ (l,u)
+    let n = rangeSize (l,u)
+    let fillFromList i xs | i == n    = return ()
+                          | otherwise = case xs of
+            []   -> return ()
+            y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys
+    fillFromList 0 es
+    return marr
+
+{-# RULES
+"listArray/Array" listArray =
+    \lu es -> runST (listArrayST lu es >>= GHC.Arr.unsafeFreezeSTArray)
+    #-}
+
+{-# INLINE listUArrayST #-}
+listUArrayST :: (MArray (STUArray s) e (ST s), Ix i)
+             => (i,i) -> [e] -> ST s (STUArray s i e)
+listUArrayST (l,u) es = do
+    marr <- newArray_ (l,u)
+    let n = rangeSize (l,u)
+    let fillFromList i xs | i == n    = return ()
+                          | otherwise = case xs of
+            []   -> return ()
+            y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys
+    fillFromList 0 es
+    return marr
+
+-- I don't know how to write a single rule for listUArrayST, because
+-- the type looks like constrained over 's', which runST doesn't
+-- like. In fact all MArray (STUArray s) instances are polymorphic
+-- wrt. 's', but runST can't know that.
+
+-- I would like to write a rule for listUArrayST (or listArray or
+-- whatever) applied to unpackCString#. Unfortunately unpackCString#
+-- calls seem to be floated out, then floated back into the middle
+-- of listUArrayST, so I was not able to do this.
+
+{-# RULES
+"listArray/UArray/Bool"      listArray = \lu (es :: [Bool])        ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Char"      listArray = \lu (es :: [Char])        ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Int"       listArray = \lu (es :: [Int])         ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Word"      listArray = \lu (es :: [Word])        ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Ptr"       listArray = \lu (es :: [Ptr a])       ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/FunPtr"    listArray = \lu (es :: [FunPtr a])    ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Float"     listArray = \lu (es :: [Float])       ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Double"    listArray = \lu (es :: [Double])      ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/StablePtr" listArray = \lu (es :: [StablePtr a]) ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Int8"      listArray = \lu (es :: [Int8])        ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Int16"     listArray = \lu (es :: [Int16])       ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Int32"     listArray = \lu (es :: [Int32])       ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Int64"     listArray = \lu (es :: [Int64])       ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Word8"     listArray = \lu (es :: [Word8])       ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Word16"    listArray = \lu (es :: [Word16])      ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Word32"    listArray = \lu (es :: [Word32])      ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Word64"    listArray = \lu (es :: [Word64])      ->
+    runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+    #-}
+
+{-# INLINE (!) #-}
+(!) :: (IArray a e, Ix i) => a i e -> i -> e
+arr ! i | (l,u) <- bounds arr = unsafeAt arr (index (l,u) i)
+
+{-# INLINE indices #-}
+indices :: (HasBounds a, Ix i) => a i e -> [i]
+indices arr | (l,u) <- bounds arr = range (l,u)
+
+{-# INLINE elems #-}
+elems :: (IArray a e, Ix i) => a i e -> [e]
+elems arr | (l,u) <- bounds arr =
+    [unsafeAt arr i | i <- [0 .. rangeSize (l,u) - 1]]
+
+{-# INLINE assocs #-}
+assocs :: (IArray a e, Ix i) => a i e -> [(i, e)]
+assocs arr | (l,u) <- bounds arr =
+    [(i, unsafeAt arr (unsafeIndex (l,u) i)) | i <- range (l,u)]
+
+{-# INLINE accumArray #-}
+accumArray :: (IArray a e, Ix i) => (e -> e' -> e) -> e -> (i,i) -> [(i, e')] -> a i e
+accumArray f init (l,u) ies =
+    unsafeAccumArray f init (l,u) [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE (//) #-}
+(//) :: (IArray a e, Ix i) => a i e -> [(i, e)] -> a i e
+arr // ies | (l,u) <- bounds arr =
+    unsafeReplace arr [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE accum #-}
+accum :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(i, e')] -> a i e
+accum f arr ies | (l,u) <- bounds arr =
+    unsafeAccum f arr [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE amap #-}
+amap :: (IArray a e', IArray a e, Ix i) => (e' -> e) -> a i e' -> a i e
+amap f arr | (l,u) <- bounds arr =
+    unsafeArray (l,u) [(i, f (unsafeAt arr i)) | i <- [0 .. rangeSize (l,u) - 1]]
+
+{-# INLINE ixmap #-}
+ixmap :: (IArray a e, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> a i e
+ixmap (l,u) f arr =
+    unsafeArray (l,u) [(unsafeIndex (l,u) i, arr ! f i) | i <- range (l,u)]
+
+-----------------------------------------------------------------------------
+-- Normal polymorphic arrays
+
+instance HasBounds GHC.Arr.Array where
+    {-# INLINE bounds #-}
+    bounds = GHC.Arr.bounds
+
+instance IArray GHC.Arr.Array e where
+    {-# INLINE unsafeArray #-}
+    unsafeArray      = GHC.Arr.unsafeArray
+    {-# INLINE unsafeAt #-}
+    unsafeAt         = GHC.Arr.unsafeAt
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace    = GHC.Arr.unsafeReplace
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum      = GHC.Arr.unsafeAccum
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray = GHC.Arr.unsafeAccumArray
+
+-----------------------------------------------------------------------------
+-- Flat unboxed arrays
+
+data UArray i e = UArray !i !i ByteArray#
+
+INSTANCE_TYPEABLE2(UArray,uArrayTc,"UArray")
+
+instance HasBounds UArray where
+    {-# INLINE bounds #-}
+    bounds (UArray l u _) = (l,u)
+
+{-# INLINE unsafeArrayUArray #-}
+unsafeArrayUArray :: (MArray (STUArray s) e (ST s), Ix i)
+                  => (i,i) -> [(Int, e)] -> ST s (UArray i e)
+unsafeArrayUArray (l,u) ies = do
+    marr <- newArray_ (l,u)
+    sequence_ [unsafeWrite marr i e | (i, e) <- ies]
+    unsafeFreezeSTUArray marr
+
+{-# INLINE unsafeFreezeSTUArray #-}
+unsafeFreezeSTUArray :: STUArray s i e -> ST s (UArray i e)
+unsafeFreezeSTUArray (STUArray l u marr#) = ST $ \s1# ->
+    case unsafeFreezeByteArray# marr# s1# of { (# s2#, arr# #) ->
+    (# s2#, UArray l u arr# #) }
+
+{-# INLINE unsafeReplaceUArray #-}
+unsafeReplaceUArray :: (MArray (STUArray s) e (ST s), Ix i)
+                    => UArray i e -> [(Int, e)] -> ST s (UArray i e)
+unsafeReplaceUArray arr ies = do
+    marr <- thawSTUArray arr
+    sequence_ [unsafeWrite marr i e | (i, e) <- ies]
+    unsafeFreezeSTUArray marr
+
+{-# INLINE unsafeAccumUArray #-}
+unsafeAccumUArray :: (MArray (STUArray s) e (ST s), Ix i)
+                  => (e -> e' -> e) -> UArray i e -> [(Int, e')] -> ST s (UArray i e)
+unsafeAccumUArray f arr ies = do
+    marr <- thawSTUArray arr
+    sequence_ [do
+        old <- unsafeRead marr i
+        unsafeWrite marr i (f old new)
+        | (i, new) <- ies]
+    unsafeFreezeSTUArray marr
+
+{-# INLINE unsafeAccumArrayUArray #-}
+unsafeAccumArrayUArray :: (MArray (STUArray s) e (ST s), Ix i)
+                       => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (UArray i e)
+unsafeAccumArrayUArray f init (l,u) ies = do
+    marr <- newArray (l,u) init
+    sequence_ [do
+        old <- unsafeRead marr i
+        unsafeWrite marr i (f old new)
+        | (i, new) <- ies]
+    unsafeFreezeSTUArray marr
+
+{-# INLINE eqUArray #-}
+eqUArray :: (IArray UArray e, Ix i, Eq e) => UArray i e -> UArray i e -> Bool
+eqUArray arr1@(UArray l1 u1 _) arr2@(UArray l2 u2 _) =
+    if rangeSize (l1,u1) == 0 then rangeSize (l2,u2) == 0 else
+    l1 == l2 && u1 == u2 &&
+    and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. rangeSize (l1,u1) - 1]]
+
+{-# INLINE cmpUArray #-}
+cmpUArray :: (IArray UArray e, Ix i, Ord e) => UArray i e -> UArray i e -> Ordering
+cmpUArray arr1 arr2 = compare (assocs arr1) (assocs arr2)
+
+{-# INLINE cmpIntUArray #-}
+cmpIntUArray :: (IArray UArray e, Ord e) => UArray Int e -> UArray Int e -> Ordering
+cmpIntUArray arr1@(UArray l1 u1 _) arr2@(UArray l2 u2 _) =
+    if rangeSize (l1,u1) == 0 then if rangeSize (l2,u2) == 0 then EQ else LT else
+    if rangeSize (l2,u2) == 0 then GT else
+    case compare l1 l2 of
+        EQ    -> foldr cmp (compare u1 u2) [0 .. rangeSize (l1, min u1 u2) - 1]
+        other -> other
+    where
+    cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of
+        EQ    -> rest
+        other -> other
+
+{-# RULES "cmpUArray/Int" cmpUArray = cmpIntUArray #-}
+
+showsUArray :: (IArray UArray e, Ix i, Show i, Show e)
+            => Int -> UArray i e -> ShowS
+showsUArray p a =
+    showParen (p > 9) $
+    showString "array " .
+    shows (bounds a) .
+    showChar ' ' .
+    shows (assocs a)
+
+-----------------------------------------------------------------------------
+-- Flat unboxed arrays: instances
+
+instance IArray UArray Bool where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) =
+        (indexWordArray# arr# (bOOL_INDEX i#) `and#` bOOL_BIT i#)
+        `neWord#` int2Word# 0#
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Char where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = C# (indexWideCharArray# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Int where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = I# (indexIntArray# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Word where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = W# (indexWordArray# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray (Ptr a) where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = Ptr (indexAddrArray# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray (FunPtr a) where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = FunPtr (indexAddrArray# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Float where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = F# (indexFloatArray# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Double where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = D# (indexDoubleArray# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray (StablePtr a) where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = StablePtr (indexStablePtrArray# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Int8 where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = I8# (indexInt8Array# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Int16 where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = I16# (indexInt16Array# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Int32 where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = I32# (indexInt32Array# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Int64 where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = I64# (indexInt64Array# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Word8 where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = W8# (indexWord8Array# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Word16 where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = W16# (indexWord16Array# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Word32 where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = W32# (indexWord32Array# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Word64 where
+    {-# INLINE unsafeArray #-}
+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+    {-# INLINE unsafeAt #-}
+    unsafeAt (UArray _ _ arr#) (I# i#) = W64# (indexWord64Array# arr# i#)
+    {-# INLINE unsafeReplace #-}
+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+    {-# INLINE unsafeAccum #-}
+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+    {-# INLINE unsafeAccumArray #-}
+    unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance Ix ix => Eq (UArray ix Bool) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Char) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Int) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Word) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix (Ptr a)) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix (FunPtr a)) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Float) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Double) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix (StablePtr a)) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Int8) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Int16) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Int32) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Int64) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Word8) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Word16) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Word32) where
+    (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Word64) where
+    (==) = eqUArray
+
+instance Ix ix => Ord (UArray ix Bool) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Char) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Int) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Word) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix (Ptr a)) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix (FunPtr a)) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Float) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Double) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Int8) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Int16) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Int32) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Int64) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Word8) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Word16) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Word32) where
+    compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Word64) where
+    compare = cmpUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Bool) where
+    showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Char) where
+    showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Int) where
+    showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Word) where
+    showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Float) where
+    showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Double) where
+    showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Int8) where
+    showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Int16) where
+    showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Int32) where
+    showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Int64) where
+    showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Word8) where
+    showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Word16) where
+    showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Word32) where
+    showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Word64) where
+    showsPrec = showsUArray
+
+-----------------------------------------------------------------------------
+-- Mutable arrays
+
+{-# NOINLINE arrEleBottom #-}
+arrEleBottom :: a
+arrEleBottom = error "MArray: undefined array element"
+
+class (HasBounds a, Monad m) => MArray a e m where
+    newArray    :: Ix i => (i,i) -> e -> m (a i e)
+    newArray_   :: Ix i => (i,i) -> m (a i e)
+    unsafeRead  :: Ix i => a i e -> Int -> m e
+    unsafeWrite :: Ix i => a i e -> Int -> e -> m ()
+
+    newArray (l,u) init = do
+        marr <- newArray_ (l,u)
+        sequence_ [unsafeWrite marr i init | i <- [0 .. rangeSize (l,u) - 1]]
+        return marr
+
+    newArray_ (l,u) = newArray (l,u) arrEleBottom
+
+    -- newArray takes an initialiser which all elements of
+    -- the newly created array are initialised to.  newArray_ takes
+    -- no initialiser, it is assumed that the array is initialised with
+    -- "undefined" values.
+
+    -- why not omit newArray_?  Because in the unboxed array case we would
+    -- like to omit the initialisation altogether if possible.  We can't do
+    -- this for boxed arrays, because the elements must all have valid values
+    -- at all times in case of garbage collection.
+
+    -- why not omit newArray?  Because in the boxed case, we can omit the
+    -- default initialisation with undefined values if we *do* know the
+    -- initial value and it is constant for all elements.
+
+{-# INLINE newListArray #-}
+newListArray :: (MArray a e m, Ix i) => (i,i) -> [e] -> m (a i e)
+newListArray (l,u) es = do
+    marr <- newArray_ (l,u)
+    let n = rangeSize (l,u)
+    let fillFromList i xs | i == n    = return ()
+                          | otherwise = case xs of
+            []   -> return ()
+            y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys
+    fillFromList 0 es
+    return marr
+
+{-# INLINE readArray #-}
+readArray :: (MArray a e m, Ix i) => a i e -> i -> m e
+readArray marr i | (l,u) <- bounds marr =
+    unsafeRead marr (index (l,u) i)
+
+{-# INLINE writeArray #-}
+writeArray :: (MArray a e m, Ix i) => a i e -> i -> e -> m ()
+writeArray marr i e | (l,u) <- bounds marr =
+    unsafeWrite marr (index (l,u) i) e
+
+{-# INLINE getElems #-}
+getElems :: (MArray a e m, Ix i) => a i e -> m [e]
+getElems marr | (l,u) <- bounds marr =
+    sequence [unsafeRead marr i | i <- [0 .. rangeSize (l,u) - 1]]
+
+{-# INLINE getAssocs #-}
+getAssocs :: (MArray a e m, Ix i) => a i e -> m [(i, e)]
+getAssocs marr | (l,u) <- bounds marr =
+    sequence [do e <- unsafeRead marr (index (l,u) i); return (i,e)
+              | i <- range (l,u)]
+
+{-# INLINE mapArray #-}
+mapArray :: (MArray a e' m, MArray a e m, Ix i) => (e' -> e) -> a i e' -> m (a i e)
+mapArray f marr | (l,u) <- bounds marr = do
+    marr' <- newArray_ (l,u)
+    sequence_ [do
+        e <- unsafeRead marr i
+        unsafeWrite marr' i (f e)
+        | i <- [0 .. rangeSize (l,u) - 1]]
+    return marr'
+
+{-# INLINE mapIndices #-}
+mapIndices :: (MArray a e m, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> m (a i e)
+mapIndices (l,u) f marr = do
+    marr' <- newArray_ (l,u)
+    sequence_ [do
+        e <- readArray marr (f i)
+        unsafeWrite marr' (unsafeIndex (l,u) i) e
+        | i <- range (l,u)]
+    return marr'
+
+-----------------------------------------------------------------------------
+-- Polymorphic non-strict mutable arrays (ST monad)
+
+instance HasBounds (STArray s) where
+    {-# INLINE bounds #-}
+    bounds = GHC.Arr.boundsSTArray
+
+instance MArray (STArray s) e (ST s) where
+    {-# INLINE newArray #-}
+    newArray    = GHC.Arr.newSTArray
+    {-# INLINE unsafeRead #-}
+    unsafeRead  = GHC.Arr.unsafeReadSTArray
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite = GHC.Arr.unsafeWriteSTArray
+
+-----------------------------------------------------------------------------
+-- Typeable instance for STArray
+
+sTArrayTc :: TyCon
+sTArrayTc = mkTyCon "STArray"
+
+instance (Typeable a, Typeable b, Typeable c) => Typeable (STArray a b c) where
+  typeOf a = mkAppTy sTArrayTc [typeOf ((undefined :: STArray a b c -> a) a),
+                               typeOf ((undefined :: STArray a b c -> b) a),
+                               typeOf ((undefined :: STArray a b c -> c) a)]
+
+-----------------------------------------------------------------------------
+-- Flat unboxed mutable arrays (ST monad)
+
+data STUArray s i a = STUArray !i !i (MutableByteArray# s)
+
+INSTANCE_TYPEABLE3(STUArray,stUArrayTc,"STUArray")
+
+instance HasBounds (STUArray s) where
+    {-# INLINE bounds #-}
+    bounds (STUArray l u _) = (l,u)
+
+instance MArray (STUArray s) Bool (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (bOOL_SCALE n#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readWordArray# marr# (bOOL_INDEX i#) s1# of { (# s2#, e# #) ->
+        (# s2#, (e# `and#` bOOL_BIT i#) `neWord#` int2Word# 0# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) e = ST $ \s1# ->
+        case bOOL_INDEX i#              of { j# ->
+        case readWordArray# marr# j# s1# of { (# s2#, old# #) ->
+        case if e then old# `or#` bOOL_BIT i#
+             else old# `and#` bOOL_NOT_BIT i# of { e# ->
+        case writeWordArray# marr# j# e# s2# of { s3# ->
+        (# s3#, () #) }}}}
+
+instance MArray (STUArray s) Char (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readWideCharArray# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, C# e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (C# e#) = ST $ \s1# ->
+        case writeWideCharArray# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) Int (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readIntArray# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, I# e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (I# e#) = ST $ \s1# ->
+        case writeIntArray# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) Word (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readWordArray# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, W# e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (W# e#) = ST $ \s1# ->
+        case writeWordArray# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) (Ptr a) (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readAddrArray# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, Ptr e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (Ptr e#) = ST $ \s1# ->
+        case writeAddrArray# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) (FunPtr a) (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readAddrArray# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, FunPtr e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (FunPtr e#) = ST $ \s1# ->
+        case writeAddrArray# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) Float (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (fLOAT_SCALE n#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readFloatArray# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, F# e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (F# e#) = ST $ \s1# ->
+        case writeFloatArray# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) Double (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (dOUBLE_SCALE n#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readDoubleArray# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, D# e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (D# e#) = ST $ \s1# ->
+        case writeDoubleArray# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) (StablePtr a) (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readStablePtrArray# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2# , StablePtr e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (StablePtr e#) = ST $ \s1# ->
+        case writeStablePtrArray# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) Int8 (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# n# s1#       of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readInt8Array# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, I8# e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (I8# e#) = ST $ \s1# ->
+        case writeInt8Array# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) Int16 (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (n# *# 2#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readInt16Array# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, I16# e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (I16# e#) = ST $ \s1# ->
+        case writeInt16Array# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) Int32 (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readInt32Array# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, I32# e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (I32# e#) = ST $ \s1# ->
+        case writeInt32Array# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) Int64 (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (n# *# 8#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readInt64Array# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, I64# e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (I64# e#) = ST $ \s1# ->
+        case writeInt64Array# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) Word8 (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# n# s1#       of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readWord8Array# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, W8# e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (W8# e#) = ST $ \s1# ->
+        case writeWord8Array# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) Word16 (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (n# *# 2#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readWord16Array# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, W16# e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (W16# e#) = ST $ \s1# ->
+        case writeWord16Array# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) Word32 (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readWord32Array# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, W32# e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (W32# e#) = ST $ \s1# ->
+        case writeWord32Array# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+instance MArray (STUArray s) Word64 (ST s) where
+    {-# INLINE newArray_ #-}
+    newArray_ (l,u) = ST $ \s1# ->
+        case rangeSize (l,u)            of { I# n# ->
+        case newByteArray# (n# *# 8#) s1# of { (# s2#, marr# #) ->
+        (# s2#, STUArray l u marr# #) }}
+    {-# INLINE unsafeRead #-}
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+        case readWord64Array# marr# i# s1# of { (# s2#, e# #) ->
+        (# s2#, W64# e# #) }
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (STUArray _ _ marr#) (I# i#) (W64# e#) = ST $ \s1# ->
+        case writeWord64Array# marr# i# e# s1# of { s2# ->
+        (# s2#, () #) }
+
+-----------------------------------------------------------------------------
+-- Translation between elements and bytes
+
+#include "config.h"
+
+bOOL_SCALE, wORD_SCALE, dOUBLE_SCALE, fLOAT_SCALE :: Int# -> Int#
+bOOL_SCALE   n# = bOOL_INDEX (n# +# last#) where I# last# = SIZEOF_VOID_P - 1
+wORD_SCALE   n# = scale# *# n# where I# scale# = SIZEOF_VOID_P
+dOUBLE_SCALE n# = scale# *# n# where I# scale# = SIZEOF_DOUBLE
+fLOAT_SCALE  n# = scale# *# n# where I# scale# = SIZEOF_FLOAT
+
+bOOL_INDEX :: Int# -> Int#
+#if SIZEOF_VOID_P == 4
+bOOL_INDEX i# = i# `iShiftRA#` 5#
+#else
+bOOL_INDEX i# = i# `iShiftRA#` 6#
+#endif
+
+bOOL_BIT, bOOL_NOT_BIT :: Int# -> Word#
+bOOL_BIT     n# = int2Word# 1# `shiftL#` (word2Int# (int2Word# n# `and#` mask#))
+    where W# mask# = SIZEOF_VOID_P * 8 - 1
+bOOL_NOT_BIT n# = bOOL_BIT n# `xor#` mb# where W# mb# = maxBound
+
+-----------------------------------------------------------------------------
+-- Freezing
+
+freeze :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e)
+freeze marr | (l,u) <- bounds marr = do
+    ies <- sequence [do e <- unsafeRead marr i; return (i,e)
+                     | i <- [0 .. rangeSize (l,u) - 1]]
+    return (unsafeArray (l,u) ies)
+
+freezeSTUArray :: Ix i => STUArray s i e -> ST s (UArray i e)
+freezeSTUArray (STUArray l u marr#) = ST $ \s1# ->
+    case sizeofMutableByteArray# marr#  of { n# ->
+    case newByteArray# n# s1#           of { (# s2#, marr'# #) ->
+    case unsafeCoerce# memcpy marr'# marr# n# s2# of { (# s3#, () #) ->
+    case unsafeFreezeByteArray# marr'# s3# of { (# s4#, arr# #) ->
+    (# s4#, UArray l u arr# #) }}}}
+
+{-# RULES
+"freeze/STArray"  freeze = GHC.Arr.freezeSTArray
+"freeze/STUArray" freeze = freezeSTUArray
+    #-}
+
+-- In-place conversion of mutable arrays to immutable ones places
+-- a proof obligation on the user: no other parts of your code can
+-- have a reference to the array at the point where you unsafely
+-- freeze it (and, subsequently mutate it, I suspect).
+
+{-# INLINE unsafeFreeze #-}
+unsafeFreeze :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e)
+unsafeFreeze = freeze
+
+{-# RULES
+"unsafeFreeze/STArray"  unsafeFreeze = GHC.Arr.unsafeFreezeSTArray
+"unsafeFreeze/STUArray" unsafeFreeze = unsafeFreezeSTUArray
+    #-}
+
+-----------------------------------------------------------------------------
+-- Thawing
+
+thaw :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e)
+thaw arr | (l,u) <- bounds arr = do
+    marr <- newArray_ (l,u)
+    sequence_ [unsafeWrite marr i (unsafeAt arr i)
+               | i <- [0 .. rangeSize (l,u) - 1]]
+    return marr
+
+thawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e)
+thawSTUArray (UArray l u arr#) = ST $ \s1# ->
+    case sizeofByteArray# arr#          of { n# ->
+    case newByteArray# n# s1#           of { (# s2#, marr# #) ->
+    case unsafeCoerce# memcpy marr# arr# n# s2# of { (# s3#, () #) ->
+    (# s3#, STUArray l u marr# #) }}}
+
+foreign import "memcpy" unsafe
+    memcpy :: MutableByteArray# RealWorld -> ByteArray# -> Int# -> IO ()
+
+{-# RULES
+"thaw/STArray"  thaw = GHC.Arr.thawSTArray
+"thaw/STUArray" thaw = thawSTUArray
+    #-}
+
+-- In-place conversion of immutable arrays to mutable ones places
+-- a proof obligation on the user: no other parts of your code can
+-- have a reference to the array at the point where you unsafely
+-- thaw it (and, subsequently mutate it, I suspect).
+
+{-# INLINE unsafeThaw #-}
+unsafeThaw :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e)
+unsafeThaw = thaw
+
+{-# INLINE unsafeThawSTUArray #-}
+unsafeThawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e)
+unsafeThawSTUArray (UArray l u marr#) =
+    return (STUArray l u (unsafeCoerce# marr#))
+
+{-# RULES
+"unsafeThaw/STArray"    unsafeThaw = GHC.Arr.unsafeThawSTArray
+"unsafeThaw/STUArray"   unsafeThaw = unsafeThawSTUArray
+    #-}
diff --git a/libraries/base/Data/Array/IArray.hs b/libraries/base/Data/Array/IArray.hs
new file mode 100644 (file)
index 0000000..b97daee
--- /dev/null
@@ -0,0 +1,42 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Array.IArray
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: IArray.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Overloaded immutable array class.
+--
+-----------------------------------------------------------------------------
+
+module Data.Array.IArray ( 
+    module Data.Ix,
+
+    -- Class of immutable array types
+    IArray,     -- :: (* -> * -> *) -> * -> class
+    -- Class of array types with immutable bounds
+    HasBounds,  -- :: (* -> * -> *) -> class
+
+    array,      -- :: (IArray a e, Ix i) => (i,i) -> [(i, e)] -> a i e
+    listArray,  -- :: (IArray a e, Ix i) => (i,i) -> [e] -> a i e
+    (!),        -- :: (IArray a e, Ix i) => a i e -> i -> e
+    bounds,     -- :: (HasBounds a, Ix i) => a i e -> (i,i)
+    indices,    -- :: (HasBounds a, Ix i) => a i e -> [i]
+    elems,      -- :: (IArray a e, Ix i) => a i e -> [e]
+    assocs,     -- :: (IArray a e, Ix i) => a i e -> [(i, e)]
+    accumArray, -- :: (IArray a e, Ix i) => (e -> e' -> e) -> e -> (i,i) -> [(i, e')] -> a i e
+    (//),       -- :: (IArray a e, Ix i) => a i e -> [(i, e)] -> a i e
+    accum,      -- :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(i, e')] -> a i e
+    amap,       -- :: (IArray a e', IArray a e, Ix i) => (e' -> e) -> a i e' -> a i e
+    ixmap)      -- :: (IArray a e, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> a i e
+    where
+
+import Prelude
+
+import Data.Ix
+import Data.Array.Base
diff --git a/libraries/base/Data/Array/IO.hs b/libraries/base/Data/Array/IO.hs
new file mode 100644 (file)
index 0000000..9e7892e
--- /dev/null
@@ -0,0 +1,365 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Array.IO
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: IO.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Mutable boxed/unboxed arrays in the IO monad.
+--
+-----------------------------------------------------------------------------
+
+module Data.Array.IO (
+   module Data.Array.MArray,
+   IOArray,            -- instance of: Eq, Typeable
+   IOUArray,           -- instance of: Eq, Typeable
+   castIOUArray,       -- :: IOUArray i a -> IO (IOUArray i b)
+ ) where
+
+import Prelude
+
+import Data.Array              ( Array )
+import Data.Array.MArray
+import Data.Int
+import Data.Word
+import Data.Dynamic
+
+import Foreign.Ptr             ( Ptr, FunPtr )
+import Foreign.StablePtr       ( StablePtr )
+
+#ifdef __GLASGOW_HASKELL__
+-- GHC only to the end of file
+
+import Data.Array.Base
+import GHC.Arr         ( STArray, freezeSTArray, unsafeFreezeSTArray,
+                          thawSTArray, unsafeThawSTArray )
+
+import GHC.ST          ( ST(..) )
+import GHC.IOBase      ( stToIO )
+
+import GHC.Base
+
+-----------------------------------------------------------------------------
+-- Polymorphic non-strict mutable arrays (IO monad)
+
+newtype IOArray i e = IOArray (STArray RealWorld i e) deriving Eq
+
+iOArrayTc :: TyCon
+iOArrayTc = mkTyCon "IOArray"
+
+instance (Typeable a, Typeable b) => Typeable (IOArray a b) where
+  typeOf a = mkAppTy iOArrayTc [typeOf ((undefined :: IOArray a b -> a) a),
+                               typeOf ((undefined :: IOArray a b -> b) a)]
+
+instance HasBounds IOArray where
+    {-# INLINE bounds #-}
+    bounds (IOArray marr) = bounds marr
+
+instance MArray IOArray e IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
+
+-----------------------------------------------------------------------------
+-- Flat unboxed mutable arrays (IO monad)
+
+newtype IOUArray i e = IOUArray (STUArray RealWorld i e) deriving Eq
+
+iOUArrayTc :: TyCon
+iOUArrayTc = mkTyCon "IOUArray"
+
+instance (Typeable a, Typeable b) => Typeable (IOUArray a b) where
+  typeOf a = mkAppTy iOUArrayTc [typeOf ((undefined :: IOUArray a b -> a) a),
+                                typeOf ((undefined :: IOUArray a b -> b) a)]
+
+instance HasBounds IOUArray where
+    {-# INLINE bounds #-}
+    bounds (IOUArray marr) = bounds marr
+
+instance MArray IOUArray Bool IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Char IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Int IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Word IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray (Ptr a) IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray (FunPtr a) IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Float IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Double IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray (StablePtr a) IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Int8 IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Int16 IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Int32 IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Int64 IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Word8 IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Word16 IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Word32 IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Word64 IO where
+    {-# INLINE newArray #-}
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOUArray marr)
+    {-# INLINE newArray_ #-}
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOUArray marr)
+    {-# INLINE unsafeRead #-}
+    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+    {-# INLINE unsafeWrite #-}
+    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+-----------------------------------------------------------------------------
+-- Freezing
+
+freezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
+freezeIOArray (IOArray marr) = stToIO (freezeSTArray marr)
+
+freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
+freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr)
+
+{-# RULES
+"freeze/IOArray"  freeze = freezeIOArray
+"freeze/IOUArray" freeze = freezeIOUArray
+    #-}
+
+{-# INLINE unsafeFreezeIOArray #-}
+unsafeFreezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
+unsafeFreezeIOArray (IOArray marr) = stToIO (unsafeFreezeSTArray marr)
+
+{-# INLINE unsafeFreezeIOUArray #-}
+unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
+unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr)
+
+{-# RULES
+"unsafeFreeze/IOArray"  unsafeFreeze = unsafeFreezeIOArray
+"unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray
+    #-}
+
+-----------------------------------------------------------------------------
+-- Thawing
+
+thawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
+thawIOArray arr = stToIO $ do
+    marr <- thawSTArray arr
+    return (IOArray marr)
+
+thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
+thawIOUArray arr = stToIO $ do
+    marr <- thawSTUArray arr
+    return (IOUArray marr)
+
+{-# RULES
+"thaw/IOArray"  thaw = thawIOArray
+"thaw/IOUArray" thaw = thawIOUArray
+    #-}
+
+{-# INLINE unsafeThawIOArray #-}
+unsafeThawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
+unsafeThawIOArray arr = stToIO $ do
+    marr <- unsafeThawSTArray arr
+    return (IOArray marr)
+
+{-# INLINE unsafeThawIOUArray #-}
+unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
+unsafeThawIOUArray arr = stToIO $ do
+    marr <- unsafeThawSTUArray arr
+    return (IOUArray marr)
+
+{-# RULES
+"unsafeThaw/IOArray"  unsafeThaw = unsafeThawIOArray
+"unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray
+    #-}
+
+castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b)
+castSTUArray (STUArray l u marr#) = return (STUArray l u marr#)
+
+castIOUArray :: IOUArray ix a -> IO (IOUArray ix b)
+castIOUArray (IOUArray marr) = stToIO $ do
+    marr' <- castSTUArray marr
+    return (IOUArray marr')
+
+#endif /* __GLASGOW_HASKELL__ */
diff --git a/libraries/base/Data/Array/MArray.hs b/libraries/base/Data/Array/MArray.hs
new file mode 100644 (file)
index 0000000..c341dab
--- /dev/null
@@ -0,0 +1,47 @@
+{-# OPTIONS -monly-3-regs #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Array.MArray
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: MArray.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Class of mutable arrays, and operations on them.
+--
+-----------------------------------------------------------------------------
+
+module Data.Array.MArray ( 
+    module Data.Ix,
+
+    -- Class of mutable array types
+    MArray,       -- :: (* -> * -> *) -> * -> (* -> *) -> class
+    -- Class of array types with immutable bounds
+    HasBounds,    -- :: (* -> * -> *) -> class
+
+    newArray,     -- :: (MArray a e m, Ix i) => (i,i) -> e -> m (a i e)
+    newArray_,    -- :: (MArray a e m, Ix i) => (i,i) -> m (a i e)
+    newListArray, -- :: (MArray a e m, Ix i) => (i,i) -> [e] -> m (a i e)
+    readArray,    -- :: (MArray a e m, Ix i) => a i e -> i -> m e
+    writeArray,   -- :: (MArray a e m, Ix i) => a i e -> i -> e -> m ()
+    bounds,       -- :: (HasBounds a, Ix i) => a i e -> (i,i)
+    indices,      -- :: (HasBounds a, Ix i) => a i e -> [i]
+    getElems,     -- :: (MArray a e m, Ix i) => a i e -> m [e]
+    getAssocs,    -- :: (MArray a e m, Ix i) => a i e -> m [(i, e)]
+    mapArray,     -- :: (MArray a e' m, MArray a e m, Ix i) => (e' -> e) -> a i e' -> m (a i e)
+    mapIndices,   -- :: (MArray a e m, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> m (a i e)
+
+    freeze,       -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e)
+    unsafeFreeze, -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e)
+    thaw,         -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e)
+    unsafeThaw,   -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e)
+  ) where
+
+import Prelude
+
+import Data.Ix
+import Data.Array.Base
diff --git a/libraries/base/Data/Array/ST.hs b/libraries/base/Data/Array/ST.hs
new file mode 100644 (file)
index 0000000..143f792
--- /dev/null
@@ -0,0 +1,35 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Array.ST
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: ST.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Mutable boxed/unboxed arrays in the ST monad.
+--
+-----------------------------------------------------------------------------
+
+module Data.Array.ST (
+   module Data.Array.MArray,
+   STArray,            -- instance of: Eq, MArray
+   STUArray,           -- instance of: Eq, MArray
+   castSTUArray,       -- :: STUArray s i a -> ST s (STUArray s i b)
+ ) where
+
+import Prelude
+
+import Data.Array.MArray
+import Data.Array.Base
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Arr
+import GHC.ST
+
+castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b)
+castSTUArray (STUArray l u marr#) = return (STUArray l u marr#)
+#endif
diff --git a/libraries/base/Data/Array/Unboxed.hs b/libraries/base/Data/Array/Unboxed.hs
new file mode 100644 (file)
index 0000000..b4a0ecf
--- /dev/null
@@ -0,0 +1,25 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Array.Unboxed
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Unboxed.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Unboxed immutable array type.
+--
+-----------------------------------------------------------------------------
+
+module Data.Array.Unboxed (
+   module Data.Array.IArray,
+   UArray,
+ ) where
+
+import Prelude
+
+import Data.Array.IArray
+import Data.Array.Base
diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs
new file mode 100644 (file)
index 0000000..8a37e82
--- /dev/null
@@ -0,0 +1,143 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Bits
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Bits.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Bitwise operations.
+--
+-----------------------------------------------------------------------------
+
+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,      -- :: Bits a => a -> Int -> a
+  rotateL, rotateR,    -- :: Bits a => a -> Int -> a
+  -- 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.
+
+#ifdef __GLASGOW_HASKELL__
+#include "MachDeps.h"
+import GHC.Num
+import GHC.Real
+import GHC.Base
+#endif
+
+--ADR: The fixity for .|. conflicts with that for .|. in Fran.
+--     Removing all fixities is a fairly safe fix; fixing the "one fixity
+--     per symbol per program" limitation in Hugs would take a lot longer.
+#ifndef __HUGS__
+infixl 8 `shift`, `rotate`
+infixl 7 .&.
+infixl 6 `xor`
+infixl 5 .|.
+#endif
+
+class Num a => Bits a where
+    (.&.), (.|.), 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
+
+    bit i               = 1 `shift` i
+    x `setBit` i        = x .|. bit i
+    x `clearBit` i      = x .&. complement (bit i)
+    x `complementBit` i = x `xor` bit i
+    x `testBit` i       = (x .&. bit i) /= 0
+
+shiftL, shiftR   :: Bits a => a -> Int -> a
+rotateL, rotateR :: Bits a => a -> Int -> a
+x `shiftL`  i = x `shift`  i
+x `shiftR`  i = x `shift`  (-i)
+x `rotateL` i = x `rotate` i
+x `rotateR` i = x `rotate` (-i)
+
+#ifdef __GLASGOW_HASKELL__
+instance Bits Int where
+    (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#) `shift` (I# i#)
+        | i# >=# 0#            = I# (x# `iShiftL#` i#)
+        | otherwise            = I# (x# `iShiftRA#` negateInt# i#)
+    (I# x#) `rotate` (I# i#) =
+#if WORD_SIZE_IN_BYTES == 4
+        I# (word2Int# ((x'# `shiftL#` i'#) `or#`
+                       (x'# `shiftRL#` (32# -# i'#))))
+        where
+        x'# = int2Word# x#
+        i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)
+#else
+        I# (word2Int# ((x'# `shiftL#` i'#) `or#`
+                       (x'# `shiftRL#` (64# -# i'#))))
+        where
+        x'# = int2Word# x#
+        i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)
+#endif
+    bitSize  _                 = WORD_SIZE_IN_BYTES * 8
+    isSigned _                 = True
+
+instance Bits Integer where
+   (S# x) .&. (S# y) = S# (word2Int# (int2Word# x `and#` int2Word# y))
+   x@(S# _) .&. y = toBig x .&. y
+   x .&. y@(S# _) = x .&. toBig y
+   (J# s1 d1) .&. (J# s2 d2) = 
+       case andInteger# s1 d1 s2 d2 of
+         (# s, d #) -> J# s d
+   
+   (S# x) .|. (S# y) = S# (word2Int# (int2Word# x `or#` int2Word# y))
+   x@(S# _) .|. y = toBig x .|. y
+   x .|. y@(S# _) = x .|. toBig y
+   (J# s1 d1) .|. (J# s2 d2) = 
+       case orInteger# s1 d1 s2 d2 of
+         (# s, d #) -> J# s d
+   
+   (S# x) `xor` (S# y) = S# (word2Int# (int2Word# x `xor#` int2Word# y))
+   x@(S# _) `xor` y = toBig x `xor` y
+   x `xor` y@(S# _) = x `xor` toBig y
+   (J# s1 d1) `xor` (J# s2 d2) =
+       case xorInteger# s1 d1 s2 d2 of
+         (# s, d #) -> J# s d
+   
+   complement (S# x) = S# (word2Int# (int2Word# x `xor#` int2Word# (0# -# 1#)))
+   complement (J# s d) = case complementInteger# s d of (# s, d #) -> J# s d
+
+   shift x i | i >= 0    = x * 2^i
+            | otherwise = x `div` 2^(-i)
+
+   rotate x i = shift x i   -- since an Integer never wraps around
+
+   bitSize _  = error "Bits.bitSize(Integer)"
+   isSigned _ = True
+#endif
diff --git a/libraries/base/Data/Bool.hs b/libraries/base/Data/Bool.hs
new file mode 100644 (file)
index 0000000..33804d2
--- /dev/null
@@ -0,0 +1,28 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Bool
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Bool.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Bool type and related functions.
+--
+-----------------------------------------------------------------------------
+
+module Data.Bool (
+   Bool(..),
+   (&&),       -- :: Bool -> Bool -> Bool
+   (||),       -- :: Bool -> Bool -> Bool
+   not,                -- :: Bool -> Bool
+   otherwise,  -- :: Bool
+  ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+#endif
diff --git a/libraries/base/Data/Char.hs b/libraries/base/Data/Char.hs
new file mode 100644 (file)
index 0000000..e0c9566
--- /dev/null
@@ -0,0 +1,51 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Char
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- $Id: Char.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Char type and associated operations.
+--
+-----------------------------------------------------------------------------
+
+module Data.Char 
+    (
+      Char
+
+    , isAscii, isLatin1, isControl
+    , isPrint, isSpace,  isUpper
+    , isLower, isAlpha,  isDigit
+    , isOctDigit, isHexDigit, isAlphaNum  -- :: Char -> Bool
+
+    , toUpper, toLower  -- :: Char -> Char
+
+    , digitToInt        -- :: Char -> Int
+    , intToDigit        -- :: Int  -> Char
+
+    , ord               -- :: Char -> Int
+    , chr               -- :: Int  -> Char
+    , readLitChar       -- :: ReadS Char 
+    , showLitChar       -- :: Char -> ShowS
+    , lexLitChar       -- :: ReadS String
+
+    , String
+
+     -- Implementation checked wrt. Haskell 98 lib report, 1/99.
+    ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+import GHC.Show
+import GHC.Read (readLitChar, lexLitChar, digitToInt)
+#endif
+
+#ifdef __HUGS__
+isLatin1 c = True
+#endif
diff --git a/libraries/base/Data/Complex.hs b/libraries/base/Data/Complex.hs
new file mode 100644 (file)
index 0000000..e132f21
--- /dev/null
@@ -0,0 +1,153 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Complex
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- $Id: Complex.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Complex numbers.
+--
+-----------------------------------------------------------------------------
+
+module Data.Complex
+       ( Complex((:+))
+       
+       , realPart      -- :: (RealFloat a) => Complex a -> a
+       , imagPart      -- :: (RealFloat a) => Complex a -> a
+       , conjugate     -- :: (RealFloat a) => Complex a -> Complex a
+       , 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
+       
+       -- 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)
+       -- 
+        -- Implementation checked wrt. Haskell 98 lib report, 1/99.
+
+        )  where
+
+import Prelude
+
+import Data.Dynamic
+
+infix  6  :+
+
+-- -----------------------------------------------------------------------------
+-- The Complex type
+
+data  (RealFloat a)     => Complex a = !a :+ !a  deriving (Eq, Read, Show)
+
+
+-- -----------------------------------------------------------------------------
+-- Functions over Complex
+
+realPart, imagPart :: (RealFloat a) => Complex a -> a
+realPart (x :+ _) =  x
+imagPart (_ :+ y) =  y
+
+conjugate       :: (RealFloat a) => Complex a -> Complex a
+conjugate (x:+y) =  x :+ (-y)
+
+mkPolar                 :: (RealFloat a) => a -> a -> Complex a
+mkPolar r theta         =  r * cos theta :+ r * sin theta
+
+cis             :: (RealFloat a) => a -> Complex a
+cis theta       =  cos theta :+ sin theta
+
+polar           :: (RealFloat a) => Complex a -> (a,a)
+polar z                 =  (magnitude z, phase z)
+
+magnitude :: (RealFloat a) => Complex a -> a
+magnitude (x:+y) =  scaleFloat k
+                    (sqrt ((scaleFloat mk x)^(2::Int) + (scaleFloat mk y)^(2::Int)))
+                   where k  = max (exponent x) (exponent y)
+                         mk = - k
+
+phase :: (RealFloat a) => Complex a -> a
+phase (0 :+ 0)   = 0           -- SLPJ July 97 from John Peterson
+phase (x:+y)    = atan2 y x
+
+
+-- -----------------------------------------------------------------------------
+-- Instances of Complex
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE1(Complex,complexTc,"Complex")
+
+instance  (RealFloat a) => Num (Complex a)  where
+    {-# SPECIALISE instance Num (Complex Float) #-}
+    {-# SPECIALISE instance Num (Complex Double) #-}
+    (x:+y) + (x':+y')  =  (x+x') :+ (y+y')
+    (x:+y) - (x':+y')  =  (x-x') :+ (y-y')
+    (x:+y) * (x':+y')  =  (x*x'-y*y') :+ (x*y'+y*x')
+    negate (x:+y)      =  negate x :+ negate y
+    abs z              =  magnitude z :+ 0
+    signum 0           =  0
+    signum z@(x:+y)    =  x/r :+ y/r  where r = magnitude z
+    fromInteger n      =  fromInteger n :+ 0
+
+instance  (RealFloat a) => Fractional (Complex a)  where
+    {-# SPECIALISE instance Fractional (Complex Float) #-}
+    {-# SPECIALISE instance Fractional (Complex Double) #-}
+    (x:+y) / (x':+y')  =  (x*x''+y*y'') / d :+ (y*x''-x*y'') / d
+                          where x'' = scaleFloat k x'
+                                y'' = scaleFloat k y'
+                                k   = - max (exponent x') (exponent y')
+                                d   = x'*x'' + y'*y''
+
+    fromRational a     =  fromRational a :+ 0
+
+instance  (RealFloat a) => Floating (Complex a)        where
+    {-# SPECIALISE instance Floating (Complex Float) #-}
+    {-# SPECIALISE instance Floating (Complex Double) #-}
+    pi             =  pi :+ 0
+    exp (x:+y)     =  expx * cos y :+ expx * sin y
+                      where expx = exp x
+    log z          =  log (magnitude z) :+ phase z
+
+    sqrt 0         =  0
+    sqrt z@(x:+y)  =  u :+ (if y < 0 then -v else v)
+                      where (u,v) = if x < 0 then (v',u') else (u',v')
+                            v'    = abs y / (u'*2)
+                            u'    = sqrt ((magnitude z + abs x) / 2)
+
+    sin (x:+y)     =  sin x * cosh y :+ cos x * sinh y
+    cos (x:+y)     =  cos x * cosh y :+ (- sin x * sinh y)
+    tan (x:+y)     =  (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))
+                      where sinx  = sin x
+                            cosx  = cos x
+                            sinhy = sinh y
+                            coshy = cosh y
+
+    sinh (x:+y)    =  cos y * sinh x :+ sin  y * cosh x
+    cosh (x:+y)    =  cos y * cosh x :+ sin y * sinh x
+    tanh (x:+y)    =  (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)
+                      where siny  = sin y
+                            cosy  = cos y
+                            sinhx = sinh x
+                            coshx = cosh x
+
+    asin z@(x:+y)  =  y':+(-x')
+                      where  (x':+y') = log (((-y):+x) + sqrt (1 - z*z))
+    acos z         =  y'':+(-x'')
+                      where (x'':+y'') = log (z + ((-y'):+x'))
+                            (x':+y')   = sqrt (1 - z*z)
+    atan z@(x:+y)  =  y':+(-x')
+                      where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))
+
+    asinh z        =  log (z + sqrt (1+z*z))
+    acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))
+    atanh z        =  log ((1+z) / sqrt (1-z*z))
diff --git a/libraries/base/Data/Dynamic.hs b/libraries/base/Data/Dynamic.hs
new file mode 100644 (file)
index 0000000..42313fd
--- /dev/null
@@ -0,0 +1,288 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Dynamic
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Dynamic.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Dynamic interface provides basic support for dynamic types.
+-- 
+-- Operations for injecting values of arbitrary type into
+-- a dynamically typed value, Dynamic, are provided, together
+-- with operations for converting dynamic values into a concrete
+-- (monomorphic) type.
+-- 
+-- The Dynamic implementation provided is closely based on code
+-- contained in Hugs library of the same name.
+-- 
+-----------------------------------------------------------------------------
+
+module Data.Dynamic
+       (
+       -- dynamic type
+         Dynamic       -- abstract, instance of: Show, Typeable
+       , toDyn         -- :: Typeable a => a -> Dynamic
+       , fromDyn       -- :: Typeable a => Dynamic -> a -> a
+       , fromDynamic   -- :: Typeable a => Dynamic -> Maybe a
+       
+       -- type representation
+
+       , Typeable(
+            typeOf)    -- :: a -> TypeRep
+
+         -- Dynamic defines Typeable instances for the following
+       -- Prelude types: [a], (), (a,b), (a,b,c), (a,b,c,d),
+       -- (a,b,c,d,e), (a->b), (Array a b), Bool, Char,
+       -- (Complex a), Double, (Either a b), Float, Handle,
+       -- Int, Integer, (IO a), (Maybe a), Ordering
+
+       , TypeRep       -- abstract, instance of: Eq, Show, Typeable
+       , TyCon         -- abstract, instance of: Eq, Show, Typeable
+
+       -- type representation constructors/operators:
+       , mkTyCon       -- :: String  -> TyCon
+       , mkAppTy       -- :: TyCon   -> [TypeRep] -> TypeRep
+       , mkFunTy       -- :: TypeRep -> TypeRep   -> TypeRep
+       , applyTy       -- :: TypeRep -> TypeRep   -> Maybe TypeRep
+
+       -- 
+       -- let fTy = mkTyCon "Foo" in show (mkAppTy (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.
+       ) where
+
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+import GHC.Maybe
+import GHC.Show
+import GHC.Err
+import GHC.Num
+import GHC.Float
+import GHC.IOBase
+import GHC.Dynamic
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Prim                        ( unsafeCoerce# )
+
+unsafeCoerce :: a -> b
+unsafeCoerce = unsafeCoerce#
+#endif
+
+#include "Dynamic.h"
+
+-- The dynamic type is represented by Dynamic, carrying
+-- the dynamic value along with its type representation:
+
+-- the instance just prints the type representation.
+instance Show Dynamic where
+   showsPrec _ (Dynamic t _) = 
+          showString "<<" . 
+         showsPrec 0 t   . 
+         showString ">>"
+
+-- Operations for going to and from Dynamic:
+
+toDyn :: Typeable a => a -> Dynamic
+toDyn v = Dynamic (typeOf v) (unsafeCoerce v)
+
+fromDyn :: Typeable a => Dynamic -> a -> a
+fromDyn (Dynamic t v) def
+  | typeOf def == t = unsafeCoerce v
+  | otherwise       = def
+
+fromDynamic :: Typeable a => Dynamic -> Maybe a
+fromDynamic (Dynamic t v) =
+  case unsafeCoerce v of 
+    r | t == typeOf r -> Just r
+      | otherwise     -> Nothing
+
+-- (Abstract) universal datatype:
+
+instance Show TypeRep where
+  showsPrec p (App tycon tys) =
+    case tys of
+      [] -> showsPrec p tycon
+      [x] | tycon == listTc    -> showChar '[' . shows x . showChar ']'
+      xs  
+        | isTupleTyCon tycon -> showTuple tycon xs
+       | otherwise          ->
+           showParen (p > 9) $
+           showsPrec p tycon . 
+           showChar ' '      . 
+           showArgs tys
+
+  showsPrec p (Fun f a) =
+     showParen (p > 8) $
+     showsPrec 9 f . showString " -> " . showsPrec 8 a
+
+-- To make it possible to convert values with user-defined types
+-- into type Dynamic, we need a systematic way of getting
+-- the type representation of an arbitrary type. A type
+-- class provides just the ticket,
+
+class Typeable a where
+  typeOf :: a -> TypeRep
+
+-- NOTE: The argument to the overloaded `typeOf' is only
+-- used to carry type information, and Typeable instances
+-- should *never* *ever* look at its value.
+
+isTupleTyCon :: TyCon -> Bool
+isTupleTyCon (TyCon _ (',':_)) = True
+isTupleTyCon _                = False
+
+instance Show TyCon where
+  showsPrec _ (TyCon _ s) = showString s
+
+-- If we enforce the restriction that there is only one
+-- @TyCon@ for a type & it is shared among all its uses,
+-- we can map them onto Ints very simply. The benefit is,
+-- of course, that @TyCon@s can then be compared efficiently.
+
+-- Provided the implementor of other @Typeable@ instances
+-- takes care of making all the @TyCon@s CAFs (toplevel constants),
+-- this will work. 
+
+-- If this constraint does turn out to be a sore thumb, changing
+-- the Eq instance for TyCons is trivial.
+
+mkTyCon :: String -> TyCon
+mkTyCon str = unsafePerformIO $ do
+   v <- readIORef uni
+   writeIORef uni (v+1)
+   return (TyCon v str)
+
+{-# NOINLINE uni #-}
+uni :: IORef Int
+uni = unsafePerformIO ( newIORef 0 )
+
+-- 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 :: TyCon -> [TypeRep] -> ShowS
+showTuple (TyCon _ str) args = showChar '(' . go str args
+ where
+  go [] [a] = showsPrec 10 a . showChar ')'
+  go _  []  = showChar ')' -- a failure condition, really.
+  go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
+  go _ _   = showChar ')'
+
+
+mkAppTy  :: TyCon   -> [TypeRep] -> TypeRep
+mkAppTy tyc args = App tyc args
+
+mkFunTy  :: TypeRep -> TypeRep   -> TypeRep
+mkFunTy f a = Fun f a
+
+-- Auxillary functions
+
+-- (f::(a->b)) `dynApply` (x::a) = (f a)::b
+dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
+dynApply (Dynamic t1 f) (Dynamic t2 x) =
+  case applyTy t1 t2 of
+    Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x))
+    Nothing -> Nothing
+
+dynApp :: Dynamic -> Dynamic -> Dynamic
+dynApp f x = case dynApply f x of 
+             Just r -> r
+             Nothing -> error ("Type error in dynamic application.\n" ++
+                               "Can't apply function " ++ show f ++
+                               " to argument " ++ show x)
+
+applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
+applyTy (Fun t1 t2) t3
+  | t1 == t3    = Just t2
+applyTy _ _     = Nothing
+
+-- Prelude types
+
+listTc :: TyCon
+listTc = mkTyCon "[]"
+
+instance Typeable a => Typeable [a] where
+  typeOf ls = mkAppTy listTc [typeOf ((undefined:: [a] -> a) ls)]
+
+unitTc :: TyCon
+unitTc = mkTyCon "()"
+
+instance Typeable () where
+  typeOf _ = mkAppTy unitTc []
+
+tup2Tc :: TyCon
+tup2Tc = mkTyCon ","
+
+instance (Typeable a, Typeable b) => Typeable (a,b) where
+  typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu),
+                             typeOf ((undefined :: (a,b) -> b) tu)]
+
+tup3Tc :: TyCon
+tup3Tc = mkTyCon ",,"
+
+instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where
+  typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu),
+                             typeOf ((undefined :: (a,b,c) -> b) tu),
+                             typeOf ((undefined :: (a,b,c) -> c) tu)]
+
+tup4Tc :: TyCon
+tup4Tc = mkTyCon ",,,"
+
+instance ( Typeable a
+        , Typeable b
+        , Typeable c
+        , Typeable d) => Typeable (a,b,c,d) where
+  typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu),
+                             typeOf ((undefined :: (a,b,c,d) -> b) tu),
+                             typeOf ((undefined :: (a,b,c,d) -> c) tu),
+                             typeOf ((undefined :: (a,b,c,d) -> d) tu)]
+
+tup5Tc :: TyCon
+tup5Tc = mkTyCon ",,,,"
+
+instance ( Typeable a
+        , Typeable b
+        , Typeable c
+        , Typeable d
+        , Typeable e) => Typeable (a,b,c,d,e) where
+  typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu),
+                             typeOf ((undefined :: (a,b,c,d,e) -> b) tu),
+                             typeOf ((undefined :: (a,b,c,d,e) -> c) tu),
+                             typeOf ((undefined :: (a,b,c,d,e) -> d) tu),
+                             typeOf ((undefined :: (a,b,c,d,e) -> e) tu)]
+
+instance (Typeable a, Typeable b) => Typeable (a -> b) where
+  typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
+                    (typeOf ((undefined :: (a -> b) -> b) f))
+
+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(Integer,integerTc,"Integer")
+INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
+INSTANCE_TYPEABLE1(IO,ioTc,"IO")
+INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
+INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
+
+INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
+INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
+INSTANCE_TYPEABLE0(Dynamic,dynamicTc,"Dynamic")
diff --git a/libraries/base/Data/Either.hs b/libraries/base/Data/Either.hs
new file mode 100644 (file)
index 0000000..f3cd106
--- /dev/null
@@ -0,0 +1,25 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Either
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Either.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Either type, and associated operations.
+--
+-----------------------------------------------------------------------------
+
+module Data.Either (
+   Either(..),
+   either      -- :: (a -> c) -> (b -> c) -> Either a b -> c
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Maybe
+#endif
diff --git a/libraries/base/Data/IORef.hs b/libraries/base/Data/IORef.hs
new file mode 100644 (file)
index 0000000..f073827
--- /dev/null
@@ -0,0 +1,57 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.IORef
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: IORef.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Mutable references in the IO monad.
+--
+-----------------------------------------------------------------------------
+
+module Data.IORef
+       ( 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 ()
+
+#if !defined(__PARALLEL_HASKELL__) && defined(__GLASGOW_HASKELL__)
+       , mkWeakIORef           -- :: IORef a -> IO () -> IO (Weak (IORef a))
+#endif
+       ) where
+
+import Prelude
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Prim                ( mkWeak# )
+import GHC.STRef
+import GHC.IOBase
+#if !defined(__PARALLEL_HASKELL__)
+import GHC.Weak
+#endif
+#endif /* __GLASGOW_HASKELL__ */
+
+#ifdef __HUGS__
+import IOExts          ( IORef, newIORef, writeIORef, readIORef )
+import ST              ( stToIO, newSTRef, readSTRef, writeSTRef )
+#endif
+
+import Data.Dynamic
+
+#ifndef __PARALLEL_HASKELL__
+mkWeakIORef :: IORef a -> IO () -> IO (Weak (IORef a))
+mkWeakIORef r@(IORef (STRef r#)) f = IO $ \s ->
+  case mkWeak# r# r f s of (# s1, w #) -> (# s1, Weak w #)
+#endif
+
+modifyIORef :: IORef a -> (a -> a) -> IO ()
+modifyIORef ref f = writeIORef ref . f =<< readIORef ref
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
diff --git a/libraries/base/Data/Int.hs b/libraries/base/Data/Int.hs
new file mode 100644 (file)
index 0000000..3a1042a
--- /dev/null
@@ -0,0 +1,37 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Int
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Int.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Sized Integer types.
+--
+-----------------------------------------------------------------------------
+
+module Data.Int
+       ( Int8
+       , Int16
+       , Int32
+       , Int64
+       -- instances: Eq, Ord, Num, Bounded, Real, Integral, Ix, Enum, Read,
+       -- Show, Bits, CCallable, CReturnable (last two are GHC specific.)
+       ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Int
+#endif
+
+import Data.Dynamic
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE0(Int8,int8Tc, "Int8")
+INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
+INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
+INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
diff --git a/libraries/base/Data/Ix.hs b/libraries/base/Data/Ix.hs
new file mode 100644 (file)
index 0000000..8d4d745
--- /dev/null
@@ -0,0 +1,43 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Ix
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- $Id: Ix.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Class of index types.
+--
+-----------------------------------------------------------------------------
+
+module Data.Ix
+    (
+       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
+    -- Ix instances:
+    --
+    --  Ix Char
+    --  Ix Int
+    --  Ix Integer
+    --  Ix Bool
+    --  Ix Ordering
+    --  Ix ()
+    --  (Ix a, Ix b) => Ix (a, b)
+    --  ...
+
+    -- Implementation checked wrt. Haskell 98 lib report, 1/99.
+    ) where
+
+import Prelude
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Arr
+#endif
diff --git a/libraries/base/Data/List.hs b/libraries/base/Data/List.hs
new file mode 100644 (file)
index 0000000..ce4c9b3
--- /dev/null
@@ -0,0 +1,537 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.List
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- $Id: List.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Operations on lists.
+--
+-----------------------------------------------------------------------------
+
+module Data.List
+   ( 
+    [] (..),
+
+   , elemIndex        -- :: (Eq a) => a -> [a] -> Maybe Int
+   , elemIndices       -- :: (Eq a) => a -> [a] -> [Int]
+
+   , find             -- :: (a -> Bool) -> [a] -> Maybe a
+   , findIndex        -- :: (a -> Bool) -> [a] -> Maybe Int
+   , findIndices       -- :: (a -> Bool) -> [a] -> [Int]
+   
+   , nub               -- :: (Eq a) => [a] -> [a]
+   , nubBy             -- :: (a -> a -> Bool) -> [a] -> [a]
+
+   , delete            -- :: (Eq a) => a -> [a] -> [a]
+   , deleteBy          -- :: (a -> a -> Bool) -> a -> [a] -> [a]
+   , (\\)              -- :: (Eq a) => [a] -> [a] -> [a]
+   , deleteFirstsBy    -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+   
+   , union             -- :: (Eq a) => [a] -> [a] -> [a]
+   , unionBy           -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+
+   , intersect         -- :: (Eq a) => [a] -> [a] -> [a]
+   , intersectBy       -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+
+   , intersperse       -- :: a -> [a] -> [a]
+   , transpose         -- :: [[a]] -> [[a]]
+   , partition         -- :: (a -> Bool) -> [a] -> ([a], [a])
+
+   , group             -- :: Eq a => [a] -> [[a]]
+   , groupBy           -- :: (a -> a -> Bool) -> [a] -> [[a]]
+
+   , inits             -- :: [a] -> [[a]]
+   , tails             -- :: [a] -> [[a]]
+
+   , isPrefixOf        -- :: (Eq a) => [a] -> [a] -> Bool
+   , isSuffixOf        -- :: (Eq a) => [a] -> [a] -> Bool
+   
+   , mapAccumL         -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
+   , mapAccumR         -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
+   
+   , sort              -- :: (Ord a) => [a] -> [a]
+   , sortBy            -- :: (a -> a -> Ordering) -> [a] -> [a]
+   
+   , insert            -- :: (Ord a) => a -> [a] -> [a]
+   , insertBy          -- :: (a -> a -> Ordering) -> a -> [a] -> [a]
+   
+   , maximumBy        -- :: (a -> a -> Ordering) -> [a] -> a
+   , minimumBy         -- :: (a -> a -> Ordering) -> [a] -> a
+   
+   , 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]
+   
+   , unfoldr           -- :: (b -> Maybe (a, b)) -> b -> [a]
+
+   , zip4, zip5, zip6, zip7
+   , zipWith4, zipWith5, zipWith6, zipWith7
+   , unzip4, unzip5, unzip6, unzip7
+
+   , map               -- :: ( a -> b ) -> [a] -> [b]
+   , (++)             -- :: [a] -> [a] -> [a]
+   , concat            -- :: [[a]] -> [a]
+   , filter           -- :: (a -> Bool) -> [a] -> [a]
+   , head             -- :: [a] -> a
+   , last             -- :: [a] -> a
+   , tail             -- :: [a] -> [a]
+   , init              -- :: [a] -> [a]
+   , null             -- :: [a] -> Bool
+   , length           -- :: [a] -> Int
+   , (!!)             -- :: [a] -> Int -> a
+   , foldl            -- :: (a -> b -> a) -> a -> [b] -> a
+   , foldl1           -- :: (a -> a -> a) -> [a] -> a
+   , scanl             -- :: (a -> b -> a) -> a -> [b] -> [a]
+   , scanl1            -- :: (a -> a -> a) -> [a] -> [a]
+   , foldr             -- :: (a -> b -> b) -> b -> [a] -> b
+   , foldr1            -- :: (a -> a -> a) -> [a] -> a
+   , scanr             -- :: (a -> b -> b) -> b -> [a] -> [b]
+   , scanr1            -- :: (a -> a -> a) -> [a] -> [a]
+   , iterate           -- :: (a -> a) -> a -> [a]
+   , repeat            -- :: a -> [a]
+   , replicate         -- :: Int -> a -> [a]
+   , cycle             -- :: [a] -> [a]
+   , take              -- :: Int -> [a] -> [a]
+   , drop              -- :: Int -> [a] -> [a]
+   , splitAt           -- :: Int -> [a] -> ([a], [a])
+   , takeWhile         -- :: (a -> Bool) -> [a] -> [a]
+   , dropWhile         -- :: (a -> Bool) -> [a] -> [a]
+   , span              -- :: (a -> Bool) -> [a] -> ([a], [a])
+   , break             -- :: (a -> Bool) -> [a] -> ([a], [a])
+
+   , lines            -- :: String   -> [String]
+   , words            -- :: String   -> [String]
+   , unlines           -- :: [String] -> String
+   , unwords           -- :: [String] -> String
+   , reverse           -- :: [a] -> [a]
+   , and              -- :: [Bool] -> Bool
+   , or                -- :: [Bool] -> Bool
+   , any               -- :: (a -> Bool) -> [a] -> Bool
+   , all               -- :: (a -> Bool) -> [a] -> Bool
+   , elem              -- :: a -> [a] -> Bool
+   , notElem           -- :: a -> [a] -> Bool
+   , lookup            -- :: (Eq a) => a -> [(a,b)] -> Maybe b
+   , sum               -- :: (Num a) => [a] -> a
+   , product           -- :: (Num a) => [a] -> a
+   , maximum           -- :: (Ord a) => [a] -> a
+   , minimum           -- :: (Ord a) => [a] -> a
+   , concatMap         -- :: (a -> [b]) -> [a] -> [b]
+   , zip               -- :: [a] -> [b] -> [(a,b)]
+   , zip3  
+   , zipWith           -- :: (a -> b -> c) -> [a] -> [b] -> [c]
+   , zipWith3
+   , unzip             -- :: [(a,b)] -> ([a],[b])
+   , unzip3
+
+   ) where
+
+import Data.Maybe
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Num
+import GHC.Real
+import GHC.List
+import GHC.Show        ( lines, words, unlines, unwords )
+import GHC.Base
+#endif
+
+infix 5 \\ 
+
+-- -----------------------------------------------------------------------------
+-- List functions
+
+elemIndex      :: Eq a => a -> [a] -> Maybe Int
+elemIndex x     = findIndex (x==)
+
+elemIndices     :: Eq a => a -> [a] -> [Int]
+elemIndices x   = findIndices (x==)
+
+find           :: (a -> Bool) -> [a] -> Maybe a
+find p          = listToMaybe . filter p
+
+findIndex       :: (a -> Bool) -> [a] -> Maybe Int
+findIndex p     = listToMaybe . findIndices p
+
+findIndices      :: (a -> Bool) -> [a] -> [Int]
+
+#ifdef USE_REPORT_PRELUDE
+findIndices p xs = [ i | (x,i) <- zip xs [0..], p x]
+#else
+#ifdef __HUGS__
+findIndices p xs = [ i | (x,i) <- zip xs [0..], p x]
+#else 
+-- Efficient definition
+findIndices p ls = loop 0# ls
+                where
+                  loop _ [] = []
+                  loop n (x:xs) | p x       = I# n : loop (n +# 1#) xs
+                                | otherwise = loop (n +# 1#) xs
+#endif  /* __HUGS__ */
+#endif  /* USE_REPORT_PRELUDE */
+
+isPrefixOf              :: (Eq a) => [a] -> [a] -> Bool
+isPrefixOf [] _         =  True
+isPrefixOf _  []        =  False
+isPrefixOf (x:xs) (y:ys)=  x == y && isPrefixOf xs ys
+
+isSuffixOf              :: (Eq a) => [a] -> [a] -> Bool
+isSuffixOf x y          =  reverse x `isPrefixOf` reverse y
+
+-- nub (meaning "essence") remove duplicate elements from its list argument.
+nub                     :: (Eq a) => [a] -> [a]
+#ifdef USE_REPORT_PRELUDE
+nub                     =  nubBy (==)
+#else
+-- stolen from HBC
+nub l                   = nub' l []            -- '
+  where
+    nub' [] _          = []                    -- '
+    nub' (x:xs) ls                             -- '
+       | x `elem` ls   = nub' xs ls            -- '
+       | otherwise     = x : nub' xs (x:ls)    -- '
+#endif
+
+nubBy                  :: (a -> a -> Bool) -> [a] -> [a]
+#ifdef USE_REPORT_PRELUDE
+nubBy eq []             =  []
+nubBy eq (x:xs)         =  x : nubBy eq (filter (\ y -> not (eq x y)) xs)
+#else
+nubBy eq l              = nubBy' l []
+  where
+    nubBy' [] _                = []
+    nubBy' (y:ys) xs
+       | elem_by eq y xs = nubBy' ys xs 
+       | otherwise      = y : nubBy' ys (y:xs)
+
+-- Not exported:
+-- Note that we keep the call to `eq` with arguments in the
+-- same order as in the reference implementation
+-- 'xs' is the list of things we've seen so far, 
+-- 'y' is the potential new element
+elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool
+elem_by _  _ []                =  False
+elem_by eq y (x:xs)    =  x `eq` y || elem_by eq y xs
+#endif
+
+
+-- delete x removes the first occurrence of x from its list argument.
+delete                  :: (Eq a) => a -> [a] -> [a]
+delete                  =  deleteBy (==)
+
+deleteBy                :: (a -> a -> Bool) -> a -> [a] -> [a]
+deleteBy _  _ []        = []
+deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys
+
+-- list difference (non-associative).  In the result of xs \\ ys,
+-- the first occurrence of each element of ys in turn (if any)
+-- has been removed from xs.  Thus, (xs ++ ys) \\ xs == ys.
+(\\)                   :: (Eq a) => [a] -> [a] -> [a]
+(\\)                   =  foldl (flip delete)
+
+-- List union, remove the elements of first list from second.
+union                  :: (Eq a) => [a] -> [a] -> [a]
+union                  = unionBy (==)
+
+unionBy                 :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+unionBy eq xs ys        =  xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs
+
+intersect               :: (Eq a) => [a] -> [a] -> [a]
+intersect               =  intersectBy (==)
+
+intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+intersectBy eq xs ys    =  [x | x <- xs, any (eq x) ys]
+
+-- intersperse sep inserts sep between the elements of its list argument.
+-- e.g. intersperse ',' "abcde" == "a,b,c,d,e"
+intersperse            :: a -> [a] -> [a]
+intersperse _   []      = []
+intersperse _   [x]     = [x]
+intersperse sep (x:xs)  = x : sep : intersperse sep xs
+
+transpose              :: [[a]] -> [[a]]
+transpose []            = []
+transpose ([]  : xss)   = transpose xss
+transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : transpose (xs : [ t | (h:t) <- xss])
+
+
+-- partition takes a predicate and a list and returns a pair of lists:
+-- those elements of the argument list that do and do not satisfy the
+-- predicate, respectively; i,e,,
+-- partition p xs == (filter p xs, filter (not . p) xs).
+partition              :: (a -> Bool) -> [a] -> ([a],[a])
+{-# INLINE partition #-}
+partition p xs = foldr (select p) ([],[]) xs
+
+select p x (ts,fs) | p x       = (x:ts,fs)
+                   | otherwise = (ts, x:fs)
+
+-- @mapAccumL@ behaves like a combination
+-- of  @map@ and @foldl@;
+-- it applies a function to each element of a list, passing an accumulating
+-- parameter from left to right, and returning a final value of this
+-- accumulator together with the new list.
+
+mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
+                                   -- and accumulator, returning new
+                                   -- accumulator and elt of result list
+         -> acc            -- Initial accumulator 
+         -> [x]            -- Input list
+         -> (acc, [y])     -- Final accumulator and result list
+mapAccumL _ s []       =  (s, [])
+mapAccumL f s (x:xs)   =  (s'',y:ys)
+                          where (s', y ) = f s x
+                                (s'',ys) = mapAccumL f s' xs
+
+-- @mapAccumR@ does the same, but working from right to left instead.
+-- Its type is the same as @mapAccumL@, though.
+
+mapAccumR :: (acc -> x -> (acc, y))    -- Function of elt of input list
+                                       -- and accumulator, returning new
+                                       -- accumulator and elt of result list
+           -> acc              -- Initial accumulator
+           -> [x]              -- Input list
+           -> (acc, [y])               -- Final accumulator and result list
+mapAccumR _ s []       =  (s, [])
+mapAccumR f s (x:xs)   =  (s'', y:ys)
+                          where (s'',y ) = f s' x
+                                (s', ys) = mapAccumR f s xs
+
+
+insert :: Ord a => a -> [a] -> [a]
+insert e ls = insertBy (compare) e ls
+
+insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]
+insertBy _   x [] = [x]
+insertBy cmp x ys@(y:ys')
+ = case cmp x y of
+     GT -> y : insertBy cmp x ys'
+     _  -> x : ys
+
+maximumBy              :: (a -> a -> a) -> [a] -> a
+maximumBy _   []       =  error "List.maximumBy: empty list"
+maximumBy max xs       =  foldl1 max xs
+
+minimumBy              :: (a -> a -> a) -> [a] -> a
+minimumBy _   []       =  error "List.minimumBy: empty list"
+minimumBy min xs       =  foldl1 min xs
+
+genericLength           :: (Num i) => [b] -> i
+genericLength []        =  0
+genericLength (_:l)     =  1 + genericLength l
+
+genericTake            :: (Integral i) => i -> [a] -> [a]
+genericTake 0 _         =  []
+genericTake _ []        =  []
+genericTake n (x:xs) | n > 0  =  x : genericTake (n-1) xs
+genericTake _  _        =  error "List.genericTake: negative argument"
+
+genericDrop            :: (Integral i) => i -> [a] -> [a]
+genericDrop 0 xs        =  xs
+genericDrop _ []        =  []
+genericDrop n (_:xs) | n > 0  =  genericDrop (n-1) xs
+genericDrop _ _                =  error "List.genericDrop: negative argument"
+
+genericSplitAt          :: (Integral i) => i -> [b] -> ([b],[b])
+genericSplitAt 0 xs     =  ([],xs)
+genericSplitAt _ []     =  ([],[])
+genericSplitAt n (x:xs) | n > 0  =  (x:xs',xs'') where
+                               (xs',xs'') = genericSplitAt (n-1) xs
+genericSplitAt _ _      =  error "List.genericSplitAt: negative argument"
+
+
+genericIndex :: (Integral a) => [b] -> a -> b
+genericIndex (x:_)  0 = x
+genericIndex (_:xs) n 
+ | n > 0     = genericIndex xs (n-1)
+ | otherwise = error "List.genericIndex: negative argument."
+genericIndex _ _      = error "List.genericIndex: index too large."
+
+genericReplicate       :: (Integral i) => i -> a -> [a]
+genericReplicate n x   =  genericTake n (repeat x)
+
+
+zip4                   :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
+zip4                   =  zipWith4 (,,,)
+
+zip5                   :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
+zip5                   =  zipWith5 (,,,,)
+
+zip6                   :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> 
+                              [(a,b,c,d,e,f)]
+zip6                   =  zipWith6 (,,,,,)
+
+zip7                   :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
+                              [g] -> [(a,b,c,d,e,f,g)]
+zip7                   =  zipWith7 (,,,,,,)
+
+zipWith4               :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
+zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
+                       =  z a b c d : zipWith4 z as bs cs ds
+zipWith4 _ _ _ _ _     =  []
+
+zipWith5               :: (a->b->c->d->e->f) -> 
+                           [a]->[b]->[c]->[d]->[e]->[f]
+zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
+                       =  z a b c d e : zipWith5 z as bs cs ds es
+zipWith5 _ _ _ _ _ _   = []
+
+zipWith6               :: (a->b->c->d->e->f->g) ->
+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]
+zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
+                       =  z a b c d e f : zipWith6 z as bs cs ds es fs
+zipWith6 _ _ _ _ _ _ _ = []
+
+zipWith7               :: (a->b->c->d->e->f->g->h) ->
+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
+zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
+                  =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs
+zipWith7 _ _ _ _ _ _ _ _ = []
+
+unzip4                 :: [(a,b,c,d)] -> ([a],[b],[c],[d])
+unzip4                 =  foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->
+                                       (a:as,b:bs,c:cs,d:ds))
+                                ([],[],[],[])
+
+unzip5                 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])
+unzip5                 =  foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->
+                                       (a:as,b:bs,c:cs,d:ds,e:es))
+                                ([],[],[],[],[])
+
+unzip6                 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])
+unzip6                 =  foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->
+                                       (a:as,b:bs,c:cs,d:ds,e:es,f:fs))
+                                ([],[],[],[],[],[])
+
+unzip7         :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])
+unzip7         =  foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->
+                               (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))
+                        ([],[],[],[],[],[],[])
+
+
+
+deleteFirstsBy          :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+deleteFirstsBy eq       =  foldl (flip (deleteBy eq))
+
+
+-- group splits its list argument into a list of lists of equal, adjacent
+-- elements.  e.g.,
+-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"]
+group                   :: (Eq a) => [a] -> [[a]]
+group                   =  groupBy (==)
+
+groupBy                :: (a -> a -> Bool) -> [a] -> [[a]]
+groupBy _  []          =  []
+groupBy eq (x:xs)      =  (x:ys) : groupBy eq zs
+                           where (ys,zs) = span (eq x) xs
+
+-- inits xs returns the list of initial segments of xs, shortest first.
+-- e.g., inits "abc" == ["","a","ab","abc"]
+inits                  :: [a] -> [[a]]
+inits []               =  [[]]
+inits (x:xs)           =  [[]] ++ map (x:) (inits xs)
+
+-- tails xs returns the list of all final segments of xs, longest first.
+-- e.g., tails "abc" == ["abc", "bc", "c",""]
+tails                  :: [a] -> [[a]]
+tails []               =  [[]]
+tails xxs@(_:xs)       =  xxs : tails xs
+
+
+------------------------------------------------------------------------------
+-- Quick Sort algorithm taken from HBC's QSort library.
+
+sort :: (Ord a) => [a] -> [a]
+sortBy :: (a -> a -> Ordering) -> [a] -> [a]
+
+#ifdef USE_REPORT_PRELUDE
+sort = sortBy compare
+sortBy cmp = foldr (insertBy cmp) []
+#else
+
+sortBy cmp l = qsort cmp l []
+sort l = qsort compare l []
+
+-- rest is not exported:
+
+-- qsort is stable and does not concatenate.
+qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
+qsort _   []     r = r
+qsort _   [x]    r = x:r
+qsort cmp (x:xs) r = qpart cmp x xs [] [] r
+
+-- qpart partitions and sorts the sublists
+qpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]
+qpart cmp x [] rlt rge r =
+    -- rlt and rge are in reverse order and must be sorted with an
+    -- anti-stable sorting
+    rqsort cmp rlt (x:rqsort cmp rge r)
+qpart cmp x (y:ys) rlt rge r =
+    case cmp x y of
+       GT -> qpart cmp x ys (y:rlt) rge r
+        _  -> qpart cmp x ys rlt (y:rge) r
+
+-- rqsort is as qsort but anti-stable, i.e. reverses equal elements
+rqsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
+rqsort _   []     r = r
+rqsort _   [x]    r = x:r
+rqsort cmp (x:xs) r = rqpart cmp x xs [] [] r
+
+rqpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]
+rqpart cmp x [] rle rgt r =
+    qsort cmp rle (x:qsort cmp rgt r)
+rqpart cmp x (y:ys) rle rgt r =
+    case cmp y x of
+       GT -> rqpart cmp x ys rle (y:rgt) r
+       _  -> rqpart cmp x ys (y:rle) rgt r
+
+#endif /* USE_REPORT_PRELUDE */
+
+{-
+\begin{verbatim}
+  unfoldr f' (foldr f z xs) == (z,xs)
+
+ if the following holds:
+
+   f' (f x y) = Just (x,y)
+   f' z       = Nothing
+\end{verbatim}
+-}
+
+unfoldr      :: (b -> Maybe (a, b)) -> b -> [a]
+unfoldr f b  =
+  case f b of
+   Just (a,new_b) -> a : unfoldr f new_b
+   Nothing        -> []
+
+-- -----------------------------------------------------------------------------
+-- List sum and product
+
+-- sum and product compute the sum or product of a finite list of numbers.
+{-# SPECIALISE sum     :: [Int] -> Int #-}
+{-# SPECIALISE sum     :: [Integer] -> Integer #-}
+{-# SPECIALISE product :: [Int] -> Int #-}
+{-# SPECIALISE product :: [Integer] -> Integer #-}
+sum, product            :: (Num a) => [a] -> a
+#ifdef USE_REPORT_PRELUDE
+sum                     =  foldl (+) 0  
+product                 =  foldl (*) 1
+#else
+sum    l       = sum' l 0
+  where
+    sum' []     a = a
+    sum' (x:xs) a = sum' xs (a+x)
+product        l       = prod l 1
+  where
+    prod []     a = a
+    prod (x:xs) a = prod xs (a*x)
+#endif
diff --git a/libraries/base/Data/Maybe.hs b/libraries/base/Data/Maybe.hs
new file mode 100644 (file)
index 0000000..06c7a25
--- /dev/null
@@ -0,0 +1,75 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Maybe
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Maybe.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Maybe type, and associated operations.
+--
+-----------------------------------------------------------------------------
+
+module Data.Maybe
+   (
+     Maybe(Nothing,Just)-- instance of: Eq, Ord, Show, Read,
+                       --              Functor, Monad, MonadPlus
+
+   , maybe             -- :: b -> (a -> b) -> Maybe a -> b
+
+   , 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]
+   ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Err ( error )
+import GHC.List
+import GHC.Maybe
+import GHC.Base
+#endif
+
+isJust         :: Maybe a -> Bool
+isJust Nothing = False
+isJust _       = True
+
+isNothing         :: Maybe a -> Bool
+isNothing Nothing = True
+isNothing _       = False
+
+fromJust          :: Maybe a -> a
+fromJust Nothing  = error "Maybe.fromJust: Nothing" -- yuck
+fromJust (Just x) = x
+
+fromMaybe     :: a -> Maybe a -> a
+fromMaybe d x = case x of {Nothing -> d;Just v  -> v}
+
+maybeToList            :: Maybe a -> [a]
+maybeToList  Nothing   = []
+maybeToList  (Just x)  = [x]
+
+listToMaybe           :: [a] -> Maybe a
+listToMaybe []        =  Nothing
+listToMaybe (a:_)     =  Just a
+catMaybes              :: [Maybe a] -> [a]
+catMaybes ls = [x | Just x <- ls]
+
+mapMaybe          :: (a -> Maybe b) -> [a] -> [b]
+mapMaybe _ []     = []
+mapMaybe f (x:xs) =
+ let rs = mapMaybe f xs in
+ case f x of
+  Nothing -> rs
+  Just r  -> r:rs
+
diff --git a/libraries/base/Data/PackedString.hs b/libraries/base/Data/PackedString.hs
new file mode 100644 (file)
index 0000000..6fc1a8f
--- /dev/null
@@ -0,0 +1,914 @@
+{-# OPTIONS -#include "PackedString.h" #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.PackedString
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: PackedString.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The PackedString type, and associated operations.
+-- GHC implementation by Bryan O'Sullivan.
+--
+-----------------------------------------------------------------------------
+
+module Data.PackedString (
+        PackedString,      -- abstract, instances: Eq, Ord, Show, Typeable
+
+         -- Creating the beasts
+       packString,          -- :: [Char] -> PackedString
+       packStringST,        -- :: [Char] -> ST s PackedString
+        packCBytesST,        -- :: Int -> Ptr a -> ST s PackedString
+
+       byteArrayToPS,       -- :: ByteArray Int -> PackedString
+       cByteArrayToPS,      -- :: ByteArray Int -> PackedString
+       unsafeByteArrayToPS, -- :: ByteArray a   -> Int -> PackedString
+
+       psToByteArray,       -- :: PackedString  -> ByteArray Int
+       psToCString,         -- :: PackedString  -> Ptr a
+        isCString,          -- :: PackedString  -> Bool
+
+       unpackPS,        -- :: PackedString -> [Char]
+       unpackNBytesPS,  -- :: PackedString -> Int -> [Char]
+       unpackPSIO,      -- :: PackedString -> IO [Char]
+
+       hPutPS,      -- :: Handle -> PackedString -> IO ()
+       hGetPS,      -- :: Handle -> Int -> IO PackedString
+
+       nilPS,       -- :: PackedString
+       consPS,      -- :: Char -> PackedString -> PackedString
+       headPS,      -- :: PackedString -> Char
+       tailPS,      -- :: PackedString -> PackedString
+       nullPS,      -- :: PackedString -> Bool
+       appendPS,    -- :: PackedString -> PackedString -> PackedString
+       lengthPS,    -- :: PackedString -> Int
+          {- 0-origin indexing into the string -}
+       indexPS,     -- :: PackedString -> Int -> Char
+       mapPS,       -- :: (Char -> Char) -> PackedString -> PackedString
+       filterPS,    -- :: (Char -> Bool) -> PackedString -> PackedString
+       foldlPS,     -- :: (a -> Char -> a) -> a -> PackedString -> a
+       foldrPS,     -- :: (Char -> a -> a) -> a -> PackedString -> a
+       takePS,      -- :: Int -> PackedString -> PackedString
+       dropPS,      -- :: Int -> PackedString -> PackedString
+       splitAtPS,   -- :: Int -> PackedString -> (PackedString, PackedString)
+       takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
+       dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
+       spanPS,      -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+       breakPS,     -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+       linesPS,     -- :: PackedString -> [PackedString]
+
+       wordsPS,     -- :: PackedString -> [PackedString]
+       reversePS,   -- :: PackedString -> PackedString
+       splitPS,     -- :: Char -> PackedString -> [PackedString]
+       splitWithPS, -- :: (Char -> Bool) -> PackedString -> [PackedString]
+       joinPS,      -- :: PackedString -> [PackedString] -> PackedString
+       concatPS,    -- :: [PackedString] -> PackedString
+       elemPS,      -- :: Char -> PackedString -> Bool
+
+        {-
+           Pluck out a piece of a PS start and end
+          chars you want; both 0-origin-specified
+         -}
+       substrPS,    -- :: PackedString -> Int -> Int -> PackedString
+
+       comparePS    -- :: PackedString -> PackedString -> Ordering
+
+    ) where
+
+import Prelude
+
+import Foreign
+import Foreign.C
+
+import GHC.Prim
+import GHC.Base
+import GHC.ST
+import GHC.ByteArr
+
+import GHC.Show                ( showList__  ) -- ToDo: better
+import GHC.Pack        ( new_ps_array,  freeze_ps_array,  write_ps_array )
+
+import Control.Monad.ST
+
+import System.IO
+import System.IO.Unsafe        ( unsafePerformIO )
+import GHC.IO          ( hPutBufBA, hGetBufBA )
+
+import Data.Ix
+import Data.Char       ( isSpace )
+import Data.Dynamic
+
+-- -----------------------------------------------------------------------------
+-- PackedString type declaration
+
+data PackedString
+  = PS ByteArray#  -- the bytes
+       Int#        -- length (*not* including NUL at the end)
+       Bool        -- True <=> contains a NUL
+  | CPS        Addr#       -- pointer to the (null-terminated) bytes in C land
+       Int#        -- length, as per strlen
+                   -- definitely doesn't contain a NUL
+
+instance Eq PackedString where
+    x == y  = compare x y == EQ
+    x /= y  = compare x y /= EQ
+
+instance Ord PackedString where
+    compare = comparePS
+    x <= y  = compare x y /= GT
+    x <         y  = compare x y == LT
+    x >= y  = compare x y /= LT
+    x >         y  = compare x y == GT
+    max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x }
+    min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y }
+
+--instance Read PackedString: ToDo
+
+instance Show PackedString where
+    showsPrec p ps r = showsPrec p (unpackPS ps) r
+    showList = showList__ (showsPrec 0) 
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE0(PackedString,packedStringTc,"PackedString")
+
+-- -----------------------------------------------------------------------------
+-- PackedString instances
+
+-- We try hard to make this go fast:
+
+comparePS :: PackedString -> PackedString -> Ordering
+
+comparePS (PS  bs1 len1 has_null1) (PS  bs2 len2 has_null2)
+  | not has_null1 && not has_null2
+  = unsafePerformIO (
+    _ccall_ strcmp ba1 ba2  >>= \ (I# res) ->
+    return (
+    if      res <#  0# then LT
+    else if res ==# 0# then EQ
+    else                   GT
+    ))
+  where
+    ba1 = ByteArray 0 (I# (len1 -# 1#)) bs1
+    ba2 = ByteArray 0 (I# (len2 -# 1#)) bs2
+
+comparePS (PS  bs1 len1 has_null1) (CPS bs2 _)
+  | not has_null1
+  = unsafePerformIO (
+    _ccall_ strcmp ba1 ba2  >>= \ (I# res) ->
+    return (
+    if      res <#  0# then LT
+    else if res ==# 0# then EQ
+    else                   GT
+    ))
+  where
+    ba1 = ByteArray 0 (I# (len1 -# 1#)) bs1
+    ba2 = Ptr bs2
+
+comparePS (CPS bs1 len1) (CPS bs2 _)
+  = unsafePerformIO (
+    _ccall_ strcmp ba1 ba2  >>= \ (I# res) ->
+    return (
+    if      res <#  0# then LT
+    else if res ==# 0# then EQ
+    else                   GT
+    ))
+  where
+    ba1 = Ptr bs1
+    ba2 = Ptr bs2
+
+comparePS a@(CPS _ _) b@(PS _ _ has_null2)
+  | not has_null2
+  = -- try them the other way 'round
+    case (comparePS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
+
+comparePS ps1 ps2 -- slow catch-all case (esp for "has_null" True)
+  = looking_at 0#
+  where
+    end1 = lengthPS# ps1 -# 1#
+    end2 = lengthPS# ps2 -# 1#
+
+    looking_at char#
+      = if char# ># end1 then
+          if char# ># end2 then -- both strings ran out at once
+             EQ
+          else -- ps1 ran out before ps2
+             LT
+       else if char# ># end2 then
+          GT   -- ps2 ran out before ps1
+       else
+          let
+             ch1 = indexPS# ps1 char#
+             ch2 = indexPS# ps2 char#
+          in
+          if ch1 `eqChar#` ch2 then
+             looking_at (char# +# 1#)
+          else if ch1 `ltChar#` ch2 then LT
+                                    else GT
+
+
+-- -----------------------------------------------------------------------------
+-- Constructor functions
+
+-- Easy ones first.  @packString@ requires getting some heap-bytes and
+-- scribbling stuff into them.
+
+nilPS :: PackedString
+nilPS = CPS ""# 0#
+
+consPS :: Char -> PackedString -> PackedString
+consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better
+
+packString :: [Char] -> PackedString
+packString str = runST (packStringST str)
+
+packStringST :: [Char] -> ST s PackedString
+packStringST str =
+  let len = length str  in
+  packNCharsST len str
+
+packNCharsST :: Int -> [Char] -> ST s PackedString
+packNCharsST (I# length#) str =
+  {- 
+   allocate an array that will hold the string
+   (not forgetting the NUL byte at the end)
+  -}
+ new_ps_array (length# +# 1#) >>= \ ch_array ->
+   -- fill in packed string from "str"
+ fill_in ch_array 0# str   >>
+   -- freeze the puppy:
+ freeze_ps_array ch_array length# >>= \ (ByteArray _ _ frozen#) ->
+ let has_null = byteArrayHasNUL# frozen# length# in
+ return (PS frozen# length# has_null)
+ where
+  fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
+  fill_in arr_in# idx [] =
+   write_ps_array arr_in# idx (chr# 0#) >>
+   return ()
+
+  fill_in arr_in# idx (C# c : cs) =
+   write_ps_array arr_in# idx c         >>
+   fill_in arr_in# (idx +# 1#) cs
+
+byteArrayToPS :: ByteArray Int -> PackedString
+byteArrayToPS (ByteArray l u frozen#) =
+ let
+  ixs = (l,u)
+  n# = 
+   case (
+        if null (range ixs)
+         then 0
+         else ((index ixs u) + 1)
+        ) of { I# x -> x }
+ in
+ PS frozen# n# (byteArrayHasNUL# frozen# n#)
+
+-- byteArray is zero-terminated, make everything upto it
+-- a packed string.
+cByteArrayToPS :: ByteArray Int -> PackedString
+cByteArrayToPS (ByteArray l u frozen#) =
+ let
+  ixs = (l,u)
+  n# = 
+   case (
+        if null (range ixs)
+         then 0
+         else ((index ixs u) + 1)
+        ) of { I# x -> x }
+  len# = findNull 0#
+
+  findNull i#
+     | i# ==# n#          = n#
+     | ch# `eqChar#` '\0'# = i# -- everything upto the sentinel
+     | otherwise          = findNull (i# +# 1#)
+    where
+     ch#  = indexCharArray# frozen# i#
+ in
+ PS frozen# len# False
+
+unsafeByteArrayToPS :: ByteArray a -> Int -> PackedString
+unsafeByteArrayToPS (ByteArray _ _ frozen#) (I# n#)
+  = PS frozen# n# (byteArrayHasNUL# frozen# n#)
+
+psToByteArray   :: PackedString -> ByteArray Int
+psToByteArray (PS bytes n _) = ByteArray 0 (I# (n -# 1#)) bytes
+
+psToByteArray (CPS addr len#)
+  = let
+       len             = I# len#
+       byte_array_form = packCBytes len (Ptr addr)
+    in
+    case byte_array_form of { PS bytes _ _ ->
+    ByteArray 0 (len - 1) bytes }
+
+-- isCString is useful when passing PackedStrings to the
+-- outside world, and need to figure out whether you can
+-- pass it as an Addr or ByteArray.
+--
+isCString :: PackedString -> Bool
+isCString (CPS _ _ ) = True
+isCString _         = False
+
+-- psToCString doesn't add a zero terminator!
+-- this doesn't appear to be very useful --SDM
+psToCString :: PackedString -> Ptr a
+psToCString (CPS addr _)    = (Ptr addr)
+psToCString (PS bytes l# _) = 
+  unsafePerformIO $ do
+    stuff <- mallocBytes (I# (l# +# 1#))
+    let
+     fill_in n# i#
+      | n# ==# 0# = return ()
+      | otherwise = do
+         let ch#  = indexCharArray# bytes i#
+         pokeByteOff stuff (I# i#) (castCharToCChar (C# ch#))
+         fill_in (n# -# 1#) (i# +# 1#)
+    fill_in l# 0#
+    pokeByteOff stuff (I# l#) (C# '\0'#)
+    return stuff    
+
+-- -----------------------------------------------------------------------------
+-- Destructor functions (taking PackedStrings apart)
+
+-- OK, but this code gets *hammered*:
+-- unpackPS ps
+--   = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ]
+
+unpackPS :: PackedString -> [Char]
+unpackPS (PS bytes len _) = unpack 0#
+ where
+    unpack nh
+      | nh >=# len  = []
+      | otherwise   = C# ch : unpack (nh +# 1#)
+      where
+       ch = indexCharArray# bytes nh
+
+unpackPS (CPS addr _) = unpack 0#
+  where
+    unpack nh
+      | ch `eqChar#` '\0'# = []
+      | otherwise         = C# ch : unpack (nh +# 1#)
+      where
+       ch = indexCharOffAddr# addr nh
+
+unpackNBytesPS :: PackedString -> Int -> [Char]
+unpackNBytesPS ps len@(I# l#)
+ | len < 0     = error ("PackedString.unpackNBytesPS: negative length "++ show len)
+ | len == 0     = []
+ | otherwise    =
+    case ps of
+      PS bytes len# has_null -> unpackPS (PS bytes (min# len# l#) has_null)
+      CPS a len# -> unpackPS (CPS a (min# len# l#))
+ where
+  min# x# y# 
+    | x# <# y#  = x#
+    | otherwise = y#
+
+unpackPSIO :: PackedString -> IO String
+unpackPSIO ps@(PS bytes _ _) = return (unpackPS ps)
+unpackPSIO (CPS addr _)      = unpack 0#
+  where
+    unpack nh = do
+       ch <- peekByteOff (Ptr addr) (I# nh)
+       let c = castCCharToChar ch
+       if c == '\0'
+        then return []
+       else do
+          ls <- unpack (nh +# 1#)
+          return (c : ls)
+
+-- Output a packed string via a handle:
+
+hPutPS :: Handle -> PackedString -> IO ()
+hPutPS handle (CPS a# len#)    = hPutBuf handle (Ptr a#) (I# len#)
+hPutPS handle (PS  ba# len# _) = do
+   let mba = MutableByteArray (bottom::Int) bottom (unsafeCoerce# ba#)
+   hPutBufBA  handle mba (I# len#)
+  where
+    bottom = error "hPutPS"
+
+-- The dual to @_putPS@, note that the size of the chunk specified
+-- is the upper bound of the size of the chunk returned.
+
+hGetPS :: Handle -> Int -> IO PackedString
+hGetPS hdl len@(I# len#)
+ | len# <=# 0# = return nilPS -- I'm being kind here.
+ | otherwise   =
+    -- Allocate an array for system call to store its bytes into.
+   stToIO (new_ps_array len# )          >>= \ ch_arr ->
+   stToIO (freeze_ps_array ch_arr len#)  >>= \ (ByteArray _ _ frozen#) ->
+   hGetBufBA hdl ch_arr len >>= \  (I# read#) ->
+   if read# ==# 0# then -- EOF or other error
+      ioError (userError "hGetPS: EOF reached or other error")
+   else
+     {-
+       The system call may not return the number of
+       bytes requested. Instead of failing with an error
+       if the number of bytes read is less than requested,
+       a packed string containing the bytes we did manage
+       to snarf is returned.
+     -}
+     let
+      has_null = byteArrayHasNUL# frozen# read#
+     in 
+     return (PS frozen# read# has_null)
+
+-- -----------------------------------------------------------------------------
+-- List-mimicking functions for PackedStrings
+
+-- First, the basic functions that do look into the representation;
+-- @indexPS@ is the most important one.
+
+lengthPS   :: PackedString -> Int
+lengthPS ps = I# (lengthPS# ps)
+
+{-# INLINE lengthPS# #-}
+
+lengthPS# :: PackedString -> Int#
+lengthPS# (PS  _ i _) = i
+lengthPS# (CPS _ i)   = i
+
+{-# INLINE strlen# #-}
+
+strlen# :: Addr# -> Int
+strlen# a
+  = unsafePerformIO (
+    _ccall_ strlen (Ptr a)  >>= \ len@(I# _) ->
+    return len
+    )
+
+byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool
+byteArrayHasNUL# bs len
+  = unsafePerformIO (
+    _ccall_ byteArrayHasNUL__ ba (I# len)  >>= \ (I# res) ->
+    return (
+    if res ==# 0# then False else True
+    ))
+  where
+    ba = ByteArray 0 (I# (len -# 1#)) bs
+
+-----------------------
+
+indexPS :: PackedString -> Int -> Char
+indexPS ps (I# n) = C# (indexPS# ps n)
+
+{-# INLINE indexPS# #-}
+
+indexPS# :: PackedString -> Int# -> Char#
+indexPS# (PS bs i _) n
+  = --ASSERT (n >=# 0# && n <# i)      -- error checking: my eye!  (WDP 94/10)
+    indexCharArray# bs n
+
+indexPS# (CPS a _) n
+  = indexCharOffAddr# a n
+
+-- Now, the rest of the functions can be defined without digging
+-- around in the representation.
+
+headPS :: PackedString -> Char
+headPS ps
+  | nullPS ps = error "headPS: head []"
+  | otherwise  = C# (indexPS# ps 0#)
+
+tailPS :: PackedString -> PackedString
+tailPS ps
+  | len <=# 0# = error "tailPS: tail []"
+  | len ==# 1# = nilPS
+  | otherwise  = substrPS# ps 1# (len -# 1#)
+  where
+    len = lengthPS# ps
+
+nullPS :: PackedString -> Bool
+nullPS (PS  _ i _) = i ==# 0#
+nullPS (CPS _ i)   = i ==# 0#
+
+appendPS :: PackedString -> PackedString -> PackedString
+appendPS xs ys
+  | nullPS xs = ys
+  | nullPS ys = xs
+  | otherwise  = concatPS [xs,ys]
+
+mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-}
+mapPS f xs = 
+  if nullPS xs then
+     xs
+  else
+     runST (
+       new_ps_array (length +# 1#)         >>= \ ps_arr ->
+       whizz ps_arr length 0#              >>
+       freeze_ps_array ps_arr length       >>= \ (ByteArray _ _ frozen#) ->
+       let has_null = byteArrayHasNUL# frozen# length in
+       return (PS frozen# length has_null))
+  where
+   length = lengthPS# xs
+
+   whizz :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
+   whizz arr# n i 
+    | n ==# 0#
+      = write_ps_array arr# i (chr# 0#) >>
+       return ()
+    | otherwise
+      = let
+        ch = indexPS# xs i
+       in
+       write_ps_array arr# i (case f (C# ch) of { (C# x) -> x})     >>
+       whizz arr# (n -# 1#) (i +# 1#)
+
+filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
+filterPS pred ps = 
+  if nullPS ps then
+     ps
+  else
+     {-
+      Filtering proceeds as follows:
+      
+       * traverse the list, applying the pred. to each element,
+        remembering the positions where it was satisfied.
+
+        Encode these positions using a run-length encoding of the gaps
+        between the matching positions. 
+       * Allocate a MutableByteArray in the heap big enough to hold
+         all the matched entries, and copy the elements that matched over.
+
+      A better solution that merges the scan&copy passes into one,
+      would be to copy the filtered elements over into a growable
+      buffer. No such operation currently supported over
+      MutableByteArrays (could of course use malloc&realloc)
+      But, this solution may in the case of repeated realloc's
+      be worse than the current solution.
+     -}
+     runST (
+       let
+        (rle,len_filtered) = filter_ps (len# -# 1#) 0# 0# []
+       len_filtered#      = case len_filtered of { I# x# -> x#}
+       in
+       if len# ==# len_filtered# then 
+         {- not much filtering as everything passed through. -}
+         return ps
+       else if len_filtered# ==# 0# then
+        return nilPS
+       else
+         new_ps_array (len_filtered# +# 1#)   >>= \ ps_arr ->
+         copy_arr ps_arr rle 0# 0#            >>
+         freeze_ps_array ps_arr len_filtered# >>= \ (ByteArray _ _ frozen#) ->
+         let has_null = byteArrayHasNUL# frozen# len_filtered# in
+         return (PS frozen# len_filtered# has_null))
+  where
+   len# = lengthPS# ps
+
+   matchOffset :: Int# -> [Char] -> (Int,[Char])
+   matchOffset off [] = (I# off,[])
+   matchOffset off (C# c:cs) =
+    let
+     x    = ord# c
+     off' = off +# x
+    in
+    if x==# 0# then -- escape code, add 255#
+       matchOffset off' cs
+    else
+       (I# off', cs)
+
+   copy_arr :: MutableByteArray s Int -> [Char] -> Int# -> Int# -> ST s ()
+   copy_arr _    [_] _ _ = return ()
+   copy_arr arr# ls  n i =
+     let
+      (x,ls') = matchOffset 0# ls
+      n'      = n +# (case x of { (I# x#) -> x#}) -# 1#
+      ch      = indexPS# ps n'
+     in
+     write_ps_array arr# i ch                >>
+     copy_arr arr# ls' (n' +# 1#) (i +# 1#)
+
+   esc :: Int# -> Int# -> [Char] -> [Char]
+   esc v 0# ls = (C# (chr# v)):ls
+   esc v n  ls = esc v (n -# 1#) (C# (chr# 0#):ls)
+
+   filter_ps :: Int# -> Int# -> Int# -> [Char] -> ([Char],Int)
+   filter_ps n hits run acc
+    | n <# 0# = 
+        let
+        escs = run `quotInt#` 255#
+        v    = run `remInt#`  255#
+        in
+       (esc (v +# 1#) escs acc, I# hits)
+    | otherwise
+       = let
+          ch = indexPS# ps n
+          n' = n -# 1#
+        in
+         if pred (C# ch) then
+           let
+            escs = run `quotInt#` 255#
+            v    = run `remInt#`  255#
+            acc' = esc (v +# 1#) escs acc
+           in
+           filter_ps n' (hits +# 1#) 0# acc'
+        else
+           filter_ps n' hits (run +# 1#) acc
+
+
+foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
+foldlPS f b ps 
+ = if nullPS ps then
+      b 
+   else
+      whizzLR b 0#
+   where
+    len = lengthPS# ps
+
+    --whizzLR :: a -> Int# -> a
+    whizzLR b idx
+     | idx ==# len = b
+     | otherwise   = whizzLR (f b (C# (indexPS# ps idx))) (idx +# 1#)
+
+foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
+foldrPS f v ps
+  | nullPS ps = v
+  | otherwise = whizzRL v len
+   where
+    len = lengthPS# ps
+
+    --whizzRL :: a -> Int# -> a
+    whizzRL b idx
+     | idx <# 0# = b
+     | otherwise = whizzRL (f (C# (indexPS# ps idx)) b) (idx -# 1#)
+
+takePS :: Int -> PackedString -> PackedString
+takePS (I# n) ps 
+  | n ==# 0#   = nilPS
+  | otherwise  = substrPS# ps 0# (n -# 1#)
+
+dropPS :: Int -> PackedString -> PackedString
+dropPS (I# n) ps
+  | n ==# len = nilPS
+  | otherwise = substrPS# ps n  (lengthPS# ps -# 1#)
+  where
+    len = lengthPS# ps
+
+splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
+splitAtPS  n ps  = (takePS n ps, dropPS n ps)
+
+takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
+takeWhilePS pred ps
+  = let
+       break_pt = char_pos_that_dissatisfies
+                       (\ c -> pred (C# c))
+                       ps
+                       (lengthPS# ps)
+                       0#
+    in
+    if break_pt ==# 0# then
+       nilPS
+    else
+       substrPS# ps 0# (break_pt -# 1#)
+
+dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
+dropWhilePS pred ps
+  = let
+       len      = lengthPS# ps
+       break_pt = char_pos_that_dissatisfies
+                       (\ c -> pred (C# c))
+                       ps
+                       len
+                       0#
+    in
+    if len ==# break_pt then
+       nilPS
+    else
+       substrPS# ps break_pt (len -# 1#)
+
+elemPS :: Char -> PackedString -> Bool
+elemPS (C# ch) ps
+  = let
+       len      = lengthPS# ps
+       break_pt = first_char_pos_that_satisfies
+                       (`eqChar#` ch)
+                       ps
+                       len
+                       0#
+    in
+    break_pt <# len
+
+char_pos_that_dissatisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
+
+char_pos_that_dissatisfies p ps len pos
+  | pos >=# len                = pos -- end
+  | p (indexPS# ps pos) = -- predicate satisfied; keep going
+                         char_pos_that_dissatisfies p ps len (pos +# 1#)
+  | otherwise          = pos -- predicate not satisfied
+
+first_char_pos_that_satisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
+first_char_pos_that_satisfies p ps len pos
+  | pos >=# len                = pos -- end
+  | p (indexPS# ps pos) = pos -- got it!
+  | otherwise          = first_char_pos_that_satisfies p ps len (pos +# 1#)
+
+-- ToDo: could certainly go quicker
+spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+spanPS  p ps = (takeWhilePS p ps, dropWhilePS p ps)
+
+breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+breakPS p ps = spanPS (not . p) ps
+
+linesPS :: PackedString -> [PackedString]
+linesPS ps = splitPS '\n' ps
+
+wordsPS :: PackedString -> [PackedString]
+wordsPS ps = splitWithPS isSpace ps
+
+reversePS :: PackedString -> PackedString
+reversePS ps =
+  if nullPS ps then -- don't create stuff unnecessarily. 
+     ps
+  else
+    runST (
+      new_ps_array (length +# 1#)    >>= \ arr# -> -- incl NUL byte!
+      fill_in arr# (length -# 1#) 0# >>
+      freeze_ps_array arr# length    >>= \ (ByteArray _ _ frozen#) ->
+      let has_null = byteArrayHasNUL# frozen# length in
+      return (PS frozen# length has_null))
+ where
+  length = lengthPS# ps
+  
+  fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
+  fill_in arr_in# n i =
+   let
+    ch = indexPS# ps n
+   in
+   write_ps_array arr_in# i ch                  >>
+   if n ==# 0# then
+      write_ps_array arr_in# (i +# 1#) (chr# 0#) >>
+      return ()
+   else
+      fill_in arr_in# (n -# 1#) (i +# 1#)
+     
+concatPS :: [PackedString] -> PackedString
+concatPS [] = nilPS
+concatPS pss
+  = let
+       tot_len# = case (foldr ((+) . lengthPS) 0 pss) of { I# x -> x }
+    in
+    runST (
+    new_ps_array (tot_len# +# 1#)   >>= \ arr# -> -- incl NUL byte!
+    packum arr# pss 0#             >>
+    freeze_ps_array arr# tot_len#   >>= \ (ByteArray _ _ frozen#) ->
+
+    let has_null = byteArrayHasNUL# frozen# tot_len# in
+         
+    return (PS frozen# tot_len# has_null)
+    )
+  where
+    packum :: MutableByteArray s Int -> [PackedString] -> Int# -> ST s ()
+
+    packum arr [] pos
+      = write_ps_array arr pos (chr# 0#) >>
+       return ()
+    packum arr (ps : pss) pos
+      = fill arr pos ps 0# (lengthPS# ps)  >>= \ (I# next_pos) ->
+       packum arr pss next_pos
+
+    fill :: MutableByteArray s Int -> Int# -> PackedString -> Int# -> Int# -> ST s Int
+
+    fill arr arr_i ps ps_i ps_len
+     | ps_i ==# ps_len
+       = return (I# (arr_i +# ps_len))
+     | otherwise
+       = write_ps_array arr (arr_i +# ps_i) (indexPS# ps ps_i) >>
+        fill arr arr_i ps (ps_i +# 1#) ps_len
+
+------------------------------------------------------------
+joinPS :: PackedString -> [PackedString] -> PackedString
+joinPS filler pss = concatPS (splice pss)
+ where
+  splice []  = []
+  splice [x] = [x]
+  splice (x:y:xs) = x:filler:splice (y:xs)
+
+-- ToDo: the obvious generalisation
+{-
+  Some properties that hold:
+
+  * splitPS x ls = ls'   
+      where False = any (map (x `elemPS`) ls')
+            False = any (map (nullPS) ls')
+
+    * all x's have been chopped out.
+    * no empty PackedStrings in returned list. A conseq.
+      of this is:
+           splitPS x nilPS = []
+         
+
+  * joinPS (packString [x]) (_splitPS x ls) = ls
+
+-}
+
+splitPS :: Char -> PackedString -> [PackedString]
+splitPS (C# ch) = splitWithPS (\ (C# c) -> c `eqChar#` ch)
+
+splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]
+splitWithPS pred ps =
+ splitify 0#
+ where
+  len = lengthPS# ps
+  
+  splitify n 
+   | n >=# len = []
+   | otherwise =
+      let
+       break_pt = 
+         first_char_pos_that_satisfies
+           (\ c -> pred (C# c))
+           ps
+           len
+           n
+      in
+      if break_pt ==# n then -- immediate match, no substring to cut out.
+         splitify (break_pt +# 1#)
+      else 
+         substrPS# ps n (break_pt -# 1#): -- leave out the matching character
+         splitify (break_pt +# 1#)
+
+-- -----------------------------------------------------------------------------
+-- Local utility functions
+
+-- The definition of @_substrPS@ is essentially:
+-- @take (end - begin + 1) (drop begin str)@.
+
+substrPS :: PackedString -> Int -> Int -> PackedString
+substrPS ps (I# begin) (I# end) = substrPS# ps begin end
+
+substrPS# :: PackedString -> Int# -> Int# -> PackedString
+substrPS# ps s e
+  | s <# 0# || s >=# len || result_len# <=# 0#
+  = nilPS
+
+  | otherwise
+  = runST (
+       new_ps_array (result_len# +# 1#)   >>= \ ch_arr -> -- incl NUL byte!
+       fill_in ch_arr 0#                  >>
+       freeze_ps_array ch_arr result_len# >>= \ (ByteArray _ _ frozen#) ->
+
+       let has_null = byteArrayHasNUL# frozen# result_len# in
+         
+       return (PS frozen# result_len# has_null)
+    )
+  where
+    len = lengthPS# ps
+
+    result_len# = (if e <# len then (e +# 1#) else len) -# s
+
+    -----------------------
+    fill_in :: MutableByteArray s Int -> Int# -> ST s ()
+
+    fill_in arr_in# idx
+      | idx ==# result_len#
+      = write_ps_array arr_in# idx (chr# 0#) >>
+       return ()
+      | otherwise
+      = let
+           ch = indexPS# ps (s +# idx)
+       in
+       write_ps_array arr_in# idx ch        >>
+       fill_in arr_in# (idx +# 1#)
+
+-- -----------------------------------------------------------------------------
+-- Packing and unpacking C strings
+
+cStringToPS     :: Ptr a -> PackedString
+cStringToPS (Ptr a#) = -- the easy one; we just believe the caller
+ CPS a# len
+ where
+  len = case (strlen# a#) of { I# x -> x }
+
+packCBytes :: Int -> Ptr a -> PackedString
+packCBytes len addr = runST (packCBytesST len addr)
+
+packCBytesST :: Int -> Ptr a -> ST s PackedString
+packCBytesST (I# length#) (Ptr addr) =
+  {- 
+    allocate an array that will hold the string
+    (not forgetting the NUL byte at the end)
+  -}
+  new_ps_array (length# +# 1#)  >>= \ ch_array ->
+   -- fill in packed string from "addr"
+  fill_in ch_array 0#   >>
+   -- freeze the puppy:
+  freeze_ps_array ch_array length# >>= \ (ByteArray _ _ frozen#) ->
+  let has_null = byteArrayHasNUL# frozen# length# in
+  return (PS frozen# length# has_null)
+  where
+    fill_in :: MutableByteArray s Int -> Int# -> ST s ()
+
+    fill_in arr_in# idx
+      | idx ==# length#
+      = write_ps_array arr_in# idx (chr# 0#) >>
+       return ()
+      | otherwise
+      = case (indexCharOffAddr# addr idx) of { ch ->
+       write_ps_array arr_in# idx ch >>
+       fill_in arr_in# (idx +# 1#) }
diff --git a/libraries/base/Data/Ratio.hs b/libraries/base/Data/Ratio.hs
new file mode 100644 (file)
index 0000000..42426ce
--- /dev/null
@@ -0,0 +1,81 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.Ratio
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- $Id: Ratio.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Standard functions on rational numbers
+--
+-----------------------------------------------------------------------------
+
+module Data.Ratio
+    ( Ratio
+    , Rational
+    , (%)              -- :: (Integral a) => a -> a -> Ratio a
+    , numerator                -- :: (Integral a) => Ratio a -> a
+    , denominator      -- :: (Integral a) => Ratio a -> a
+    , approxRational   -- :: (RealFrac a) => a -> a -> Rational
+
+    -- Ratio instances: 
+    --   (Integral a) => Eq   (Ratio a)
+    --   (Integral a) => Ord  (Ratio a)
+    --   (Integral a) => Num  (Ratio a)
+    --   (Integral a) => Real (Ratio a)
+    --   (Integral a) => Fractional (Ratio a)
+    --   (Integral a) => RealFrac (Ratio a)
+    --   (Integral a) => Enum    (Ratio a)
+    --   (Read a, Integral a) => Read (Ratio a)
+    --   (Integral a) => Show    (Ratio a)
+
+  ) where
+
+import Prelude
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Real                -- The basic defns for Ratio
+#endif
+
+-- -----------------------------------------------------------------------------
+-- approxRational
+
+-- @approxRational@, applied to two real fractional numbers x and epsilon,
+-- returns the simplest rational number within epsilon of x.  A rational
+-- number n%d in reduced form is said to be simpler than another n'%d' if
+-- abs n <= abs n' && d <= d'.  Any real interval contains a unique
+-- simplest rational; here, for simplicity, we assume a closed rational
+-- interval.  If such an interval includes at least one whole number, then
+-- the simplest rational is the absolutely least whole number.  Otherwise,
+-- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d
+-- and abs r' < d', and the simplest rational is q%1 + the reciprocal of
+-- the simplest rational between d'%r' and d%r.
+
+approxRational         :: (RealFrac a) => a -> a -> Rational
+approxRational rat eps =  simplest (rat-eps) (rat+eps)
+       where simplest x y | y < x      =  simplest y x
+                          | x == y     =  xr
+                          | x > 0      =  simplest' n d n' d'
+                          | y < 0      =  - simplest' (-n') d' (-n) d
+                          | otherwise  =  0 :% 1
+                                       where xr  = toRational x
+                                             n   = numerator xr
+                                             d   = denominator xr
+                                             nd' = toRational y
+                                             n'  = numerator nd'
+                                             d'  = denominator nd'
+
+             simplest' n d n' d'       -- assumes 0 < n%d < n'%d'
+                       | r == 0     =  q :% 1
+                       | q /= q'    =  (q+1) :% 1
+                       | otherwise  =  (q*n''+d'') :% n''
+                                    where (q,r)      =  quotRem n d
+                                          (q',r')    =  quotRem n' d'
+                                          nd''       =  simplest' d' r' d r
+                                          n''        =  numerator nd''
+                                          d''        =  denominator nd''
+
diff --git a/libraries/base/Data/STRef.hs b/libraries/base/Data/STRef.hs
new file mode 100644 (file)
index 0000000..01e5cb0
--- /dev/null
@@ -0,0 +1,33 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Data.STRef
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: STRef.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Mutable references in the ST monad.
+--
+-----------------------------------------------------------------------------
+
+module Data.STRef (
+       STRef,          -- abstract, instance Eq
+       newSTRef,       -- :: a -> ST s (STRef s a)
+       readSTRef,      -- :: STRef s a -> ST s a
+       writeSTRef      -- :: STRef s a -> a -> ST s ()
+ ) where
+
+import Prelude
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.STRef
+#endif
+
+import Data.Dynamic
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
diff --git a/libraries/base/Data/Word.hs b/libraries/base/Data/Word.hs
new file mode 100644 (file)
index 0000000..7fbdc87
--- /dev/null
@@ -0,0 +1,38 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Word.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Sized unsigned integer types.
+--
+-----------------------------------------------------------------------------
+
+module Data.Word
+       ( Word
+       , Word8
+       , Word16
+       , Word32
+       , Word64
+       -- instances: Eq, Ord, Num, Bounded, Real, Integral, Ix, Enum, Read,
+       -- Show, Bits, CCallable, CReturnable (last two are GHC specific.)
+       ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Word
+#endif
+
+import Data.Dynamic
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE0(Word8,word8Tc, "Word8" )
+INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
+INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
+INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
diff --git a/libraries/base/Debug/Trace.hs b/libraries/base/Debug/Trace.hs
new file mode 100644 (file)
index 0000000..d5a012a
--- /dev/null
@@ -0,0 +1,41 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Debug.Trace
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- $Id: Trace.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The trace function.
+--
+-----------------------------------------------------------------------------
+
+module Debug.Trace (
+       trace -- :: String -> a -> a
+  ) where
+
+import Prelude
+import System.IO.Unsafe
+import System.IO
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.IOBase
+import GHC.Handle
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+{-# NOINLINE trace #-}
+trace :: String -> a -> a
+trace string expr = unsafePerformIO $ do
+    hPutStr stderr string
+    hPutChar stderr '\n'
+    fd <- withHandle_ "trace" stderr $ (return.haFD)
+    postTraceHook fd
+    return expr
+
+foreign import "PostTraceHook" postTraceHook :: Int -> IO ()
+#endif
diff --git a/libraries/base/Foreign.hs b/libraries/base/Foreign.hs
new file mode 100644 (file)
index 0000000..75639e4
--- /dev/null
@@ -0,0 +1,44 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Foreign
+-- Copyright   :  (c) The FFI task force 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  ffi@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Foreign.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+--
+-- A collection of data types, classes, and functions for interfacing
+-- with another programming language. This is only a convenience module
+-- in the future, but currently it has the additional task of hiding
+-- those entities exported from other modules, which are not part of the
+-- FFI proposal.
+--
+-----------------------------------------------------------------------------
+
+module Foreign
+        ( module Data.Int
+       , module Data.Word
+       , module Foreign.Ptr
+       , module Foreign.ForeignPtr
+       , module Foreign.StablePtr
+        , module Foreign.Storable
+       , module Foreign.Marshal.Alloc
+       , module Foreign.Marshal.Array
+       , module Foreign.Marshal.Error
+       , module Foreign.Marshal.Utils
+        ) where
+
+import Data.Int
+import Data.Word
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Foreign.StablePtr
+import Foreign.Storable
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Array
+import Foreign.Marshal.Error
+import Foreign.Marshal.Utils
diff --git a/libraries/base/Foreign/C.hs b/libraries/base/Foreign/C.hs
new file mode 100644 (file)
index 0000000..b91d6d7
--- /dev/null
@@ -0,0 +1,28 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Foreign.C
+-- Copyright   :  (c) The FFI task force 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  ffi@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: C.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- Bundles the C specific FFI library functionality
+--
+-----------------------------------------------------------------------------
+
+module Foreign.C
+        ( module Foreign.C.Types
+       , module Foreign.C.TypesISO
+       , module Foreign.C.String
+       , module Foreign.C.Error
+        ) where
+
+import Foreign.C.Types
+import Foreign.C.TypesISO
+import Foreign.C.String
+import Foreign.C.Error
diff --git a/libraries/base/Foreign/C/Error.hs b/libraries/base/Foreign/C/Error.hs
new file mode 100644 (file)
index 0000000..3bba4ed
--- /dev/null
@@ -0,0 +1,514 @@
+{-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-}
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Foreign.C.Error
+-- Copyright   :  (c) The FFI task force 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  ffi@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Error.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- C-specific Marshalling support: Handling of C "errno" error codes
+--
+-----------------------------------------------------------------------------
+
+module Foreign.C.Error (
+
+  -- Haskell representation for "errno" values
+  --
+  Errno(..),           -- instance: Eq
+  eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN, 
+  eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED, 
+  eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT, 
+  eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ, 
+  eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK, 
+  eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH, 
+  eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK, 
+  eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS, 
+  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO, 
+  eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL, 
+  ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE, 
+  eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN, 
+  eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT, 
+  eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV,
+                        -- :: Errno
+  isValidErrno,                -- :: Errno -> Bool
+
+  -- access to the current thread's "errno" value
+  --
+  getErrno,             -- :: IO Errno
+  resetErrno,           -- :: IO ()
+
+  -- conversion of an "errno" value into IO error
+  --
+  errnoToIOError,       -- :: String       -- location
+                        -- -> Errno        -- errno
+                        -- -> Maybe Handle -- handle
+                        -- -> Maybe String -- filename
+                        -- -> IOError
+
+  -- throw current "errno" value
+  --
+  throwErrno,           -- ::                String               -> IO a
+
+  -- guards for IO operations that may fail
+  --
+  throwErrnoIf,         -- :: (a -> Bool) -> String -> IO a       -> IO a
+  throwErrnoIf_,        -- :: (a -> Bool) -> String -> IO a       -> IO ()
+  throwErrnoIfRetry,    -- :: (a -> Bool) -> String -> IO a       -> IO a
+  throwErrnoIfRetry_,   -- :: (a -> Bool) -> String -> IO a       -> IO ()
+  throwErrnoIfMinus1,   -- :: Num a 
+                       -- =>                String -> IO a       -> IO a
+  throwErrnoIfMinus1_,  -- :: Num a 
+                       -- =>                String -> IO a       -> IO ()
+  throwErrnoIfMinus1Retry,  
+                       -- :: Num a 
+                       -- =>                String -> IO a       -> IO a
+  throwErrnoIfMinus1Retry_,  
+                       -- :: Num a 
+                       -- =>                String -> IO a       -> IO ()
+  throwErrnoIfNull,    -- ::                String -> IO (Ptr a) -> IO (Ptr a)
+  throwErrnoIfNullRetry,-- ::                String -> IO (Ptr a) -> IO (Ptr a)
+
+  throwErrnoIfRetryMayBlock, 
+  throwErrnoIfRetryMayBlock_,
+  throwErrnoIfMinus1RetryMayBlock,
+  throwErrnoIfMinus1RetryMayBlock_,  
+  throwErrnoIfNullRetryMayBlock
+) where
+
+
+-- this is were we get the CCONST_XXX definitions from that configure
+-- calculated for us
+--
+#include "config.h"
+
+-- system dependent imports
+-- ------------------------
+
+-- GHC allows us to get at the guts inside IO errors/exceptions
+--
+#if __GLASGOW_HASKELL__
+import GHC.IOBase (Exception(..), IOException(..), IOErrorType(..))
+#endif /* __GLASGOW_HASKELL__ */
+
+
+-- regular imports
+-- ---------------
+
+import Foreign.Ptr
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Marshal.Error   ( void )
+import Data.Maybe
+
+#if __GLASGOW_HASKELL__
+import GHC.Storable
+import GHC.IOBase
+import GHC.Num
+import GHC.Base
+#else
+import System.IO               ( IOError, Handle, ioError )
+#endif
+
+-- "errno" type
+-- ------------
+
+-- import of C function that gives address of errno
+--
+foreign import "ghcErrno" unsafe _errno :: Ptr CInt
+
+-- Haskell representation for "errno" values
+--
+newtype Errno = Errno CInt
+
+instance Eq Errno where
+  errno1@(Errno no1) == errno2@(Errno no2) 
+    | isValidErrno errno1 && isValidErrno errno2 = no1 == no2
+    | otherwise                                         = False
+
+-- common "errno" symbols
+--
+eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN, 
+  eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED, 
+  eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT, 
+  eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ, 
+  eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK, 
+  eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH, 
+  eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK, 
+  eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS, 
+  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO, 
+  eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL, 
+  ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE, 
+  eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN, 
+  eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT, 
+  eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV                   :: Errno
+--
+-- the CCONST_XXX identifiers are cpp symbols whose value is computed by
+-- configure 
+--
+eOK             = Errno 0
+e2BIG           = Errno (CCONST_E2BIG)
+eACCES         = Errno (CCONST_EACCES)
+eADDRINUSE     = Errno (CCONST_EADDRINUSE)
+eADDRNOTAVAIL  = Errno (CCONST_EADDRNOTAVAIL)
+eADV           = Errno (CCONST_EADV)
+eAFNOSUPPORT   = Errno (CCONST_EAFNOSUPPORT)
+eAGAIN         = Errno (CCONST_EAGAIN)
+eALREADY       = Errno (CCONST_EALREADY)
+eBADF          = Errno (CCONST_EBADF)
+eBADMSG                = Errno (CCONST_EBADMSG)
+eBADRPC                = Errno (CCONST_EBADRPC)
+eBUSY          = Errno (CCONST_EBUSY)
+eCHILD         = Errno (CCONST_ECHILD)
+eCOMM          = Errno (CCONST_ECOMM)
+eCONNABORTED   = Errno (CCONST_ECONNABORTED)
+eCONNREFUSED   = Errno (CCONST_ECONNREFUSED)
+eCONNRESET     = Errno (CCONST_ECONNRESET)
+eDEADLK                = Errno (CCONST_EDEADLK)
+eDESTADDRREQ   = Errno (CCONST_EDESTADDRREQ)
+eDIRTY         = Errno (CCONST_EDIRTY)
+eDOM           = Errno (CCONST_EDOM)
+eDQUOT         = Errno (CCONST_EDQUOT)
+eEXIST         = Errno (CCONST_EEXIST)
+eFAULT         = Errno (CCONST_EFAULT)
+eFBIG          = Errno (CCONST_EFBIG)
+eFTYPE         = Errno (CCONST_EFTYPE)
+eHOSTDOWN      = Errno (CCONST_EHOSTDOWN)
+eHOSTUNREACH   = Errno (CCONST_EHOSTUNREACH)
+eIDRM          = Errno (CCONST_EIDRM)
+eILSEQ         = Errno (CCONST_EILSEQ)
+eINPROGRESS    = Errno (CCONST_EINPROGRESS)
+eINTR          = Errno (CCONST_EINTR)
+eINVAL         = Errno (CCONST_EINVAL)
+eIO            = Errno (CCONST_EIO)
+eISCONN                = Errno (CCONST_EISCONN)
+eISDIR         = Errno (CCONST_EISDIR)
+eLOOP          = Errno (CCONST_ELOOP)
+eMFILE         = Errno (CCONST_EMFILE)
+eMLINK         = Errno (CCONST_EMLINK)
+eMSGSIZE       = Errno (CCONST_EMSGSIZE)
+eMULTIHOP      = Errno (CCONST_EMULTIHOP)
+eNAMETOOLONG   = Errno (CCONST_ENAMETOOLONG)
+eNETDOWN       = Errno (CCONST_ENETDOWN)
+eNETRESET      = Errno (CCONST_ENETRESET)
+eNETUNREACH    = Errno (CCONST_ENETUNREACH)
+eNFILE         = Errno (CCONST_ENFILE)
+eNOBUFS                = Errno (CCONST_ENOBUFS)
+eNODATA                = Errno (CCONST_ENODATA)
+eNODEV         = Errno (CCONST_ENODEV)
+eNOENT         = Errno (CCONST_ENOENT)
+eNOEXEC                = Errno (CCONST_ENOEXEC)
+eNOLCK         = Errno (CCONST_ENOLCK)
+eNOLINK                = Errno (CCONST_ENOLINK)
+eNOMEM         = Errno (CCONST_ENOMEM)
+eNOMSG         = Errno (CCONST_ENOMSG)
+eNONET         = Errno (CCONST_ENONET)
+eNOPROTOOPT    = Errno (CCONST_ENOPROTOOPT)
+eNOSPC         = Errno (CCONST_ENOSPC)
+eNOSR          = Errno (CCONST_ENOSR)
+eNOSTR         = Errno (CCONST_ENOSTR)
+eNOSYS         = Errno (CCONST_ENOSYS)
+eNOTBLK                = Errno (CCONST_ENOTBLK)
+eNOTCONN       = Errno (CCONST_ENOTCONN)
+eNOTDIR                = Errno (CCONST_ENOTDIR)
+eNOTEMPTY      = Errno (CCONST_ENOTEMPTY)
+eNOTSOCK       = Errno (CCONST_ENOTSOCK)
+eNOTTY         = Errno (CCONST_ENOTTY)
+eNXIO          = Errno (CCONST_ENXIO)
+eOPNOTSUPP     = Errno (CCONST_EOPNOTSUPP)
+ePERM          = Errno (CCONST_EPERM)
+ePFNOSUPPORT   = Errno (CCONST_EPFNOSUPPORT)
+ePIPE          = Errno (CCONST_EPIPE)
+ePROCLIM       = Errno (CCONST_EPROCLIM)
+ePROCUNAVAIL   = Errno (CCONST_EPROCUNAVAIL)
+ePROGMISMATCH  = Errno (CCONST_EPROGMISMATCH)
+ePROGUNAVAIL   = Errno (CCONST_EPROGUNAVAIL)
+ePROTO         = Errno (CCONST_EPROTO)
+ePROTONOSUPPORT = Errno (CCONST_EPROTONOSUPPORT)
+ePROTOTYPE     = Errno (CCONST_EPROTOTYPE)
+eRANGE         = Errno (CCONST_ERANGE)
+eREMCHG                = Errno (CCONST_EREMCHG)
+eREMOTE                = Errno (CCONST_EREMOTE)
+eROFS          = Errno (CCONST_EROFS)
+eRPCMISMATCH   = Errno (CCONST_ERPCMISMATCH)
+eRREMOTE       = Errno (CCONST_ERREMOTE)
+eSHUTDOWN      = Errno (CCONST_ESHUTDOWN)
+eSOCKTNOSUPPORT = Errno (CCONST_ESOCKTNOSUPPORT)
+eSPIPE         = Errno (CCONST_ESPIPE)
+eSRCH          = Errno (CCONST_ESRCH)
+eSRMNT         = Errno (CCONST_ESRMNT)
+eSTALE         = Errno (CCONST_ESTALE)
+eTIME          = Errno (CCONST_ETIME)
+eTIMEDOUT      = Errno (CCONST_ETIMEDOUT)
+eTOOMANYREFS   = Errno (CCONST_ETOOMANYREFS)
+eTXTBSY                = Errno (CCONST_ETXTBSY)
+eUSERS         = Errno (CCONST_EUSERS)
+eWOULDBLOCK    = Errno (CCONST_EWOULDBLOCK)
+eXDEV          = Errno (CCONST_EXDEV)
+
+-- checks whether the given errno value is supported on the current
+-- architecture
+--
+isValidErrno               :: Errno -> Bool
+--
+-- the configure script sets all invalid "errno"s to -1
+--
+isValidErrno (Errno errno)  = errno /= -1
+
+
+-- access to the current thread's "errno" value
+-- --------------------------------------------
+
+-- yield the current thread's "errno" value
+--
+getErrno :: IO Errno
+getErrno  = do e <- peek _errno; return (Errno e)
+
+-- set the current thread's "errno" value to 0
+--
+resetErrno :: IO ()
+resetErrno  = poke _errno 0
+
+
+-- throw current "errno" value
+-- ---------------------------
+
+-- the common case: throw an IO error based on a textual description
+-- of the error location and the current thread's "errno" value
+--
+throwErrno     :: String -> IO a
+throwErrno loc  =
+  do
+    errno <- getErrno
+    ioError (errnoToIOError loc errno Nothing Nothing)
+
+
+-- guards for IO operations that may fail
+-- --------------------------------------
+
+-- guard an IO operation and throw an "errno" based exception of the result
+-- value of the IO operation meets the given predicate
+--
+throwErrnoIf            :: (a -> Bool) -> String -> IO a -> IO a
+throwErrnoIf pred loc f  = 
+  do
+    res <- f
+    if pred res then throwErrno loc else return res
+
+-- as `throwErrnoIf', but discards the result
+--
+throwErrnoIf_            :: (a -> Bool) -> String -> IO a -> IO ()
+throwErrnoIf_ pred loc f  = void $ throwErrnoIf pred loc f
+
+-- as `throwErrnoIf', but retries interrupted IO operations (ie, those whose
+-- flag `EINTR')
+--
+throwErrnoIfRetry            :: (a -> Bool) -> String -> IO a -> IO a
+throwErrnoIfRetry pred loc f  = 
+  do
+    res <- f
+    if pred res
+      then do
+       err <- getErrno
+       if err == eINTR
+         then throwErrnoIfRetry pred loc f
+         else throwErrno loc
+      else return res
+
+-- as `throwErrnoIfRetry', but checks for operations that would block and
+-- executes an alternative action in that case.
+
+throwErrnoIfRetryMayBlock  :: (a -> Bool) -> String -> IO a -> IO b -> IO a
+throwErrnoIfRetryMayBlock pred loc f on_block  = 
+  do
+    res <- f
+    if pred res
+      then do
+       err <- getErrno
+       if err == eINTR
+         then throwErrnoIfRetryMayBlock pred loc f on_block
+          else if err == eWOULDBLOCK || err == eAGAIN
+                then do on_block; throwErrnoIfRetryMayBlock pred loc f on_block
+                 else throwErrno loc
+      else return res
+
+-- as `throwErrnoIfRetry', but discards the result
+--
+throwErrnoIfRetry_            :: (a -> Bool) -> String -> IO a -> IO ()
+throwErrnoIfRetry_ pred loc f  = void $ throwErrnoIfRetry pred loc f
+
+-- as `throwErrnoIfRetryMayBlock', but discards the result
+--
+throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO ()
+throwErrnoIfRetryMayBlock_ pred loc f on_block 
+  = void $ throwErrnoIfRetryMayBlock pred loc f on_block
+
+-- throws "errno" if a result of "-1" is returned
+--
+throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a
+throwErrnoIfMinus1  = throwErrnoIf (== -1)
+
+-- as `throwErrnoIfMinus1', but discards the result
+--
+throwErrnoIfMinus1_ :: Num a => String -> IO a -> IO ()
+throwErrnoIfMinus1_  = throwErrnoIf_ (== -1)
+
+-- throws "errno" if a result of "-1" is returned, but retries in case of an
+-- interrupted operation
+--
+throwErrnoIfMinus1Retry :: Num a => String -> IO a -> IO a
+throwErrnoIfMinus1Retry  = throwErrnoIfRetry (== -1)
+
+-- as `throwErrnoIfMinus1', but discards the result
+--
+throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO ()
+throwErrnoIfMinus1Retry_  = throwErrnoIfRetry_ (== -1)
+
+-- as throwErrnoIfMinus1Retry, but checks for operations that would block
+--
+throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a
+throwErrnoIfMinus1RetryMayBlock  = throwErrnoIfRetryMayBlock (== -1)
+
+-- as `throwErrnoIfMinus1RetryMayBlock', but discards the result
+--
+throwErrnoIfMinus1RetryMayBlock_ :: Num a => String -> IO a -> IO b -> IO ()
+throwErrnoIfMinus1RetryMayBlock_  = throwErrnoIfRetryMayBlock_ (== -1)
+
+-- throws "errno" if a result of a NULL pointer is returned
+--
+throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
+throwErrnoIfNull  = throwErrnoIf (== nullPtr)
+
+-- throws "errno" if a result of a NULL pointer is returned, but retries in
+-- case of an interrupted operation
+--
+throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a)
+throwErrnoIfNullRetry  = throwErrnoIfRetry (== nullPtr)
+
+-- as throwErrnoIfNullRetry, but checks for operations that would block
+--
+throwErrnoIfNullRetryMayBlock :: String -> IO (Ptr a) -> IO b -> IO (Ptr a)
+throwErrnoIfNullRetryMayBlock  = throwErrnoIfRetryMayBlock (== nullPtr)
+
+-- conversion of an "errno" value into IO error
+-- --------------------------------------------
+
+-- convert a location string, an "errno" value, an optional handle,
+-- and an optional filename into a matching IO error
+--
+errnoToIOError :: String -> Errno -> Maybe Handle -> Maybe String -> IOError
+errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do
+    str <- strerror errno >>= peekCString
+#if __GLASGOW_HASKELL__
+    return (IOException (IOError maybeHdl errType loc str maybeName))
+    where
+    errType
+        | errno == eOK             = OtherError
+        | errno == e2BIG           = ResourceExhausted
+        | errno == eACCES          = PermissionDenied
+        | errno == eADDRINUSE      = ResourceBusy
+        | errno == eADDRNOTAVAIL   = UnsupportedOperation
+        | errno == eADV            = OtherError
+        | errno == eAFNOSUPPORT    = UnsupportedOperation
+        | errno == eAGAIN          = ResourceExhausted
+        | errno == eALREADY        = AlreadyExists
+        | errno == eBADF           = OtherError
+        | errno == eBADMSG         = InappropriateType
+        | errno == eBADRPC         = OtherError
+        | errno == eBUSY           = ResourceBusy
+        | errno == eCHILD          = NoSuchThing
+        | errno == eCOMM           = ResourceVanished
+        | errno == eCONNABORTED    = OtherError
+        | errno == eCONNREFUSED    = NoSuchThing
+        | errno == eCONNRESET      = ResourceVanished
+        | errno == eDEADLK         = ResourceBusy
+        | errno == eDESTADDRREQ    = InvalidArgument
+        | errno == eDIRTY          = UnsatisfiedConstraints
+        | errno == eDOM            = InvalidArgument
+        | errno == eDQUOT          = PermissionDenied
+        | errno == eEXIST          = AlreadyExists
+        | errno == eFAULT          = OtherError</