Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Remove non-random stuff (of base), and rename package to "random"

  • Loading branch information...
commit 559e696cc1c9601f45083da767bb81533f99d3c8 1 parent 6b1a36a
@igfoo igfoo authored
Showing with 0 additions and 28,222 deletions.
  1. +0 −220 Control/Applicative.hs
  2. +0 −281 Control/Arrow.hs
  3. +0 −546 Control/Concurrent.hs
  4. +0 −132 Control/Concurrent/Chan.hs
  5. +0 −114 Control/Concurrent/MVar.hs
  6. +0 −77 Control/Concurrent/QSem.hs
  7. +0 −70 Control/Concurrent/QSemN.hs
  8. +0 −117 Control/Concurrent/SampleVar.hs
  9. +0 −592 Control/Exception.hs
  10. +0 −334 Control/Monad.hs
  11. +0 −73 Control/Monad/Fix.hs
  12. +0 −31 Control/Monad/Instances.hs
  13. +0 −64 Control/Monad/ST.hs
  14. +0 −152 Control/Monad/ST/Lazy.hs
  15. +0 −20 Control/Monad/ST/Strict.hs
  16. +0 −88 Data/Array.hs
  17. +0 −1,686 Data/Array/Base.hs
  18. +0 −423 Data/Array/Diff.hs
  19. +0 −51 Data/Array/IArray.hs
  20. +0 −262 Data/Array/IO.hs
  21. +0 −322 Data/Array/IO/Internals.hs
  22. +0 −55 Data/Array/MArray.hs
  23. +0 −77 Data/Array/ST.hs
  24. +0 −92 Data/Array/Storable.hs
  25. +0 −26 Data/Array/Unboxed.hs
  26. +0 −342 Data/Bits.hs
  27. +0 −39 Data/Bool.hs
  28. +0 −2,020 Data/ByteString.hs
  29. +0 −514 Data/ByteString/Base.hs
  30. +0 −995 Data/ByteString/Char8.hs
  31. +0 −699 Data/ByteString/Fusion.hs
  32. +0 −1,293 Data/ByteString/Lazy.hs
  33. +0 −748 Data/ByteString/Lazy/Char8.hs
  34. +0 −211 Data/Char.hs
  35. +0 −200 Data/Complex.hs
  36. +0 −166 Data/Dynamic.hs
  37. +0 −5 Data/Dynamic.hs-boot
  38. +0 −42 Data/Either.hs
  39. +0 −22 Data/Eq.hs
  40. +0 −147 Data/Fixed.hs
  41. +0 −301 Data/Foldable.hs
  42. +0 −83 Data/Function.hs
  43. +0 −53 Data/Generics.hs
  44. +0 −368 Data/Generics/Aliases.hs
  45. +0 −766 Data/Generics/Basics.hs
  46. +0 −617 Data/Generics/Instances.hs
  47. +0 −168 Data/Generics/Schemes.hs
  48. +0 −124 Data/Generics/Text.hs
  49. +0 −250 Data/Generics/Twins.hs
  50. +0 −432 Data/Graph.hs
  51. +0 −466 Data/HashTable.hs
  52. +0 −93 Data/IORef.hs
  53. +0 −65 Data/Int.hs
  54. +0 −1,549 Data/IntMap.hs
  55. +0 −1,020 Data/IntSet.hs
  56. +0 −76 Data/Ix.hs
  57. +0 −969 Data/List.hs
  58. +0 −1,846 Data/Map.hs
  59. +0 −149 Data/Maybe.hs
  60. +0 −253 Data/Monoid.hs
  61. +0 −34 Data/Ord.hs
  62. +0 −434 Data/PackedString.hs
  63. +0 −94 Data/Ratio.hs
  64. +0 −41 Data/STRef.hs
  65. +0 −34 Data/STRef/Lazy.hs
  66. +0 −20 Data/STRef/Strict.hs
  67. +0 −1,124 Data/Sequence.hs
  68. +0 −1,149 Data/Set.hs
  69. +0 −31 Data/String.hs
  70. +0 −139 Data/Traversable.hs
  71. +0 −166 Data/Tree.hs
  72. +0 −276 Data/Tuple.hs
  73. +0 −683 Data/Typeable.hs
  74. +0 −18 Data/Typeable.hs-boot
  75. +0 −61 Data/Unique.hs
  76. +0 −152 Data/Version.hs
  77. +0 −68 Data/Word.hs
  78. +0 −67 Debug/Trace.hs
  79. +0 −41 Foreign.hs
  80. +0 −24 Foreign/C.hs
  81. +0 −570 Foreign/C/Error.hs
Sorry, we could not display the entire diff because it was too big.
View
220 Control/Applicative.hs
@@ -1,220 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Control.Applicative
--- Copyright : Conor McBride and Ross Paterson 2005
--- License : BSD-style (see the LICENSE file in the distribution)
---
--- Maintainer : ross@soi.city.ac.uk
--- Stability : experimental
--- Portability : portable
---
--- This module describes a structure intermediate between a functor and
--- a monad: it provides pure expressions and sequencing, but no binding.
--- (Technically, a strong lax monoidal functor.) For more details, see
--- /Applicative Programming with Effects/,
--- by Conor McBride and Ross Paterson, online at
--- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.
---
--- This interface was introduced for parsers by Niklas R&#xF6;jemo, because
--- it admits more sharing than the monadic interface. The names here are
--- mostly based on recent parsing work by Doaitse Swierstra.
---
--- This class is also useful with instances of the
--- 'Data.Traversable.Traversable' class.
-
-module Control.Applicative (
- -- * Applicative functors
- Applicative(..),
- -- * Alternatives
- Alternative(..),
- -- * Instances
- Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),
- -- * Utility functions
- (<$>), (<$), (*>), (<*), (<**>),
- liftA, liftA2, liftA3,
- optional, some, many
- ) where
-
-#ifdef __HADDOCK__
-import Prelude
-#endif
-
-import Control.Arrow
- (Arrow(arr, (>>>), (&&&)), ArrowZero(zeroArrow), ArrowPlus((<+>)))
-import Control.Monad (liftM, ap, MonadPlus(..))
-import Control.Monad.Instances ()
-import Data.Monoid (Monoid(..))
-
-infixl 3 <|>
-infixl 4 <$>, <$
-infixl 4 <*>, <*, *>, <**>
-
--- | A functor with application.
---
--- Instances should satisfy the following laws:
---
--- [/identity/]
--- @'pure' 'id' '<*>' v = v@
---
--- [/composition/]
--- @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@
---
--- [/homomorphism/]
--- @'pure' f '<*>' 'pure' x = 'pure' (f x)@
---
--- [/interchange/]
--- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@
---
--- The 'Functor' instance should satisfy
---
--- @
--- 'fmap' f x = 'pure' f '<*>' x
--- @
---
--- If @f@ is also a 'Monad', define @'pure' = 'return'@ and @('<*>') = 'ap'@.
-
-class Functor f => Applicative f where
- -- | Lift a value.
- pure :: a -> f a
-
- -- | Sequential application.
- (<*>) :: f (a -> b) -> f a -> f b
-
--- | A monoid on applicative functors.
-class Applicative f => Alternative f where
- -- | The identity of '<|>'
- empty :: f a
- -- | An associative binary operation
- (<|>) :: f a -> f a -> f a
-
--- instances for Prelude types
-
-instance Applicative Maybe where
- pure = return
- (<*>) = ap
-
-instance Alternative Maybe where
- empty = Nothing
- Nothing <|> p = p
- Just x <|> _ = Just x
-
-instance Applicative [] where
- pure = return
- (<*>) = ap
-
-instance Alternative [] where
- empty = []
- (<|>) = (++)
-
-instance Applicative IO where
- pure = return
- (<*>) = ap
-
-instance Applicative ((->) a) where
- pure = const
- (<*>) f g x = f x (g x)
-
-instance Monoid a => Applicative ((,) a) where
- pure x = (mempty, x)
- (u, f) <*> (v, x) = (u `mappend` v, f x)
-
--- new instances
-
-newtype Const a b = Const { getConst :: a }
-
-instance Functor (Const m) where
- fmap _ (Const v) = Const v
-
-instance Monoid m => Applicative (Const m) where
- pure _ = Const mempty
- Const f <*> Const v = Const (f `mappend` v)
-
-newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }
-
-instance Monad m => Functor (WrappedMonad m) where
- fmap f (WrapMonad v) = WrapMonad (liftM f v)
-
-instance Monad m => Applicative (WrappedMonad m) where
- pure = WrapMonad . return
- WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)
-
-instance MonadPlus m => Alternative (WrappedMonad m) where
- empty = WrapMonad mzero
- WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v)
-
-newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c }
-
-instance Arrow a => Functor (WrappedArrow a b) where
- fmap f (WrapArrow a) = WrapArrow (a >>> arr f)
-
-instance Arrow a => Applicative (WrappedArrow a b) where
- pure x = WrapArrow (arr (const x))
- WrapArrow f <*> WrapArrow v = WrapArrow (f &&& v >>> arr (uncurry id))
-
-instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where
- empty = WrapArrow zeroArrow
- WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v)
-
--- | Lists, but with an 'Applicative' functor based on zipping, so that
---
--- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@
---
-newtype ZipList a = ZipList { getZipList :: [a] }
-
-instance Functor ZipList where
- fmap f (ZipList xs) = ZipList (map f xs)
-
-instance Applicative ZipList where
- pure x = ZipList (repeat x)
- ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs)
-
--- extra functions
-
--- | A synonym for 'fmap'.
-(<$>) :: Functor f => (a -> b) -> f a -> f b
-f <$> a = fmap f a
-
--- | Replace the value.
-(<$) :: Functor f => a -> f b -> f a
-(<$) = (<$>) . const
-
--- | Sequence actions, discarding the value of the first argument.
-(*>) :: Applicative f => f a -> f b -> f b
-(*>) = liftA2 (const id)
-
--- | Sequence actions, discarding the value of the second argument.
-(<*) :: Applicative f => f a -> f b -> f a
-(<*) = liftA2 const
-
--- | A variant of '<*>' with the arguments reversed.
-(<**>) :: Applicative f => f a -> f (a -> b) -> f b
-(<**>) = liftA2 (flip ($))
-
--- | Lift a function to actions.
--- This function may be used as a value for `fmap` in a `Functor` instance.
-liftA :: Applicative f => (a -> b) -> f a -> f b
-liftA f a = pure f <*> a
-
--- | Lift a binary function to actions.
-liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
-liftA2 f a b = f <$> a <*> b
-
--- | Lift a ternary function to actions.
-liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
-liftA3 f a b c = f <$> a <*> b <*> c
-
--- | One or none.
-optional :: Alternative f => f a -> f (Maybe a)
-optional v = Just <$> v <|> pure Nothing
-
--- | One or more.
-some :: Alternative f => f a -> f [a]
-some v = some_v
- where many_v = some_v <|> pure []
- some_v = (:) <$> v <*> many_v
-
--- | Zero or more.
-many :: Alternative f => f a -> f [a]
-many v = many_v
- where many_v = some_v <|> pure []
- some_v = (:) <$> v <*> many_v
View
281 Control/Arrow.hs
@@ -1,281 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Control.Arrow
--- Copyright : (c) Ross Paterson 2002
--- License : BSD-style (see the LICENSE file in the distribution)
---
--- Maintainer : ross@soi.city.ac.uk
--- Stability : experimental
--- Portability : portable
---
--- Basic arrow definitions, based on
--- /Generalising Monads to Arrows/, by John Hughes,
--- /Science of Computer Programming/ 37, pp67-111, May 2000.
--- plus a couple of definitions ('returnA' and 'loop') from
--- /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/,
--- Firenze, Italy, pp229-240.
--- See these papers for the equations these combinators are expected to
--- satisfy. These papers and more information on arrows can be found at
--- <http://www.haskell.org/arrows/>.
-
-module Control.Arrow (
- -- * Arrows
- Arrow(..), Kleisli(..),
- -- ** Derived combinators
- returnA,
- (^>>), (>>^),
- -- ** Right-to-left variants
- (<<<), (<<^), (^<<),
- -- * Monoid operations
- ArrowZero(..), ArrowPlus(..),
- -- * Conditionals
- ArrowChoice(..),
- -- * Arrow application
- ArrowApply(..), ArrowMonad(..), leftApp,
- -- * Feedback
- ArrowLoop(..)
- ) where
-
-import Prelude
-
-import Control.Monad
-import Control.Monad.Fix
-
-infixr 5 <+>
-infixr 3 ***
-infixr 3 &&&
-infixr 2 +++
-infixr 2 |||
-infixr 1 >>>, ^>>, >>^
-infixr 1 <<<, ^<<, <<^
-
--- | The basic arrow class.
--- Any instance must define either 'arr' or 'pure' (which are synonyms),
--- as well as '>>>' and 'first'. The other combinators have sensible
--- default definitions, which may be overridden for efficiency.
-
-class Arrow a where
-
- -- | Lift a function to an arrow: you must define either this
- -- or 'pure'.
- arr :: (b -> c) -> a b c
- arr = pure
-
- -- | A synonym for 'arr': you must define one or other of them.
- pure :: (b -> c) -> a b c
- pure = arr
-
- -- | Left-to-right composition of arrows.
- (>>>) :: a b c -> a c d -> a b d
-
- -- | Send the first component of the input through the argument
- -- arrow, and copy the rest unchanged to the output.
- first :: a b c -> a (b,d) (c,d)
-
- -- | A mirror image of 'first'.
- --
- -- The default definition may be overridden with a more efficient
- -- version if desired.
- second :: a b c -> a (d,b) (d,c)
- second f = arr swap >>> first f >>> arr swap
- where swap ~(x,y) = (y,x)
-
- -- | Split the input between the two argument arrows and combine
- -- their output. Note that this is in general not a functor.
- --
- -- The default definition may be overridden with a more efficient
- -- version if desired.
- (***) :: a b c -> a b' c' -> a (b,b') (c,c')
- f *** g = first f >>> second g
-
- -- | Fanout: send the input to both argument arrows and combine
- -- their output.
- --
- -- The default definition may be overridden with a more efficient
- -- version if desired.
- (&&&) :: a b c -> a b c' -> a b (c,c')
- f &&& g = arr (\b -> (b,b)) >>> f *** g
-
-{-# RULES
-"compose/arr" forall f g .
- arr f >>> arr g = arr (f >>> g)
-"first/arr" forall f .
- first (arr f) = arr (first f)
-"second/arr" forall f .
- second (arr f) = arr (second f)
-"product/arr" forall f g .
- arr f *** arr g = arr (f *** g)
-"fanout/arr" forall f g .
- arr f &&& arr g = arr (f &&& g)
-"compose/first" forall f g .
- first f >>> first g = first (f >>> g)
-"compose/second" forall f g .
- second f >>> second g = second (f >>> g)
- #-}
-
--- Ordinary functions are arrows.
-
-instance Arrow (->) where
- arr f = f
- f >>> g = g . f
- first f = f *** id
- second f = id *** f
--- (f *** g) ~(x,y) = (f x, g y)
--- sorry, although the above defn is fully H'98, nhc98 can't parse it.
- (***) f g ~(x,y) = (f x, g y)
-
--- | Kleisli arrows of a monad.
-
-newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }
-
-instance Monad m => Arrow (Kleisli m) where
- arr f = Kleisli (return . f)
- Kleisli f >>> Kleisli g = Kleisli (\b -> f b >>= g)
- first (Kleisli f) = Kleisli (\ ~(b,d) -> f b >>= \c -> return (c,d))
- second (Kleisli f) = Kleisli (\ ~(d,b) -> f b >>= \c -> return (d,c))
-
--- | The identity arrow, which plays the role of 'return' in arrow notation.
-
-returnA :: Arrow a => a b b
-returnA = arr id
-
--- | Precomposition with a pure function.
-(^>>) :: Arrow a => (b -> c) -> a c d -> a b d
-f ^>> a = arr f >>> a
-
--- | Postcomposition with a pure function.
-(>>^) :: Arrow a => a b c -> (c -> d) -> a b d
-a >>^ f = a >>> arr f
-
--- | Right-to-left composition, for a better fit with arrow notation.
-(<<<) :: Arrow a => a c d -> a b c -> a b d
-f <<< g = g >>> f
-
--- | Precomposition with a pure function (right-to-left variant).
-(<<^) :: Arrow a => a c d -> (b -> c) -> a b d
-a <<^ f = a <<< arr f
-
--- | Postcomposition with a pure function (right-to-left variant).
-(^<<) :: Arrow a => (c -> d) -> a b c -> a b d
-f ^<< a = arr f <<< a
-
-class Arrow a => ArrowZero a where
- zeroArrow :: a b c
-
-instance MonadPlus m => ArrowZero (Kleisli m) where
- zeroArrow = Kleisli (\x -> mzero)
-
-class ArrowZero a => ArrowPlus a where
- (<+>) :: a b c -> a b c -> a b c
-
-instance MonadPlus m => ArrowPlus (Kleisli m) where
- Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x)
-
--- | Choice, for arrows that support it. This class underlies the
--- @if@ and @case@ constructs in arrow notation.
--- Any instance must define 'left'. The other combinators have sensible
--- default definitions, which may be overridden for efficiency.
-
-class Arrow a => ArrowChoice a where
-
- -- | Feed marked inputs through the argument arrow, passing the
- -- rest through unchanged to the output.
- left :: a b c -> a (Either b d) (Either c d)
-
- -- | A mirror image of 'left'.
- --
- -- The default definition may be overridden with a more efficient
- -- version if desired.
- right :: a b c -> a (Either d b) (Either d c)
- right f = arr mirror >>> left f >>> arr mirror
- where mirror (Left x) = Right x
- mirror (Right y) = Left y
-
- -- | Split the input between the two argument arrows, retagging
- -- and merging their outputs.
- -- Note that this is in general not a functor.
- --
- -- The default definition may be overridden with a more efficient
- -- version if desired.
- (+++) :: a b c -> a b' c' -> a (Either b b') (Either c c')
- f +++ g = left f >>> right g
-
- -- | Fanin: Split the input between the two argument arrows and
- -- merge their outputs.
- --
- -- The default definition may be overridden with a more efficient
- -- version if desired.
- (|||) :: a b d -> a c d -> a (Either b c) d
- f ||| g = f +++ g >>> arr untag
- where untag (Left x) = x
- untag (Right y) = y
-
-{-# RULES
-"left/arr" forall f .
- left (arr f) = arr (left f)
-"right/arr" forall f .
- right (arr f) = arr (right f)
-"sum/arr" forall f g .
- arr f +++ arr g = arr (f +++ g)
-"fanin/arr" forall f g .
- arr f ||| arr g = arr (f ||| g)
-"compose/left" forall f g .
- left f >>> left g = left (f >>> g)
-"compose/right" forall f g .
- right f >>> right g = right (f >>> g)
- #-}
-
-instance ArrowChoice (->) where
- left f = f +++ id
- right f = id +++ f
- f +++ g = (Left . f) ||| (Right . g)
- (|||) = either
-
-instance Monad m => ArrowChoice (Kleisli m) where
- left f = f +++ arr id
- right f = arr id +++ f
- f +++ g = (f >>> arr Left) ||| (g >>> arr Right)
- Kleisli f ||| Kleisli g = Kleisli (either f g)
-
--- | Some arrows allow application of arrow inputs to other inputs.
-
-class Arrow a => ArrowApply a where
- app :: a (a b c, b) c
-
-instance ArrowApply (->) where
- app (f,x) = f x
-
-instance Monad m => ArrowApply (Kleisli m) where
- app = Kleisli (\(Kleisli f, x) -> f x)
-
--- | The 'ArrowApply' class is equivalent to 'Monad': any monad gives rise
--- to a 'Kleisli' arrow, and any instance of 'ArrowApply' defines a monad.
-
-newtype ArrowApply a => ArrowMonad a b = ArrowMonad (a () b)
-
-instance ArrowApply a => Monad (ArrowMonad a) where
- return x = ArrowMonad (arr (\z -> x))
- ArrowMonad m >>= f = ArrowMonad (m >>>
- arr (\x -> let ArrowMonad h = f x in (h, ())) >>>
- app)
-
--- | Any instance of 'ArrowApply' can be made into an instance of
--- 'ArrowChoice' by defining 'left' = 'leftApp'.
-
-leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d)
-leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) |||
- (\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app
-
--- | The 'loop' operator expresses computations in which an output value is
--- fed back as input, even though the computation occurs only once.
--- It underlies the @rec@ value recursion construct in arrow notation.
-
-class Arrow a => ArrowLoop a where
- loop :: a (b,d) (c,d) -> a b c
-
-instance ArrowLoop (->) where
- loop f b = let (c,d) = f (b,d) in c
-
-instance MonadFix m => ArrowLoop (Kleisli m) where
- loop (Kleisli f) = Kleisli (liftM fst . mfix . f')
- where f' x y = f (x, snd y)
View
546 Control/Concurrent.hs
@@ -1,546 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Control.Concurrent
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (concurrency)
---
--- A common interface to a collection of useful concurrency
--- abstractions.
---
------------------------------------------------------------------------------
-
-module Control.Concurrent (
- -- * Concurrent Haskell
-
- -- $conc_intro
-
- -- * Basic concurrency operations
-
- ThreadId,
-#ifdef __GLASGOW_HASKELL__
- myThreadId,
-#endif
-
- forkIO,
-#ifdef __GLASGOW_HASKELL__
- killThread,
- throwTo,
-#endif
-
- -- * Scheduling
-
- -- $conc_scheduling
- yield, -- :: IO ()
-
- -- ** Blocking
-
- -- $blocking
-
-#ifdef __GLASGOW_HASKELL__
- -- ** Waiting
- threadDelay, -- :: Int -> IO ()
- threadWaitRead, -- :: Int -> IO ()
- threadWaitWrite, -- :: Int -> IO ()
-#endif
-
- -- * Communication abstractions
-
- module Control.Concurrent.MVar,
- module Control.Concurrent.Chan,
- module Control.Concurrent.QSem,
- module Control.Concurrent.QSemN,
- module Control.Concurrent.SampleVar,
-
- -- * Merging of streams
-#ifndef __HUGS__
- mergeIO, -- :: [a] -> [a] -> IO [a]
- nmergeIO, -- :: [[a]] -> IO [a]
-#endif
- -- $merge
-
-#ifdef __GLASGOW_HASKELL__
- -- * Bound Threads
- -- $boundthreads
- rtsSupportsBoundThreads,
- forkOS,
- isCurrentThreadBound,
- runInBoundThread,
- runInUnboundThread
-#endif
-
- -- * GHC's implementation of concurrency
-
- -- |This section describes features specific to GHC's
- -- implementation of Concurrent Haskell.
-
- -- ** Haskell threads and Operating System threads
-
- -- $osthreads
-
- -- ** Terminating the program
-
- -- $termination
-
- -- ** Pre-emption
-
- -- $preemption
- ) where
-
-import Prelude
-
-import Control.Exception as Exception
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Conc ( ThreadId(..), myThreadId, killThread, yield,
- threadDelay, threadWaitRead, threadWaitWrite,
- forkIO, childHandler )
-import GHC.TopHandler ( reportStackOverflow, reportError )
-import GHC.IOBase ( IO(..) )
-import GHC.IOBase ( unsafeInterleaveIO )
-import GHC.IOBase ( newIORef, readIORef, writeIORef )
-import GHC.Base
-
-import Foreign.StablePtr
-import Foreign.C.Types ( CInt )
-import Control.Monad ( when )
-#endif
-
-#ifdef __HUGS__
-import Hugs.ConcBase
-#endif
-
-import Control.Concurrent.MVar
-import Control.Concurrent.Chan
-import Control.Concurrent.QSem
-import Control.Concurrent.QSemN
-import Control.Concurrent.SampleVar
-
-#ifdef __HUGS__
-type ThreadId = ()
-#endif
-
-{- $conc_intro
-
-The concurrency extension for Haskell is described in the paper
-/Concurrent Haskell/
-<http://www.haskell.org/ghc/docs/papers/concurrent-haskell.ps.gz>.
-
-Concurrency is \"lightweight\", which means that both thread creation
-and context switching overheads are extremely low. Scheduling of
-Haskell threads is done internally in the Haskell runtime system, and
-doesn't make use of any operating system-supplied thread packages.
-
-However, if you want to interact with a foreign library that expects your
-program to use the operating system-supplied thread package, you can do so
-by using 'forkOS' instead of 'forkIO'.
-
-Haskell threads can communicate via 'MVar's, a kind of synchronised
-mutable variable (see "Control.Concurrent.MVar"). Several common
-concurrency abstractions can be built from 'MVar's, and these are
-provided by the "Control.Concurrent" library.
-In GHC, threads may also communicate via exceptions.
--}
-
-{- $conc_scheduling
-
- Scheduling may be either pre-emptive or co-operative,
- depending on the implementation of Concurrent Haskell (see below
- for information related to specific compilers). In a co-operative
- system, context switches only occur when you use one of the
- primitives defined in this module. This means that programs such
- as:
-
-
-> main = forkIO (write 'a') >> write 'b'
-> where write c = putChar c >> write c
-
- will print either @aaaaaaaaaaaaaa...@ or @bbbbbbbbbbbb...@,
- instead of some random interleaving of @a@s and @b@s. In
- practice, cooperative multitasking is sufficient for writing
- simple graphical user interfaces.
--}
-
-{- $blocking
-Different Haskell implementations have different characteristics with
-regard to which operations block /all/ threads.
-
-Using GHC without the @-threaded@ option, all foreign calls will block
-all other Haskell threads in the system, although I\/O operations will
-not. With the @-threaded@ option, only foreign calls with the @unsafe@
-attribute will block all other threads.
-
-Using Hugs, all I\/O operations and foreign calls will block all other
-Haskell threads.
--}
-
-#ifndef __HUGS__
-max_buff_size :: Int
-max_buff_size = 1
-
-mergeIO :: [a] -> [a] -> IO [a]
-nmergeIO :: [[a]] -> IO [a]
-
--- $merge
--- The 'mergeIO' and 'nmergeIO' functions fork one thread for each
--- input list that concurrently evaluates that list; the results are
--- merged into a single output list.
---
--- Note: Hugs does not provide these functions, since they require
--- preemptive multitasking.
-
-mergeIO ls rs
- = newEmptyMVar >>= \ tail_node ->
- newMVar tail_node >>= \ tail_list ->
- newQSem max_buff_size >>= \ e ->
- newMVar 2 >>= \ branches_running ->
- let
- buff = (tail_list,e)
- in
- forkIO (suckIO branches_running buff ls) >>
- forkIO (suckIO branches_running buff rs) >>
- takeMVar tail_node >>= \ val ->
- signalQSem e >>
- return val
-
-type Buffer a
- = (MVar (MVar [a]), QSem)
-
-suckIO :: MVar Int -> Buffer a -> [a] -> IO ()
-
-suckIO branches_running buff@(tail_list,e) vs
- = case vs of
- [] -> takeMVar branches_running >>= \ val ->
- if val == 1 then
- takeMVar tail_list >>= \ node ->
- putMVar node [] >>
- putMVar tail_list node
- else
- putMVar branches_running (val-1)
- (x:xs) ->
- waitQSem e >>
- takeMVar tail_list >>= \ node ->
- newEmptyMVar >>= \ next_node ->
- unsafeInterleaveIO (
- takeMVar next_node >>= \ y ->
- signalQSem e >>
- return y) >>= \ next_node_val ->
- putMVar node (x:next_node_val) >>
- putMVar tail_list next_node >>
- suckIO branches_running buff xs
-
-nmergeIO lss
- = let
- len = length lss
- in
- newEmptyMVar >>= \ tail_node ->
- newMVar tail_node >>= \ tail_list ->
- newQSem max_buff_size >>= \ e ->
- newMVar len >>= \ branches_running ->
- let
- buff = (tail_list,e)
- in
- mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>
- takeMVar tail_node >>= \ val ->
- signalQSem e >>
- return val
- where
- mapIO f xs = sequence (map f xs)
-#endif /* __HUGS__ */
-
-#ifdef __GLASGOW_HASKELL__
--- ---------------------------------------------------------------------------
--- Bound Threads
-
-{- $boundthreads
- #boundthreads#
-
-Support for multiple operating system threads and bound threads as described
-below is currently only available in the GHC runtime system if you use the
-/-threaded/ option when linking.
-
-Other Haskell systems do not currently support multiple operating system threads.
-
-A bound thread is a haskell thread that is /bound/ to an operating system
-thread. While the bound thread is still scheduled by the Haskell run-time
-system, the operating system thread takes care of all the foreign calls made
-by the bound thread.
-
-To a foreign library, the bound thread will look exactly like an ordinary
-operating system thread created using OS functions like @pthread_create@
-or @CreateThread@.
-
-Bound threads can be created using the 'forkOS' function below. All foreign
-exported functions are run in a bound thread (bound to the OS thread that
-called the function). Also, the @main@ action of every Haskell program is
-run in a bound thread.
-
-Why do we need this? Because if a foreign library is called from a thread
-created using 'forkIO', it won't have access to any /thread-local state/ -
-state variables that have specific values for each OS thread
-(see POSIX's @pthread_key_create@ or Win32's @TlsAlloc@). Therefore, some
-libraries (OpenGL, for example) will not work from a thread created using
-'forkIO'. They work fine in threads created using 'forkOS' or when called
-from @main@ or from a @foreign export@.
--}
-
--- | 'True' if bound threads are supported.
--- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound'
--- will always return 'False' and both 'forkOS' and 'runInBoundThread' will
--- fail.
-foreign import ccall rtsSupportsBoundThreads :: Bool
-
-
-{- |
-Like 'forkIO', this sparks off a new thread to run the 'IO' computation passed as the
-first argument, and returns the 'ThreadId' of the newly created
-thread.
-
-However, @forkOS@ uses operating system-supplied multithreading support to create
-a new operating system thread. The new thread is /bound/, which means that
-all foreign calls made by the 'IO' computation are guaranteed to be executed
-in this new operating system thread; also, the operating system thread is not
-used for any other foreign calls.
-
-This means that you can use all kinds of foreign libraries from this thread
-(even those that rely on thread-local state), without the limitations of 'forkIO'.
-
-Just to clarify, 'forkOS' is /only/ necessary if you need to associate
-a Haskell thread with a particular OS thread. It is not necessary if
-you only need to make non-blocking foreign calls (see
-"Control.Concurrent#osthreads"). Neither is it necessary if you want
-to run threads in parallel on a multiprocessor: threads created with
-'forkIO' will be shared out amongst the running CPUs (using GHC,
-@-threaded@, and the @+RTS -N@ runtime option).
-
--}
-forkOS :: IO () -> IO ThreadId
-
-foreign export ccall forkOS_entry
- :: StablePtr (IO ()) -> IO ()
-
-foreign import ccall "forkOS_entry" forkOS_entry_reimported
- :: StablePtr (IO ()) -> IO ()
-
-forkOS_entry stableAction = do
- action <- deRefStablePtr stableAction
- action
-
-foreign import ccall forkOS_createThread
- :: StablePtr (IO ()) -> IO CInt
-
-failNonThreaded = fail $ "RTS doesn't support multiple OS threads "
- ++"(use ghc -threaded when linking)"
-
-forkOS action
- | rtsSupportsBoundThreads = do
- mv <- newEmptyMVar
- let action_plus = Exception.catch action childHandler
- entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus)
- err <- forkOS_createThread entry
- when (err /= 0) $ fail "Cannot create OS thread."
- tid <- takeMVar mv
- freeStablePtr entry
- return tid
- | otherwise = failNonThreaded
-
--- | Returns 'True' if the calling thread is /bound/, that is, if it is
--- safe to use foreign libraries that rely on thread-local state from the
--- calling thread.
-isCurrentThreadBound :: IO Bool
-isCurrentThreadBound = IO $ \ s# ->
- case isCurrentThreadBound# s# of
- (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
-
-
-{- |
-Run the 'IO' computation passed as the first argument. If the calling thread
-is not /bound/, a bound thread is created temporarily. @runInBoundThread@
-doesn't finish until the 'IO' computation finishes.
-
-You can wrap a series of foreign function calls that rely on thread-local state
-with @runInBoundThread@ so that you can use them without knowing whether the
-current thread is /bound/.
--}
-runInBoundThread :: IO a -> IO a
-
-runInBoundThread action
- | rtsSupportsBoundThreads = do
- bound <- isCurrentThreadBound
- if bound
- then action
- else do
- ref <- newIORef undefined
- let action_plus = Exception.try action >>= writeIORef ref
- resultOrException <-
- bracket (newStablePtr action_plus)
- freeStablePtr
- (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref)
- case resultOrException of
- Left exception -> Exception.throw exception
- Right result -> return result
- | otherwise = failNonThreaded
-
-{- |
-Run the 'IO' computation passed as the first argument. If the calling thread
-is /bound/, an unbound thread is created temporarily using 'forkIO'.
-@runInBoundThread@ doesn't finish until the 'IO' computation finishes.
-
-Use this function /only/ in the rare case that you have actually observed a
-performance loss due to the use of bound threads. A program that
-doesn't need it's main thread to be bound and makes /heavy/ use of concurrency
-(e.g. a web server), might want to wrap it's @main@ action in
-@runInUnboundThread@.
--}
-runInUnboundThread :: IO a -> IO a
-
-runInUnboundThread action = do
- bound <- isCurrentThreadBound
- if bound
- then do
- mv <- newEmptyMVar
- forkIO (Exception.try action >>= putMVar mv)
- takeMVar mv >>= \either -> case either of
- Left exception -> Exception.throw exception
- Right result -> return result
- else action
-
-#endif /* __GLASGOW_HASKELL__ */
-
--- ---------------------------------------------------------------------------
--- More docs
-
-{- $osthreads
-
- #osthreads# In GHC, threads created by 'forkIO' are lightweight threads, and
- are managed entirely by the GHC runtime. Typically Haskell
- threads are an order of magnitude or two more efficient (in
- terms of both time and space) than operating system threads.
-
- The downside of having lightweight threads is that only one can
- run at a time, so if one thread blocks in a foreign call, for
- example, the other threads cannot continue. The GHC runtime
- works around this by making use of full OS threads where
- necessary. When the program is built with the @-threaded@
- option (to link against the multithreaded version of the
- runtime), a thread making a @safe@ foreign call will not block
- the other threads in the system; another OS thread will take
- over running Haskell threads until the original call returns.
- The runtime maintains a pool of these /worker/ threads so that
- multiple Haskell threads can be involved in external calls
- simultaneously.
-
- The "System.IO" library manages multiplexing in its own way. On
- Windows systems it uses @safe@ foreign calls to ensure that
- threads doing I\/O operations don't block the whole runtime,
- whereas on Unix systems all the currently blocked I\/O reqwests
- are managed by a single thread (the /IO manager thread/) using
- @select@.
-
- The runtime will run a Haskell thread using any of the available
- worker OS threads. If you need control over which particular OS
- thread is used to run a given Haskell thread, perhaps because
- you need to call a foreign library that uses OS-thread-local
- state, then you need bound threads (see "Control.Concurrent#boundthreads").
-
- If you don't use the @-threaded@ option, then the runtime does
- not make use of multiple OS threads. Foreign calls will block
- all other running Haskell threads until the call returns. The
- "System.IO" library still does multiplexing, so there can be multiple
- threads doing I\/O, and this is handled internally by the runtime using
- @select@.
--}
-
-{- $termination
-
- In a standalone GHC program, only the main thread is
- required to terminate in order for the process to terminate.
- Thus all other forked threads will simply terminate at the same
- time as the main thread (the terminology for this kind of
- behaviour is \"daemonic threads\").
-
- If you want the program to wait for child threads to
- finish before exiting, you need to program this yourself. A
- simple mechanism is to have each child thread write to an
- 'MVar' when it completes, and have the main
- thread wait on all the 'MVar's before
- exiting:
-
-> myForkIO :: IO () -> IO (MVar ())
-> myForkIO io = do
-> mvar <- newEmptyMVar
-> forkIO (io `finally` putMVar mvar ())
-> return mvar
-
- Note that we use 'finally' from the
- "Control.Exception" module to make sure that the
- 'MVar' is written to even if the thread dies or
- is killed for some reason.
-
- A better method is to keep a global list of all child
- threads which we should wait for at the end of the program:
-
-> children :: MVar [MVar ()]
-> children = unsafePerformIO (newMVar [])
->
-> waitForChildren :: IO ()
-> waitForChildren = do
-> cs <- takeMVar children
-> case cs of
-> [] -> return ()
-> m:ms -> do
-> putMVar children ms
-> takeMVar m
-> waitForChildren
->
-> forkChild :: IO () -> IO ()
-> forkChild io = do
-> mvar <- newEmptyMVar
-> childs <- takeMVar children
-> putMVar children (mvar:childs)
-> forkIO (io `finally` putMVar mvar ())
->
-> main =
-> later waitForChildren $
-> ...
-
- The main thread principle also applies to calls to Haskell from
- outside, using @foreign export@. When the @foreign export@ed
- function is invoked, it starts a new main thread, and it returns
- when this main thread terminates. If the call causes new
- threads to be forked, they may remain in the system after the
- @foreign export@ed function has returned.
--}
-
-{- $preemption
-
- GHC implements pre-emptive multitasking: the execution of
- threads are interleaved in a random fashion. More specifically,
- a thread may be pre-empted whenever it allocates some memory,
- which unfortunately means that tight loops which do no
- allocation tend to lock out other threads (this only seems to
- happen with pathological benchmark-style code, however).
-
- The rescheduling timer runs on a 20ms granularity by
- default, but this may be altered using the
- @-i\<n\>@ RTS option. After a rescheduling
- \"tick\" the running thread is pre-empted as soon as
- possible.
-
- One final note: the
- @aaaa@ @bbbb@ example may not
- work too well on GHC (see Scheduling, above), due
- to the locking on a 'System.IO.Handle'. Only one thread
- may hold the lock on a 'System.IO.Handle' at any one
- time, so if a reschedule happens while a thread is holding the
- lock, the other thread won't be able to run. The upshot is that
- the switch from @aaaa@ to
- @bbbbb@ happens infrequently. It can be
- improved by lowering the reschedule tick period. We also have a
- patch that causes a reschedule whenever a thread waiting on a
- lock is woken up, but haven't found it to be useful for anything
- other than this example :-)
--}
View
132 Control/Concurrent/Chan.hs
@@ -1,132 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Control.Concurrent.Chan
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (concurrency)
---
--- Unbounded channels.
---
------------------------------------------------------------------------------
-
-module Control.Concurrent.Chan
- (
- -- * The 'Chan' type
- Chan, -- abstract
-
- -- * Operations
- newChan, -- :: IO (Chan a)
- writeChan, -- :: Chan a -> a -> IO ()
- readChan, -- :: Chan a -> IO a
- dupChan, -- :: Chan a -> IO (Chan a)
- unGetChan, -- :: Chan a -> a -> IO ()
- isEmptyChan, -- :: Chan a -> IO Bool
-
- -- * Stream interface
- getChanContents, -- :: Chan a -> IO [a]
- writeList2Chan, -- :: Chan a -> [a] -> IO ()
- ) where
-
-import Prelude
-
-import System.IO.Unsafe ( unsafeInterleaveIO )
-import Control.Concurrent.MVar
-import Data.Typeable
-
-#include "Typeable.h"
-
--- A channel is represented by two @MVar@s keeping track of the two ends
--- of the channel contents,i.e., the read- and write ends. Empty @MVar@s
--- are used to handle consumers trying to read from an empty channel.
-
--- |'Chan' is an abstract type representing an unbounded FIFO channel.
-data Chan a
- = Chan (MVar (Stream a))
- (MVar (Stream a))
-
-INSTANCE_TYPEABLE1(Chan,chanTc,"Chan")
-
-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@.
-
--- |Build and returns a new instance of 'Chan'.
-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.
-
--- |Write a value to a 'Chan'.
-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
-
--- |Read the next value from the 'Chan'.
-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)
-
--- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to
--- either channel from then on will be available from both. Hence this creates
--- a kind of broadcast channel, where data written by anyone is seen by
--- everyone else.
-dupChan :: Chan a -> IO (Chan a)
-dupChan (Chan _read write) = do
- hole <- readMVar write
- new_read <- newMVar hole
- return (Chan new_read write)
-
--- |Put a data item back onto a channel, where it will be the next item read.
-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
-
--- |Returns 'True' if the supplied 'Chan' is empty.
-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.
-
--- |Return a lazy list representing the contents of the supplied
--- 'Chan', much like 'System.IO.hGetContents'.
-getChanContents :: Chan a -> IO [a]
-getChanContents ch
- = unsafeInterleaveIO (do
- x <- readChan ch
- xs <- getChanContents ch
- return (x:xs)
- )
-
--- |Write an entire list of items to a 'Chan'.
-writeList2Chan :: Chan a -> [a] -> IO ()
-writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)
View
114 Control/Concurrent/MVar.hs
@@ -1,114 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Control.Concurrent.MVar
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (concurrency)
---
--- Synchronising variables
---
------------------------------------------------------------------------------
-
-module Control.Concurrent.MVar
- (
- -- * @MVar@s
- 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
-#ifndef __HUGS__
- , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
-#endif
- ) where
-
-#ifdef __HUGS__
-import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
- tryTakeMVar, tryPutMVar, isEmptyMVar,
- )
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
- tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer
- )
-#endif
-
-import Prelude
-import Control.Exception as Exception
-
-{-|
- This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value
- from the 'MVar', puts it back, and also returns it.
--}
-readMVar :: MVar a -> IO a
-readMVar m =
- block $ do
- a <- takeMVar m
- putMVar m a
- return a
-
--- |Swap the contents of an 'MVar' for a new value.
-swapMVar :: MVar a -> a -> IO a
-swapMVar mvar new =
- block $ do
- old <- takeMVar mvar
- putMVar mvar new
- return old
-
-{-|
- 'withMVar' is a safe wrapper for operating on the contents of an
- 'MVar'. This operation is exception-safe: it will replace the
- original contents of the 'MVar' if an exception is raised (see
- "Control.Exception").
--}
-{-# INLINE withMVar #-}
--- inlining has been reported to have dramatic effects; see
--- http://www.haskell.org//pipermail/haskell/2006-May/017907.html
-withMVar :: MVar a -> (a -> IO b) -> IO b
-withMVar m io =
- block $ do
- a <- takeMVar m
- b <- Exception.catch (unblock (io a))
- (\e -> do putMVar m a; throw e)
- putMVar m a
- return b
-
-{-|
- A safe wrapper for modifying the contents of an 'MVar'. Like 'withMVar',
- 'modifyMVar' will replace the original contents of the 'MVar' if an
- exception is raised during the operation.
--}
-{-# INLINE modifyMVar_ #-}
-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'
-
-{-|
- A slight variation on 'modifyMVar_' that allows a value to be
- returned (@b@) in addition to the modified value of the 'MVar'.
--}
-{-# INLINE modifyMVar #-}
-modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
-modifyMVar m io =
- block $ do
- a <- takeMVar m
- (a',b) <- Exception.catch (unblock (io a))
- (\e -> do putMVar m a; throw e)
- putMVar m a'
- return b
View
77 Control/Concurrent/QSem.hs
@@ -1,77 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Control.Concurrent.QSem
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (concurrency)
---
--- Simple quantity semaphores.
---
------------------------------------------------------------------------------
-
-module Control.Concurrent.QSem
- ( -- * Simple Quantity Semaphores
- QSem, -- abstract
- newQSem, -- :: Int -> IO QSem
- waitQSem, -- :: QSem -> IO ()
- signalQSem -- :: QSem -> IO ()
- ) where
-
-import Prelude
-import Control.Concurrent.MVar
-import Data.Typeable
-
-#include "Typeable.h"
-
--- General semaphores are also implemented readily in terms of shared
--- @MVar@s, only have to catch the case when the semaphore is tried
--- waited on when it is empty (==0). Implement this in the same way as
--- shared variables are implemented - maintaining a list of @MVar@s
--- representing threads currently waiting. The counter is a shared
--- variable, ensuring the mutual exclusion on its access.
-
--- |A 'QSem' is a simple quantity semaphore, in which the available
--- \"quantity\" is always dealt with in units of one.
-newtype QSem = QSem (MVar (Int, [MVar ()]))
-
-INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")
-
--- |Build a new 'QSem'
-newQSem :: Int -> IO QSem
-newQSem init = do
- sem <- newMVar (init,[])
- return (QSem sem)
-
--- |Wait for a unit to become available
-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
-
--- |Signal that a unit of the 'QSem' is available
-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 ()
View
70 Control/Concurrent/QSemN.hs
@@ -1,70 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Control.Concurrent.QSemN
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (concurrency)
---
--- Quantity semaphores in which each thread may wait for an arbitrary
--- \"amount\".
---
------------------------------------------------------------------------------
-
-module Control.Concurrent.QSemN
- ( -- * General Quantity Semaphores
- QSemN, -- abstract
- newQSemN, -- :: Int -> IO QSemN
- waitQSemN, -- :: QSemN -> Int -> IO ()
- signalQSemN -- :: QSemN -> Int -> IO ()
- ) where
-
-import Prelude
-
-import Control.Concurrent.MVar
-import Data.Typeable
-
-#include "Typeable.h"
-
--- |A 'QSemN' is a quantity semaphore, in which the available
--- \"quantity\" may be signalled or waited for in arbitrary amounts.
-newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())]))
-
-INSTANCE_TYPEABLE0(QSemN,qSemNTc,"QSemN")
-
--- |Build a new 'QSemN' with a supplied initial quantity.
-newQSemN :: Int -> IO QSemN
-newQSemN init = do
- sem <- newMVar (init,[])
- return (QSemN sem)
-
--- |Wait for the specified quantity to become available
-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,blocked)
- else do
- block <- newEmptyMVar
- putMVar sem (avail, blocked++[(sz,block)])
- takeMVar block
-
--- |Signal that a given quantity is now available from the 'QSemN'.
-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')
View
117 Control/Concurrent/SampleVar.hs
@@ -1,117 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Control.Concurrent.SampleVar
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (concurrency)
---
--- Sample variables
---
------------------------------------------------------------------------------
-
-module Control.Concurrent.SampleVar
- (
- -- * Sample Variables
- SampleVar, -- :: type _ =
-
- newEmptySampleVar, -- :: IO (SampleVar a)
- newSampleVar, -- :: a -> IO (SampleVar a)
- emptySampleVar, -- :: SampleVar a -> IO ()
- readSampleVar, -- :: SampleVar a -> IO a
- writeSampleVar, -- :: SampleVar a -> a -> IO ()
- isEmptySampleVar, -- :: SampleVar a -> IO Bool
-
- ) where
-
-import Prelude
-
-import Control.Concurrent.MVar
-
--- |
--- 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)
-
--- |Build a new, empty, 'SampleVar'
-newEmptySampleVar :: IO (SampleVar a)
-newEmptySampleVar = do
- v <- newEmptyMVar
- newMVar (0,v)
-
--- |Build a 'SampleVar' with an initial value.
-newSampleVar :: a -> IO (SampleVar a)
-newSampleVar a = do
- v <- newEmptyMVar
- putMVar v a
- newMVar (1,v)
-
--- |If the SampleVar is full, leave it empty. Otherwise, do nothing.
-emptySampleVar :: SampleVar a -> IO ()
-emptySampleVar v = do
- (readers, var) <- takeMVar v
- if readers > 0 then do
- takeMVar var
- putMVar v (0,var)
- else
- putMVar v (readers,var)
-
--- |Wait for a value to become available, then take it and return.
-readSampleVar :: SampleVar a -> IO a
-readSampleVar svar = do
---
--- filled => make empty and grab sample
--- not filled => try to grab value, empty when read val.
---
- (readers,val) <- takeMVar svar
- putMVar svar (readers-1,val)
- takeMVar val
-
--- |Write a value into the 'SampleVar', overwriting any previous value that
--- was there.
-writeSampleVar :: SampleVar a -> a -> IO ()
-writeSampleVar svar v = do
---
--- filled => overwrite
--- not filled => fill, write val
---
- (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)
-
--- | Returns 'True' if the 'SampleVar' is currently empty.
---
--- Note that this function is only useful if you know that no other
--- threads can be modifying the state of the 'SampleVar', because
--- otherwise the state of the 'SampleVar' may have changed by the time
--- you see the result of 'isEmptySampleVar'.
---
-isEmptySampleVar :: SampleVar a -> IO Bool
-isEmptySampleVar svar = do
- (readers,val) <- readMVar svar
- return (readers == 0)
-
View
592 Control/Exception.hs
@@ -1,592 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Control.Exception
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (extended exceptions)
---
--- This module provides support for raising and catching both built-in
--- and user-defined exceptions.
---
--- In addition to exceptions thrown by 'IO' operations, exceptions may
--- be thrown by pure code (imprecise exceptions) or by external events
--- (asynchronous exceptions), but may only be caught in the 'IO' monad.
--- For more details, see:
---
--- * /A semantics for imprecise exceptions/, by Simon Peyton Jones,
--- Alastair Reid, Tony Hoare, Simon Marlow, Fergus Henderson,
--- in /PLDI'99/.
---
--- * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton
--- Jones, Andy Moran and John Reppy, in /PLDI'01/.
---
------------------------------------------------------------------------------
-
-module Control.Exception (
-
- -- * The Exception type
- 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
-
- -- * Throwing exceptions
- throwIO, -- :: Exception -> IO a
- throw, -- :: Exception -> a
- ioError, -- :: IOError -> IO a
-#ifdef __GLASGOW_HASKELL__
- throwTo, -- :: ThreadId -> Exception -> a
-#endif
-
- -- * Catching Exceptions
-
- -- |There are several functions for catching and examining
- -- exceptions; all of them may only be used from within the
- -- 'IO' monad.
-
- -- ** The @catch@ functions
- catch, -- :: IO a -> (Exception -> IO a) -> IO a
- catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
-
- -- ** The @handle@ functions
- handle, -- :: (Exception -> IO a) -> IO a -> IO a
- handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a
-
- -- ** The @try@ functions
- try, -- :: IO a -> IO (Either Exception a)
- tryJust, -- :: (Exception -> Maybe b) -> a -> IO (Either b a)
-
- -- ** The @evaluate@ function
- evaluate, -- :: a -> IO a
-
- -- ** The @mapException@ function
- mapException, -- :: (Exception -> Exception) -> a -> a
-
- -- ** Exception predicates
-
- -- $preds
-
- 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
-
- -- * Dynamic exceptions
-
- -- $dynamic
- throwDyn, -- :: Typeable ex => ex -> b
-#ifdef __GLASGOW_HASKELL__
- throwDynTo, -- :: Typeable ex => ThreadId -> ex -> b
-#endif
- catchDyn, -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a
-
- -- * Asynchronous Exceptions
-
- -- $async
-
- -- ** Asynchronous exception control
-
- -- |The following two functions allow a thread to control delivery of
- -- asynchronous exceptions during a critical region.
-
- block, -- :: IO a -> IO a
- unblock, -- :: IO a -> IO a
-
- -- *** Applying @block@ to an exception handler
-
- -- $block_handler
-
- -- *** Interruptible operations
-
- -- $interruptible
-
- -- * Assertions
-
- assert, -- :: Bool -> a -> a
-
- -- * Utilities
-
- bracket, -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()
- bracket_, -- :: IO a -> IO b -> IO c -> IO ()
- bracketOnError,
-
- finally, -- :: IO a -> IO b -> IO a
-
-#ifdef __GLASGOW_HASKELL__
- setUncaughtExceptionHandler, -- :: (Exception -> IO ()) -> IO ()
- getUncaughtExceptionHandler -- :: IO (Exception -> IO ())
-#endif
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base ( assert )
-import GHC.Exception as ExceptionBase hiding (catch)
-import GHC.Conc ( throwTo, ThreadId )
-import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
-import Foreign.C.String ( CString, withCString )
-import System.IO ( stdout, hFlush )
-#endif
-
-#ifdef __HUGS__
-import Hugs.Exception as ExceptionBase
-#endif
-
-import Prelude hiding ( catch )
-import System.IO.Error hiding ( catch, try )
-import System.IO.Unsafe (unsafePerformIO)
-import Data.Dynamic
-
-#ifdef __NHC__
-import System.IO.Error (catch, ioError)
-import IO (bracket)
-import DIOError -- defn of IOError type
-
--- minimum needed for nhc98 to pretend it has Exceptions
-type Exception = IOError
-type IOException = IOError
-data ArithException
-data ArrayException
-data AsyncException
-
-throwIO :: Exception -> IO a
-throwIO = ioError
-throw :: Exception -> a
-throw = unsafePerformIO . throwIO
-
-evaluate :: a -> IO a
-evaluate x = x `seq` return x
-
-ioErrors :: Exception -> Maybe IOError
-ioErrors e = Just e
-arithExceptions :: Exception -> Maybe ArithException
-arithExceptions = const Nothing
-errorCalls :: Exception -> Maybe String
-errorCalls = const Nothing
-dynExceptions :: Exception -> Maybe Dynamic
-dynExceptions = const Nothing
-assertions :: Exception -> Maybe String
-assertions = const Nothing
-asyncExceptions :: Exception -> Maybe AsyncException
-asyncExceptions = const Nothing
-userErrors :: Exception -> Maybe String
-userErrors (UserError _ s) = Just s
-userErrors _ = Nothing
-
-block :: IO a -> IO a
-block = id
-unblock :: IO a -> IO a
-unblock = id
-
-assert :: Bool -> a -> a
-assert True x = x
-assert False _ = throw (UserError "" "Assertion failed")
-#endif
-
------------------------------------------------------------------------------
--- Catching exceptions
-
--- |This is the simplest of the exception-catching functions. It
--- takes a single argument, runs it, and if an exception is raised
--- the \"handler\" is executed, with the value of the exception passed as an
--- argument. Otherwise, the result is returned as normal. For example:
---
--- > catch (openFile f ReadMode)
--- > (\e -> hPutStr stderr ("Couldn't open "++f++": " ++ show e))
---
--- For catching exceptions in pure (non-'IO') expressions, see the
--- function 'evaluate'.
---
--- Note that due to Haskell\'s unspecified evaluation order, an
--- expression may return one of several possible exceptions: consider
--- the expression @error \"urk\" + 1 \`div\` 0@. Does
--- 'catch' execute the handler passing
--- @ErrorCall \"urk\"@, or @ArithError DivideByZero@?
---
--- The answer is \"either\": 'catch' makes a
--- non-deterministic choice about which exception to catch. If you
--- call it again, you might get a different exception back. This is
--- ok, because 'catch' is an 'IO' computation.
---
--- Note that 'catch' catches all types of exceptions, and is generally
--- used for \"cleaning up\" before passing on the exception using
--- 'throwIO'. It is not good practice to discard the exception and
--- continue, without first checking the type of the exception (it
--- might be a 'ThreadKilled', for example). In this case it is usually better
--- to use 'catchJust' and select the kinds of exceptions to catch.
---
--- Also note that the "Prelude" also exports a function called
--- 'Prelude.catch' with a similar type to 'Control.Exception.catch',
--- except that the "Prelude" version only catches the IO and user
--- families of exceptions (as required by Haskell 98).
---
--- We recommend either hiding the "Prelude" version of 'Prelude.catch'
--- when importing "Control.Exception":
---
--- > import Prelude hiding (catch)
---
--- or importing "Control.Exception" qualified, to avoid name-clashes:
---
--- > import qualified Control.Exception as C
---
--- and then using @C.catch@
---
-#ifndef __NHC__
-catch :: IO a -- ^ The computation to run
- -> (Exception -> IO a) -- ^ Handler to invoke if an exception is raised
- -> IO a
-catch = ExceptionBase.catchException
-#endif
--- | The function 'catchJust' is like 'catch', but it takes an extra
--- argument which is an /exception predicate/, a function which
--- selects which type of exceptions we\'re interested in. There are
--- some predefined exception predicates for useful subsets of
--- exceptions: 'ioErrors', 'arithExceptions', and so on. For example,
--- to catch just calls to the 'error' function, we could use
---
--- > result <- catchJust errorCalls thing_to_try handler
---
--- Any other exceptions which are not matched by the predicate
--- are re-raised, and may be caught by an enclosing
--- 'catch' or 'catchJust'.
-catchJust
- :: (Exception -> Maybe b) -- ^ Predicate to select exceptions
- -> IO a -- ^ Computation to run
- -> (b -> IO a) -- ^ Handler
- -> IO a
-catchJust p a handler = catch a handler'
- where handler' e = case p e of
- Nothing -> throw e
- Just b -> handler b
-
--- | A version of 'catch' with the arguments swapped around; useful in
--- situations where the code for the handler is shorter. For example:
---
--- > do handle (\e -> exitWith (ExitFailure 1)) $
--- > ...
-handle :: (Exception -> IO a) -> IO a -> IO a
-handle = flip catch
-
--- | A version of 'catchJust' with the arguments swapped around (see
--- 'handle').
-handleJust :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a
-handleJust p = flip (catchJust p)
-
------------------------------------------------------------------------------
--- 'mapException'
-
--- | This function maps one exception into another as proposed in the
--- paper \"A semantics for imprecise exceptions\".
-
--- Notice that the usage of 'unsafePerformIO' is safe here.
-
-mapException :: (Exception -> Exception) -> a -> a
-mapException f v = unsafePerformIO (catch (evaluate v)
- (\x -> throw (f x)))
-
------------------------------------------------------------------------------
--- 'try' and variations.
-
--- | Similar to 'catch', but returns an 'Either' result which is
--- @('Right' a)@ if no exception was raised, or @('Left' e)@ if an
--- exception was raised and its value is @e@.
---
--- > try a = catch (Right `liftM` a) (return . Left)
---
--- Note: as with 'catch', it is only polite to use this variant if you intend
--- to re-throw the exception after performing whatever cleanup is needed.
--- Otherwise, 'tryJust' is generally considered to be better.
---
--- Also note that "System.IO.Error" also exports a function called
--- 'System.IO.Error.try' with a similar type to 'Control.Exception.try',
--- except that it catches only the IO and user families of exceptions
--- (as required by the Haskell 98 @IO@ module).
-
-try :: IO a -> IO (Either Exception a)
-try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))
-
--- | A variant of 'try' that takes an exception predicate to select
--- which exceptions are caught (c.f. 'catchJust'). If the exception
--- does not match the predicate, it is re-thrown.
-tryJust :: (Exception -> 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 exceptions
-
--- $dynamic
--- #DynamicExceptions# Because the 'Exception' datatype is not extensible, there is an
--- interface for throwing and catching exceptions of type 'Dynamic'
--- (see "Data.Dynamic") which allows exception values of any type in
--- the 'Typeable' class to be thrown and caught.
-
--- | Raise any value as an exception, provided it is in the
--- 'Typeable' class.
-throwDyn :: Typeable exception => exception -> b
-#ifdef __NHC__
-throwDyn exception = throw (UserError "" "dynamic exception")
-#else
-throwDyn exception = throw (DynException (toDyn exception))
-#endif
-
-#ifdef __GLASGOW_HASKELL__
--- | A variant of 'throwDyn' that throws the dynamic exception to an
--- arbitrary thread (GHC only: c.f. 'throwTo').
-throwDynTo :: Typeable exception => ThreadId -> exception -> IO ()
-throwDynTo t exception = throwTo t (DynException (toDyn exception))
-#endif /* __GLASGOW_HASKELL__ */
-
--- | Catch dynamic exceptions of the required type. All other
--- exceptions are re-thrown, including dynamic exceptions of the wrong
--- type.
---
--- When using dynamic exceptions it is advisable to define a new
--- datatype to use for your exception type, to avoid possible clashes
--- with dynamic exceptions used in other libraries.
---
-catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a
-#ifdef __NHC__
-catchDyn m k = m -- can't catch dyn exceptions in nhc98
-#else
-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
-#endif
-
------------------------------------------------------------------------------
--- Exception Predicates
-
--- $preds
--- These pre-defined predicates may be used as the first argument to
--- 'catchJust', 'tryJust', or 'handleJust' to select certain common
--- classes of exceptions.
-#ifndef __NHC__
-ioErrors :: Exception -> Maybe IOError
-arithExceptions :: Exception -> Maybe ArithException
-errorCalls :: Exception -> Maybe String
-assertions :: Exception -> Maybe String
-dynExceptions :: Exception -> Maybe Dynamic
-asyncExceptions :: Exception -> Maybe AsyncException
-userErrors :: Exception -> Maybe String
-
-ioErrors (IOException e) = 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 (IOException e) | isUserError e = Just (ioeGetErrorString e)
-userErrors _ = Nothing
-#endif
------------------------------------------------------------------------------
--- Some Useful Functions
-
--- | When you want to acquire a resource, do some work with it, and
--- then release the resource, it is a good idea to use 'bracket',
--- because 'bracket' will install the necessary exception handler to
--- release the resource in the event that an exception is raised
--- during the computation. If an exception is raised, then 'bracket' will
--- re-raise the exception (after performing the release).
---
--- A common example is opening a file:
---
--- > bracket
--- > (openFile "filename" ReadMode)
--- > (hClose)
--- > (\handle -> do { ... })
---
--- The arguments to 'bracket' are in this order so that we can partially apply
--- it, e.g.:
---
--- > withFile name mode = bracket (openFile name mode) hClose
---
-#ifndef __NHC__
-bracket
- :: IO a -- ^ computation to run first (\"acquire resource\")
- -> (a -> IO b) -- ^ computation to run last (\"release resource\")
- -> (a -> IO c) -- ^ computation to run in-between
- -> IO c -- returns the value from the in-between computation
-bracket before after thing =
- block (do
- a <- before
- r <- catch
- (unblock (thing a))
- (\e -> do { after a; throw e })
- after a
- return r
- )
-#endif
-
--- | A specialised variant of 'bracket' with just a computation to run
--- afterward.
---
-finally :: IO a -- ^ computation to run first
- -> IO b -- ^ computation to run afterward (even if an exception
- -- was raised)
- -> IO a -- returns the value from the first computation
-a `finally` sequel =
- block (do
- r <- catch
- (unblock a)
- (\e -> do { sequel; throw e })
- sequel
- return r
- )
-
--- | A variant of 'bracket' where the return value from the first computation
--- is not required.
-bracket_ :: IO a -> IO b -> IO c -> IO c
-bracket_ before after thing = bracket before (const after) (const thing)
-
--- | Like bracket, but only performs the final action if there was an
--- exception raised by the in-between computation.
-bracketOnError
- :: IO a -- ^ computation to run first (\"acquire resource\")
- -> (a -> IO b) -- ^ computation to run last (\"release resource\")
- -> (a -> IO c) -- ^ computation to run in-between
- -> IO c -- returns the value from the in-between computation
-bracketOnError before after thing =
- block (do
- a <- before
- catch
- (unblock (thing a))
- (\e -> do { after a; throw e })
- )
-
--- -----------------------------------------------------------------------------
--- Asynchronous exceptions
-
-{- $async
-
- #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to
-external influences, and can be raised at any point during execution.
-'StackOverflow' and 'HeapOverflow' are two examples of
-system-generated asynchronous exceptions.
-
-The primary source of asynchronous exceptions, however, is
-'throwTo':
-
-> throwTo :: ThreadId -> Exception -> IO ()
-
-'throwTo' (also 'throwDynTo' and 'Control.Concurrent.killThread') allows one
-running thread to raise an arbitrary exception in another thread. The
-exception is therefore asynchronous with respect to the target thread,
-which could be doing anything at the time it receives the exception.
-Great care should be taken with asynchronous exceptions; it is all too
-easy to introduce race conditions by the over zealous use of
-'throwTo'.
--}
-
-{- $block_handler
-There\'s an implied 'block' around every exception handler in a call
-to one of the 'catch' family of functions. This is because that is
-what you want most of the time - it eliminates a common race condition
-in starting an exception handler, because there may be no exception
-handler on the stack to handle another exception if one arrives
-immediately. If asynchronous exceptions are blocked on entering the
-handler, though, we have time to install a new exception handler
-before being interrupted. If this weren\'t the default, one would have
-to write something like
-
-> block (
-> catch (unblock (...))
-> (\e -> handler)
-> )
-
-If you need to unblock asynchronous exceptions again in the exception
-handler, just use 'unblock' as normal.
-
-Note that 'try' and friends /do not/ have a similar default, because
-there is no exception handler in this case. If you want to use 'try'
-in an asynchronous-exception-safe way, you will need to use
-'block'.
--}
-
-{- $interruptible
-
-Some operations are /interruptible/, which means that they can receive
-asynchronous exceptions even in the scope of a 'block'. Any function
-which may itself block is defined as interruptible; this includes
-'Control.Concurrent.MVar.takeMVar'
-(but not 'Control.Concurrent.MVar.tryTakeMVar'),
-and most operations which perform
-some I\/O with the outside world. The reason for having
-interruptible operations is so that we can write things like
-
-> block (
-> a <- takeMVar m
-> catch (unblock (...))
-> (\e -> ...)
-> )
-
-if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,
-then this particular
-combination could lead to deadlock, because the thread itself would be
-blocked in a state where it can\'t receive any asynchronous exceptions.
-With 'Control.Concurrent.MVar.takeMVar' interruptible, however, we can be
-safe in the knowledge that the thread can receive exceptions right up
-until the point when the 'Control.Concurrent.MVar.takeMVar' succeeds.
-Similar arguments apply for other interruptible operations like
-'System.IO.openFile'.
--}
-
-#if !(__GLASGOW_HASKELL__ || __NHC__)
-assert :: Bool -> a -> a
-assert True x = x
-assert False _ = throw (AssertionFailed "")
-#endif
-
-
-#ifdef __GLASGOW_HASKELL__
-{-# NOINLINE uncaughtExceptionHandler #-}
-uncaughtExceptionHandler :: IORef (Exception -> IO ())
-uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
- where
- defaultHandler :: Exception -> IO ()
- defaultHandler ex = do
- (hFlush stdout) `catchException` (\ _ -> return ())
- let msg = case ex of
- Deadlock -> "no threads to run: infinite loop or deadlock?"
- ErrorCall s -> s
- other -> showsPrec 0 other "\n"
- withCString "%s" $ \cfmt ->
- withCString msg $ \cmsg ->
- errorBelch cfmt cmsg
-
-foreign import ccall unsafe "RtsMessages.h errorBelch"
- errorBelch :: CString -> CString -> IO ()
-
-setUncaughtExceptionHandler :: (Exception -> IO ()) -> IO ()
-setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
-
-getUncaughtExceptionHandler :: IO (Exception -> IO ())
-getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
-#endif
View
334 Control/Monad.hs
@@ -1,334 +0,0 @@
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Control.Monad
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- The 'Functor', 'Monad' and 'MonadPlus' classes,
--- with some useful operations on monads.
-
-module Control.Monad
- (
- -- * Functor and monad classes
-
- Functor(fmap)
- , Monad((>>=), (>>), return, fail)
-
- , MonadPlus ( -- class context: Monad
- mzero -- :: (MonadPlus m) => m a
- , mplus -- :: (MonadPlus m) => m a -> m a -> m a
- )
- -- * Functions
-
- -- ** Naming conventions
- -- $naming
-
- -- ** Basic functions from the "Prelude"
-
- , mapM -- :: (Monad m) => (a -> m b) -> [a] -> m [b]
- , mapM_ -- :: (Monad m) => (a -> m b) -> [a] -> m ()
- , forM -- :: (Monad m) => [a] -> (a -> m b) -> m [b]
- , forM_ -- :: (Monad m) => [a] -> (a -> m b) -> m ()
- , sequence -- :: (Monad m) => [m a] -> m [a]
- , sequence_ -- :: (Monad m) => [m a] -> m ()
- , (=<<) -- :: (Monad m) => (a -> m b) -> m a -> m b
- , (>=>) -- :: (Monad m) => (a -> m b) -> (b -> m c) -> (a -> m c)
- , (<=<) -- :: (Monad m) => (b -> m c) -> (a -> m b) -> (a -> m c)
- , forever -- :: (Monad m) => m a -> m ()
-
- -- ** Generalisations of list functions
-
- , join -- :: (Monad m) => m (m a) -> m a
- , 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
- , foldM_ -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m ()
- , replicateM -- :: (Monad m) => Int -> m a -> m [a]
- , replicateM_ -- :: (Monad m) => Int -> m a -> m ()
-
- -- ** Conditional execution of monadic expressions
-
- , guard -- :: (MonadPlus m) => Bool -> m ()
- , when -- :: (Monad m) => Bool -> m () -> m ()
- , unless -- :: (Monad m) => Bool -> m () -> m ()
-
- -- ** Monadic lifting operators
-
- , liftM -- :: (Monad m) => (a -> b) -> (m a -> m b)
- , liftM2 -- :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)
- , liftM3 -- :: ...
- , liftM4 -- :: ...
- , liftM5 -- :: ...
-
- , ap -- :: (Monad m) => m (a -> b) -> m a -> m b
-
- ) where
-
-import Data.Maybe
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.List
-import GHC.Base
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-infixr 1 =<<
-
--- -----------------------------------------------------------------------------
--- Prelude monad functions
-
--- | Same as '>>=', but with the arguments interchanged.
-{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-}
-(=<<) :: Monad m => (a -> m b) -> m a -> m b
-f =<< x = x >>= f
-
--- | Evaluate each action in the sequence from left to right,
--- and collect the results.
-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) }
-
--- | Evaluate each action in the sequence from left to right,
--- and ignore the results.
-sequence_ :: Monad m => [m a] -> m ()
-{-# INLINE sequence_ #-}
-sequence_ ms = foldr (>>) (return ()) ms
-
--- | @'mapM' f@ is equivalent to @'sequence' . 'map' f@.
-mapM :: Monad m => (a -> m b) -> [a] -> m [b]
-{-# INLINE mapM #-}
-mapM f as = sequence (map f as)
-
--- | @'mapM_' f@ is equivalent to @'sequence_' . 'map' f@.
-mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
-{-# INLINE mapM_ #-}
-mapM_ f as = sequence_ (map f as)
-
-#endif /* __GLASGOW_HASKELL__ */
-
--- -----------------------------------------------------------------------------
--- The MonadPlus class definition
-
--- | Monads that also support choice and failure.
-class Monad m => MonadPlus m where
- -- | the identity of 'mplus'. It should also satisfy the equations
- --
- -- > mzero >>= f = mzero
- -- > v >> mzero = mzero
- --
- -- (but the instance for 'System.IO.IO' defined in "Control.Monad.Error"
- -- does not satisfy the second one).
- mzero :: m a
- -- | an associative operation
- 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' b@ is @'return' ()@ if @b@ is 'True',
--- and 'mzero' if @b@ is 'False'.
-guard :: (MonadPlus m) => Bool -> m ()
-guard True = return ()
-guard False = mzero
-
--- | This generalizes 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)
-
--- | 'forM' is 'mapM' with its arguments flipped
-forM :: Monad m => [a] -> (a -> m b) -> m [b]
-{-# INLINE forM #-}
-forM = flip mapM
-
--- | 'forM_' is 'mapM_' with its arguments flipped
-forM_ :: Monad m => [a] -> (a -> m b) -> m ()
-{-# INLINE forM_ #-}
-forM_ = flip mapM_
-
--- | This generalizes the list-based 'concat' function.
-
-msum :: MonadPlus m => [m a] -> m a
-{-# INLINE msum #-}
-msum = foldr mplus mzero
-
-infixr 1 <=<, >=>
-
--- | Left-to-right Kleisli composition of monads.
-(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
-f >=> g = \x -> f x >>= g
-
--- | Right-to-left Kleisli composition of monads. '(>=>)', with the arguments flipped
-(<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)
-(<=<) = flip (>=>)
-
--- | @'forever' act@ repeats the action infinitely.
-forever :: (Monad m) => m a -> m ()
-forever a = a >> forever a
-
--- -----------------------------------------------------------------------------
--- Other monad functions
-
--- | The 'join' function is the conventional monad join operator. It is used to
--- remove one level of monadic structure, projecting its bound argument into the
--- outer level.
-join :: (Monad m) => m (m a) -> m a
-join x = x >>= id
-
--- | The 'mapAndUnzipM' function maps its first argument over a list, returning
--- the result as a pair of lists. This function is mainly used with complicated
--- data structures or a state-transforming monad.
-mapAndUnzipM :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
-mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip
-
--- | The 'zipWithM' function generalizes 'zipWith' to arbitrary monads.
-zipWithM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
-zipWithM f xs ys = sequence (zipWith f xs ys)
-
--- | 'zipWithM_' is the extension of 'zipWithM' which ignores the final result.
-zipWithM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()
-zipWithM_ f xs ys = sequence_ (zipWith f xs ys)
-
-{- | The 'foldM' function is analogous to 'foldl', except that its result is
-encapsulated in a monad. Note that 'foldM' works from left-to-right over
-the list arguments. This could be an issue where '(>>)' and the `folded
-function' are not commutative.
-
-
-> foldM f a1 [x1, x2, ..., xm ]
-
-==
-
-> do
-> a2 <- f a1 x1
-> a3 <- f a2 x2
-> ...
-> f am xm
-
-If right-to-left evaluation is required, the input list should be reversed.
--}
-
-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
-
--- | Like 'foldM', but discards the result.
-foldM_ :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m ()
-foldM_ f a xs = foldM f a xs >> return ()
-
--- | @'replicateM' n act@ performs the action @n@ times,
--- gathering the results.
-replicateM :: (Monad m) => Int -> m a -> m [a]
-replicateM n x = sequence (replicate n x)
-
--- | Like 'replicateM', but discards the result.
-replicateM_ :: (Monad m) => Int -> m a -> m ()
-replicateM_ n x = sequence_ (replicate n x)
-
-{- | Conditional execution of monadic expressions. For example,
-
-> when debug (putStr "Debugging\n")
-
-will output the string @Debugging\\n@ if the Boolean value @debug@ is 'True',
-and otherwise do nothing.
--}
-
-when :: (Monad m) => Bool -> m () -> m ()
-when p s = if p then s else return ()
-
--- | The reverse of 'when'.
-
-unless :: (Monad m) => Bool -> m () -> m ()
-unless p s = if p then return () else s
-
--- | Promote a function to a monad.
-liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r
-liftM f m1 = do { x1 <- m1; return (f x1) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right. For example,
---
--- > liftM2 (+) [0,1] [0,2] = [0,2,1,3]
--- > liftM2 (+) (Just 1) Nothing = Nothing
---
-liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
-liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right (cf. 'liftM2').
-liftM3 :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
-liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right (cf. 'liftM2').
-liftM4 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
-liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right (cf. 'liftM2').
-liftM5 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
-liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) }
-
-{- | In many situations, the 'liftM' operations can be replaced by uses of
-'ap', which promotes function application.
-
-> return f `ap` x1 `ap` ... `ap` xn
-
-is equivalent to
-
-> liftMn f x1 x2 ... xn
-
--}
-
-ap :: (Monad m) => m (a -> b) -> m a -> m b
-ap = liftM2 id
-
-
-{- $naming
-
-The functions in this library use the following naming conventions:
-
-* A postfix \'@M@\' always stands for a function in the Kleisli category:
- The monad type constructor @m@ is added to function results
- (modulo currying) and nowhere else. So, for example,
-
-> filter :: (a -> Bool) -> [a] -> [a]
-> filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
-
-* A postfix \'@_@\' changes the result type from @(m a)@ to @(m ())@.
- Thus, for example:
-
-> sequence :: Monad m => [m a] -> m [a]
-> sequence_ :: Monad m => [m a] -> m ()
-
-* A prefix \'@m@\' generalizes an existing function to a monadic form.
- Thus, for example:
-
-> sum :: Num a => [a] -> a
-> msum :: MonadPlus m => [m a] -> m a
-
--}
View
73 Control/Monad/Fix.hs
@@ -1,73 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Control.Monad.Fix
--- Copyright : (c) Andy Gill 2001,
--- (c) Oregon Graduate Institute of Science and Technology, 2002
--- License : BSD-style (see the file libraries/base/LICENSE)
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Monadic fixpoints.
---
--- For a detailed discussion, see Levent Erkok's thesis,
--- /Value Recursion in Monadic Computations/, Oregon Graduate Institute, 2002.
---
------------------------------------------------------------------------------
-
-module Control.Monad.Fix (
- MonadFix(
- mfix -- :: (a -> m a) -> m a