Skip to content
Browse files

[project @ 2001-06-28 14:15:04 by 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...
  • Loading branch information...
0 parents commit 7f1f4e7a695c402ddd3a1dc2cc7114e649a78ebc simonmar committed Jun 28, 2001
Showing with 19,795 additions and 0 deletions.
  1. +199 −0 Control/Concurrent.hs
  2. +57 −0 Control/Concurrent/CVar.hs
  3. +119 −0 Control/Concurrent/Chan.hs
  4. +95 −0 Control/Concurrent/MVar.hs
  5. +67 −0 Control/Concurrent/QSem.hs
  6. +60 −0 Control/Concurrent/QSemN.hs
  7. +98 −0 Control/Concurrent/SampleVar.hs
  8. +226 −0 Control/Exception.hs
  9. +160 −0 Control/Monad.hs
  10. +122 −0 Control/Monad/Cont.hs
  11. +224 −0 Control/Monad/Error.hs
  12. +55 −0 Control/Monad/Fix.hs
  13. +63 −0 Control/Monad/Identity.hs
  14. +87 −0 Control/Monad/List.hs
  15. +58 −0 Control/Monad/Monoid.hs
  16. +170 −0 Control/Monad/RWS.hs
  17. +143 −0 Control/Monad/Reader.hs
  18. +53 −0 Control/Monad/ST.hs
  19. +247 −0 Control/Monad/ST/Lazy.hs
  20. +22 −0 Control/Monad/ST/Strict.hs
  21. +227 −0 Control/Monad/State.hs
  22. +46 −0 Control/Monad/Trans.hs
  23. +170 −0 Control/Monad/Writer.hs
  24. +62 −0 Control/Parallel.hs
  25. +964 −0 Control/Parallel/Strategies.hs
  26. +145 −0 Data/Array.hs
  27. +1,163 −0 Data/Array/Base.hs
  28. +42 −0 Data/Array/IArray.hs
  29. +365 −0 Data/Array/IO.hs
  30. +47 −0 Data/Array/MArray.hs
  31. +35 −0 Data/Array/ST.hs
  32. +25 −0 Data/Array/Unboxed.hs
  33. +143 −0 Data/Bits.hs
  34. +28 −0 Data/Bool.hs
  35. +51 −0 Data/Char.hs
  36. +153 −0 Data/Complex.hs
  37. +288 −0 Data/Dynamic.hs
  38. +25 −0 Data/Either.hs
  39. +57 −0 Data/IORef.hs
  40. +37 −0 Data/Int.hs
  41. +43 −0 Data/Ix.hs
  42. +537 −0 Data/List.hs
  43. +75 −0 Data/Maybe.hs
  44. +914 −0 Data/PackedString.hs
  45. +81 −0 Data/Ratio.hs
  46. +33 −0 Data/STRef.hs
  47. +38 −0 Data/Word.hs
  48. +41 −0 Debug/Trace.hs
  49. +44 −0 Foreign.hs
  50. +28 −0 Foreign/C.hs
  51. +514 −0 Foreign/C/Error.hs
  52. +179 −0 Foreign/C/String.hs
  53. +114 −0 Foreign/C/Types.hs
  54. +84 −0 Foreign/C/TypesISO.hs
  55. +88 −0 Foreign/ForeignPtr.hs
  56. +115 −0 Foreign/Marshal/Alloc.hs
  57. +268 −0 Foreign/Marshal/Array.hs
  58. +81 −0 Foreign/Marshal/Error.hs
  59. +168 −0 Foreign/Marshal/Utils.hs
  60. +55 −0 Foreign/Ptr.hs
  61. +35 −0 Foreign/StablePtr.hs
  62. +33 −0 Foreign/Storable.hs
  63. +574 −0 GHC/Arr.lhs
  64. +761 −0 GHC/Base.lhs
  65. +184 −0 GHC/ByteArr.lhs
  66. +202 −0 GHC/Conc.lhs
  67. +35 −0 GHC/Dynamic.lhs
  68. +414 −0 GHC/Enum.lhs
  69. +12 −0 GHC/Err.hi-boot
  70. +129 −0 GHC/Err.lhs
  71. +123 −0 GHC/Exception.lhs
  72. +892 −0 GHC/Float.lhs
  73. +1,191 −0 GHC/Handle.hsc
  74. +787 −0 GHC/IO.hsc
  75. +605 −0 GHC/IOBase.lhs
  76. +599 −0 GHC/Int.lhs
  77. +610 −0 GHC/List.lhs
  78. +24 −0 GHC/Main.lhs
  79. +64 −0 GHC/Maybe.lhs
  80. +14 −0 GHC/Num.hi-boot
  81. +447 −0 GHC/Num.lhs
  82. +231 −0 GHC/Pack.lhs
  83. +295 −0 GHC/Posix.hsc
  84. +441 −0 GHC/Prim.hi-boot
  85. +61 −0 GHC/Ptr.lhs
  86. +608 −0 GHC/Read.lhs
  87. +369 −0 GHC/Real.lhs
  88. +127 −0 GHC/ST.lhs
  89. +30 −0 GHC/STRef.lhs
Sorry, we could not display the entire diff because it was too big.
199 Control/Concurrent.hs
@@ -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)
57 Control/Concurrent/CVar.hs
@@ -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
119 Control/Concurrent/Chan.hs
@@ -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)
95 Control/Concurrent/MVar.hs
@@ -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
67 Control/Concurrent/QSem.hs
@@ -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 ()
60 Control/Concurrent/QSemN.hs
@@ -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')
98 Control/Concurrent/SampleVar.hs
@@ -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)
226 Control/Exception.hs
@@ -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)
160 Control/Monad.hs
@@ -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) }
122 Control/Monad/Cont.hs
@@ -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
224 Control/Monad/Error.hs
@@ -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
55 Control/Monad/Fix.hs
@@ -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
63 Control/Monad/Identity.hs
@@ -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))
87 Control/Monad/List.hs
@@ -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)
58 Control/Monad/Monoid.hs
@@ -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 _ = ()
170 Control/Monad/RWS.hs
@@ -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)
143 Control/Monad/Reader.hs
@@ -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
53 Control/Monad/ST.hs
@@ -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)]
247 Control/Monad/ST/Lazy.hs
@@ -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