+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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ö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
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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)
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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 :-)
--}
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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)
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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 ()
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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')
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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)
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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
+++ /dev/null
-{-# 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
-
--}
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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
- ),
- fix -- :: (a -> a) -> a
- ) where
-
-import Prelude
-import System.IO
-import Control.Monad.Instances ()
-import Data.Function (fix)
-
--- | Monads having fixed points with a \'knot-tying\' semantics.
--- Instances of 'MonadFix' should satisfy the following laws:
---
--- [/purity/]
--- @'mfix' ('return' . h) = 'return' ('fix' h)@
---
--- [/left shrinking/ (or /tightening/)]
--- @'mfix' (\\x -> a >>= \\y -> f x y) = a >>= \\y -> 'mfix' (\\x -> f x y)@
---
--- [/sliding/]
--- @'mfix' ('Control.Monad.liftM' h . f) = 'Control.Monad.liftM' h ('mfix' (f . h))@,
--- for strict @h@.
---
--- [/nesting/]
--- @'mfix' (\\x -> 'mfix' (\\y -> f x y)) = 'mfix' (\\x -> f x x)@
---
--- This class is used in the translation of the recursive @do@ notation
--- supported by GHC and Hugs.
-class (Monad m) => MonadFix m where
- -- | The fixed point of a monadic computation.
- -- @'mfix' f@ executes the action @f@ only once, with the eventual
- -- output fed back as the input. Hence @f@ should not be strict,
- -- for then @'mfix' f@ would diverge.
- mfix :: (a -> m a) -> m a
-
--- Instances of MonadFix for Prelude monads
-
--- Maybe:
-instance MonadFix Maybe where
- mfix f = let a = f (unJust a) in a
- where unJust (Just x) = x
-
--- List:
-instance MonadFix [] where
- mfix f = case fix (f . head) of
- [] -> []
- (x:_) -> x : mfix (tail . f)
-
--- IO:
-instance MonadFix IO where
- mfix = fixIO
-
-instance MonadFix ((->) r) where
- mfix f = \ r -> let a = f a r in a
+++ /dev/null
-{-# OPTIONS_NHC98 -prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Control.Monad.Instances
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- 'Functor' and 'Monad' instances for @(->) r@ and
--- 'Functor' instances for @(,) a@ and @'Either' a@.
-
-module Control.Monad.Instances (Functor(..),Monad(..)) where
-
-import Prelude
-
-instance Functor ((->) r) where
- fmap = (.)
-
-instance Monad ((->) r) where
- return = const
- f >>= k = \ r -> k (f r) r
-
-instance Functor ((,) a) where
- fmap f (x,y) = (x, f y)
-
-instance Functor (Either a) where
- fmap _ (Left x) = Left x
- fmap f (Right y) = Right (f y)
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Control.Monad.ST
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (requires universal quantification for runST)
---
--- This library provides support for /strict/ state threads, as
--- described in the PLDI \'94 paper by John Launchbury and Simon Peyton
--- Jones /Lazy Functional State Threads/.
---
------------------------------------------------------------------------------
-
-module Control.Monad.ST
- (
- -- * The 'ST' Monad
- ST, -- abstract, instance of Functor, Monad, Typeable.
- runST, -- :: (forall s. ST s a) -> a
- fixST, -- :: (a -> ST s a) -> ST s a
-
- -- * Converting 'ST' to 'IO'
- RealWorld, -- abstract
- stToIO, -- :: ST RealWorld a -> IO a
-
- -- * Unsafe operations
- unsafeInterleaveST, -- :: ST s a -> ST s a
- unsafeIOToST, -- :: IO a -> ST s a
- unsafeSTToIO -- :: ST s a -> IO a
- ) where
-
-import Prelude
-
-import Control.Monad.Fix
-
-#include "Typeable.h"
-
-#ifdef __HUGS__
-import Data.Typeable
-import Hugs.ST
-import qualified Hugs.LazyST as LazyST
-
-INSTANCE_TYPEABLE2(ST,sTTc,"ST")
-INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")
-
-fixST :: (a -> ST s a) -> ST s a
-fixST f = LazyST.lazyToStrictST (LazyST.fixST (LazyST.strictToLazyST . f))
-
-unsafeInterleaveST :: ST s a -> ST s a
-unsafeInterleaveST =
- LazyST.lazyToStrictST . LazyST.unsafeInterleaveST . LazyST.strictToLazyST
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.ST ( ST, runST, fixST, unsafeInterleaveST )
-import GHC.Base ( RealWorld )
-import GHC.IOBase ( stToIO, unsafeIOToST, unsafeSTToIO )
-#endif
-
-instance MonadFix (ST s) where
- mfix = fixST
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Control.Monad.ST.Lazy
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : non-portable (requires universal quantification for runST)
---
--- This module presents an identical interface to "Control.Monad.ST",
--- except that the monad delays evaluation of state operations until
--- a value depending on them is required.
---
------------------------------------------------------------------------------
-
-module Control.Monad.ST.Lazy (
- -- * The 'ST' monad
- ST,
- runST,
- fixST,
-
- -- * Converting between strict and lazy 'ST'
- strictToLazyST, lazyToStrictST,
-
- -- * Converting 'ST' To 'IO'
- RealWorld,
- stToIO,
-
- -- * Unsafe operations
- unsafeInterleaveST,
- unsafeIOToST
- ) where
-
-import Prelude
-
-import Control.Monad.Fix
-
-import Control.Monad.ST (RealWorld)
-import qualified Control.Monad.ST as ST
-
-#ifdef __GLASGOW_HASKELL__
-import qualified GHC.ST
-import GHC.Base
-import Control.Monad
-#endif
-
-#ifdef __HUGS__
-import Hugs.LazyST
-#endif
-
-#ifdef __GLASGOW_HASKELL__
--- | The lazy state-transformer monad.
--- A computation of type @'ST' s a@ transforms an internal state indexed
--- by @s@, and returns a value of type @a@.
--- The @s@ parameter is either
---
--- * an unstantiated type variable (inside invocations of 'runST'), or
---
--- * 'RealWorld' (inside invocations of 'stToIO').
---
--- It serves to keep the internal states of different invocations of
--- 'runST' separate from each other and from invocations of 'stToIO'.
---
--- The '>>=' and '>>' operations are not strict in the state. For example,
---
--- @'runST' (writeSTRef _|_ v >>= readSTRef _|_ >> return 2) = 2@
-newtype ST s a = ST (State s -> (a, State s))
-data State s = S# (State# s)
-
-instance Functor (ST s) where
- fmap f m = ST $ \ s ->
- let
- ST m_a = m
- (r,new_s) = m_a s
- in
- (f r,new_s)
-
-instance Monad (ST s) where
-
- return a = ST $ \ s -> (a,s)
- m >> k = m >>= \ _ -> k
- fail s = error s
-
- (ST m) >>= k
- = ST $ \ s ->
- let
- (r,new_s) = m s
- ST k_a = k r
- in
- k_a new_s
-
-{-# NOINLINE runST #-}
--- | Return the value computed by a state transformer computation.
--- The @forall@ ensures that the internal state used by the 'ST'
--- computation is inaccessible to the rest of the program.
-runST :: (forall s. ST s a) -> a
-runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r
-
--- | Allow the result of a state transformer computation to be used (lazily)
--- inside the computation.
--- Note that if @f@ is strict, @'fixST' f = _|_@.
-fixST :: (a -> ST s a) -> ST s a
-fixST m = ST (\ s ->
- let
- ST m_r = m r
- (r,s') = m_r s
- in
- (r,s'))
-#endif
-
-instance MonadFix (ST s) where
- mfix = fixST
-
--- ---------------------------------------------------------------------------
--- Strict <--> Lazy
-
-#ifdef __GLASGOW_HASKELL__
-{-|
-Convert a strict 'ST' computation into a lazy one. The strict state
-thread passed to 'strictToLazyST' is not performed until the result of
-the lazy state thread it returns is demanded.
--}
-strictToLazyST :: ST.ST s a -> ST s a
-strictToLazyST m = ST $ \s ->
- let
- pr = case s of { S# s# -> GHC.ST.liftST m s# }
- r = case pr of { GHC.ST.STret _ v -> v }
- s' = case pr of { GHC.ST.STret s2# _ -> S# s2# }
- in
- (r, s')
-
-{-|
-Convert a lazy 'ST' computation into a strict one.
--}
-lazyToStrictST :: ST s a -> ST.ST s a
-lazyToStrictST (ST m) = GHC.ST.ST $ \s ->
- case (m (S# s)) of (a, S# s') -> (# s', a #)
-
-unsafeInterleaveST :: ST s a -> ST s a
-unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST
-#endif
-
-unsafeIOToST :: IO a -> ST s a
-unsafeIOToST = strictToLazyST . ST.unsafeIOToST
-
--- | A monad transformer embedding lazy state transformers in the 'IO'
--- monad. The 'RealWorld' parameter indicates that the internal state
--- used by the 'ST' computation is a special one supplied by the 'IO'
--- monad, and thus distinct from those used by invocations of 'runST'.
-stToIO :: ST RealWorld a -> IO a
-stToIO = ST.stToIO . lazyToStrictST
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Control.Monad.ST.Strict
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : non-portable (requires universal quantification for runST)
---
--- The strict ST monad (re-export of "Control.Monad.ST")
---
------------------------------------------------------------------------------
-
-module Control.Monad.ST.Strict (
- module Control.Monad.ST
- ) where
-
-import Prelude
-import Control.Monad.ST
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Array
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Basic non-strict arrays.
---
--- /Note:/ The "Data.Array.IArray" module provides more general interface
--- to immutable arrays: it defines operations with the same names as
--- those defined below, but with more general types, and also defines
--- 'Array' instances of the relevant classes. To use that more general
--- interface, import "Data.Array.IArray" but not "Data.Array".
------------------------------------------------------------------------------
-
-module Data.Array
-
- (
- -- * Immutable non-strict arrays
- -- $intro
- module Data.Ix -- export all of Ix
- , Array -- Array type is abstract
-
- -- * Array construction
- , array -- :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
- , listArray -- :: (Ix a) => (a,a) -> [b] -> Array a b
- , accumArray -- :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b
- -- * Accessing arrays
- , (!) -- :: (Ix a) => Array a b -> a -> b
- , bounds -- :: (Ix a) => Array a b -> (a,a)
- , indices -- :: (Ix a) => Array a b -> [a]
- , elems -- :: (Ix a) => Array a b -> [b]
- , assocs -- :: (Ix a) => Array a b -> [(a,b)]
- -- * Incremental array updates
- , (//) -- :: (Ix a) => Array a b -> [(a,b)] -> Array a b
- , accum -- :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b
- -- * Derived arrays
- , ixmap -- :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a b
-
- -- Array instances:
- --
- -- Ix a => Functor (Array a)
- -- (Ix a, Eq b) => Eq (Array a b)
- -- (Ix a, Ord b) => Ord (Array a b)
- -- (Ix a, Show a, Show b) => Show (Array a b)
- -- (Ix a, Read a, Read b) => Read (Array a b)
- --
-
- -- Implementation checked wrt. Haskell 98 lib report, 1/99.
-
- ) where
-
-import Data.Ix
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Arr -- Most of the hard work is done here
-import Data.Generics.Basics -- To provide a Data instance
-import Data.Generics.Instances -- To provide a Data instance
-import GHC.Err ( error ) -- Needed for Data instance
-#endif
-
-#ifdef __HUGS__
-import Hugs.Array
-#endif
-
-#ifdef __NHC__
-import Array -- Haskell'98 arrays
-#endif
-
-import Data.Typeable
-
-{- $intro
-Haskell provides indexable /arrays/, which may be thought of as functions
-whose domains are isomorphic to contiguous subsets of the integers.
-Functions restricted in this way can be implemented efficiently;
-in particular, a programmer may reasonably expect rapid access to
-the components. To ensure the possibility of such an implementation,
-arrays are treated as data, not as general functions.
-
-Since most array functions involve the class 'Ix', this module is exported
-from "Data.Array" so that modules need not import both "Data.Array" and
-"Data.Ix".
--}
+++ /dev/null
-{-# OPTIONS_GHC -fno-bang-patterns #-}
-
------------------------------------------------------------------------------
--- |
--- Module : Data.Array.Base
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (MPTCs, uses Control.Monad.ST)
---
--- Basis for IArray and MArray. Not intended for external consumption;
--- use IArray or MArray instead.
---
------------------------------------------------------------------------------
-
--- #hide
-module Data.Array.Base where
-
-import Prelude
-
-import Control.Monad.ST.Lazy ( strictToLazyST )
-import qualified Control.Monad.ST.Lazy as Lazy (ST)
-import Data.Ix ( Ix, range, index, rangeSize )
-import Data.Int
-import Data.Word
-import Foreign.C.Types
-import Foreign.Ptr
-import Foreign.StablePtr
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Arr ( STArray, unsafeIndex )
-import qualified GHC.Arr as Arr
-import qualified GHC.Arr as ArrST
-import GHC.ST ( ST(..), runST )
-import GHC.Base
-import GHC.Word ( Word(..) )
-import GHC.Ptr ( Ptr(..), FunPtr(..), nullPtr, nullFunPtr )
-import GHC.Float ( Float(..), Double(..) )
-import GHC.Stable ( StablePtr(..) )
-import GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..) )
-import GHC.Word ( Word8(..), Word16(..), Word32(..), Word64(..) )
-import GHC.IOBase ( IO(..) )
-#endif
-
-#ifdef __HUGS__
-import Data.Bits
-import Foreign.Storable
-import qualified Hugs.Array as Arr
-import qualified Hugs.ST as ArrST
-import Hugs.Array ( unsafeIndex )
-import Hugs.ST ( STArray, ST(..), runST )
-import Hugs.ByteArray
-#endif
-
-import Data.Typeable
-#include "Typeable.h"
-
-#include "MachDeps.h"
-
------------------------------------------------------------------------------
--- Class of immutable arrays
-
-{- | Class of immutable array types.
-
-An array type has the form @(a i e)@ where @a@ is the array type
-constructor (kind @* -> * -> *@), @i@ is the index type (a member of
-the class 'Ix'), and @e@ is the element type. The @IArray@ class is
-parameterised over both @a@ and @e@, so that instances specialised to
-certain element types can be defined.
--}
-class IArray a e where
- -- | Extracts the bounds of an immutable array
- bounds :: Ix i => a i e -> (i,i)
- unsafeArray :: Ix i => (i,i) -> [(Int, e)] -> a i e
- unsafeAt :: Ix i => a i e -> Int -> e
- unsafeReplace :: Ix i => a i e -> [(Int, e)] -> a i e
- unsafeAccum :: Ix i => (e -> e' -> e) -> a i e -> [(Int, e')] -> a i e
- unsafeAccumArray :: Ix i => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> a i e
-
- unsafeReplace arr ies = runST (unsafeReplaceST arr ies >>= unsafeFreeze)
- unsafeAccum f arr ies = runST (unsafeAccumST f arr ies >>= unsafeFreeze)
- unsafeAccumArray f e lu ies = runST (unsafeAccumArrayST f e lu ies >>= unsafeFreeze)
-
-{-# INLINE unsafeReplaceST #-}
-unsafeReplaceST :: (IArray a e, Ix i) => a i e -> [(Int, e)] -> ST s (STArray s i e)
-unsafeReplaceST arr ies = do
- marr <- thaw arr
- sequence_ [unsafeWrite marr i e | (i, e) <- ies]
- return marr
-
-{-# INLINE unsafeAccumST #-}
-unsafeAccumST :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(Int, e')] -> ST s (STArray s i e)
-unsafeAccumST f arr ies = do
- marr <- thaw arr
- sequence_ [do
- old <- unsafeRead marr i
- unsafeWrite marr i (f old new)
- | (i, new) <- ies]
- return marr
-
-{-# INLINE unsafeAccumArrayST #-}
-unsafeAccumArrayST :: Ix i => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (STArray s i e)
-unsafeAccumArrayST f e (l,u) ies = do
- marr <- newArray (l,u) e
- sequence_ [do
- old <- unsafeRead marr i
- unsafeWrite marr i (f old new)
- | (i, new) <- ies]
- return marr
-
-
-{-# INLINE array #-}
-
-{-| Constructs an immutable array from a pair of bounds and a list of
-initial associations.
-
-The bounds are specified as a pair of the lowest and highest bounds in
-the array respectively. For example, a one-origin vector of length 10
-has bounds (1,10), and a one-origin 10 by 10 matrix has bounds
-((1,1),(10,10)).
-
-An association is a pair of the form @(i,x)@, which defines the value of
-the array at index @i@ to be @x@. The array is undefined if any index
-in the list is out of bounds. If any two associations in the list have
-the same index, the value at that index is implementation-dependent.
-(In GHC, the last value specified for that index is used.
-Other implementations will also do this for unboxed arrays, but Haskell
-98 requires that for 'Array' the value at such indices is bottom.)
-
-Because the indices must be checked for these errors, 'array' is
-strict in the bounds argument and in the indices of the association
-list. Whether @array@ is strict or non-strict in the elements depends
-on the array type: 'Data.Array.Array' is a non-strict array type, but
-all of the 'Data.Array.Unboxed.UArray' arrays are strict. Thus in a
-non-strict array, recurrences such as the following are possible:
-
-> a = array (1,100) ((1,1) : [(i, i * a!(i-1)) | i \<- [2..100]])
-
-Not every index within the bounds of the array need appear in the
-association list, but the values associated with indices that do not
-appear will be undefined.
-
-If, in any dimension, the lower bound is greater than the upper bound,
-then the array is legal, but empty. Indexing an empty array always
-gives an array-bounds error, but 'bounds' still yields the bounds with
-which the array was constructed.
--}
-array :: (IArray a e, Ix i)
- => (i,i) -- ^ bounds of the array: (lowest,highest)
- -> [(i, e)] -- ^ list of associations
- -> a i e
-array (l,u) ies = unsafeArray (l,u) [(index (l,u) i, e) | (i, e) <- ies]
-
--- Since unsafeFreeze is not guaranteed to be only a cast, we will
--- use unsafeArray and zip instead of a specialized loop to implement
--- listArray, unlike Array.listArray, even though it generates some
--- unnecessary heap allocation. Will use the loop only when we have
--- fast unsafeFreeze, namely for Array and UArray (well, they cover
--- almost all cases).
-
-{-# INLINE listArray #-}
-
--- | Constructs an immutable array from a list of initial elements.
--- The list gives the elements of the array in ascending order
--- beginning with the lowest index.
-listArray :: (IArray a e, Ix i) => (i,i) -> [e] -> a i e
-listArray (l,u) es = unsafeArray (l,u) (zip [0 .. rangeSize (l,u) - 1] es)
-
-{-# INLINE listArrayST #-}
-listArrayST :: Ix i => (i,i) -> [e] -> ST s (STArray s i e)
-listArrayST (l,u) es = do
- marr <- newArray_ (l,u)
- let n = rangeSize (l,u)
- let fillFromList i xs | i == n = return ()
- | otherwise = case xs of
- [] -> return ()
- y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys
- fillFromList 0 es
- return marr
-
-{-# RULES
-"listArray/Array" listArray =
- \lu es -> runST (listArrayST lu es >>= ArrST.unsafeFreezeSTArray)
- #-}
-
-{-# INLINE listUArrayST #-}
-listUArrayST :: (MArray (STUArray s) e (ST s), Ix i)
- => (i,i) -> [e] -> ST s (STUArray s i e)
-listUArrayST (l,u) es = do
- marr <- newArray_ (l,u)
- let n = rangeSize (l,u)
- let fillFromList i xs | i == n = return ()
- | otherwise = case xs of
- [] -> return ()
- y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys
- fillFromList 0 es
- return marr
-
--- I don't know how to write a single rule for listUArrayST, because
--- the type looks like constrained over 's', which runST doesn't
--- like. In fact all MArray (STUArray s) instances are polymorphic
--- wrt. 's', but runST can't know that.
---
--- More precisely, we'd like to write this:
--- listUArray :: (forall s. MArray (STUArray s) e (ST s), Ix i)
--- => (i,i) -> [e] -> UArray i e
--- listUArray lu = runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
--- {-# RULES listArray = listUArray
--- Then we could call listUArray at any type 'e' that had a suitable
--- MArray instance. But sadly we can't, because we don't have quantified
--- constraints. Hence the mass of rules below.
-
--- I would like also to write a rule for listUArrayST (or listArray or
--- whatever) applied to unpackCString#. Unfortunately unpackCString#
--- calls seem to be floated out, then floated back into the middle
--- of listUArrayST, so I was not able to do this.
-
-#ifdef __GLASGOW_HASKELL__
-type ListUArray e = forall i . Ix i => (i,i) -> [e] -> UArray i e
-
-{-# RULES
-"listArray/UArray/Bool" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Bool
-"listArray/UArray/Char" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Char
-"listArray/UArray/Int" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Int
-"listArray/UArray/Word" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Word
-"listArray/UArray/Ptr" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray (Ptr a)
-"listArray/UArray/FunPtr" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray (FunPtr a)
-"listArray/UArray/Float" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Float
-"listArray/UArray/Double" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Double
-"listArray/UArray/StablePtr" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray (StablePtr a)
-"listArray/UArray/Int8" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Int8
-"listArray/UArray/Int16" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Int16
-"listArray/UArray/Int32" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Int32
-"listArray/UArray/Int64" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Int64
-"listArray/UArray/Word8" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Word8
-"listArray/UArray/Word16" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Word16
-"listArray/UArray/Word32" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Word32
-"listArray/UArray/Word64" listArray
- = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Word64
- #-}
-#endif
-
-{-# INLINE (!) #-}
--- | Returns the element of an immutable array at the specified index.
-(!) :: (IArray a e, Ix i) => a i e -> i -> e
-arr ! i = case bounds arr of (l,u) -> unsafeAt arr (index (l,u) i)
-
-{-# INLINE indices #-}
--- | Returns a list of all the valid indices in an array.
-indices :: (IArray a e, Ix i) => a i e -> [i]
-indices arr = case bounds arr of (l,u) -> range (l,u)
-
-{-# INLINE elems #-}
--- | Returns a list of all the elements of an array, in the same order
--- as their indices.
-elems :: (IArray a e, Ix i) => a i e -> [e]
-elems arr = case bounds arr of
- (l,u) -> [unsafeAt arr i | i <- [0 .. rangeSize (l,u) - 1]]
-
-{-# INLINE assocs #-}
--- | Returns the contents of an array as a list of associations.
-assocs :: (IArray a e, Ix i) => a i e -> [(i, e)]
-assocs arr = case bounds arr of
- (l,u) -> [(i, unsafeAt arr (unsafeIndex (l,u) i)) | i <- range (l,u)]
-
-{-# INLINE accumArray #-}
-
-{-|
-Constructs an immutable array from a list of associations. Unlike
-'array', the same index is allowed to occur multiple times in the list
-of associations; an /accumulating function/ is used to combine the
-values of elements with the same index.
-
-For example, given a list of values of some index type, hist produces
-a histogram of the number of occurrences of each index within a
-specified range:
-
-> hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b
-> hist bnds is = accumArray (+) 0 bnds [(i, 1) | i\<-is, inRange bnds i]
--}
-accumArray :: (IArray a e, Ix i)
- => (e -> e' -> e) -- ^ An accumulating function
- -> e -- ^ A default element
- -> (i,i) -- ^ The bounds of the array
- -> [(i, e')] -- ^ List of associations
- -> a i e -- ^ Returns: the array
-accumArray f init (l,u) ies =
- unsafeAccumArray f init (l,u) [(index (l,u) i, e) | (i, e) <- ies]
-
-{-# INLINE (//) #-}
-{-|
-Takes an array and a list of pairs and returns an array identical to
-the left argument except that it has been updated by the associations
-in the right argument. For example, if m is a 1-origin, n by n matrix,
-then @m\/\/[((i,i), 0) | i \<- [1..n]]@ is the same matrix, except with
-the diagonal zeroed.
-
-As with the 'array' function, if any two associations in the list have
-the same index, the value at that index is implementation-dependent.
-(In GHC, the last value specified for that index is used.
-Other implementations will also do this for unboxed arrays, but Haskell
-98 requires that for 'Array' the value at such indices is bottom.)
-
-For most array types, this operation is O(/n/) where /n/ is the size
-of the array. However, the 'Data.Array.Diff.DiffArray' type provides
-this operation with complexity linear in the number of updates.
--}
-(//) :: (IArray a e, Ix i) => a i e -> [(i, e)] -> a i e
-arr // ies = case bounds arr of
- (l,u) -> unsafeReplace arr [(index (l,u) i, e) | (i, e) <- ies]
-
-{-# INLINE accum #-}
-{-|
-@accum f@ takes an array and an association list and accumulates pairs
-from the list into the array with the accumulating function @f@. Thus
-'accumArray' can be defined using 'accum':
-
-> accumArray f z b = accum f (array b [(i, z) | i \<- range b])
--}
-accum :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(i, e')] -> a i e
-accum f arr ies = case bounds arr of
- (l,u) -> unsafeAccum f arr [(index (l,u) i, e) | (i, e) <- ies]
-
-{-# INLINE amap #-}
--- | Returns a new array derived from the original array by applying a
--- function to each of the elements.
-amap :: (IArray a e', IArray a e, Ix i) => (e' -> e) -> a i e' -> a i e
-amap f arr = case bounds arr of
- (l,u) -> unsafeArray (l,u) [(i, f (unsafeAt arr i)) |
- i <- [0 .. rangeSize (l,u) - 1]]
-{-# INLINE ixmap #-}
--- | Returns a new array derived from the original array by applying a
--- function to each of the indices.
-ixmap :: (IArray a e, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> a i e
-ixmap (l,u) f arr =
- unsafeArray (l,u) [(unsafeIndex (l,u) i, arr ! f i) | i <- range (l,u)]
-
------------------------------------------------------------------------------
--- Normal polymorphic arrays
-
-instance IArray Arr.Array e where
- {-# INLINE bounds #-}
- bounds = Arr.bounds
- {-# INLINE unsafeArray #-}
- unsafeArray = Arr.unsafeArray
- {-# INLINE unsafeAt #-}
- unsafeAt = Arr.unsafeAt
- {-# INLINE unsafeReplace #-}
- unsafeReplace = Arr.unsafeReplace
- {-# INLINE unsafeAccum #-}
- unsafeAccum = Arr.unsafeAccum
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray = Arr.unsafeAccumArray
-
------------------------------------------------------------------------------
--- Flat unboxed arrays
-
--- | Arrays with unboxed elements. Instances of 'IArray' are provided
--- for 'UArray' with certain element types ('Int', 'Float', 'Char',
--- etc.; see the 'UArray' class for a full list).
---
--- A 'UArray' will generally be more efficient (in terms of both time
--- and space) than the equivalent 'Data.Array.Array' with the same
--- element type. However, 'UArray' is strict in its elements - so
--- don\'t use 'UArray' if you require the non-strictness that
--- 'Data.Array.Array' provides.
---
--- Because the @IArray@ interface provides operations overloaded on
--- the type of the array, it should be possible to just change the
--- array type being used by a program from say @Array@ to @UArray@ to
--- get the benefits of unboxed arrays (don\'t forget to import
--- "Data.Array.Unboxed" instead of "Data.Array").
---
-#ifdef __GLASGOW_HASKELL__
-data UArray i e = UArray !i !i ByteArray#
-#endif
-#ifdef __HUGS__
-data UArray i e = UArray !i !i !ByteArray
-#endif
-
-INSTANCE_TYPEABLE2(UArray,uArrayTc,"UArray")
-
-{-# INLINE unsafeArrayUArray #-}
-unsafeArrayUArray :: (MArray (STUArray s) e (ST s), Ix i)
- => (i,i) -> [(Int, e)] -> e -> ST s (UArray i e)
-unsafeArrayUArray (l,u) ies default_elem = do
- marr <- newArray (l,u) default_elem
- sequence_ [unsafeWrite marr i e | (i, e) <- ies]
- unsafeFreezeSTUArray marr
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE unsafeFreezeSTUArray #-}
-unsafeFreezeSTUArray :: STUArray s i e -> ST s (UArray i e)
-unsafeFreezeSTUArray (STUArray l u marr#) = ST $ \s1# ->
- case unsafeFreezeByteArray# marr# s1# of { (# s2#, arr# #) ->
- (# s2#, UArray l u arr# #) }
-#endif
-
-#ifdef __HUGS__
-unsafeFreezeSTUArray :: STUArray s i e -> ST s (UArray i e)
-unsafeFreezeSTUArray (STUArray l u marr) = do
- arr <- unsafeFreezeMutableByteArray marr
- return (UArray l u arr)
-#endif
-
-{-# INLINE unsafeReplaceUArray #-}
-unsafeReplaceUArray :: (MArray (STUArray s) e (ST s), Ix i)
- => UArray i e -> [(Int, e)] -> ST s (UArray i e)
-unsafeReplaceUArray arr ies = do
- marr <- thawSTUArray arr
- sequence_ [unsafeWrite marr i e | (i, e) <- ies]
- unsafeFreezeSTUArray marr
-
-{-# INLINE unsafeAccumUArray #-}
-unsafeAccumUArray :: (MArray (STUArray s) e (ST s), Ix i)
- => (e -> e' -> e) -> UArray i e -> [(Int, e')] -> ST s (UArray i e)
-unsafeAccumUArray f arr ies = do
- marr <- thawSTUArray arr
- sequence_ [do
- old <- unsafeRead marr i
- unsafeWrite marr i (f old new)
- | (i, new) <- ies]
- unsafeFreezeSTUArray marr
-
-{-# INLINE unsafeAccumArrayUArray #-}
-unsafeAccumArrayUArray :: (MArray (STUArray s) e (ST s), Ix i)
- => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (UArray i e)
-unsafeAccumArrayUArray f init (l,u) ies = do
- marr <- newArray (l,u) init
- sequence_ [do
- old <- unsafeRead marr i
- unsafeWrite marr i (f old new)
- | (i, new) <- ies]
- unsafeFreezeSTUArray marr
-
-{-# INLINE eqUArray #-}
-eqUArray :: (IArray UArray e, Ix i, Eq e) => UArray i e -> UArray i e -> Bool
-eqUArray arr1@(UArray l1 u1 _) arr2@(UArray l2 u2 _) =
- if rangeSize (l1,u1) == 0 then rangeSize (l2,u2) == 0 else
- l1 == l2 && u1 == u2 &&
- and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. rangeSize (l1,u1) - 1]]
-
-{-# INLINE cmpUArray #-}
-cmpUArray :: (IArray UArray e, Ix i, Ord e) => UArray i e -> UArray i e -> Ordering
-cmpUArray arr1 arr2 = compare (assocs arr1) (assocs arr2)
-
-{-# INLINE cmpIntUArray #-}
-cmpIntUArray :: (IArray UArray e, Ord e) => UArray Int e -> UArray Int e -> Ordering
-cmpIntUArray arr1@(UArray l1 u1 _) arr2@(UArray l2 u2 _) =
- if rangeSize (l1,u1) == 0 then if rangeSize (l2,u2) == 0 then EQ else LT else
- if rangeSize (l2,u2) == 0 then GT else
- case compare l1 l2 of
- EQ -> foldr cmp (compare u1 u2) [0 .. rangeSize (l1, min u1 u2) - 1]
- other -> other
- where
- cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of
- EQ -> rest
- other -> other
-
-{-# RULES "cmpUArray/Int" cmpUArray = cmpIntUArray #-}
-
------------------------------------------------------------------------------
--- Showing IArrays
-
-{-# SPECIALISE
- showsIArray :: (IArray UArray e, Ix i, Show i, Show e) =>
- Int -> UArray i e -> ShowS
- #-}
-
-showsIArray :: (IArray a e, Ix i, Show i, Show e) => Int -> a i e -> ShowS
-showsIArray p a =
- showParen (p > 9) $
- showString "array " .
- shows (bounds a) .
- showChar ' ' .
- shows (assocs a)
-
------------------------------------------------------------------------------
--- Flat unboxed arrays: instances
-
-#ifdef __HUGS__
-unsafeAtBArray :: Storable e => UArray i e -> Int -> e
-unsafeAtBArray (UArray _ _ arr) = readByteArray arr
-#endif
-
-instance IArray UArray Bool where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies False)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) =
- (indexWordArray# arr# (bOOL_INDEX i#) `and#` bOOL_BIT i#)
- `neWord#` int2Word# 0#
-#endif
-#ifdef __HUGS__
- unsafeAt (UArray _ _ arr) i =
- testBit (readByteArray arr (bOOL_INDEX i)::BitSet) (bOOL_SUBINDEX i)
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray Char where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies '\0')
- {-# INLINE unsafeAt #-}
-#ifdef __GLASGOW_HASKELL__
- unsafeAt (UArray _ _ arr#) (I# i#) = C# (indexWideCharArray# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray Int where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = I# (indexIntArray# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray Word where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = W# (indexWordArray# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray (Ptr a) where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies nullPtr)
- {-# INLINE unsafeAt #-}
-#ifdef __GLASGOW_HASKELL__
- unsafeAt (UArray _ _ arr#) (I# i#) = Ptr (indexAddrArray# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray (FunPtr a) where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies nullFunPtr)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = FunPtr (indexAddrArray# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray Float where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = F# (indexFloatArray# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray Double where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = D# (indexDoubleArray# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray (StablePtr a) where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies nullStablePtr)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = StablePtr (indexStablePtrArray# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
--- bogus StablePtr value for initialising a UArray of StablePtr.
-#ifdef __GLASGOW_HASKELL__
-nullStablePtr = StablePtr (unsafeCoerce# 0#)
-#endif
-#ifdef __HUGS__
-nullStablePtr = castPtrToStablePtr nullPtr
-#endif
-
-instance IArray UArray Int8 where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = I8# (indexInt8Array# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray Int16 where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = I16# (indexInt16Array# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray Int32 where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = I32# (indexInt32Array# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray Int64 where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = I64# (indexInt64Array# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray Word8 where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = W8# (indexWord8Array# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray Word16 where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = W16# (indexWord16Array# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray Word32 where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = W32# (indexWord32Array# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance IArray UArray Word64 where
- {-# INLINE bounds #-}
- bounds (UArray l u _) = (l,u)
- {-# INLINE unsafeArray #-}
- unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0)
-#ifdef __GLASGOW_HASKELL__
- {-# INLINE unsafeAt #-}
- unsafeAt (UArray _ _ arr#) (I# i#) = W64# (indexWord64Array# arr# i#)
-#endif
-#ifdef __HUGS__
- unsafeAt = unsafeAtBArray
-#endif
- {-# INLINE unsafeReplace #-}
- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
- {-# INLINE unsafeAccum #-}
- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
- {-# INLINE unsafeAccumArray #-}
- unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
-
-instance (Ix ix, Eq e, IArray UArray e) => Eq (UArray ix e) where
- (==) = eqUArray
-
-instance (Ix ix, Ord e, IArray UArray e) => Ord (UArray ix e) where
- compare = cmpUArray
-
-instance (Ix ix, Show ix, Show e, IArray UArray e) => Show (UArray ix e) where
- showsPrec = showsIArray
-
------------------------------------------------------------------------------
--- Mutable arrays
-
-{-# NOINLINE arrEleBottom #-}
-arrEleBottom :: a
-arrEleBottom = error "MArray: undefined array element"
-
-{-| Class of mutable array types.
-
-An array type has the form @(a i e)@ where @a@ is the array type
-constructor (kind @* -> * -> *@), @i@ is the index type (a member of
-the class 'Ix'), and @e@ is the element type.
-
-The @MArray@ class is parameterised over both @a@ and @e@ (so that
-instances specialised to certain element types can be defined, in the
-same way as for 'IArray'), and also over the type of the monad, @m@,
-in which the mutable array will be manipulated.
--}
-class (Monad m) => MArray a e m where
-
- -- | Returns the bounds of the array
- getBounds :: Ix i => a i e -> m (i,i)
-
- -- | Builds a new array, with every element initialised to the supplied
- -- value.
- newArray :: Ix i => (i,i) -> e -> m (a i e)
-
- -- | Builds a new array, with every element initialised to undefined.
- newArray_ :: Ix i => (i,i) -> m (a i e)
-
- unsafeRead :: Ix i => a i e -> Int -> m e
- unsafeWrite :: Ix i => a i e -> Int -> e -> m ()
-
- {-# INLINE newArray #-}
- -- The INLINE is crucial, because until we know at least which monad
- -- we are in, the code below allocates like crazy. So inline it,
- -- in the hope that the context will know the monad.
- newArray (l,u) init = do
- marr <- newArray_ (l,u)
- sequence_ [unsafeWrite marr i init | i <- [0 .. rangeSize (l,u) - 1]]
- return marr
-
- newArray_ (l,u) = newArray (l,u) arrEleBottom
-
- -- newArray takes an initialiser which all elements of
- -- the newly created array are initialised to. newArray_ takes
- -- no initialiser, it is assumed that the array is initialised with
- -- "undefined" values.
-
- -- why not omit newArray_? Because in the unboxed array case we would
- -- like to omit the initialisation altogether if possible. We can't do
- -- this for boxed arrays, because the elements must all have valid values
- -- at all times in case of garbage collection.
-
- -- why not omit newArray? Because in the boxed case, we can omit the
- -- default initialisation with undefined values if we *do* know the
- -- initial value and it is constant for all elements.
-
-{-# INLINE newListArray #-}
--- | Constructs a mutable array from a list of initial elements.
--- The list gives the elements of the array in ascending order
--- beginning with the lowest index.
-newListArray :: (MArray a e m, Ix i) => (i,i) -> [e] -> m (a i e)
-newListArray (l,u) es = do
- marr <- newArray_ (l,u)
- let n = rangeSize (l,u)
- let fillFromList i xs | i == n = return ()
- | otherwise = case xs of
- [] -> return ()
- y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys
- fillFromList 0 es
- return marr
-
-{-# INLINE readArray #-}
--- | Read an element from a mutable array
-readArray :: (MArray a e m, Ix i) => a i e -> i -> m e
-readArray marr i = do
- (l,u) <- getBounds marr
- unsafeRead marr (index (l,u) i)
-
-{-# INLINE writeArray #-}
--- | Write an element in a mutable array
-writeArray :: (MArray a e m, Ix i) => a i e -> i -> e -> m ()
-writeArray marr i e = do
- (l,u) <- getBounds marr
- unsafeWrite marr (index (l,u) i) e
-
-{-# INLINE getElems #-}
--- | Return a list of all the elements of a mutable array
-getElems :: (MArray a e m, Ix i) => a i e -> m [e]
-getElems marr = do
- (l,u) <- getBounds marr
- sequence [unsafeRead marr i | i <- [0 .. rangeSize (l,u) - 1]]
-
-{-# INLINE getAssocs #-}
--- | Return a list of all the associations of a mutable array, in
--- index order.
-getAssocs :: (MArray a e m, Ix i) => a i e -> m [(i, e)]
-getAssocs marr = do
- (l,u) <- getBounds marr
- sequence [ do e <- unsafeRead marr (index (l,u) i); return (i,e)
- | i <- range (l,u)]
-
-{-# INLINE mapArray #-}
--- | Constructs a new array derived from the original array by applying a
--- function to each of the elements.
-mapArray :: (MArray a e' m, MArray a e m, Ix i) => (e' -> e) -> a i e' -> m (a i e)
-mapArray f marr = do
- (l,u) <- getBounds marr
- marr' <- newArray_ (l,u)
- sequence_ [do
- e <- unsafeRead marr i
- unsafeWrite marr' i (f e)
- | i <- [0 .. rangeSize (l,u) - 1]]
- return marr'
-
-{-# INLINE mapIndices #-}
--- | Constructs a new array derived from the original array by applying a
--- function to each of the indices.
-mapIndices :: (MArray a e m, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> m (a i e)
-mapIndices (l,u) f marr = do
- marr' <- newArray_ (l,u)
- sequence_ [do
- e <- readArray marr (f i)
- unsafeWrite marr' (unsafeIndex (l,u) i) e
- | i <- range (l,u)]
- return marr'
-
------------------------------------------------------------------------------
--- Polymorphic non-strict mutable arrays (ST monad)
-
-instance MArray (STArray s) e (ST s) where
- {-# INLINE getBounds #-}
- getBounds arr = return $! ArrST.boundsSTArray arr
- {-# INLINE newArray #-}
- newArray = ArrST.newSTArray
- {-# INLINE unsafeRead #-}
- unsafeRead = ArrST.unsafeReadSTArray
- {-# INLINE unsafeWrite #-}
- unsafeWrite = ArrST.unsafeWriteSTArray
-
-instance MArray (STArray s) e (Lazy.ST s) where
- {-# INLINE getBounds #-}
- getBounds arr = strictToLazyST (return $! ArrST.boundsSTArray arr)
- {-# INLINE newArray #-}
- newArray (l,u) e = strictToLazyST (ArrST.newSTArray (l,u) e)
- {-# INLINE unsafeRead #-}
- unsafeRead arr i = strictToLazyST (ArrST.unsafeReadSTArray arr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite arr i e = strictToLazyST (ArrST.unsafeWriteSTArray arr i e)
-
-#ifdef __HUGS__
-INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
-#endif
-
------------------------------------------------------------------------------
--- Flat unboxed mutable arrays (ST monad)
-
--- | A mutable array with unboxed elements, that can be manipulated in
--- the 'ST' monad. The type arguments are as follows:
---
--- * @s@: the state variable argument for the 'ST' type
---
--- * @i@: the index type of the array (should be an instance of @Ix@)
---
--- * @e@: the element type of the array. Only certain element types
--- are supported.
---
--- An 'STUArray' will generally be more efficient (in terms of both time
--- and space) than the equivalent boxed version ('STArray') with the same
--- element type. However, 'STUArray' is strict in its elements - so
--- don\'t use 'STUArray' if you require the non-strictness that
--- 'STArray' provides.
-#ifdef __GLASGOW_HASKELL__
-data STUArray s i a = STUArray !i !i (MutableByteArray# s)
-#endif
-#ifdef __HUGS__
-data STUArray s i a = STUArray !i !i !(MutableByteArray s)
-#endif
-
-INSTANCE_TYPEABLE3(STUArray,stUArrayTc,"STUArray")
-
-#ifdef __GLASGOW_HASKELL__
-instance MArray (STUArray s) Bool (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray #-}
- newArray (l,u) init = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (bOOL_SCALE n#) s1# of { (# s2#, marr# #) ->
- case bOOL_WORD_SCALE n# of { n'# ->
- let loop i# s3# | i# ==# n'# = s3#
- | otherwise =
- case writeWordArray# marr# i# e# s3# of { s4# ->
- loop (i# +# 1#) s4# } in
- case loop 0# s2# of { s3# ->
- (# s3#, STUArray l u marr# #) }}}}
- where
- W# e# = if init then maxBound else 0
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (bOOL_SCALE n#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readWordArray# marr# (bOOL_INDEX i#) s1# of { (# s2#, e# #) ->
- (# s2#, (e# `and#` bOOL_BIT i#) `neWord#` int2Word# 0# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) e = ST $ \s1# ->
- case bOOL_INDEX i# of { j# ->
- case readWordArray# marr# j# s1# of { (# s2#, old# #) ->
- case if e then old# `or#` bOOL_BIT i#
- else old# `and#` bOOL_NOT_BIT i# of { e# ->
- case writeWordArray# marr# j# e# s2# of { s3# ->
- (# s3#, () #) }}}}
-
-instance MArray (STUArray s) Char (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readWideCharArray# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, C# e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (C# e#) = ST $ \s1# ->
- case writeWideCharArray# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) Int (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readIntArray# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, I# e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (I# e#) = ST $ \s1# ->
- case writeIntArray# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) Word (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readWordArray# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, W# e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (W# e#) = ST $ \s1# ->
- case writeWordArray# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) (Ptr a) (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readAddrArray# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, Ptr e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (Ptr e#) = ST $ \s1# ->
- case writeAddrArray# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) (FunPtr a) (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readAddrArray# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, FunPtr e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (FunPtr e#) = ST $ \s1# ->
- case writeAddrArray# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) Float (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (fLOAT_SCALE n#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readFloatArray# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, F# e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (F# e#) = ST $ \s1# ->
- case writeFloatArray# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) Double (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (dOUBLE_SCALE n#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readDoubleArray# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, D# e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (D# e#) = ST $ \s1# ->
- case writeDoubleArray# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) (StablePtr a) (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readStablePtrArray# marr# i# s1# of { (# s2#, e# #) ->
- (# s2# , StablePtr e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (StablePtr e#) = ST $ \s1# ->
- case writeStablePtrArray# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) Int8 (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# n# s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readInt8Array# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, I8# e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (I8# e#) = ST $ \s1# ->
- case writeInt8Array# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) Int16 (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (n# *# 2#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readInt16Array# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, I16# e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (I16# e#) = ST $ \s1# ->
- case writeInt16Array# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) Int32 (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readInt32Array# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, I32# e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (I32# e#) = ST $ \s1# ->
- case writeInt32Array# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) Int64 (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (n# *# 8#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readInt64Array# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, I64# e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (I64# e#) = ST $ \s1# ->
- case writeInt64Array# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) Word8 (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# n# s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readWord8Array# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, W8# e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (W8# e#) = ST $ \s1# ->
- case writeWord8Array# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) Word16 (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (n# *# 2#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readWord16Array# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, W16# e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (W16# e#) = ST $ \s1# ->
- case writeWord16Array# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) Word32 (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readWord32Array# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, W32# e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (W32# e#) = ST $ \s1# ->
- case writeWord32Array# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
-instance MArray (STUArray s) Word64 (ST s) where
- {-# INLINE getBounds #-}
- getBounds (STUArray l u _) = return (l,u)
- {-# INLINE newArray_ #-}
- newArray_ (l,u) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newByteArray# (n# *# 8#) s1# of { (# s2#, marr# #) ->
- (# s2#, STUArray l u marr# #) }}
- {-# INLINE unsafeRead #-}
- unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
- case readWord64Array# marr# i# s1# of { (# s2#, e# #) ->
- (# s2#, W64# e# #) }
- {-# INLINE unsafeWrite #-}
- unsafeWrite (STUArray _ _ marr#) (I# i#) (W64# e#) = ST $ \s1# ->
- case writeWord64Array# marr# i# e# s1# of { s2# ->
- (# s2#, () #) }
-
------------------------------------------------------------------------------
--- Translation between elements and bytes
-
-bOOL_SCALE, bOOL_WORD_SCALE,
- wORD_SCALE, dOUBLE_SCALE, fLOAT_SCALE :: Int# -> Int#
-bOOL_SCALE n# = (n# +# last#) `uncheckedIShiftRA#` 3#
- where I# last# = SIZEOF_HSWORD * 8 - 1
-bOOL_WORD_SCALE n# = bOOL_INDEX (n# +# last#)
- where I# last# = SIZEOF_HSWORD * 8 - 1
-wORD_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSWORD
-dOUBLE_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSDOUBLE
-fLOAT_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSFLOAT
-
-bOOL_INDEX :: Int# -> Int#
-#if SIZEOF_HSWORD == 4
-bOOL_INDEX i# = i# `uncheckedIShiftRA#` 5#
-#elif SIZEOF_HSWORD == 8
-bOOL_INDEX i# = i# `uncheckedIShiftRA#` 6#
-#endif
-
-bOOL_BIT, bOOL_NOT_BIT :: Int# -> Word#
-bOOL_BIT n# = int2Word# 1# `uncheckedShiftL#` (word2Int# (int2Word# n# `and#` mask#))
- where W# mask# = SIZEOF_HSWORD * 8 - 1
-bOOL_NOT_BIT n# = bOOL_BIT n# `xor#` mb# where W# mb# = maxBound
-#endif /* __GLASGOW_HASKELL__ */
-
-#ifdef __HUGS__
-newMBArray_ :: (Ix i, Storable e) => (i,i) -> ST s (STUArray s i e)
-newMBArray_ = makeArray undefined
- where
- makeArray :: (Ix i, Storable e) => e -> (i,i) -> ST s (STUArray s i e)
- makeArray dummy (l,u) = do
- marr <- newMutableByteArray (rangeSize (l,u) * sizeOf dummy)
- return (STUArray l u marr)
-
-unsafeReadMBArray :: Storable e => STUArray s i e -> Int -> ST s e
-unsafeReadMBArray (STUArray _ _ marr) = readMutableByteArray marr
-
-unsafeWriteMBArray :: Storable e => STUArray s i e -> Int -> e -> ST s ()
-unsafeWriteMBArray (STUArray _ _ marr) = writeMutableByteArray marr
-
-getBoundsMBArray (STUArray l u _) = return (l,u)
-
-instance MArray (STUArray s) Bool (ST s) where
- getBounds = getBoundsMBArray
- newArray_ (l,u) = do
- marr <- newMutableByteArray (bOOL_SCALE (rangeSize (l,u)))
- return (STUArray l u marr)
- unsafeRead (STUArray _ _ marr) i = do
- let ix = bOOL_INDEX i
- bit = bOOL_SUBINDEX i
- w <- readMutableByteArray marr ix
- return (testBit (w::BitSet) bit)
- unsafeWrite (STUArray _ _ marr) i e = do
- let ix = bOOL_INDEX i
- bit = bOOL_SUBINDEX i
- w <- readMutableByteArray marr ix
- writeMutableByteArray marr ix
- (if e then setBit (w::BitSet) bit else clearBit w bit)
-
-instance MArray (STUArray s) Char (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) Int (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) Word (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) (Ptr a) (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) (FunPtr a) (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) Float (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) Double (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) (StablePtr a) (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) Int8 (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) Int16 (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) Int32 (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) Int64 (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) Word8 (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) Word16 (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) Word32 (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-instance MArray (STUArray s) Word64 (ST s) where
- getBounds = getBoundsMBArray
- newArray_ = newMBArray_
- unsafeRead = unsafeReadMBArray
- unsafeWrite = unsafeWriteMBArray
-
-type BitSet = Word8
-
-bitSetSize = bitSize (0::BitSet)
-
-bOOL_SCALE :: Int -> Int
-bOOL_SCALE n = (n + bitSetSize - 1) `div` bitSetSize
-
-bOOL_INDEX :: Int -> Int
-bOOL_INDEX i = i `div` bitSetSize
-
-bOOL_SUBINDEX :: Int -> Int
-bOOL_SUBINDEX i = i `mod` bitSetSize
-#endif /* __HUGS__ */
-
------------------------------------------------------------------------------
--- Freezing
-
--- | Converts a mutable array (any instance of 'MArray') to an
--- immutable array (any instance of 'IArray') by taking a complete
--- copy of it.
-freeze :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e)
-freeze marr = do
- (l,u) <- getBounds marr
- ies <- sequence [do e <- unsafeRead marr i; return (i,e)
- | i <- [0 .. rangeSize (l,u) - 1]]
- return (unsafeArray (l,u) ies)
-
-#ifdef __GLASGOW_HASKELL__
-freezeSTUArray :: Ix i => STUArray s i e -> ST s (UArray i e)
-freezeSTUArray (STUArray l u marr#) = ST $ \s1# ->
- case sizeofMutableByteArray# marr# of { n# ->
- case newByteArray# n# s1# of { (# s2#, marr'# #) ->
- case memcpy_freeze marr'# marr# (fromIntegral (I# n#)) of { IO m ->
- case unsafeCoerce# m s2# of { (# s3#, _ #) ->
- case unsafeFreezeByteArray# marr'# s3# of { (# s4#, arr# #) ->
- (# s4#, UArray l u arr# #) }}}}}
-
-foreign import ccall unsafe "memcpy"
- memcpy_freeze :: MutableByteArray# s -> MutableByteArray# s -> CSize
- -> IO (Ptr a)
-
-{-# RULES
-"freeze/STArray" freeze = ArrST.freezeSTArray
-"freeze/STUArray" freeze = freezeSTUArray
- #-}
-#endif /* __GLASGOW_HASKELL__ */
-
--- In-place conversion of mutable arrays to immutable ones places
--- a proof obligation on the user: no other parts of your code can
--- have a reference to the array at the point where you unsafely
--- freeze it (and, subsequently mutate it, I suspect).
-
-{- |
- Converts an mutable array into an immutable array. The
- implementation may either simply cast the array from
- one type to the other without copying the array, or it
- may take a full copy of the array.
-
- Note that because the array is possibly not copied, any subsequent
- modifications made to the mutable version of the array may be
- shared with the immutable version. It is safe to use, therefore, if
- the mutable version is never modified after the freeze operation.
-
- The non-copying implementation is supported between certain pairs
- of array types only; one constraint is that the array types must
- have identical representations. In GHC, The following pairs of
- array types have a non-copying O(1) implementation of
- 'unsafeFreeze'. Because the optimised versions are enabled by
- specialisations, you will need to compile with optimisation (-O) to
- get them.
-
- * 'Data.Array.IO.IOUArray' -> 'Data.Array.Unboxed.UArray'
-
- * 'Data.Array.ST.STUArray' -> 'Data.Array.Unboxed.UArray'
-
- * 'Data.Array.IO.IOArray' -> 'Data.Array.Array'
-
- * 'Data.Array.ST.STArray' -> 'Data.Array.Array'
--}
-{-# INLINE unsafeFreeze #-}
-unsafeFreeze :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e)
-unsafeFreeze = freeze
-
-{-# RULES
-"unsafeFreeze/STArray" unsafeFreeze = ArrST.unsafeFreezeSTArray
-"unsafeFreeze/STUArray" unsafeFreeze = unsafeFreezeSTUArray
- #-}
-
------------------------------------------------------------------------------
--- Thawing
-
--- | Converts an immutable array (any instance of 'IArray') into a
--- mutable array (any instance of 'MArray') by taking a complete copy
--- of it.
-thaw :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e)
-thaw arr = case bounds arr of
- (l,u) -> do
- marr <- newArray_ (l,u)
- sequence_ [unsafeWrite marr i (unsafeAt arr i)
- | i <- [0 .. rangeSize (l,u) - 1]]
- return marr
-
-#ifdef __GLASGOW_HASKELL__
-thawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e)
-thawSTUArray (UArray l u arr#) = ST $ \s1# ->
- case sizeofByteArray# arr# of { n# ->
- case newByteArray# n# s1# of { (# s2#, marr# #) ->
- case memcpy_thaw marr# arr# (fromIntegral (I# n#)) of { IO m ->
- case unsafeCoerce# m s2# of { (# s3#, _ #) ->
- (# s3#, STUArray l u marr# #) }}}}
-
-foreign import ccall unsafe "memcpy"
- memcpy_thaw :: MutableByteArray# s -> ByteArray# -> CSize
- -> IO (Ptr a)
-
-{-# RULES
-"thaw/STArray" thaw = ArrST.thawSTArray
-"thaw/STUArray" thaw = thawSTUArray
- #-}
-#endif /* __GLASGOW_HASKELL__ */
-
-#ifdef __HUGS__
-thawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e)
-thawSTUArray (UArray l u arr) = do
- marr <- thawByteArray arr
- return (STUArray l u marr)
-#endif
-
--- In-place conversion of immutable arrays to mutable ones places
--- a proof obligation on the user: no other parts of your code can
--- have a reference to the array at the point where you unsafely
--- thaw it (and, subsequently mutate it, I suspect).
-
-{- |
- Converts an immutable array into a mutable array. The
- implementation may either simply cast the array from
- one type to the other without copying the array, or it
- may take a full copy of the array.
-
- Note that because the array is possibly not copied, any subsequent
- modifications made to the mutable version of the array may be
- shared with the immutable version. It is only safe to use,
- therefore, if the immutable array is never referenced again in this
- thread, and there is no possibility that it can be also referenced
- in another thread. If you use an unsafeThaw/write/unsafeFreeze
- sequence in a multi-threaded setting, then you must ensure that
- this sequence is atomic with respect to other threads, or a garbage
- collector crash may result (because the write may be writing to a
- frozen array).
-
- The non-copying implementation is supported between certain pairs
- of array types only; one constraint is that the array types must
- have identical representations. In GHC, The following pairs of
- array types have a non-copying O(1) implementation of
- 'unsafeThaw'. Because the optimised versions are enabled by
- specialisations, you will need to compile with optimisation (-O) to
- get them.
-
- * 'Data.Array.Unboxed.UArray' -> 'Data.Array.IO.IOUArray'
-
- * 'Data.Array.Unboxed.UArray' -> 'Data.Array.ST.STUArray'
-
- * 'Data.Array.Array' -> 'Data.Array.IO.IOArray'
-
- * 'Data.Array.Array' -> 'Data.Array.ST.STArray'
--}
-{-# INLINE unsafeThaw #-}
-unsafeThaw :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e)
-unsafeThaw = thaw
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE unsafeThawSTUArray #-}
-unsafeThawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e)
-unsafeThawSTUArray (UArray l u marr#) =
- return (STUArray l u (unsafeCoerce# marr#))
-
-{-# RULES
-"unsafeThaw/STArray" unsafeThaw = ArrST.unsafeThawSTArray
-"unsafeThaw/STUArray" unsafeThaw = unsafeThawSTUArray
- #-}
-#endif /* __GLASGOW_HASKELL__ */
-
--- | Casts an 'STUArray' with one element type into one with a
--- different element type. All the elements of the resulting array
--- are undefined (unless you know what you\'re doing...).
-
-#ifdef __GLASGOW_HASKELL__
-castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b)
-castSTUArray (STUArray l u marr#) = return (STUArray l u marr#)
-#endif
-
-#ifdef __HUGS__
-castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b)
-castSTUArray (STUArray l u marr) = return (STUArray l u marr)
-#endif
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Array.Diff
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Data.Array.IArray)
---
--- Functional arrays with constant-time update.
---
------------------------------------------------------------------------------
-
-module Data.Array.Diff (
-
- -- * Diff array types
-
- -- | Diff arrays have an immutable interface, but rely on internal
- -- updates in place to provide fast functional update operator
- -- '//'.
- --
- -- When the '//' operator is applied to a diff array, its contents
- -- are physically updated in place. The old array silently changes
- -- its representation without changing the visible behavior:
- -- it stores a link to the new current array along with the
- -- difference to be applied to get the old contents.
- --
- -- So if a diff array is used in a single-threaded style,
- -- i.e. after '//' application the old version is no longer used,
- -- @a'!'i@ takes O(1) time and @a '//' d@ takes O(@length d@).
- -- Accessing elements of older versions gradually becomes slower.
- --
- -- Updating an array which is not current makes a physical copy.
- -- The resulting array is unlinked from the old family. So you
- -- can obtain a version which is guaranteed to be current and
- -- thus have fast element access by @a '//' []@.
-
- -- Possible improvement for the future (not implemented now):
- -- make it possible to say "I will make an update now, but when
- -- I later return to the old version, I want it to mutate back
- -- instead of being copied".
-
- IOToDiffArray, -- data IOToDiffArray
- -- (a :: * -> * -> *) -- internal mutable array
- -- (i :: *) -- indices
- -- (e :: *) -- elements
-
- -- | Type synonyms for the two most important IO array types.
-
- -- Two most important diff array types are fully polymorphic
- -- lazy boxed DiffArray:
- DiffArray, -- = IOToDiffArray IOArray
- -- ...and strict unboxed DiffUArray, working only for elements
- -- of primitive types but more compact and usually faster:
- DiffUArray, -- = IOToDiffArray IOUArray
-
- -- * Overloaded immutable array interface
-
- -- | Module "Data.Array.IArray" provides the interface of diff arrays.
- -- They are instances of class 'IArray'.
- module Data.Array.IArray,
-
- -- * Low-level interface
-
- -- | These are really internal functions, but you will need them
- -- to make further 'IArray' instances of various diff array types
- -- (for either more 'MArray' types or more unboxed element types).
- newDiffArray, readDiffArray, replaceDiffArray
- )
- where
-
-------------------------------------------------------------------------
--- Imports.
-
-import Prelude
-
-import Data.Ix
-import Data.Array.Base
-import Data.Array.IArray
-import Data.Array.IO
-
-import Foreign.Ptr ( Ptr, FunPtr )
-import Foreign.StablePtr ( StablePtr )
-import Data.Int ( Int8, Int16, Int32, Int64 )
-import Data.Word ( Word, Word8, Word16, Word32, Word64 )
-
-import System.IO.Unsafe ( unsafePerformIO )
-import Control.Exception ( evaluate )
-import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, readMVar )
-
-------------------------------------------------------------------------
--- Diff array types.
-
--- | An arbitrary 'MArray' type living in the 'IO' monad can be converted
--- to a diff array.
-
-newtype IOToDiffArray a i e =
- DiffArray {varDiffArray :: MVar (DiffArrayData a i e)}
-
--- Internal representation: either a mutable array, or a link to
--- another diff array patched with a list of index+element pairs.
-data DiffArrayData a i e = Current (a i e)
- | Diff (IOToDiffArray a i e) [(Int, e)]
-
--- | Fully polymorphic lazy boxed diff array.
-type DiffArray = IOToDiffArray IOArray
-
--- | Strict unboxed diff array, working only for elements
--- of primitive types but more compact and usually faster than 'DiffArray'.
-type DiffUArray = IOToDiffArray IOUArray
-
--- Having 'MArray a e IO' in instance context would require
--- -fallow-undecidable-instances, so each instance is separate here.
-
-------------------------------------------------------------------------
--- Showing DiffArrays
-
-instance (Ix ix, Show ix, Show e) => Show (DiffArray ix e) where
- showsPrec = showsIArray
-
-instance (Ix ix, Show ix) => Show (DiffUArray ix Char) where
- showsPrec = showsIArray
-
-instance (Ix ix, Show ix) => Show (DiffUArray ix Int) where
- showsPrec = showsIArray
-
-instance (Ix ix, Show ix) => Show (DiffUArray ix Word) where
- showsPrec = showsIArray
-
-instance (Ix ix, Show ix) => Show (DiffUArray ix Float) where
- showsPrec = showsIArray
-
-instance (Ix ix, Show ix) => Show (DiffUArray ix Double) where
- showsPrec = showsIArray
-
-instance (Ix ix, Show ix) => Show (DiffUArray ix Int8) where
- showsPrec = showsIArray
-
-instance (Ix ix, Show ix) => Show (DiffUArray ix Int16) where
- showsPrec = showsIArray
-
-instance (Ix ix, Show ix) => Show (DiffUArray ix Int32) where
- showsPrec = showsIArray
-
-instance (Ix ix, Show ix) => Show (DiffUArray ix Int64) where
- showsPrec = showsIArray
-
-instance (Ix ix, Show ix) => Show (DiffUArray ix Word8) where
- showsPrec = showsIArray
-
-instance (Ix ix, Show ix) => Show (DiffUArray ix Word16) where
- showsPrec = showsIArray
-
-instance (Ix ix, Show ix) => Show (DiffUArray ix Word32) where
- showsPrec = showsIArray
-
-instance (Ix ix, Show ix) => Show (DiffUArray ix Word64) where
- showsPrec = showsIArray
-
-------------------------------------------------------------------------
--- Boring instances.
-
-instance IArray (IOToDiffArray IOArray) e where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray1` ies
-
-instance IArray (IOToDiffArray IOUArray) Char where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) Int where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) Word where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) (Ptr a) where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) (FunPtr a) where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) Float where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) Double where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) (StablePtr a) where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) Int8 where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) Int16 where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) Int32 where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) Int64 where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) Word8 where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) Word16 where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) Word32 where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-instance IArray (IOToDiffArray IOUArray) Word64 where
- bounds a = unsafePerformIO $ boundsDiffArray a
- unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
- unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
- unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
-
-
-
-------------------------------------------------------------------------
--- The important stuff.
-
-newDiffArray :: (MArray a e IO, Ix i)
- => (i,i)
- -> [(Int, e)]
- -> IO (IOToDiffArray a i e)
-newDiffArray (l,u) ies = do
- a <- newArray_ (l,u)
- sequence_ [unsafeWrite a i e | (i, e) <- ies]
- var <- newMVar (Current a)
- return (DiffArray var)
-
-readDiffArray :: (MArray a e IO, Ix i)
- => IOToDiffArray a i e
- -> Int
- -> IO e
-a `readDiffArray` i = do
- d <- readMVar (varDiffArray a)
- case d of
- Current a' -> unsafeRead a' i
- Diff a' ies -> maybe (readDiffArray a' i) return (lookup i ies)
-
-replaceDiffArray :: (MArray a e IO, Ix i)
- => IOToDiffArray a i e
- -> [(Int, e)]
- -> IO (IOToDiffArray a i e)
-a `replaceDiffArray` ies = do
- d <- takeMVar (varDiffArray a)
- case d of
- Current a' -> case ies of
- [] -> do
- -- We don't do the copy when there is nothing to change
- -- and this is the current version. But see below.
- putMVar (varDiffArray a) d
- return a
- _:_ -> do
- diff <- sequence [do e <- unsafeRead a' i; return (i, e)
- | (i, _) <- ies]
- sequence_ [unsafeWrite a' i e | (i, e) <- ies]
- var' <- newMVar (Current a')
- putMVar (varDiffArray a) (Diff (DiffArray var') diff)
- return (DiffArray var')
- Diff _ _ -> do
- -- We still do the copy when there is nothing to change
- -- but this is not the current version. So you can use
- -- 'a // []' to make sure that the resulting array has
- -- fast element access.
- putMVar (varDiffArray a) d
- a' <- thawDiffArray a
- -- thawDiffArray gives a fresh array which we can
- -- safely mutate.
- sequence_ [unsafeWrite a' i e | (i, e) <- ies]
- var' <- newMVar (Current a')
- return (DiffArray var')
-
--- The elements of the diff list might recursively reference the
--- array, so we must seq them before taking the MVar to avoid
--- deadlock.
-replaceDiffArray1 :: (MArray a e IO, Ix i)
- => IOToDiffArray a i e
- -> [(Int, e)]
- -> IO (IOToDiffArray a i e)
-a `replaceDiffArray1` ies = do
- mapM_ (evaluate . fst) ies
- a `replaceDiffArray` ies
-
--- If the array contains unboxed elements, then the elements of the
--- diff list may also recursively reference the array from inside
--- replaceDiffArray, so we must seq them too.
-replaceDiffArray2 :: (MArray a e IO, Ix i)
- => IOToDiffArray a i e
- -> [(Int, e)]
- -> IO (IOToDiffArray a i e)
-a `replaceDiffArray2` ies = do
- mapM_ (\(a,b) -> do evaluate a; evaluate b) ies
- a `replaceDiffArray` ies
-
-
-boundsDiffArray :: (MArray a e IO, Ix ix)
- => IOToDiffArray a ix e
- -> IO (ix,ix)
-boundsDiffArray a = do
- d <- readMVar (varDiffArray a)
- case d of
- Current a' -> getBounds a'
- Diff a' _ -> boundsDiffArray a'
-
-freezeDiffArray :: (MArray a e IO, Ix ix)
- => a ix e
- -> IO (IOToDiffArray a ix e)
-freezeDiffArray a = do
- (l,u) <- getBounds a
- a' <- newArray_ (l,u)
- sequence_ [unsafeRead a i >>= unsafeWrite a' i | i <- [0 .. rangeSize (l,u) - 1]]
- var <- newMVar (Current a')
- return (DiffArray var)
-
-{-# RULES
-"freeze/DiffArray" freeze = freezeDiffArray
- #-}
-
--- unsafeFreezeDiffArray is really unsafe. Better don't use the old
--- array at all after freezing. The contents of the source array will
--- be changed when '//' is applied to the resulting array.
-
-unsafeFreezeDiffArray :: (MArray a e IO, Ix ix)
- => a ix e
- -> IO (IOToDiffArray a ix e)
-unsafeFreezeDiffArray a = do
- var <- newMVar (Current a)
- return (DiffArray var)
-
-{-# RULES
-"unsafeFreeze/DiffArray" unsafeFreeze = unsafeFreezeDiffArray
- #-}
-
-thawDiffArray :: (MArray a e IO, Ix ix)
- => IOToDiffArray a ix e
- -> IO (a ix e)
-thawDiffArray a = do
- d <- readMVar (varDiffArray a)
- case d of
- Current a' -> do
- (l,u) <- getBounds a'
- a'' <- newArray_ (l,u)
- sequence_ [unsafeRead a' i >>= unsafeWrite a'' i | i <- [0 .. rangeSize (l,u) - 1]]
- return a''
- Diff a' ies -> do
- a'' <- thawDiffArray a'
- sequence_ [unsafeWrite a'' i e | (i, e) <- ies]
- return a''
-
-{-# RULES
-"thaw/DiffArray" thaw = thawDiffArray
- #-}
-
--- unsafeThawDiffArray is really unsafe. Better don't use the old
--- array at all after thawing. The contents of the resulting array
--- will be changed when '//' is applied to the source array.
-
-unsafeThawDiffArray :: (MArray a e IO, Ix ix)
- => IOToDiffArray a ix e
- -> IO (a ix e)
-unsafeThawDiffArray a = do
- d <- readMVar (varDiffArray a)
- case d of
- Current a' -> return a'
- Diff a' ies -> do
- a'' <- unsafeThawDiffArray a'
- sequence_ [unsafeWrite a'' i e | (i, e) <- ies]
- return a''
-
-{-# RULES
-"unsafeThaw/DiffArray" unsafeThaw = unsafeThawDiffArray
- #-}
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Array.IArray
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Data.Array.Base)
---
--- Immutable arrays, with an overloaded interface. For array types which
--- can be used with this interface, see the 'Array' type exported by this
--- module, and the "Data.Array.Unboxed" and "Data.Array.Diff" modules.
---
------------------------------------------------------------------------------
-
-module Data.Array.IArray (
- -- * Array classes
- IArray, -- :: (* -> * -> *) -> * -> class
-
- module Data.Ix,
-
- -- * Immutable non-strict (boxed) arrays
- Array,
-
- -- * Array construction
- array, -- :: (IArray a e, Ix i) => (i,i) -> [(i, e)] -> a i e
- listArray, -- :: (IArray a e, Ix i) => (i,i) -> [e] -> a i e
- accumArray, -- :: (IArray a e, Ix i) => (e -> e' -> e) -> e -> (i,i) -> [(i, e')] -> a i e
-
- -- * Accessing arrays
- (!), -- :: (IArray a e, Ix i) => a i e -> i -> e
- bounds, -- :: (HasBounds a, Ix i) => a i e -> (i,i)
- indices, -- :: (HasBounds a, Ix i) => a i e -> [i]
- elems, -- :: (IArray a e, Ix i) => a i e -> [e]
- assocs, -- :: (IArray a e, Ix i) => a i e -> [(i, e)]
-
- -- * Incremental array updates
- (//), -- :: (IArray a e, Ix i) => a i e -> [(i, e)] -> a i e
- accum, -- :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(i, e')] -> a i e
-
- -- * Derived arrays
- amap, -- :: (IArray a e', IArray a e, Ix i) => (e' -> e) -> a i e' -> a i e
- ixmap, -- :: (IArray a e, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> a i e
- ) where
-
-import Prelude
-
-import Data.Ix
-import Data.Array (Array)
-import Data.Array.Base
+++ /dev/null
-{-# OPTIONS_GHC -#include "HsBase.h" #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Array.IO
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Data.Array.MArray)
---
--- Mutable boxed and unboxed arrays in the IO monad.
---
------------------------------------------------------------------------------
-
-module Data.Array.IO (
- -- * @IO@ arrays with boxed elements
- IOArray, -- instance of: Eq, Typeable
-
- -- * @IO@ arrays with unboxed elements
- IOUArray, -- instance of: Eq, Typeable
- castIOUArray, -- :: IOUArray i a -> IO (IOUArray i b)
-
- -- * Overloaded mutable array interface
- module Data.Array.MArray,
-
- -- * Doing I\/O with @IOUArray@s
- hGetArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO Int
- hPutArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO ()
- ) where
-
-import Prelude
-
-import Data.Array.Base
-import Data.Array.IO.Internals
-import Data.Array ( Array )
-import Data.Array.MArray
-import Data.Int
-import Data.Word
-
-#ifdef __GLASGOW_HASKELL__
-import Foreign
-import Foreign.C
-
-import GHC.Arr
-import GHC.IOBase
-import GHC.Handle
-#else
-import Data.Char
-import System.IO
-import System.IO.Error
-#endif
-
-#ifdef __GLASGOW_HASKELL__
------------------------------------------------------------------------------
--- Freezing
-
-freezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
-freezeIOArray (IOArray marr) = stToIO (freezeSTArray marr)
-
-freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
-freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr)
-
-{-# RULES
-"freeze/IOArray" freeze = freezeIOArray
-"freeze/IOUArray" freeze = freezeIOUArray
- #-}
-
-{-# INLINE unsafeFreezeIOArray #-}
-unsafeFreezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
-unsafeFreezeIOArray (IOArray marr) = stToIO (unsafeFreezeSTArray marr)
-
-{-# INLINE unsafeFreezeIOUArray #-}
-unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
-unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr)
-
-{-# RULES
-"unsafeFreeze/IOArray" unsafeFreeze = unsafeFreezeIOArray
-"unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray
- #-}
-
------------------------------------------------------------------------------
--- Thawing
-
-thawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
-thawIOArray arr = stToIO $ do
- marr <- thawSTArray arr
- return (IOArray marr)
-
-thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
-thawIOUArray arr = stToIO $ do
- marr <- thawSTUArray arr
- return (IOUArray marr)
-
-{-# RULES
-"thaw/IOArray" thaw = thawIOArray
-"thaw/IOUArray" thaw = thawIOUArray
- #-}
-
-{-# INLINE unsafeThawIOArray #-}
-unsafeThawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
-unsafeThawIOArray arr = stToIO $ do
- marr <- unsafeThawSTArray arr
- return (IOArray marr)
-
-{-# INLINE unsafeThawIOUArray #-}
-unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
-unsafeThawIOUArray arr = stToIO $ do
- marr <- unsafeThawSTUArray arr
- return (IOUArray marr)
-
-{-# RULES
-"unsafeThaw/IOArray" unsafeThaw = unsafeThawIOArray
-"unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray
- #-}
-
--- ---------------------------------------------------------------------------
--- hGetArray
-
--- | Reads a number of 'Word8's from the specified 'Handle' directly
--- into an array.
-hGetArray
- :: Handle -- ^ Handle to read from
- -> IOUArray Int Word8 -- ^ Array in which to place the values
- -> Int -- ^ Number of 'Word8's to read
- -> IO Int
- -- ^ Returns: the number of 'Word8's actually
- -- read, which might be smaller than the number requested
- -- if the end of file was reached.
-
-hGetArray handle (IOUArray (STUArray l u ptr)) count
- | count == 0
- = return 0
- | count < 0 || count > rangeSize (l,u)
- = illegalBufferSize handle "hGetArray" count
- | otherwise = do
- wantReadableHandle "hGetArray" handle $
- \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
- buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
- if bufferEmpty buf
- then readChunk fd is_stream ptr 0 count
- else do
- let avail = w - r
- copied <- if (count >= avail)
- then do
- memcpy_ba_baoff ptr raw (fromIntegral r) (fromIntegral avail)
- writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
- return avail
- else do
- memcpy_ba_baoff ptr raw (fromIntegral r) (fromIntegral count)
- writeIORef ref buf{ bufRPtr = r + count }
- return count
-
- let remaining = count - copied
- if remaining > 0
- then do rest <- readChunk fd is_stream ptr copied remaining
- return (rest + copied)
- else return count
-
-readChunk :: FD -> Bool -> RawBuffer -> Int -> Int -> IO Int
-readChunk fd is_stream ptr init_off bytes = loop init_off bytes
- where
- loop :: Int -> Int -> IO Int
- loop off bytes | bytes <= 0 = return (off - init_off)
- loop off bytes = do
- r' <- readRawBuffer "readChunk" (fromIntegral fd) is_stream ptr
- (fromIntegral off) (fromIntegral bytes)
- let r = fromIntegral r'
- if r == 0
- then return (off - init_off)
- else loop (off + r) (bytes - r)
-
--- ---------------------------------------------------------------------------
--- hPutArray
-
--- | Writes an array of 'Word8' to the specified 'Handle'.
-hPutArray
- :: Handle -- ^ Handle to write to
- -> IOUArray Int Word8 -- ^ Array to write from
- -> Int -- ^ Number of 'Word8's to write
- -> IO ()
-
-hPutArray handle (IOUArray (STUArray l u raw)) count
- | count == 0
- = return ()
- | count < 0 || count > rangeSize (l,u)
- = illegalBufferSize handle "hPutArray" count
- | otherwise
- = do wantWritableHandle "hPutArray" handle $
- \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
-
- old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
- <- readIORef ref
-
- -- enough room in handle buffer?
- if (size - w > count)
- -- There's enough room in the buffer:
- -- just copy the data in and update bufWPtr.
- then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count)
- writeIORef ref old_buf{ bufWPtr = w + count }
- return ()
-
- -- else, we have to flush
- else do flushed_buf <- flushWriteBuffer fd stream old_buf
- writeIORef ref flushed_buf
- let this_buf =
- Buffer{ bufBuf=raw, bufState=WriteBuffer,
- bufRPtr=0, bufWPtr=count, bufSize=count }
- flushWriteBuffer fd stream this_buf
- return ()
-
--- ---------------------------------------------------------------------------
--- Internal Utils
-
-foreign import ccall unsafe "__hscore_memcpy_dst_off"
- memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ())
-foreign import ccall unsafe "__hscore_memcpy_src_off"
- memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
-
-illegalBufferSize :: Handle -> String -> Int -> IO a
-illegalBufferSize handle fn sz =
- ioException (IOError (Just handle)
- InvalidArgument fn
- ("illegal buffer size " ++ showsPrec 9 (sz::Int) [])
- Nothing)
-
-#else /* !__GLASGOW_HASKELL__ */
-hGetArray :: Handle -> IOUArray Int Word8 -> Int -> IO Int
-hGetArray handle arr count = do
- bds <- getBounds arr
- if count < 0 || count > rangeSize bds
- then illegalBufferSize handle "hGetArray" count
- else get 0
- where
- get i | i == count = return i
- | otherwise = do
- error_or_c <- try (hGetChar handle)
- case error_or_c of
- Left ex
- | isEOFError ex -> return i
- | otherwise -> ioError ex
- Right c -> do
- unsafeWrite arr i (fromIntegral (ord c))
- get (i+1)
-
-hPutArray :: Handle -> IOUArray Int Word8 -> Int -> IO ()
-hPutArray handle arr count = do
- bds <- getBounds arr
- if count < 0 || count > rangeSize bds
- then illegalBufferSize handle "hPutArray" count
- else put 0
- where
- put i | i == count = return ()
- | otherwise = do
- w <- unsafeRead arr i
- hPutChar handle (chr (fromIntegral w))
- put (i+1)
-
-illegalBufferSize :: Handle -> String -> Int -> IO a
-illegalBufferSize _ fn sz = ioError $
- userError (fn ++ ": illegal buffer size " ++ showsPrec 9 (sz::Int) [])
-#endif /* !__GLASGOW_HASKELL__ */
+++ /dev/null
-{-# OPTIONS_GHC -#include "HsBase.h" #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Array.IO.Internal
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Data.Array.Base)
---
--- Mutable boxed and unboxed arrays in the IO monad.
---
------------------------------------------------------------------------------
-
--- #hide
-module Data.Array.IO.Internals (
- IOArray(..), -- instance of: Eq, Typeable
- IOUArray(..), -- instance of: Eq, Typeable
- castIOUArray, -- :: IOUArray ix a -> IO (IOUArray ix b)
- ) where
-
-import Prelude
-
-import Data.Array.MArray
-import Data.Int
-import Data.Word
-import Data.Typeable
-
-#ifdef __HUGS__
-import Hugs.IOArray
-#endif
-
-import Control.Monad.ST ( RealWorld, stToIO )
-import Foreign.Ptr ( Ptr, FunPtr )
-import Foreign.StablePtr ( StablePtr )
-import Data.Array.Base
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase
-import GHC.Base
-#endif /* __GLASGOW_HASKELL__ */
-
-#include "Typeable.h"
-
-INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")
-
------------------------------------------------------------------------------
--- | Instance declarations for 'IOArray's
-
-instance MArray IOArray e IO where
-#if defined(__HUGS__)
- getBounds = return . boundsIOArray
-#elif defined(__GLASGOW_HASKELL__)
- {-# INLINE getBounds #-}
- getBounds (IOArray marr) = stToIO $ getBounds marr
-#endif
- newArray = newIOArray
- unsafeRead = unsafeReadIOArray
- unsafeWrite = unsafeWriteIOArray
-
------------------------------------------------------------------------------
--- Flat unboxed mutable arrays (IO monad)
-
--- | Mutable, unboxed, strict arrays in the 'IO' monad. The type
--- arguments are as follows:
---
--- * @i@: the index type of the array (should be an instance of 'Ix')
---
--- * @e@: the element type of the array. Only certain element types
--- are supported: see "Data.Array.MArray" for a list of instances.
---
-newtype IOUArray i e = IOUArray (STUArray RealWorld i e)
-
-INSTANCE_TYPEABLE2(IOUArray,iOUArrayTc,"IOUArray")
-
-instance MArray IOUArray Bool IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Char IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Int IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Word IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray (Ptr a) IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray (FunPtr a) IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Float IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Double IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray (StablePtr a) IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Int8 IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Int16 IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Int32 IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Int64 IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Word8 IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Word16 IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Word32 IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Word64 IO where
- {-# INLINE getBounds #-}
- getBounds (IOUArray arr) = stToIO $ getBounds arr
- {-# INLINE newArray #-}
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOUArray marr)
- {-# INLINE newArray_ #-}
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOUArray marr)
- {-# INLINE unsafeRead #-}
- unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
- {-# INLINE unsafeWrite #-}
- unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
--- | Casts an 'IOUArray' with one element type into one with a
--- different element type. All the elements of the resulting array
--- are undefined (unless you know what you\'re doing...).
-castIOUArray :: IOUArray ix a -> IO (IOUArray ix b)
-castIOUArray (IOUArray marr) = stToIO $ do
- marr' <- castSTUArray marr
- return (IOUArray marr')
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Array.MArray
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Data.Array.Base)
---
--- An overloaded interface to mutable arrays. For array types which can be
--- used with this interface, see "Data.Array.IO", "Data.Array.ST",
--- and "Data.Array.Storable".
---
------------------------------------------------------------------------------
-
-module Data.Array.MArray (
- -- * Class of mutable array types
- MArray, -- :: (* -> * -> *) -> * -> (* -> *) -> class
-
- -- * The @Ix@ class and operations
- module Data.Ix,
-
- -- * Constructing mutable arrays
- newArray, -- :: (MArray a e m, Ix i) => (i,i) -> e -> m (a i e)
- newArray_, -- :: (MArray a e m, Ix i) => (i,i) -> m (a i e)
- newListArray, -- :: (MArray a e m, Ix i) => (i,i) -> [e] -> m (a i e)
-
- -- * Reading and writing mutable arrays
- readArray, -- :: (MArray a e m, Ix i) => a i e -> i -> m e
- writeArray, -- :: (MArray a e m, Ix i) => a i e -> i -> e -> m ()
-
- -- * Derived arrays
- mapArray, -- :: (MArray a e' m, MArray a e m, Ix i) => (e' -> e) -> a i e' -> m (a i e)
- mapIndices, -- :: (MArray a e m, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> m (a i e)
-
- -- * Deconstructing mutable arrays
- getBounds, -- :: (MArray a e m, Ix i) => a i e -> m (i,i)
- getElems, -- :: (MArray a e m, Ix i) => a i e -> m [e]
- getAssocs, -- :: (MArray a e m, Ix i) => a i e -> m [(i, e)]
-
- -- * Conversions between mutable and immutable arrays
- freeze, -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e)
- unsafeFreeze, -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e)
- thaw, -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e)
- unsafeThaw, -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e)
- ) where
-
-import Prelude
-
-import Data.Ix
-#ifdef __HADDOCK__
-import Data.Array.IArray
-#endif
-import Data.Array.Base
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Array.ST
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Data.Array.MArray)
---
--- Mutable boxed and unboxed arrays in the 'Control.Monad.ST.ST' monad.
---
------------------------------------------------------------------------------
-
-module Data.Array.ST (
-
- -- * Boxed arrays
- STArray, -- instance of: Eq, MArray
- runSTArray,
-
- -- * Unboxed arrays
- STUArray, -- instance of: Eq, MArray
- runSTUArray,
- castSTUArray, -- :: STUArray s i a -> ST s (STUArray s i b)
-
- -- * Overloaded mutable array interface
- module Data.Array.MArray,
- ) where
-
-import Prelude
-
-import Data.Array.MArray
-import Data.Array.Base ( STUArray, castSTUArray, UArray, unsafeFreezeSTUArray )
-import Control.Monad.ST ( ST, runST )
-
-#ifdef __HUGS__
-import Hugs.Array ( Array )
-import Hugs.ST ( STArray, unsafeFreezeSTArray )
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Arr ( STArray, Array, unsafeFreezeSTArray )
-#endif
-
--- | A safe way to create and work with a mutable array before returning an
--- immutable array for later perusal. This function avoids copying
--- the array before returning it - it uses 'unsafeFreeze' internally, but
--- this wrapper is a safe interface to that function.
---
-runSTArray :: (Ix i)
- => (forall s . ST s (STArray s i e))
- -> Array i e
-runSTArray st = runST (st >>= unsafeFreezeSTArray)
-
--- | A safe way to create and work with an unboxed mutable array before
--- returning an immutable array for later perusal. This function
--- avoids copying the array before returning it - it uses
--- 'unsafeFreeze' internally, but this wrapper is a safe interface to
--- that function.
---
-runSTUArray :: (Ix i)
- => (forall s . ST s (STUArray s i e))
- -> UArray i e
-runSTUArray st = runST (st >>= unsafeFreezeSTUArray)
-
-
--- INTERESTING... this is the type we'd like to give to runSTUArray:
---
--- runSTUArray :: (Ix i, IArray UArray e,
--- forall s. MArray (STUArray s) e (ST s))
--- => (forall s . ST s (STUArray s i e))
--- -> UArray i e
---
--- Note the quantified constraint. We dodged the problem by using
--- unsafeFreezeSTUArray directly in the defn of runSTUArray above, but
--- this essentially constrains us to a single unsafeFreeze for all STUArrays
--- (in theory we might have a different one for certain element types).
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Array.Storable
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Data.Array.MArray)
---
--- A storable array is an IO-mutable array which stores its
--- contents in a contiguous memory block living in the C
--- heap. Elements are stored according to the class 'Storable'.
--- You can obtain the pointer to the array contents to manipulate
--- elements from languages like C.
---
--- It is similar to 'Data.Array.IO.IOUArray' but slower.
--- Its advantage is that it's compatible with C.
---
------------------------------------------------------------------------------
-
-module Data.Array.Storable (
-
- -- * Arrays of 'Storable' things.
- StorableArray, -- data StorableArray index element
- -- -- index type must be in class Ix
- -- -- element type must be in class Storable
-
- -- * Overloaded mutable array interface
- -- | Module "Data.Array.MArray" provides the interface of storable arrays.
- -- They are instances of class 'MArray' (with the 'IO' monad).
- module Data.Array.MArray,
-
- -- * Accessing the pointer to the array contents
- withStorableArray, -- :: StorableArray i e -> (Ptr e -> IO a) -> IO a
-
- touchStorableArray, -- :: StorableArray i e -> IO ()
-
- unsafeForeignPtrToStorableArray
- )
- where
-
-import Prelude
-
-import Data.Array.Base
-import Data.Array.MArray
-import Foreign hiding (newArray)
-
--- |The array type
-data StorableArray i e = StorableArray !i !i !(ForeignPtr e)
-
-instance Storable e => MArray StorableArray e IO where
- getBounds (StorableArray l u _) = return (l,u)
-
- newArray (l,u) init = do
- fp <- mallocForeignPtrArray size
- withForeignPtr fp $ \a ->
- sequence_ [pokeElemOff a i init | i <- [0..size-1]]
- return (StorableArray l u fp)
- where
- size = rangeSize (l,u)
-
- newArray_ (l,u) = do
- fp <- mallocForeignPtrArray (rangeSize (l,u))
- return (StorableArray l u fp)
-
- unsafeRead (StorableArray _ _ fp) i =
- withForeignPtr fp $ \a -> peekElemOff a i
-
- unsafeWrite (StorableArray _ _ fp) i e =
- withForeignPtr fp $ \a -> pokeElemOff a i e
-
--- |The pointer to the array contents is obtained by 'withStorableArray'.
--- The idea is similar to 'ForeignPtr' (used internally here).
--- The pointer should be used only during execution of the 'IO' action
--- retured by the function passed as argument to 'withStorableArray'.
-withStorableArray :: StorableArray i e -> (Ptr e -> IO a) -> IO a
-withStorableArray (StorableArray _ _ fp) f = withForeignPtr fp f
-
--- |If you want to use it afterwards, ensure that you
--- 'touchStorableArray' after the last use of the pointer,
--- so the array is not freed too early.
-touchStorableArray :: StorableArray i e -> IO ()
-touchStorableArray (StorableArray _ _ fp) = touchForeignPtr fp
-
--- |Construct a 'StorableArray' from an arbitrary 'ForeignPtr'. It is
--- the caller's responsibility to ensure that the 'ForeignPtr' points to
--- an area of memory sufficient for the specified bounds.
-unsafeForeignPtrToStorableArray
- :: ForeignPtr e -> (i,i) -> IO (StorableArray i e)
-unsafeForeignPtrToStorableArray p (l,u) =
- return (StorableArray l u p)
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Array.Unboxed
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Data.Array.IArray)
---
--- Unboxed immutable arrays.
---
------------------------------------------------------------------------------
-
-module Data.Array.Unboxed (
- -- * Arrays with unboxed elements
- UArray,
-
- -- * The overloaded immutable array interface
- module Data.Array.IArray,
- ) where
-
-import Prelude
-
-import Data.Array.IArray
-import Data.Array.Base
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Bits
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- This module defines bitwise operations for signed and unsigned
--- integers. Instances of the class 'Bits' for the 'Int' and
--- 'Integer' types are available from this module, and instances for
--- explicitly sized integral types are available from the
--- "Data.Int" and "Data.Word" modules.
---
------------------------------------------------------------------------------
-
-module Data.Bits (
- Bits(
- (.&.), (.|.), xor, -- :: a -> a -> a
- complement, -- :: a -> a
- shift, -- :: a -> Int -> a
- rotate, -- :: a -> Int -> a
- bit, -- :: Int -> a
- setBit, -- :: a -> Int -> a
- clearBit, -- :: a -> Int -> a
- complementBit, -- :: a -> Int -> a
- testBit, -- :: a -> Int -> Bool
- bitSize, -- :: a -> Int
- isSigned, -- :: a -> Bool
- shiftL, shiftR, -- :: a -> Int -> a
- rotateL, rotateR -- :: a -> Int -> a
- )
-
- -- instance Bits Int
- -- instance Bits Integer
- ) where
-
--- Defines the @Bits@ class containing bit-based operations.
--- See library document for details on the semantics of the
--- individual operations.
-
-#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
-#include "MachDeps.h"
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Num
-import GHC.Real
-import GHC.Base
-#endif
-
-#ifdef __HUGS__
-import Hugs.Bits
-#endif
-
-infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`
-infixl 7 .&.
-infixl 6 `xor`
-infixl 5 .|.
-
-{-|
-The 'Bits' class defines bitwise operations over integral types.
-
-* Bits are numbered from 0 with bit 0 being the least
- significant bit.
-
-Minimal complete definition: '.&.', '.|.', 'xor', 'complement',
-('shift' or ('shiftL' and 'shiftR')), ('rotate' or ('rotateL' and 'rotateR')),
-'bitSize' and 'isSigned'.
--}
-class Num a => Bits a where
- -- | Bitwise \"and\"
- (.&.) :: a -> a -> a
-
- -- | Bitwise \"or\"
- (.|.) :: a -> a -> a
-
- -- | Bitwise \"xor\"
- xor :: a -> a -> a
-
- {-| Reverse all the bits in the argument -}
- complement :: a -> a
-
- {-| @'shift' x i@ shifts @x@ left by @i@ bits if @i@ is positive,
- or right by @-i@ bits otherwise.
- Right shifts perform sign extension on signed number types;
- i.e. they fill the top bits with 1 if the @x@ is negative
- and with 0 otherwise.
-
- An instance can define either this unified 'shift' or 'shiftL' and
- 'shiftR', depending on which is more convenient for the type in
- question. -}
- shift :: a -> Int -> a
-
- x `shift` i | i<0 = x `shiftR` (-i)
- | i==0 = x
- | i>0 = x `shiftL` i
-
- {-| @'rotate' x i@ rotates @x@ left by @i@ bits if @i@ is positive,
- or right by @-i@ bits otherwise.
-
- For unbounded types like 'Integer', 'rotate' is equivalent to 'shift'.
-
- An instance can define either this unified 'rotate' or 'rotateL' and
- 'rotateR', depending on which is more convenient for the type in
- question. -}
- rotate :: a -> Int -> a
-
- x `rotate` i | i<0 = x `rotateR` (-i)
- | i==0 = x
- | i>0 = x `rotateL` i
-
- {-
- -- Rotation can be implemented in terms of two shifts, but care is
- -- needed for negative values. This suggested implementation assumes
- -- 2's-complement arithmetic. It is commented out because it would
- -- require an extra context (Ord a) on the signature of 'rotate'.
- x `rotate` i | i<0 && isSigned x && x<0
- = let left = i+bitSize x in
- ((x `shift` i) .&. complement ((-1) `shift` left))
- .|. (x `shift` left)
- | i<0 = (x `shift` i) .|. (x `shift` (i+bitSize x))
- | i==0 = x
- | i>0 = (x `shift` i) .|. (x `shift` (i-bitSize x))
- -}
-
- -- | @bit i@ is a value with the @i@th bit set
- bit :: Int -> a
-
- -- | @x \`setBit\` i@ is the same as @x .|. bit i@
- setBit :: a -> Int -> a
-
- -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@
- clearBit :: a -> Int -> a
-
- -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@
- complementBit :: a -> Int -> a
-
- -- | Return 'True' if the @n@th bit of the argument is 1
- testBit :: a -> Int -> Bool
-
- {-| Return the number of bits in the type of the argument. The actual
- value of the argument is ignored. The function 'bitSize' is
- undefined for types that do not have a fixed bitsize, like 'Integer'.
- -}
- bitSize :: a -> Int
-
- {-| Return 'True' if the argument is a signed type. The actual
- value of the argument is ignored -}
- isSigned :: a -> Bool
-
- bit i = 1 `shiftL` i
- x `setBit` i = x .|. bit i
- x `clearBit` i = x .&. complement (bit i)
- x `complementBit` i = x `xor` bit i
- x `testBit` i = (x .&. bit i) /= 0
-
- {-| Shift the argument left by the specified number of bits
- (which must be non-negative).
-
- An instance can define either this and 'shiftR' or the unified
- 'shift', depending on which is more convenient for the type in
- question. -}
- shiftL :: a -> Int -> a
- x `shiftL` i = x `shift` i
-
- {-| Shift the first argument right by the specified number of bits
- (which must be non-negative).
- Right shifts perform sign extension on signed number types;
- i.e. they fill the top bits with 1 if the @x@ is negative
- and with 0 otherwise.
-
- An instance can define either this and 'shiftL' or the unified
- 'shift', depending on which is more convenient for the type in
- question. -}
- shiftR :: a -> Int -> a
- x `shiftR` i = x `shift` (-i)
-
- {-| Rotate the argument left by the specified number of bits
- (which must be non-negative).
-
- An instance can define either this and 'rotateR' or the unified
- 'rotate', depending on which is more convenient for the type in
- question. -}
- rotateL :: a -> Int -> a
- x `rotateL` i = x `rotate` i
-
- {-| Rotate the argument right by the specified number of bits
- (which must be non-negative).
-
- An instance can define either this and 'rotateL' or the unified
- 'rotate', depending on which is more convenient for the type in
- question. -}
- rotateR :: a -> Int -> a
- x `rotateR` i = x `rotate` (-i)
-
-instance Bits Int where
- {-# INLINE shift #-}
-
-#ifdef __GLASGOW_HASKELL__
- (I# x#) .&. (I# y#) = I# (word2Int# (int2Word# x# `and#` int2Word# y#))
- (I# x#) .|. (I# y#) = I# (word2Int# (int2Word# x# `or#` int2Word# y#))
- (I# x#) `xor` (I# y#) = I# (word2Int# (int2Word# x# `xor#` int2Word# y#))
- complement (I# x#) = I# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))
- (I# x#) `shift` (I# i#)
- | i# >=# 0# = I# (x# `iShiftL#` i#)
- | otherwise = I# (x# `iShiftRA#` negateInt# i#)
- (I# x#) `rotate` (I# i#) =
- I# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`
- (x'# `uncheckedShiftRL#` (wsib -# i'#))))
- where
- x'# = int2Word# x#
- i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#))
- wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -}
- bitSize _ = WORD_SIZE_IN_BITS
-#else /* !__GLASGOW_HASKELL__ */
-
-#ifdef __HUGS__
- (.&.) = primAndInt
- (.|.) = primOrInt
- xor = primXorInt
- complement = primComplementInt
- shift = primShiftInt
- bit = primBitInt
- testBit = primTestInt
- bitSize _ = SIZEOF_HSINT*8
-#elif defined(__NHC__)
- (.&.) = nhc_primIntAnd
- (.|.) = nhc_primIntOr
- xor = nhc_primIntXor
- complement = nhc_primIntCompl
- shiftL = nhc_primIntLsh
- shiftR = nhc_primIntRsh
- bitSize _ = 32
-#endif /* __NHC__ */
-
- x `rotate` i
- | i<0 && x<0 = let left = i+bitSize x in
- ((x `shift` i) .&. complement ((-1) `shift` left))
- .|. (x `shift` left)
- | i<0 = (x `shift` i) .|. (x `shift` (i+bitSize x))
- | i==0 = x
- | i>0 = (x `shift` i) .|. (x `shift` (i-bitSize x))
-
-#endif /* !__GLASGOW_HASKELL__ */
-
- isSigned _ = True
-
-#ifdef __NHC__
-foreign import ccall nhc_primIntAnd :: Int -> Int -> Int
-foreign import ccall nhc_primIntOr :: Int -> Int -> Int
-foreign import ccall nhc_primIntXor :: Int -> Int -> Int
-foreign import ccall nhc_primIntLsh :: Int -> Int -> Int
-foreign import ccall nhc_primIntRsh :: Int -> Int -> Int
-foreign import ccall nhc_primIntCompl :: Int -> Int
-#endif /* __NHC__ */
-
-instance Bits Integer where
-#ifdef __GLASGOW_HASKELL__
- (S# x) .&. (S# y) = S# (word2Int# (int2Word# x `and#` int2Word# y))
- x@(S# _) .&. y = toBig x .&. y
- x .&. y@(S# _) = x .&. toBig y
- (J# s1 d1) .&. (J# s2 d2) =
- case andInteger# s1 d1 s2 d2 of
- (# s, d #) -> J# s d
-
- (S# x) .|. (S# y) = S# (word2Int# (int2Word# x `or#` int2Word# y))
- x@(S# _) .|. y = toBig x .|. y
- x .|. y@(S# _) = x .|. toBig y
- (J# s1 d1) .|. (J# s2 d2) =
- case orInteger# s1 d1 s2 d2 of
- (# s, d #) -> J# s d
-
- (S# x) `xor` (S# y) = S# (word2Int# (int2Word# x `xor#` int2Word# y))
- x@(S# _) `xor` y = toBig x `xor` y
- x `xor` y@(S# _) = x `xor` toBig y
- (J# s1 d1) `xor` (J# s2 d2) =
- case xorInteger# s1 d1 s2 d2 of
- (# s, d #) -> J# s d
-
- complement (S# x) = S# (word2Int# (int2Word# x `xor#` int2Word# (0# -# 1#)))
- complement (J# s d) = case complementInteger# s d of (# s, d #) -> J# s d
-#else
- -- reduce bitwise binary operations to special cases we can handle
-
- x .&. y | x<0 && y<0 = complement (complement x `posOr` complement y)
- | otherwise = x `posAnd` y
-
- x .|. y | x<0 || y<0 = complement (complement x `posAnd` complement y)
- | otherwise = x `posOr` y
-
- x `xor` y | x<0 && y<0 = complement x `posXOr` complement y
- | x<0 = complement (complement x `posXOr` y)
- | y<0 = complement (x `posXOr` complement y)
- | otherwise = x `posXOr` y
-
- -- assuming infinite 2's-complement arithmetic
- complement a = -1 - a
-#endif
-
- shift x i | i >= 0 = x * 2^i
- | otherwise = x `div` 2^(-i)
-
- rotate x i = shift x i -- since an Integer never wraps around
-
- bitSize _ = error "Data.Bits.bitSize(Integer)"
- isSigned _ = True
-
-#ifndef __GLASGOW_HASKELL__
--- Crude implementation of bitwise operations on Integers: convert them
--- to finite lists of Ints (least significant first), zip and convert
--- back again.
-
--- posAnd requires at least one argument non-negative
--- posOr and posXOr require both arguments non-negative
-
-posAnd, posOr, posXOr :: Integer -> Integer -> Integer
-posAnd x y = fromInts $ zipWith (.&.) (toInts x) (toInts y)
-posOr x y = fromInts $ longZipWith (.|.) (toInts x) (toInts y)
-posXOr x y = fromInts $ longZipWith xor (toInts x) (toInts y)
-
-longZipWith :: (a -> a -> a) -> [a] -> [a] -> [a]
-longZipWith f xs [] = xs
-longZipWith f [] ys = ys
-longZipWith f (x:xs) (y:ys) = f x y:longZipWith f xs ys
-
-toInts :: Integer -> [Int]
-toInts n
- | n == 0 = []
- | otherwise = mkInt (n `mod` numInts):toInts (n `div` numInts)
- where mkInt n | n > toInteger(maxBound::Int) = fromInteger (n-numInts)
- | otherwise = fromInteger n
-
-fromInts :: [Int] -> Integer
-fromInts = foldr catInt 0
- where catInt d n = (if d<0 then n+1 else n)*numInts + toInteger d
-
-numInts = toInteger (maxBound::Int) - toInteger (minBound::Int) + 1
-#endif /* !__GLASGOW_HASKELL__ */
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Bool
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- The 'Bool' type and related functions.
---
------------------------------------------------------------------------------
-
-module Data.Bool (
- -- * Booleans
- Bool(..),
- -- ** Operations
- (&&), -- :: Bool -> Bool -> Bool
- (||), -- :: Bool -> Bool -> Bool
- not, -- :: Bool -> Bool
- otherwise, -- :: Bool
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-#endif
-
-#ifdef __NHC__
-import Prelude
-import Prelude
- ( Bool(..)
- , (&&)
- , (||)
- , not
- , otherwise
- )
-#endif
+++ /dev/null
-{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}
--- |
--- Module : Data.ByteString
--- Copyright : (c) The University of Glasgow 2001,
--- (c) David Roundy 2003-2005,
--- (c) Simon Marlow 2005
--- (c) Don Stewart 2005-2006
--- (c) Bjorn Bringert 2006
--- Array fusion code:
--- (c) 2001,2002 Manuel M T Chakravarty & Gabriele Keller
--- (c) 2006 Manuel M T Chakravarty & Roman Leshchinskiy
---
--- License : BSD-style
---
--- Maintainer : dons@cse.unsw.edu.au
--- Stability : experimental
--- Portability : portable
---
--- A time and space-efficient implementation of byte vectors using
--- packed Word8 arrays, suitable for high performance use, both in terms
--- of large data quantities, or high speed requirements. Byte vectors
--- are encoded as strict 'Word8' arrays of bytes, held in a 'ForeignPtr',
--- and can be passed between C and Haskell with little effort.
---
--- This module is intended to be imported @qualified@, to avoid name
--- clashes with "Prelude" functions. eg.
---
--- > import qualified Data.ByteString as B
---
--- Original GHC implementation by Bryan O\'Sullivan.
--- Rewritten to use 'Data.Array.Unboxed.UArray' by Simon Marlow.
--- Rewritten to support slices and use 'ForeignPtr' by David Roundy.
--- Polished and extended by Don Stewart.
---
-
-module Data.ByteString (
-
- -- * The @ByteString@ type
- ByteString, -- abstract, instances: Eq, Ord, Show, Read, Data, Typeable, Monoid
-
- -- * Introducing and eliminating 'ByteString's
- empty, -- :: ByteString
- singleton, -- :: Word8 -> ByteString
- pack, -- :: [Word8] -> ByteString
- unpack, -- :: ByteString -> [Word8]
-
- -- * Basic interface
- cons, -- :: Word8 -> ByteString -> ByteString
- snoc, -- :: ByteString -> Word8 -> ByteString
- append, -- :: ByteString -> ByteString -> ByteString
- head, -- :: ByteString -> Word8
- last, -- :: ByteString -> Word8
- tail, -- :: ByteString -> ByteString
- init, -- :: ByteString -> ByteString
- null, -- :: ByteString -> Bool
- length, -- :: ByteString -> Int
-
- -- * Transformating ByteStrings
- map, -- :: (Word8 -> Word8) -> ByteString -> ByteString
- reverse, -- :: ByteString -> ByteString
- intersperse, -- :: Word8 -> ByteString -> ByteString
- transpose, -- :: [ByteString] -> [ByteString]
-
- -- * Reducing 'ByteString's (folds)
- foldl, -- :: (a -> Word8 -> a) -> a -> ByteString -> a
- foldl', -- :: (a -> Word8 -> a) -> a -> ByteString -> a
- foldl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
- foldl1', -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
-
- foldr, -- :: (Word8 -> a -> a) -> a -> ByteString -> a
- foldr', -- :: (Word8 -> a -> a) -> a -> ByteString -> a
- foldr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
- foldr1', -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
-
- -- ** Special folds
- concat, -- :: [ByteString] -> ByteString
- concatMap, -- :: (Word8 -> ByteString) -> ByteString -> ByteString
- any, -- :: (Word8 -> Bool) -> ByteString -> Bool
- all, -- :: (Word8 -> Bool) -> ByteString -> Bool
- maximum, -- :: ByteString -> Word8
- minimum, -- :: ByteString -> Word8
-
- -- * Building ByteStrings
- -- ** Scans
- scanl, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString
- scanl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString
- scanr, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString
- scanr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString
-
- -- ** Accumulating maps
- mapAccumL, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString)
- mapAccumR, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString)
- mapIndexed, -- :: (Int -> Word8 -> Word8) -> ByteString -> ByteString
-
- -- ** Unfolding ByteStrings
- replicate, -- :: Int -> Word8 -> ByteString
- unfoldr, -- :: (a -> Maybe (Word8, a)) -> a -> ByteString
- unfoldrN, -- :: Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a)
-
- -- * Substrings
-
- -- ** Breaking strings
- take, -- :: Int -> ByteString -> ByteString
- drop, -- :: Int -> ByteString -> ByteString
- splitAt, -- :: Int -> ByteString -> (ByteString, ByteString)
- takeWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString
- dropWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString
- span, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
- spanEnd, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
- break, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
- breakEnd, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
- group, -- :: ByteString -> [ByteString]
- groupBy, -- :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString]
- inits, -- :: ByteString -> [ByteString]
- tails, -- :: ByteString -> [ByteString]
-
- -- ** Breaking into many substrings
- split, -- :: Word8 -> ByteString -> [ByteString]
- splitWith, -- :: (Word8 -> Bool) -> ByteString -> [ByteString]
-
- -- ** Joining strings
- join, -- :: ByteString -> [ByteString] -> ByteString
-
- -- * Predicates
- isPrefixOf, -- :: ByteString -> ByteString -> Bool
- isSuffixOf, -- :: ByteString -> ByteString -> Bool
-
- -- ** Search for arbitrary substrings
- isSubstringOf, -- :: ByteString -> ByteString -> Bool
- findSubstring, -- :: ByteString -> ByteString -> Maybe Int
- findSubstrings, -- :: ByteString -> ByteString -> [Int]
-
- -- * Searching ByteStrings
-
- -- ** Searching by equality
- -- | These functions use memchr(3) to efficiently search the ByteString
- elem, -- :: Word8 -> ByteString -> Bool
- notElem, -- :: Word8 -> ByteString -> Bool
-
- -- ** Searching with a predicate
- find, -- :: (Word8 -> Bool) -> ByteString -> Maybe Word8
- filter, -- :: (Word8 -> Bool) -> ByteString -> ByteString
--- partition -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
-
- -- * Indexing ByteStrings
- index, -- :: ByteString -> Int -> Word8
- elemIndex, -- :: Word8 -> ByteString -> Maybe Int
- elemIndices, -- :: Word8 -> ByteString -> [Int]
- elemIndexEnd, -- :: Word8 -> ByteString -> Maybe Int
- findIndex, -- :: (Word8 -> Bool) -> ByteString -> Maybe Int
- findIndices, -- :: (Word8 -> Bool) -> ByteString -> [Int]
- count, -- :: Word8 -> ByteString -> Int
-
- -- * Zipping and unzipping ByteStrings
- zip, -- :: ByteString -> ByteString -> [(Word8,Word8)]
- zipWith, -- :: (Word8 -> Word8 -> c) -> ByteString -> ByteString -> [c]
- unzip, -- :: [(Word8,Word8)] -> (ByteString,ByteString)
-
- -- * Ordered ByteStrings
- sort, -- :: ByteString -> ByteString
-
- -- * Low level CString conversions
-
- -- ** Packing CStrings and pointers
- packCString, -- :: CString -> ByteString
- packCStringLen, -- :: CString -> ByteString
- packMallocCString, -- :: CString -> ByteString
-
- -- ** Using ByteStrings as CStrings
- useAsCString, -- :: ByteString -> (CString -> IO a) -> IO a
- useAsCStringLen, -- :: ByteString -> (CStringLen -> IO a) -> IO a
-
- -- ** Copying ByteStrings
- -- | These functions perform memcpy(3) operations
- copy, -- :: ByteString -> ByteString
- copyCString, -- :: CString -> IO ByteString
- copyCStringLen, -- :: CStringLen -> IO ByteString
-
- -- * I\/O with 'ByteString's
-
- -- ** Standard input and output
- getLine, -- :: IO ByteString
- getContents, -- :: IO ByteString
- putStr, -- :: ByteString -> IO ()
- putStrLn, -- :: ByteString -> IO ()
- interact, -- :: (ByteString -> ByteString) -> IO ()
-
- -- ** Files
- readFile, -- :: FilePath -> IO ByteString
- writeFile, -- :: FilePath -> ByteString -> IO ()
- appendFile, -- :: FilePath -> ByteString -> IO ()
--- mmapFile, -- :: FilePath -> IO ByteString
-
- -- ** I\/O with Handles
- hGetLine, -- :: Handle -> IO ByteString
- hGetContents, -- :: Handle -> IO ByteString
- hGet, -- :: Handle -> Int -> IO ByteString
- hGetNonBlocking, -- :: Handle -> Int -> IO ByteString
- hPut, -- :: Handle -> ByteString -> IO ()
- hPutStr, -- :: Handle -> ByteString -> IO ()
- hPutStrLn, -- :: Handle -> ByteString -> IO ()
-
-#if defined(__GLASGOW_HASKELL__)
- -- * Fusion utilities
- unpackList, -- eek, otherwise it gets thrown away by the simplifier
- lengthU, maximumU, minimumU
-#endif
-
- ) where
-
-import qualified Prelude as P
-import Prelude hiding (reverse,head,tail,last,init,null
- ,length,map,lines,foldl,foldr,unlines
- ,concat,any,take,drop,splitAt,takeWhile
- ,dropWhile,span,break,elem,filter,maximum
- ,minimum,all,concatMap,foldl1,foldr1
- ,scanl,scanl1,scanr,scanr1
- ,readFile,writeFile,appendFile,replicate
- ,getContents,getLine,putStr,putStrLn,interact
- ,zip,zipWith,unzip,notElem)
-
-import Data.ByteString.Base
-import Data.ByteString.Fusion
-
-import qualified Data.List as List
-
-import Data.Word (Word8)
-import Data.Maybe (listToMaybe)
-import Data.Array (listArray)
-import qualified Data.Array as Array ((!))
-
--- Control.Exception.bracket not available in yhc or nhc
-import Control.Exception (bracket, assert)
-import qualified Control.Exception as Exception
-import Control.Monad (when)
-
-import Foreign.C.String (CString, CStringLen)
-import Foreign.C.Types (CSize)
-import Foreign.ForeignPtr
-import Foreign.Marshal.Array
-import Foreign.Ptr
-import Foreign.Storable (Storable(..))
-
--- hGetBuf and hPutBuf not available in yhc or nhc
-import System.IO (stdin,stdout,hClose,hFileSize
- ,hGetBuf,hPutBuf,openBinaryFile
- ,Handle,IOMode(..))
-
-import Data.Monoid (Monoid, mempty, mappend, mconcat)
-
-#if !defined(__GLASGOW_HASKELL__)
-import System.IO.Unsafe
-import qualified System.Environment
-import qualified System.IO (hGetLine)
-#endif
-
-#if defined(__GLASGOW_HASKELL__)
-
-import System.IO (hGetBufNonBlocking)
-import System.IO.Error (isEOFError)
-
-import GHC.Handle
-import GHC.Prim (Word#, (+#), writeWord8OffAddr#)
-import GHC.Base (build)
-import GHC.Word hiding (Word8)
-import GHC.Ptr (Ptr(..))
-import GHC.ST (ST(..))
-import GHC.IOBase
-
-#endif
-
--- -----------------------------------------------------------------------------
---
--- Useful macros, until we have bang patterns
---
-
-#define STRICT1(f) f a | a `seq` False = undefined
-#define STRICT2(f) f a b | a `seq` b `seq` False = undefined
-#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
-#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined
-#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined
-
--- -----------------------------------------------------------------------------
-
-instance Eq ByteString
- where (==) = eq
-
-instance Ord ByteString
- where compare = compareBytes
-
-instance Monoid ByteString where
- mempty = empty
- mappend = append
- mconcat = concat
-
-{-
-instance Arbitrary PackedString where
- arbitrary = P.pack `fmap` arbitrary
- coarbitrary s = coarbitrary (P.unpack s)
--}
-
--- | /O(n)/ Equality on the 'ByteString' type.
-eq :: ByteString -> ByteString -> Bool
-eq a@(PS p s l) b@(PS p' s' l')
- | l /= l' = False -- short cut on length
- | p == p' && s == s' = True -- short cut for the same string
- | otherwise = compareBytes a b == EQ
-{-# INLINE eq #-}
-
--- | /O(n)/ 'compareBytes' provides an 'Ordering' for 'ByteStrings' supporting slices.
-compareBytes :: ByteString -> ByteString -> Ordering
-compareBytes (PS x1 s1 l1) (PS x2 s2 l2)
- | l1 == 0 && l2 == 0 = EQ -- short cut for empty strings
- | x1 == x2 && s1 == s2 && l1 == l2 = EQ -- short cut for the same string
- | otherwise = inlinePerformIO $
- withForeignPtr x1 $ \p1 ->
- withForeignPtr x2 $ \p2 -> do
- i <- memcmp (p1 `plusPtr` s1) (p2 `plusPtr` s2) (fromIntegral $ min l1 l2)
- return $! case i `compare` 0 of
- EQ -> l1 `compare` l2
- x -> x
-{-# INLINE compareBytes #-}
-
-{-
---
--- About 4x slower over 32M
---
-compareBytes :: ByteString -> ByteString -> Ordering
-compareBytes (PS fp1 off1 len1) (PS fp2 off2 len2) = inlinePerformIO $
- withForeignPtr fp1 $ \p1 ->
- withForeignPtr fp2 $ \p2 ->
- cmp (p1 `plusPtr` off1)
- (p2 `plusPtr` off2) 0 len1 len2
-
-cmp :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> Int-> IO Ordering
-STRICT5(cmp)
-cmp p1 p2 n len1 len2
- | n == len1 = if n == len2 then return EQ else return LT
- | n == len2 = return GT
- | otherwise = do
- (a :: Word8) <- peekByteOff p1 n
- (b :: Word8) <- peekByteOff p2 n
- case a `compare` b of
- EQ -> cmp p1 p2 (n+1) len1 len2
- LT -> return LT
- GT -> return GT
-{-# INLINE compareBytes #-}
--}
-
--- -----------------------------------------------------------------------------
--- Introducing and eliminating 'ByteString's
-
--- | /O(1)/ Convert a 'Word8' into a 'ByteString'
-singleton :: Word8 -> ByteString
-singleton c = unsafeCreate 1 $ \p -> poke p c
-{-# INLINE [1] singleton #-}
-
---
--- XXX The unsafePerformIO is critical!
---
--- Otherwise:
---
--- singleton 255 `compare` singleton 127
---
--- is compiled to:
---
--- case mallocByteString 2 of
--- ForeignPtr f internals ->
--- case writeWord8OffAddr# f 0 255 of _ ->
--- case writeWord8OffAddr# f 0 127 of _ ->
--- case eqAddr# f f of
--- False -> case compare (GHC.Prim.plusAddr# f 0)
--- (GHC.Prim.plusAddr# f 0)
---
---
-
--- | /O(n)/ Convert a '[Word8]' into a 'ByteString'.
---
--- For applications with large numbers of string literals, pack can be a
--- bottleneck. In such cases, consider using packAddress (GHC only).
-pack :: [Word8] -> ByteString
-
-#if !defined(__GLASGOW_HASKELL__)
-
-pack str = unsafeCreate (P.length str) $ \p -> go p str
- where
- go _ [] = return ()
- go p (x:xs) = poke p x >> go (p `plusPtr` 1) xs -- less space than pokeElemOff
-
-#else /* hack away */
-
-pack str = unsafeCreate (P.length str) $ \(Ptr p) -> stToIO (go p 0# str)
- where
- go _ _ [] = return ()
- go p i (W8# c:cs) = writeByte p i c >> go p (i +# 1#) cs
-
- writeByte p i c = ST $ \s# ->
- case writeWord8OffAddr# p i c s# of s2# -> (# s2#, () #)
-
-#endif
-
--- | /O(n)/ Converts a 'ByteString' to a '[Word8]'.
-unpack :: ByteString -> [Word8]
-
-#if !defined(__GLASGOW_HASKELL__)
-
-unpack (PS _ _ 0) = []
-unpack (PS ps s l) = inlinePerformIO $ withForeignPtr ps $ \p ->
- go (p `plusPtr` s) (l - 1) []
- where
- STRICT3(go)
- go p 0 acc = peek p >>= \e -> return (e : acc)
- go p n acc = peekByteOff p n >>= \e -> go p (n-1) (e : acc)
-{-# INLINE unpack #-}
-
-#else
-
-unpack ps = build (unpackFoldr ps)
-{-# INLINE unpack #-}
-
---
--- critical this isn't strict in the acc
--- as it will break in the presence of list fusion. this is a known
--- issue with seq and build/foldr rewrite rules, which rely on lazy
--- demanding to avoid bottoms in the list.
---
-unpackFoldr :: ByteString -> (Word8 -> a -> a) -> a -> a
-unpackFoldr (PS fp off len) f ch = withPtr fp $ \p -> do
- let loop q n _ | q `seq` n `seq` False = undefined -- n.b.
- loop _ (-1) acc = return acc
- loop q n acc = do
- a <- peekByteOff q n
- loop q (n-1) (a `f` acc)
- loop (p `plusPtr` off) (len-1) ch
-{-# INLINE [0] unpackFoldr #-}
-
-unpackList :: ByteString -> [Word8]
-unpackList (PS fp off len) = withPtr fp $ \p -> do
- let STRICT3(loop)
- loop _ (-1) acc = return acc
- loop q n acc = do
- a <- peekByteOff q n
- loop q (n-1) (a : acc)
- loop (p `plusPtr` off) (len-1) []
-
-{-# RULES
- "FPS unpack-list" [1] forall p . unpackFoldr p (:) [] = unpackList p
- #-}
-
-#endif
-
--- ---------------------------------------------------------------------
--- Basic interface
-
--- | /O(1)/ Test whether a ByteString is empty.
-null :: ByteString -> Bool
-null (PS _ _ l) = assert (l >= 0) $ l <= 0
-{-# INLINE null #-}
-
--- ---------------------------------------------------------------------
--- | /O(1)/ 'length' returns the length of a ByteString as an 'Int'.
-length :: ByteString -> Int
-length (PS _ _ l) = assert (l >= 0) $ l
-
---
--- length/loop fusion. When taking the length of any fuseable loop,
--- rewrite it as a foldl', and thus avoid allocating the result buffer
--- worth around 10% in speed testing.
---
-
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] length #-}
-#endif
-
-lengthU :: ByteString -> Int
-lengthU = foldl' (const . (+1)) (0::Int)
-{-# INLINE lengthU #-}
-
-{-# RULES
-
--- v2 fusion
-"FPS length/loop" forall loop s .
- length (loopArr (loopWrapper loop s)) =
- lengthU (loopArr (loopWrapper loop s))
-
- #-}
-
-------------------------------------------------------------------------
-
--- | /O(n)/ 'cons' is analogous to (:) for lists, but of different
--- complexity, as it requires a memcpy.
-cons :: Word8 -> ByteString -> ByteString
-cons c (PS x s l) = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do
- poke p c
- memcpy (p `plusPtr` 1) (f `plusPtr` s) (fromIntegral l)
-{-# INLINE cons #-}
-
--- | /O(n)/ Append a byte to the end of a 'ByteString'
-snoc :: ByteString -> Word8 -> ByteString
-snoc (PS x s l) c = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do
- memcpy p (f `plusPtr` s) (fromIntegral l)
- poke (p `plusPtr` l) c
-{-# INLINE snoc #-}
-
--- todo fuse
-
--- | /O(1)/ Extract the first element of a ByteString, which must be non-empty.
--- An exception will be thrown in the case of an empty ByteString.
-head :: ByteString -> Word8
-head (PS x s l)
- | l <= 0 = errorEmptyList "head"
- | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p s
-{-# INLINE head #-}
-
--- | /O(1)/ Extract the elements after the head of a ByteString, which must be non-empty.
--- An exception will be thrown in the case of an empty ByteString.
-tail :: ByteString -> ByteString
-tail (PS p s l)
- | l <= 0 = errorEmptyList "tail"
- | otherwise = PS p (s+1) (l-1)
-{-# INLINE tail #-}
-
--- | /O(1)/ Extract the last element of a ByteString, which must be finite and non-empty.
--- An exception will be thrown in the case of an empty ByteString.
-last :: ByteString -> Word8
-last ps@(PS x s l)
- | null ps = errorEmptyList "last"
- | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p (s+l-1)
-{-# INLINE last #-}
-
--- | /O(1)/ Return all the elements of a 'ByteString' except the last one.
--- An exception will be thrown in the case of an empty ByteString.
-init :: ByteString -> ByteString
-init ps@(PS p s l)
- | null ps = errorEmptyList "init"
- | otherwise = PS p s (l-1)
-{-# INLINE init #-}
-
--- | /O(n)/ Append two ByteStrings
-append :: ByteString -> ByteString -> ByteString
-append xs ys | null xs = ys
- | null ys = xs
- | otherwise = concat [xs,ys]
-{-# INLINE append #-}
-
--- ---------------------------------------------------------------------
--- Transformations
-
--- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each
--- element of @xs@. This function is subject to array fusion.
-map :: (Word8 -> Word8) -> ByteString -> ByteString
-#if defined(LOOPU_FUSION)
-map f = loopArr . loopU (mapEFL f) NoAcc
-#elif defined(LOOPUP_FUSION)
-map f = loopArr . loopUp (mapEFL f) NoAcc
-#elif defined(LOOPNOACC_FUSION)
-map f = loopArr . loopNoAcc (mapEFL f)
-#else
-map f = loopArr . loopMap f
-#endif
-{-# INLINE map #-}
-
-{-
--- | /O(n)/ Like 'map', but not fuseable. The benefit is that it is
--- slightly faster for one-shot cases.
-map' :: (Word8 -> Word8) -> ByteString -> ByteString
-map' f (PS fp s len) = inlinePerformIO $ withForeignPtr fp $ \a ->
- create len $ map_ 0 (a `plusPtr` s)
- where
- map_ :: Int -> Ptr Word8 -> Ptr Word8 -> IO ()
- STRICT3(map_)
- map_ n p1 p2
- | n >= len = return ()
- | otherwise = do
- x <- peekByteOff p1 n
- pokeByteOff p2 n (f x)
- map_ (n+1) p1 p2
-{-# INLINE map' #-}
--}
-
--- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order.
-reverse :: ByteString -> ByteString
-reverse (PS x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f ->
- c_reverse p (f `plusPtr` s) (fromIntegral l)
-
--- todo, fuseable version
-
--- | /O(n)/ The 'intersperse' function takes a 'Word8' and a
--- 'ByteString' and \`intersperses\' that byte between the elements of
--- the 'ByteString'. It is analogous to the intersperse function on
--- Lists.
-intersperse :: Word8 -> ByteString -> ByteString
-intersperse c ps@(PS x s l)
- | length ps < 2 = ps
- | otherwise = unsafeCreate (2*l-1) $ \p -> withForeignPtr x $ \f ->
- c_intersperse p (f `plusPtr` s) (fromIntegral l) c
-
-{-
-intersperse c = pack . List.intersperse c . unpack
--}
-
--- | The 'transpose' function transposes the rows and columns of its
--- 'ByteString' argument.
-transpose :: [ByteString] -> [ByteString]
-transpose ps = P.map pack (List.transpose (P.map unpack ps))
-
--- ---------------------------------------------------------------------
--- Reducing 'ByteString's
-
--- | 'foldl', applied to a binary operator, a starting value (typically
--- the left-identity of the operator), and a ByteString, reduces the
--- ByteString using the binary operator, from left to right.
--- This function is subject to array fusion.
-foldl :: (a -> Word8 -> a) -> a -> ByteString -> a
-#if !defined(LOOPU_FUSION)
-foldl f z = loopAcc . loopUp (foldEFL f) z
-#else
-foldl f z = loopAcc . loopU (foldEFL f) z
-#endif
-{-# INLINE foldl #-}
-
-{-
---
--- About twice as fast with 6.4.1, but not fuseable
--- A simple fold . map is enough to make it worth while.
---
-foldl f v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->
- lgo v (ptr `plusPtr` s) (ptr `plusPtr` (s+l))
- where
- STRICT3(lgo)
- lgo z p q | p == q = return z
- | otherwise = do c <- peek p
- lgo (f z c) (p `plusPtr` 1) q
--}
-
--- | 'foldl\'' is like 'foldl', but strict in the accumulator.
--- Though actually foldl is also strict in the accumulator.
-foldl' :: (a -> Word8 -> a) -> a -> ByteString -> a
-foldl' = foldl
--- foldl' f z = loopAcc . loopU (foldEFL' f) z
-{-# INLINE foldl' #-}
-
--- | 'foldr', applied to a binary operator, a starting value
--- (typically the right-identity of the operator), and a ByteString,
--- reduces the ByteString using the binary operator, from right to left.
-foldr :: (Word8 -> a -> a) -> a -> ByteString -> a
-foldr k z = loopAcc . loopDown (foldEFL (flip k)) z
-{-# INLINE foldr #-}
-
--- | 'foldr\'' is like 'foldr', but strict in the accumulator.
-foldr' :: (Word8 -> a -> a) -> a -> ByteString -> a
-foldr' k v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->
- go v (ptr `plusPtr` (s+l-1)) (ptr `plusPtr` (s-1))
- where
- STRICT3(go)
- go z p q | p == q = return z
- | otherwise = do c <- peek p
- go (c `k` z) (p `plusPtr` (-1)) q -- tail recursive
-{-# INLINE [1] foldr' #-}
-
--- | 'foldl1' is a variant of 'foldl' that has no starting value
--- argument, and thus must be applied to non-empty 'ByteStrings'.
--- This function is subject to array fusion.
--- An exception will be thrown in the case of an empty ByteString.
-foldl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
-foldl1 f ps
- | null ps = errorEmptyList "foldl1"
- | otherwise = foldl f (unsafeHead ps) (unsafeTail ps)
-{-# INLINE foldl1 #-}
-
--- | 'foldl1\'' is like 'foldl1', but strict in the accumulator.
--- An exception will be thrown in the case of an empty ByteString.
-foldl1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
-foldl1' f ps
- | null ps = errorEmptyList "foldl1'"
- | otherwise = foldl' f (unsafeHead ps) (unsafeTail ps)
-{-# INLINE foldl1' #-}
-
--- | 'foldr1' is a variant of 'foldr' that has no starting value argument,
--- and thus must be applied to non-empty 'ByteString's
--- An exception will be thrown in the case of an empty ByteString.
-foldr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
-foldr1 f ps
- | null ps = errorEmptyList "foldr1"
- | otherwise = foldr f (last ps) (init ps)
-{-# INLINE foldr1 #-}
-
--- | 'foldr1\'' is a variant of 'foldr1', but is strict in the
--- accumulator.
-foldr1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
-foldr1' f ps
- | null ps = errorEmptyList "foldr1"
- | otherwise = foldr' f (last ps) (init ps)
-{-# INLINE [1] foldr1' #-}
-
--- ---------------------------------------------------------------------
--- Special folds
-
--- | /O(n)/ Concatenate a list of ByteStrings.
-concat :: [ByteString] -> ByteString
-concat [] = empty
-concat [ps] = ps
-concat xs = unsafeCreate len $ \ptr -> go xs ptr
- where len = P.sum . P.map length $ xs
- STRICT2(go)
- go [] _ = return ()
- go (PS p s l:ps) ptr = do
- withForeignPtr p $ \fp -> memcpy ptr (fp `plusPtr` s) (fromIntegral l)
- go ps (ptr `plusPtr` l)
-
--- | Map a function over a 'ByteString' and concatenate the results
-concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString
-concatMap f = concat . foldr ((:) . f) []
-
--- foldr (append . f) empty
-
--- | /O(n)/ Applied to a predicate and a ByteString, 'any' determines if
--- any element of the 'ByteString' satisfies the predicate.
-any :: (Word8 -> Bool) -> ByteString -> Bool
-any _ (PS _ _ 0) = False
-any f (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->
- go (ptr `plusPtr` s) (ptr `plusPtr` (s+l))
- where
- STRICT2(go)
- go p q | p == q = return False
- | otherwise = do c <- peek p
- if f c then return True
- else go (p `plusPtr` 1) q
-
--- todo fuse
-
--- | /O(n)/ Applied to a predicate and a 'ByteString', 'all' determines
--- if all elements of the 'ByteString' satisfy the predicate.
-all :: (Word8 -> Bool) -> ByteString -> Bool
-all _ (PS _ _ 0) = True
-all f (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->
- go (ptr `plusPtr` s) (ptr `plusPtr` (s+l))
- where
- STRICT2(go)
- go p q | p == q = return True -- end of list
- | otherwise = do c <- peek p
- if f c
- then go (p `plusPtr` 1) q
- else return False
-
-------------------------------------------------------------------------
-
--- | /O(n)/ 'maximum' returns the maximum value from a 'ByteString'
--- This function will fuse.
--- An exception will be thrown in the case of an empty ByteString.
-maximum :: ByteString -> Word8
-maximum xs@(PS x s l)
- | null xs = errorEmptyList "maximum"
- | otherwise = inlinePerformIO $ withForeignPtr x $ \p ->
- c_maximum (p `plusPtr` s) (fromIntegral l)
-
--- | /O(n)/ 'minimum' returns the minimum value from a 'ByteString'
--- This function will fuse.
--- An exception will be thrown in the case of an empty ByteString.
-minimum :: ByteString -> Word8
-minimum xs@(PS x s l)
- | null xs = errorEmptyList "minimum"
- | otherwise = inlinePerformIO $ withForeignPtr x $ \p ->
- c_minimum (p `plusPtr` s) (fromIntegral l)
-
---
--- minimum/maximum/loop fusion. As for length (and other folds), when we
--- see we're applied after a fuseable op, switch from using the C
--- version, to the fuseable version. The result should then avoid
--- allocating a buffer.
---
-
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] minimum #-}
-{-# INLINE [1] maximum #-}
-#endif
-
-maximumU :: ByteString -> Word8
-maximumU = foldl1' max
-{-# INLINE maximumU #-}
-
-minimumU :: ByteString -> Word8
-minimumU = foldl1' min
-{-# INLINE minimumU #-}
-
-{-# RULES
-
-"FPS minimum/loop" forall loop s .
- minimum (loopArr (loopWrapper loop s)) =
- minimumU (loopArr (loopWrapper loop s))
-
-"FPS maximum/loop" forall loop s .
- maximum (loopArr (loopWrapper loop s)) =
- maximumU (loopArr (loopWrapper loop s))
-
- #-}
-
-------------------------------------------------------------------------
-
--- | The 'mapAccumL' function behaves like a combination of 'map' and
--- 'foldl'; it applies a function to each element of a ByteString,
--- passing an accumulating parameter from left to right, and returning a
--- final value of this accumulator together with the new list.
-mapAccumL :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString)
-#if !defined(LOOPU_FUSION)
-mapAccumL f z = unSP . loopUp (mapAccumEFL f) z
-#else
-mapAccumL f z = unSP . loopU (mapAccumEFL f) z
-#endif
-{-# INLINE mapAccumL #-}
-
--- | The 'mapAccumR' function behaves like a combination of 'map' and
--- 'foldr'; it applies a function to each element of a ByteString,
--- passing an accumulating parameter from right to left, and returning a
--- final value of this accumulator together with the new ByteString.
-mapAccumR :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString)
-mapAccumR f z = unSP . loopDown (mapAccumEFL f) z
-{-# INLINE mapAccumR #-}
-
--- | /O(n)/ map Word8 functions, provided with the index at each position
-mapIndexed :: (Int -> Word8 -> Word8) -> ByteString -> ByteString
-mapIndexed f = loopArr . loopUp (mapIndexEFL f) 0
-{-# INLINE mapIndexed #-}
-
--- ---------------------------------------------------------------------
--- Building ByteStrings
-
--- | 'scanl' is similar to 'foldl', but returns a list of successive
--- reduced values from the left. This function will fuse.
---
--- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
---
--- Note that
---
--- > last (scanl f z xs) == foldl f z xs.
-scanl :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString
-#if !defined(LOOPU_FUSION)
-scanl f z ps = loopArr . loopUp (scanEFL f) z $ (ps `snoc` 0)
-#else
-scanl f z ps = loopArr . loopU (scanEFL f) z $ (ps `snoc` 0)
-#endif
-
- -- n.b. haskell's List scan returns a list one bigger than the
- -- input, so we need to snoc here to get some extra space, however,
- -- it breaks map/up fusion (i.e. scanl . map no longer fuses)
-{-# INLINE scanl #-}
-
--- | 'scanl1' is a variant of 'scanl' that has no starting value argument.
--- This function will fuse.
---
--- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
-scanl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString
-scanl1 f ps
- | null ps = empty
- | otherwise = scanl f (unsafeHead ps) (unsafeTail ps)
-{-# INLINE scanl1 #-}
-
--- | scanr is the right-to-left dual of scanl.
-scanr :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString
-scanr f z ps = loopArr . loopDown (scanEFL (flip f)) z $ (0 `cons` ps) -- extra space
-{-# INLINE scanr #-}
-
--- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
-scanr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString
-scanr1 f ps
- | null ps = empty
- | otherwise = scanr f (last ps) (init ps) -- todo, unsafe versions
-{-# INLINE scanr1 #-}
-
--- ---------------------------------------------------------------------
--- Unfolds and replicates
-
--- | /O(n)/ 'replicate' @n x@ is a ByteString of length @n@ with @x@
--- the value of every element. The following holds:
---
--- > replicate w c = unfoldr w (\u -> Just (u,u)) c
---
--- This implemenation uses @memset(3)@
-replicate :: Int -> Word8 -> ByteString
-replicate w c
- | w <= 0 = empty
- | otherwise = unsafeCreate w $ \ptr ->
- memset ptr c (fromIntegral w) >> return ()
-
--- | /O(n)/, where /n/ is the length of the result. The 'unfoldr'
--- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a
--- ByteString from a seed value. The function takes the element and
--- returns 'Nothing' if it is done producing the ByteString or returns
--- 'Just' @(a,b)@, in which case, @a@ is the next byte in the string,
--- and @b@ is the seed value for further production.
---
--- Examples:
---
--- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0
--- > == pack [0, 1, 2, 3, 4, 5]
---
-unfoldr :: (a -> Maybe (Word8, a)) -> a -> ByteString
-unfoldr f = concat . unfoldChunk 32 64
- where unfoldChunk n n' x =
- case unfoldrN n f x of
- (s, Nothing) -> s : []
- (s, Just x') -> s : unfoldChunk n' (n+n') x'
-
--- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a ByteString from a seed
--- value. However, the length of the result is limited by the first
--- argument to 'unfoldrN'. This function is more efficient than 'unfoldr'
--- when the maximum length of the result is known.
---
--- The following equation relates 'unfoldrN' and 'unfoldr':
---
--- > unfoldrN n f s == take n (unfoldr f s)
---
-unfoldrN :: Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a)
-unfoldrN i f x0
- | i < 0 = (empty, Just x0)
- | otherwise = unsafePerformIO $ createAndTrim' i $ \p -> go p x0 0
- where STRICT3(go)
- go p x n =
- case f x of
- Nothing -> return (0, n, Nothing)
- Just (w,x')
- | n == i -> return (0, n, Just x)
- | otherwise -> do poke p w
- go (p `plusPtr` 1) x' (n+1)
-
--- ---------------------------------------------------------------------
--- Substrings
-
--- | /O(1)/ 'take' @n@, applied to a ByteString @xs@, returns the prefix
--- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@.
-take :: Int -> ByteString -> ByteString
-take n ps@(PS x s l)
- | n <= 0 = empty
- | n >= l = ps
- | otherwise = PS x s n
-{-# INLINE take #-}
-
--- | /O(1)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@
--- elements, or @[]@ if @n > 'length' xs@.
-drop :: Int -> ByteString -> ByteString
-drop n ps@(PS x s l)
- | n <= 0 = ps
- | n >= l = empty
- | otherwise = PS x (s+n) (l-n)
-{-# INLINE drop #-}
-
--- | /O(1)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@.
-splitAt :: Int -> ByteString -> (ByteString, ByteString)
-splitAt n ps@(PS x s l)
- | n <= 0 = (empty, ps)
- | n >= l = (ps, empty)
- | otherwise = (PS x s n, PS x (s+n) (l-n))
-{-# INLINE splitAt #-}
-
--- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@,
--- returns the longest prefix (possibly empty) of @xs@ of elements that
--- satisfy @p@.
-takeWhile :: (Word8 -> Bool) -> ByteString -> ByteString
-takeWhile f ps = unsafeTake (findIndexOrEnd (not . f) ps) ps
-{-# INLINE takeWhile #-}
-
--- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@.
-dropWhile :: (Word8 -> Bool) -> ByteString -> ByteString
-dropWhile f ps = unsafeDrop (findIndexOrEnd (not . f) ps) ps
-{-# INLINE dropWhile #-}
-
--- | 'break' @p@ is equivalent to @'span' ('not' . p)@.
-break :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
-break p ps = case findIndexOrEnd p ps of n -> (unsafeTake n ps, unsafeDrop n ps)
-{-# INLINE [1] break #-}
-
-{-# RULES
-"FPS specialise break (x==)" forall x.
- break ((==) x) = breakByte x
- #-}
-
-#if __GLASGOW_HASKELL__ >= 605
-{-# RULES
-"FPS specialise break (==x)" forall x.
- break (==x) = breakByte x
- #-}
-#endif
-
--- | 'breakByte' breaks its ByteString argument at the first occurence
--- of the specified byte. It is more efficient than 'break' as it is
--- implemented with @memchr(3)@. I.e.
---
--- > break (=='c') "abcd" == breakByte 'c' "abcd"
---
-breakByte :: Word8 -> ByteString -> (ByteString, ByteString)
-breakByte c p = case elemIndex c p of
- Nothing -> (p,empty)
- Just n -> (unsafeTake n p, unsafeDrop n p)
-{-# INLINE breakByte #-}
-
--- | 'breakEnd' behaves like 'break' but from the end of the 'ByteString'
---
--- breakEnd p == spanEnd (not.p)
-breakEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
-breakEnd p ps = splitAt (findFromEndUntil p ps) ps
-
--- | 'span' @p xs@ breaks the ByteString into two segments. It is
--- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@
-span :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
-span p ps = break (not . p) ps
-{-# INLINE [1] span #-}
-
--- | 'spanByte' breaks its ByteString argument at the first
--- occurence of a byte other than its argument. It is more efficient
--- than 'span (==)'
---
--- > span (=='c') "abcd" == spanByte 'c' "abcd"
---
-spanByte :: Word8 -> ByteString -> (ByteString, ByteString)
-spanByte c ps@(PS x s l) = inlinePerformIO $ withForeignPtr x $ \p ->
- go (p `plusPtr` s) 0
- where
- STRICT2(go)
- go p i | i >= l = return (ps, empty)
- | otherwise = do c' <- peekByteOff p i
- if c /= c'
- then return (unsafeTake i ps, unsafeDrop i ps)
- else go p (i+1)
-{-# INLINE spanByte #-}
-
-{-# RULES
-"FPS specialise span (x==)" forall x.
- span ((==) x) = spanByte x
- #-}
-
-#if __GLASGOW_HASKELL__ >= 605
-{-# RULES
-"FPS specialise span (==x)" forall x.
- span (==x) = spanByte x
- #-}
-#endif
-
--- | 'spanEnd' behaves like 'span' but from the end of the 'ByteString'.
--- We have
---
--- > spanEnd (not.isSpace) "x y z" == ("x y ","z")
---
--- and
---
--- > spanEnd (not . isSpace) ps
--- > ==
--- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x)
---
-spanEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
-spanEnd p ps = splitAt (findFromEndUntil (not.p) ps) ps
-
--- | /O(n)/ Splits a 'ByteString' into components delimited by
--- separators, where the predicate returns True for a separator element.
--- The resulting components do not contain the separators. Two adjacent
--- separators result in an empty component in the output. eg.
---
--- > splitWith (=='a') "aabbaca" == ["","","bb","c",""]
--- > splitWith (=='a') [] == []
---
-splitWith :: (Word8 -> Bool) -> ByteString -> [ByteString]
-
-#if defined(__GLASGOW_HASKELL__)
-splitWith _pred (PS _ _ 0) = []
-splitWith pred_ (PS fp off len) = splitWith0 pred# off len fp
- where pred# c# = pred_ (W8# c#)
-
- STRICT4(splitWith0)
- splitWith0 pred' off' len' fp' = withPtr fp $ \p ->
- splitLoop pred' p 0 off' len' fp'
-
- splitLoop :: (Word# -> Bool)
- -> Ptr Word8
- -> Int -> Int -> Int
- -> ForeignPtr Word8
- -> IO [ByteString]
-
- splitLoop pred' p idx' off' len' fp'
- | pred' `seq` p `seq` idx' `seq` off' `seq` len' `seq` fp' `seq` False = undefined
- | idx' >= len' = return [PS fp' off' idx']
- | otherwise = do
- w <- peekElemOff p (off'+idx')
- if pred' (case w of W8# w# -> w#)
- then return (PS fp' off' idx' :
- splitWith0 pred' (off'+idx'+1) (len'-idx'-1) fp')
- else splitLoop pred' p (idx'+1) off' len' fp'
-{-# INLINE splitWith #-}
-
-#else
-splitWith _ (PS _ _ 0) = []
-splitWith p ps = loop p ps
- where
- STRICT2(loop)
- loop q qs = if null rest then [chunk]
- else chunk : loop q (unsafeTail rest)
- where (chunk,rest) = break q qs
-#endif
-
--- | /O(n)/ Break a 'ByteString' into pieces separated by the byte
--- argument, consuming the delimiter. I.e.
---
--- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"]
--- > split 'a' "aXaXaXa" == ["","X","X","X",""]
--- > split 'x' "x" == ["",""]
---
--- and
---
--- > join [c] . split c == id
--- > split == splitWith . (==)
---
--- As for all splitting functions in this library, this function does
--- not copy the substrings, it just constructs new 'ByteStrings' that
--- are slices of the original.
---
-split :: Word8 -> ByteString -> [ByteString]
-split _ (PS _ _ 0) = []
-split w (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do
- let ptr = p `plusPtr` s
-
- STRICT1(loop)
- loop n =
- let q = inlinePerformIO $ memchr (ptr `plusPtr` n)
- w (fromIntegral (l-n))
- in if q == nullPtr
- then [PS x (s+n) (l-n)]
- else let i = q `minusPtr` ptr in PS x (s+n) (i-n) : loop (i+1)
-
- return (loop 0)
-{-# INLINE split #-}
-
-{-
--- slower. but stays inside Haskell.
-split _ (PS _ _ 0) = []
-split (W8# w#) (PS fp off len) = splitWith' off len fp
- where
- splitWith' off' len' fp' = withPtr fp $ \p ->
- splitLoop p 0 off' len' fp'
-
- splitLoop :: Ptr Word8
- -> Int -> Int -> Int
- -> ForeignPtr Word8
- -> IO [ByteString]
-
- STRICT5(splitLoop)
- splitLoop p idx' off' len' fp'
- | p `seq` idx' `seq` off' `seq` len' `seq` fp' `seq` False = undefined
- | idx' >= len' = return [PS fp' off' idx']
- | otherwise = do
- (W8# x#) <- peekElemOff p (off'+idx')
- if word2Int# w# ==# word2Int# x#
- then return (PS fp' off' idx' :
- splitWith' (off'+idx'+1) (len'-idx'-1) fp')
- else splitLoop p (idx'+1) off' len' fp'
--}
-
-{-
--- | Like 'splitWith', except that sequences of adjacent separators are
--- treated as a single separator. eg.
---
--- > tokens (=='a') "aabbaca" == ["bb","c"]
---
-tokens :: (Word8 -> Bool) -> ByteString -> [ByteString]
-tokens f = P.filter (not.null) . splitWith f
-{-# INLINE tokens #-}
--}
-
--- | The 'group' function takes a ByteString and returns a list of
--- ByteStrings such that the concatenation of the result is equal to the
--- argument. Moreover, each sublist in the result contains only equal
--- elements. For example,
---
--- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"]
---
--- It is a special case of 'groupBy', which allows the programmer to
--- supply their own equality test. It is about 40% faster than
--- /groupBy (==)/
-group :: ByteString -> [ByteString]
-group xs
- | null xs = []
- | otherwise = ys : group zs
- where
- (ys, zs) = spanByte (unsafeHead xs) xs
-
--- | The 'groupBy' function is the non-overloaded version of 'group'.
-groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString]
-groupBy k xs
- | null xs = []
- | otherwise = unsafeTake n xs : groupBy k (unsafeDrop n xs)
- where
- n = 1 + findIndexOrEnd (not . k (unsafeHead xs)) (unsafeTail xs)
-
--- | /O(n)/ The 'join' function takes a 'ByteString' and a list of
--- 'ByteString's and concatenates the list after interspersing the first
--- argument between each element of the list.
-join :: ByteString -> [ByteString] -> ByteString
-join s = concat . (List.intersperse s)
-{-# INLINE [1] join #-}
-
-{-# RULES
-"FPS specialise join c -> joinByte" forall c s1 s2 .
- join (singleton c) (s1 : s2 : []) = joinWithByte c s1 s2
- #-}
-
---
--- | /O(n)/ joinWithByte. An efficient way to join to two ByteStrings
--- with a char. Around 4 times faster than the generalised join.
---
-joinWithByte :: Word8 -> ByteString -> ByteString -> ByteString
-joinWithByte c f@(PS ffp s l) g@(PS fgp t m) = unsafeCreate len $ \ptr ->
- withForeignPtr ffp $ \fp ->
- withForeignPtr fgp $ \gp -> do
- memcpy ptr (fp `plusPtr` s) (fromIntegral l)
- poke (ptr `plusPtr` l) c
- memcpy (ptr `plusPtr` (l + 1)) (gp `plusPtr` t) (fromIntegral m)
- where
- len = length f + length g + 1
-{-# INLINE joinWithByte #-}
-
--- ---------------------------------------------------------------------
--- Indexing ByteStrings
-
--- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0.
-index :: ByteString -> Int -> Word8
-index ps n
- | n < 0 = moduleError "index" ("negative index: " ++ show n)
- | n >= length ps = moduleError "index" ("index too large: " ++ show n
- ++ ", length = " ++ show (length ps))
- | otherwise = ps `unsafeIndex` n
-{-# INLINE index #-}
-
--- | /O(n)/ The 'elemIndex' function returns the index of the first
--- element in the given 'ByteString' which is equal to the query
--- element, or 'Nothing' if there is no such element.
--- This implementation uses memchr(3).
-elemIndex :: Word8 -> ByteString -> Maybe Int
-elemIndex c (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do
- let p' = p `plusPtr` s
- q <- memchr p' c (fromIntegral l)
- return $! if q == nullPtr then Nothing else Just $! q `minusPtr` p'
-{-# INLINE elemIndex #-}
-
--- | /O(n)/ The 'elemIndexEnd' function returns the last index of the
--- element in the given 'ByteString' which is equal to the query
--- element, or 'Nothing' if there is no such element. The following
--- holds:
---
--- > elemIndexEnd c xs ==
--- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs)
---
-elemIndexEnd :: Word8 -> ByteString -> Maybe Int
-elemIndexEnd ch (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p ->
- go (p `plusPtr` s) (l-1)
- where
- STRICT2(go)
- go p i | i < 0 = return Nothing
- | otherwise = do ch' <- peekByteOff p i
- if ch == ch'
- then return $ Just i
- else go p (i-1)
-{-# INLINE elemIndexEnd #-}
-
--- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning
--- the indices of all elements equal to the query element, in ascending order.
--- This implementation uses memchr(3).
-elemIndices :: Word8 -> ByteString -> [Int]
-elemIndices w (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do
- let ptr = p `plusPtr` s
-
- STRICT1(loop)
- loop n = let q = inlinePerformIO $ memchr (ptr `plusPtr` n)
- w (fromIntegral (l - n))
- in if q == nullPtr
- then []
- else let i = q `minusPtr` ptr
- in i : loop (i+1)
- return $! loop 0
-{-# INLINE elemIndices #-}
-
-{-
--- much slower
-elemIndices :: Word8 -> ByteString -> [Int]
-elemIndices c ps = loop 0 ps
- where STRICT2(loop)
- loop _ ps' | null ps' = []
- loop n ps' | c == unsafeHead ps' = n : loop (n+1) (unsafeTail ps')
- | otherwise = loop (n+1) (unsafeTail ps')
--}
-
--- | count returns the number of times its argument appears in the ByteString
---
--- > count = length . elemIndices
---
--- But more efficiently than using length on the intermediate list.
-count :: Word8 -> ByteString -> Int
-count w (PS x s m) = inlinePerformIO $ withForeignPtr x $ \p ->
- fmap fromIntegral $ c_count (p `plusPtr` s) (fromIntegral m) w
-{-# INLINE count #-}
-
-{-
---
--- around 30% slower
---
-count w (PS x s m) = inlinePerformIO $ withForeignPtr x $ \p ->
- go (p `plusPtr` s) (fromIntegral m) 0
- where
- go :: Ptr Word8 -> CSize -> Int -> IO Int
- STRICT3(go)
- go p l i = do
- q <- memchr p w l
- if q == nullPtr
- then return i
- else do let k = fromIntegral $ q `minusPtr` p
- go (q `plusPtr` 1) (l-k-1) (i+1)
--}
-
--- | The 'findIndex' function takes a predicate and a 'ByteString' and
--- returns the index of the first element in the ByteString
--- satisfying the predicate.
-findIndex :: (Word8 -> Bool) -> ByteString -> Maybe Int
-findIndex k (PS x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0
- where
- STRICT2(go)
- go ptr n | n >= l = return Nothing
- | otherwise = do w <- peek ptr
- if k w
- then return (Just n)
- else go (ptr `plusPtr` 1) (n+1)
-{-# INLINE findIndex #-}
-
--- | The 'findIndices' function extends 'findIndex', by returning the
--- indices of all elements satisfying the predicate, in ascending order.
-findIndices :: (Word8 -> Bool) -> ByteString -> [Int]
-findIndices p ps = loop 0 ps
- where
- STRICT2(loop)
- loop n qs | null qs = []
- | p (unsafeHead qs) = n : loop (n+1) (unsafeTail qs)
- | otherwise = loop (n+1) (unsafeTail qs)
-
--- ---------------------------------------------------------------------
--- Searching ByteStrings
-
--- | /O(n)/ 'elem' is the 'ByteString' membership predicate.
-elem :: Word8 -> ByteString -> Bool
-elem c ps = case elemIndex c ps of Nothing -> False ; _ -> True
-{-# INLINE elem #-}
-
--- | /O(n)/ 'notElem' is the inverse of 'elem'
-notElem :: Word8 -> ByteString -> Bool
-notElem c ps = not (elem c ps)
-{-# INLINE notElem #-}
-
--- | /O(n)/ 'filter', applied to a predicate and a ByteString,
--- returns a ByteString containing those characters that satisfy the
--- predicate. This function is subject to array fusion.
-filter :: (Word8 -> Bool) -> ByteString -> ByteString
-#if defined(LOOPU_FUSION)
-filter p = loopArr . loopU (filterEFL p) NoAcc
-#elif defined(LOOPUP_FUSION)
-filter p = loopArr . loopUp (filterEFL p) NoAcc
-#elif defined(LOOPNOACC_FUSION)
-filter p = loopArr . loopNoAcc (filterEFL p)
-#else
-filter f = loopArr . loopFilter f
-#endif
-{-# INLINE filter #-}
-
-{-
--- | /O(n)/ 'filter\'' is a non-fuseable version of filter, that may be
--- around 2x faster for some one-shot applications.
-filter' :: (Word8 -> Bool) -> ByteString -> ByteString
-filter' k ps@(PS x s l)
- | null ps = ps
- | otherwise = unsafePerformIO $ createAndTrim l $ \p -> withForeignPtr x $ \f -> do
- t <- go (f `plusPtr` s) p (f `plusPtr` (s + l))
- return $! t `minusPtr` p -- actual length
- where
- STRICT3(go)
- go f t end | f == end = return t
- | otherwise = do
- w <- peek f
- if k w
- then poke t w >> go (f `plusPtr` 1) (t `plusPtr` 1) end
- else go (f `plusPtr` 1) t end
-{-# INLINE filter' #-}
--}
-
---
--- | /O(n)/ A first order equivalent of /filter . (==)/, for the common
--- case of filtering a single byte. It is more efficient to use
--- /filterByte/ in this case.
---
--- > filterByte == filter . (==)
---
--- filterByte is around 10x faster, and uses much less space, than its
--- filter equivalent
-filterByte :: Word8 -> ByteString -> ByteString
-filterByte w ps = replicate (count w ps) w
-{-# INLINE filterByte #-}
-
-{-# RULES
- "FPS specialise filter (== x)" forall x.
- filter ((==) x) = filterByte x
- #-}
-
-#if __GLASGOW_HASKELL__ >= 605
-{-# RULES
- "FPS specialise filter (== x)" forall x.
- filter (== x) = filterByte x
- #-}
-#endif
-
---
--- | /O(n)/ A first order equivalent of /filter . (\/=)/, for the common
--- case of filtering a single byte out of a list. It is more efficient
--- to use /filterNotByte/ in this case.
---
--- > filterNotByte == filter . (/=)
---
--- filterNotByte is around 2x faster than its filter equivalent.
-filterNotByte :: Word8 -> ByteString -> ByteString
-filterNotByte w = filter (/= w)
-{-# INLINE filterNotByte #-}
-
-{-# RULES
-"FPS specialise filter (x /=)" forall x.
- filter ((/=) x) = filterNotByte x
- #-}
-
-#if __GLASGOW_HASKELL__ >= 605
-{-# RULES
-"FPS specialise filter (/= x)" forall x.
- filter (/= x) = filterNotByte x
- #-}
-#endif
-
--- | /O(n)/ The 'find' function takes a predicate and a ByteString,
--- and returns the first element in matching the predicate, or 'Nothing'
--- if there is no such element.
---
--- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing
---
-find :: (Word8 -> Bool) -> ByteString -> Maybe Word8
-find f p = case findIndex f p of
- Just n -> Just (p `unsafeIndex` n)
- _ -> Nothing
-{-# INLINE find #-}
-
-{-
---
--- fuseable, but we don't want to walk the whole array.
---
-find k = foldl findEFL Nothing
- where findEFL a@(Just _) _ = a
- findEFL _ c | k c = Just c
- | otherwise = Nothing
--}
-
--- ---------------------------------------------------------------------
--- Searching for substrings
-
--- | /O(n)/ The 'isPrefixOf' function takes two ByteStrings and returns 'True'
--- iff the first is a prefix of the second.
-isPrefixOf :: ByteString -> ByteString -> Bool
-isPrefixOf (PS x1 s1 l1) (PS x2 s2 l2)
- | l1 == 0 = True
- | l2 < l1 = False
- | otherwise = inlinePerformIO $ withForeignPtr x1 $ \p1 ->
- withForeignPtr x2 $ \p2 -> do
- i <- memcmp (p1 `plusPtr` s1) (p2 `plusPtr` s2) (fromIntegral l1)
- return $! i == 0
-
--- | /O(n)/ The 'isSuffixOf' function takes two ByteStrings and returns 'True'
--- iff the first is a suffix of the second.
---
--- The following holds:
---
--- > isSuffixOf x y == reverse x `isPrefixOf` reverse y
---
--- However, the real implemenation uses memcmp to compare the end of the
--- string only, with no reverse required..
-isSuffixOf :: ByteString -> ByteString -> Bool
-isSuffixOf (PS x1 s1 l1) (PS x2 s2 l2)
- | l1 == 0 = True
- | l2 < l1 = False
- | otherwise = inlinePerformIO $ withForeignPtr x1 $ \p1 ->
- withForeignPtr x2 $ \p2 -> do
- i <- memcmp (p1 `plusPtr` s1) (p2 `plusPtr` s2 `plusPtr` (l2 - l1)) (fromIntegral l1)
- return $! i == 0
-
--- | Check whether one string is a substring of another. @isSubstringOf
--- p s@ is equivalent to @not (null (findSubstrings p s))@.
-isSubstringOf :: ByteString -- ^ String to search for.
- -> ByteString -- ^ String to search in.
- -> Bool
-isSubstringOf p s = not $ P.null $ findSubstrings p s
-
--- | Get the first index of a substring in another string,
--- or 'Nothing' if the string is not found.
--- @findSubstring p s@ is equivalent to @listToMaybe (findSubstrings p s)@.
-findSubstring :: ByteString -- ^ String to search for.
- -> ByteString -- ^ String to seach in.
- -> Maybe Int
-findSubstring = (listToMaybe .) . findSubstrings
-
--- | Find the indexes of all (possibly overlapping) occurances of a
--- substring in a string. This function uses the Knuth-Morris-Pratt
--- string matching algorithm.
-findSubstrings :: ByteString -- ^ String to search for.
- -> ByteString -- ^ String to seach in.
- -> [Int]
-
-findSubstrings pat@(PS _ _ m) str@(PS _ _ n) = search 0 0
- where
- patc x = pat `unsafeIndex` x
- strc x = str `unsafeIndex` x
-
- -- maybe we should make kmpNext a UArray before using it in search?
- kmpNext = listArray (0,m) (-1:kmpNextL pat (-1))
- kmpNextL p _ | null p = []
- kmpNextL p j = let j' = next (unsafeHead p) j + 1
- ps = unsafeTail p
- x = if not (null ps) && unsafeHead ps == patc j'
- then kmpNext Array.! j' else j'
- in x:kmpNextL ps j'
- search i j = match ++ rest -- i: position in string, j: position in pattern
- where match = if j == m then [(i - j)] else []
- rest = if i == n then [] else search (i+1) (next (strc i) j + 1)
- next c j | j >= 0 && (j == m || c /= patc j) = next c (kmpNext Array.! j)
- | otherwise = j
-
--- ---------------------------------------------------------------------
--- Zipping
-
--- | /O(n)/ 'zip' takes two ByteStrings and returns a list of
--- corresponding pairs of bytes. If one input ByteString is short,
--- excess elements of the longer ByteString are discarded. This is
--- equivalent to a pair of 'unpack' operations.
-zip :: ByteString -> ByteString -> [(Word8,Word8)]
-zip ps qs
- | null ps || null qs = []
- | otherwise = (unsafeHead ps, unsafeHead qs) : zip (unsafeTail ps) (unsafeTail qs)
-
--- | 'zipWith' generalises 'zip' by zipping with the function given as
--- the first argument, instead of a tupling function. For example,
--- @'zipWith' (+)@ is applied to two ByteStrings to produce the list of
--- corresponding sums.
-zipWith :: (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a]
-zipWith f ps qs
- | null ps || null qs = []
- | otherwise = f (unsafeHead ps) (unsafeHead qs) : zipWith f (unsafeTail ps) (unsafeTail qs)
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] zipWith #-}
-#endif
-
---
--- | A specialised version of zipWith for the common case of a
--- simultaneous map over two bytestrings, to build a 3rd. Rewrite rules
--- are used to automatically covert zipWith into zipWith' when a pack is
--- performed on the result of zipWith, but we also export it for
--- convenience.
---
-zipWith' :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> ByteString
-zipWith' f (PS fp s l) (PS fq t m) = inlinePerformIO $
- withForeignPtr fp $ \a ->
- withForeignPtr fq $ \b ->
- create len $ zipWith_ 0 (a `plusPtr` s) (b `plusPtr` t)
- where
- zipWith_ :: Int -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO ()
- STRICT4(zipWith_)
- zipWith_ n p1 p2 r
- | n >= len = return ()
- | otherwise = do
- x <- peekByteOff p1 n
- y <- peekByteOff p2 n
- pokeByteOff r n (f x y)
- zipWith_ (n+1) p1 p2 r
-
- len = min l m
-{-# INLINE zipWith' #-}
-
-{-# RULES
-
-"FPS specialise zipWith" forall (f :: Word8 -> Word8 -> Word8) p q .
- zipWith f p q = unpack (zipWith' f p q)
-
- #-}
-
--- | /O(n)/ 'unzip' transforms a list of pairs of bytes into a pair of
--- ByteStrings. Note that this performs two 'pack' operations.
-unzip :: [(Word8,Word8)] -> (ByteString,ByteString)
-unzip ls = (pack (P.map fst ls), pack (P.map snd ls))
-{-# INLINE unzip #-}
-
--- ---------------------------------------------------------------------
--- Special lists
-
--- | /O(n)/ Return all initial segments of the given 'ByteString', shortest first.
-inits :: ByteString -> [ByteString]
-inits (PS x s l) = [PS x s n | n <- [0..l]]
-
--- | /O(n)/ Return all final segments of the given 'ByteString', longest first.
-tails :: ByteString -> [ByteString]
-tails p | null p = [empty]
- | otherwise = p : tails (unsafeTail p)
-
--- less efficent spacewise: tails (PS x s l) = [PS x (s+n) (l-n) | n <- [0..l]]
-
--- ---------------------------------------------------------------------
--- ** Ordered 'ByteString's
-
--- | /O(n)/ Sort a ByteString efficiently, using counting sort.
-sort :: ByteString -> ByteString
-sort (PS input s l) = unsafeCreate l $ \p -> allocaArray 256 $ \arr -> do
-
- memset (castPtr arr) 0 (256 * fromIntegral (sizeOf (undefined :: CSize)))
- withForeignPtr input (\x -> countOccurrences arr (x `plusPtr` s) l)
-
- let STRICT2(go)
- go 256 _ = return ()
- go i ptr = do n <- peekElemOff arr i
- when (n /= 0) $ memset ptr (fromIntegral i) n >> return ()
- go (i + 1) (ptr `plusPtr` (fromIntegral n))
- go 0 p
-
-{-
-sort :: ByteString -> ByteString
-sort (PS x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f -> do
- memcpy p (f `plusPtr` s) l
- c_qsort p l -- inplace
--}
-
--- | The 'sortBy' function is the non-overloaded version of 'sort'.
---
--- Try some linear sorts: radix, counting
--- Or mergesort.
---
--- sortBy :: (Word8 -> Word8 -> Ordering) -> ByteString -> ByteString
--- sortBy f ps = undefined
-
--- ---------------------------------------------------------------------
--- Low level constructors
-
--- | /O(n)/ Build a @ByteString@ from a @CString@. This value will have /no/
--- finalizer associated to it. The ByteString length is calculated using
--- /strlen(3)/, and thus the complexity is a /O(n)/.
-packCString :: CString -> ByteString
-packCString cstr = unsafePerformIO $ do
- fp <- newForeignPtr_ (castPtr cstr)
- l <- c_strlen cstr
- return $! PS fp 0 (fromIntegral l)
-
--- | /O(1)/ Build a @ByteString@ from a @CStringLen@. This value will
--- have /no/ finalizer associated with it. This operation has /O(1)/
--- complexity as we already know the final size, so no /strlen(3)/ is
--- required.
-packCStringLen :: CStringLen -> ByteString
-packCStringLen (ptr,len) = unsafePerformIO $ do
- fp <- newForeignPtr_ (castPtr ptr)
- return $! PS fp 0 (fromIntegral len)
-
--- | /O(n)/ Build a @ByteString@ from a malloced @CString@. This value will
--- have a @free(3)@ finalizer associated to it.
-packMallocCString :: CString -> ByteString
-packMallocCString cstr = unsafePerformIO $ do
- fp <- newForeignFreePtr (castPtr cstr)
- len <- c_strlen cstr
- return $! PS fp 0 (fromIntegral len)
-
--- | /O(n) construction/ Use a @ByteString@ with a function requiring a
--- null-terminated @CString@. The @CString@ will be freed
--- automatically. This is a memcpy(3).
-useAsCString :: ByteString -> (CString -> IO a) -> IO a
-useAsCString (PS ps s l) = bracket alloc (c_free.castPtr)
- where alloc = withForeignPtr ps $ \p -> do
- buf <- c_malloc (fromIntegral l+1)
- memcpy (castPtr buf) (castPtr p `plusPtr` s) (fromIntegral l)
- poke (buf `plusPtr` l) (0::Word8) -- n.b.
- return (castPtr buf)
-
--- | /O(1) construction/ Use a @ByteString@ with a function requiring a @CStringLen@.
-useAsCStringLen :: ByteString -> (CStringLen -> IO a) -> IO a
-useAsCStringLen = unsafeUseAsCStringLen
-
---
--- why were we doing this?
---
--- useAsCStringLen :: ByteString -> (CStringLen -> IO a) -> IO a
--- useAsCStringLen (PS ps s l) = bracket alloc (c_free.castPtr.fst)
--- where
--- alloc = withForeignPtr ps $ \p -> do
--- buf <- c_malloc (fromIntegral l+1)
--- memcpy (castPtr buf) (castPtr p `plusPtr` s) (fromIntegral l)
--- poke (buf `plusPtr` l) (0::Word8) -- n.b.
--- return $! (castPtr buf, l)
---
-
--- | /O(n)/ Make a copy of the 'ByteString' with its own storage.
--- This is mainly useful to allow the rest of the data pointed
--- to by the 'ByteString' to be garbage collected, for example
--- if a large string has been read in, and only a small part of it
--- is needed in the rest of the program.
-copy :: ByteString -> ByteString
-copy (PS x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f ->
- memcpy p (f `plusPtr` s) (fromIntegral l)
-
--- | /O(n)/ Duplicate a CString as a ByteString. Useful if you know the
--- CString is going to be deallocated from C land.
-copyCString :: CString -> IO ByteString
-copyCString cstr = do
- len <- c_strlen cstr
- copyCStringLen (cstr, fromIntegral len)
-
--- | /O(n)/ Same as copyCString, but saves a strlen call when the length is known.
-copyCStringLen :: CStringLen -> IO ByteString
-copyCStringLen (cstr, len) = create len $ \p ->
- memcpy p (castPtr cstr) (fromIntegral len)
-
--- ---------------------------------------------------------------------
--- line IO
-
--- | Read a line from stdin.
-getLine :: IO ByteString
-getLine = hGetLine stdin
-
-{-
--- | Lazily construct a list of lines of ByteStrings. This will be much
--- better on memory consumption than using 'hGetContents >>= lines'
--- If you're considering this, a better choice might be to use
--- Data.ByteString.Lazy
-hGetLines :: Handle -> IO [ByteString]
-hGetLines h = go
- where
- go = unsafeInterleaveIO $ do
- e <- hIsEOF h
- if e
- then return []
- else do
- x <- hGetLine h
- xs <- go
- return (x:xs)
--}
-
--- | Read a line from a handle
-
-hGetLine :: Handle -> IO ByteString
-#if !defined(__GLASGOW_HASKELL__)
-hGetLine h = System.IO.hGetLine h >>= return . pack . P.map c2w
-#else
-hGetLine h = wantReadableHandle "Data.ByteString.hGetLine" h $ \ handle_ -> do
- case haBufferMode handle_ of
- NoBuffering -> error "no buffering"
- _other -> hGetLineBuffered handle_
-
- where
- hGetLineBuffered handle_ = do
- let ref = haBuffer handle_
- buf <- readIORef ref
- hGetLineBufferedLoop handle_ ref buf 0 []
-
- hGetLineBufferedLoop handle_ ref
- buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } len xss =
- len `seq` do
- off <- findEOL r w raw
- let new_len = len + off - r
- xs <- mkPS raw r off
-
- -- if eol == True, then off is the offset of the '\n'
- -- otherwise off == w and the buffer is now empty.
- if off /= w
- then do if (w == off + 1)
- then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
- else writeIORef ref buf{ bufRPtr = off + 1 }
- mkBigPS new_len (xs:xss)
- else do
- maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
- buf{ bufWPtr=0, bufRPtr=0 }
- case maybe_buf of
- -- Nothing indicates we caught an EOF, and we may have a
- -- partial line to return.
- Nothing -> do
- writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
- if new_len > 0
- then mkBigPS new_len (xs:xss)
- else ioe_EOF
- Just new_buf ->
- hGetLineBufferedLoop handle_ ref new_buf new_len (xs:xss)
-
- -- find the end-of-line character, if there is one
- findEOL r w raw
- | r == w = return w
- | otherwise = do
- (c,r') <- readCharFromBuffer raw r
- if c == '\n'
- then return r -- NB. not r': don't include the '\n'
- else findEOL r' w raw
-
- maybeFillReadBuffer fd is_line is_stream buf = catch
- (do buf' <- fillReadBuffer fd is_line is_stream buf
- return (Just buf'))
- (\e -> if isEOFError e then return Nothing else ioError e)
-
--- TODO, rewrite to use normal memcpy
-mkPS :: RawBuffer -> Int -> Int -> IO ByteString
-mkPS buf start end =
- let len = end - start
- in create len $ \p -> do
- memcpy_ptr_baoff p buf (fromIntegral start) (fromIntegral len)
- return ()
-
-mkBigPS :: Int -> [ByteString] -> IO ByteString
-mkBigPS _ [ps] = return ps
-mkBigPS _ pss = return $! concat (P.reverse pss)
-
-#endif
-
--- ---------------------------------------------------------------------
--- Block IO
-
--- | Outputs a 'ByteString' to the specified 'Handle'.
-hPut :: Handle -> ByteString -> IO ()
-hPut _ (PS _ _ 0) = return ()
-hPut h (PS ps s l) = withForeignPtr ps $ \p-> hPutBuf h (p `plusPtr` s) l
-
--- | A synonym for @hPut@, for compatibility
-hPutStr :: Handle -> ByteString -> IO ()
-hPutStr = hPut
-
--- | Write a ByteString to a handle, appending a newline byte
-hPutStrLn :: Handle -> ByteString -> IO ()
-hPutStrLn h ps
- | length ps < 1024 = hPut h (ps `snoc` 0x0a)
- | otherwise = hPut h ps >> hPut h (singleton (0x0a)) -- don't copy
-
--- | Write a ByteString to stdout
-putStr :: ByteString -> IO ()
-putStr = hPut stdout
-
--- | Write a ByteString to stdout, appending a newline byte
-putStrLn :: ByteString -> IO ()
-putStrLn = hPutStrLn stdout
-
--- | Read a 'ByteString' directly from the specified 'Handle'. This
--- is far more efficient than reading the characters into a 'String'
--- and then using 'pack'.
-hGet :: Handle -> Int -> IO ByteString
-hGet _ 0 = return empty
-hGet h i = createAndTrim i $ \p -> hGetBuf h p i
-
--- | hGetNonBlocking is identical to 'hGet', except that it will never block
--- waiting for data to become available, instead it returns only whatever data
--- is available.
-hGetNonBlocking :: Handle -> Int -> IO ByteString
-#if defined(__GLASGOW_HASKELL__)
-hGetNonBlocking _ 0 = return empty
-hGetNonBlocking h i = createAndTrim i $ \p -> hGetBufNonBlocking h p i
-#else
-hGetNonBlocking = hGet
-#endif
-
--- | Read entire handle contents into a 'ByteString'.
--- This function reads chunks at a time, doubling the chunksize on each
--- read. The final buffer is then realloced to the appropriate size. For
--- files > half of available memory, this may lead to memory exhaustion.
--- Consider using 'readFile' in this case.
---
--- As with 'hGet', the string representation in the file is assumed to
--- be ISO-8859-1.
---
-hGetContents :: Handle -> IO ByteString
-hGetContents h = do
- let start_size = 1024
- p <- mallocArray start_size
- i <- hGetBuf h p start_size
- if i < start_size
- then do p' <- reallocArray p i
- fp <- newForeignFreePtr p'
- return $! PS fp 0 i
- else f p start_size
- where
- f p s = do
- let s' = 2 * s
- p' <- reallocArray p s'
- i <- hGetBuf h (p' `plusPtr` s) s
- if i < s
- then do let i' = s + i
- p'' <- reallocArray p' i'
- fp <- newForeignFreePtr p''
- return $! PS fp 0 i'
- else f p' s'
-
--- | getContents. Equivalent to hGetContents stdin
-getContents :: IO ByteString
-getContents = hGetContents stdin
-
--- | The interact function takes a function of type @ByteString -> ByteString@
--- as its argument. The entire input from the standard input device is passed
--- to this function as its argument, and the resulting string is output on the
--- standard output device. It's great for writing one line programs!
-interact :: (ByteString -> ByteString) -> IO ()
-interact transformer = putStr . transformer =<< getContents
-
--- | Read an entire file strictly into a 'ByteString'. This is far more
--- efficient than reading the characters into a 'String' and then using
--- 'pack'. It also may be more efficient than opening the file and
--- reading it using hGet. Files are read using 'binary mode' on Windows,
--- for 'text mode' use the Char8 version of this function.
-readFile :: FilePath -> IO ByteString
-readFile f = bracket (openBinaryFile f ReadMode) hClose
- (\h -> hFileSize h >>= hGet h . fromIntegral)
-
--- | Write a 'ByteString' to a file.
-writeFile :: FilePath -> ByteString -> IO ()
-writeFile f txt = bracket (openBinaryFile f WriteMode) hClose
- (\h -> hPut h txt)
-
--- | Append a 'ByteString' to a file.
-appendFile :: FilePath -> ByteString -> IO ()
-appendFile f txt = bracket (openBinaryFile f AppendMode) hClose
- (\h -> hPut h txt)
-
-{-
---
--- Disable until we can move it into a portable .hsc file
---
-
--- | Like readFile, this reads an entire file directly into a
--- 'ByteString', but it is even more efficient. It involves directly
--- mapping the file to memory. This has the advantage that the contents
--- of the file never need to be copied. Also, under memory pressure the
--- page may simply be discarded, while in the case of readFile it would
--- need to be written to swap. If you read many small files, mmapFile
--- will be less memory-efficient than readFile, since each mmapFile
--- takes up a separate page of memory. Also, you can run into bus
--- errors if the file is modified. As with 'readFile', the string
--- representation in the file is assumed to be ISO-8859-1.
---
--- On systems without mmap, this is the same as a readFile.
---
-mmapFile :: FilePath -> IO ByteString
-mmapFile f = mmap f >>= \(fp,l) -> return $! PS fp 0 l
-
-mmap :: FilePath -> IO (ForeignPtr Word8, Int)
-mmap f = do
- h <- openBinaryFile f ReadMode
- l <- fromIntegral `fmap` hFileSize h
- -- Don't bother mmaping small files because each mmapped file takes up
- -- at least one full VM block.
- if l < mmap_limit
- then do thefp <- mallocByteString l
- withForeignPtr thefp $ \p-> hGetBuf h p l
- hClose h
- return (thefp, l)
- else do
- -- unix only :(
- fd <- fromIntegral `fmap` handleToFd h
- p <- my_mmap l fd
- fp <- if p == nullPtr
- then do thefp <- mallocByteString l
- withForeignPtr thefp $ \p' -> hGetBuf h p' l
- return thefp
- else do
- -- The munmap leads to crashes on OpenBSD.
- -- maybe there's a use after unmap in there somewhere?
- -- Bulat suggests adding the hClose to the
- -- finalizer, excellent idea.
-#if !defined(__OpenBSD__)
- let unmap = c_munmap p l >> return ()
-#else
- let unmap = return ()
-#endif
- fp <- newForeignPtr p unmap
- return fp
- c_close fd
- hClose h
- return (fp, l)
- where mmap_limit = 16*1024
--}
-
--- ---------------------------------------------------------------------
--- Internal utilities
-
--- | 'findIndexOrEnd' is a variant of findIndex, that returns the length
--- of the string if no element is found, rather than Nothing.
-findIndexOrEnd :: (Word8 -> Bool) -> ByteString -> Int
-findIndexOrEnd k (PS x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0
- where
- STRICT2(go)
- go ptr n | n >= l = return l
- | otherwise = do w <- peek ptr
- if k w
- then return n
- else go (ptr `plusPtr` 1) (n+1)
-{-# INLINE findIndexOrEnd #-}
-
--- | Perform an operation with a temporary ByteString
-withPtr :: ForeignPtr a -> (Ptr a -> IO b) -> b
-withPtr fp io = inlinePerformIO (withForeignPtr fp io)
-{-# INLINE withPtr #-}
-
--- Common up near identical calls to `error' to reduce the number
--- constant strings created when compiled:
-errorEmptyList :: String -> a
-errorEmptyList fun = moduleError fun "empty ByteString"
-{-# NOINLINE errorEmptyList #-}
-
-moduleError :: String -> String -> a
-moduleError fun msg = error ("Data.ByteString." ++ fun ++ ':':' ':msg)
-{-# NOINLINE moduleError #-}
-
--- Find from the end of the string using predicate
-findFromEndUntil :: (Word8 -> Bool) -> ByteString -> Int
-STRICT2(findFromEndUntil)
-findFromEndUntil f ps@(PS x s l) =
- if null ps then 0
- else if f (last ps) then l
- else findFromEndUntil f (PS x s (l-1))
-
-{-# INLINE newForeignFreePtr #-}
-newForeignFreePtr :: Ptr Word8 -> IO (ForeignPtr Word8)
-newForeignFreePtr p = newForeignPtr c_free_finalizer p
+++ /dev/null
-{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
--- |
--- Module : Data.ByteString.Base
--- License : BSD-style
--- Maintainer : dons@cse.unsw.edu.au
--- Stability : experimental
--- Portability : portable
---
--- A module containing semi-public 'ByteString' internals. This exposes
--- the 'ByteString' representation and low level construction functions.
--- Modules which extend the 'ByteString' system will need to use this module
--- while ideally most users will be able to make do with the public interface
--- modules.
---
-module Data.ByteString.Base (
-
- -- * The @ByteString@ type and representation
- ByteString(..), -- instances: Eq, Ord, Show, Read, Data, Typeable
- LazyByteString(..), -- instances: Eq, Ord, Show, Read, Data, Typeable
-
- -- * Unchecked access
- unsafeHead, -- :: ByteString -> Word8
- unsafeTail, -- :: ByteString -> ByteString
- unsafeIndex, -- :: ByteString -> Int -> Word8
- unsafeTake, -- :: Int -> ByteString -> ByteString
- unsafeDrop, -- :: Int -> ByteString -> ByteString
-
- -- * Low level introduction and elimination
- empty, -- :: ByteString
- create, -- :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString
- createAndTrim, -- :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString
- createAndTrim', -- :: Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a)
- mallocByteString, -- :: Int -> IO (ForeignPtr a)
-
- unsafeCreate, -- :: Int -> (Ptr Word8 -> IO ()) -> ByteString
- unsafeUseAsCString, -- :: ByteString -> (CString -> IO a) -> IO a
- unsafeUseAsCStringLen, -- :: ByteString -> (CStringLen -> IO a) -> IO a
-
- fromForeignPtr, -- :: ForeignPtr Word8 -> Int -> ByteString
- toForeignPtr, -- :: ByteString -> (ForeignPtr Word8, Int, Int)
-
-#if defined(__GLASGOW_HASKELL__)
- packCStringFinalizer, -- :: Ptr Word8 -> Int -> IO () -> IO ByteString
- packAddress, -- :: Addr# -> ByteString
- unsafePackAddress, -- :: Int -> Addr# -> ByteString
- unsafeFinalize, -- :: ByteString -> IO ()
-#endif
-
- -- * Utilities
- inlinePerformIO, -- :: IO a -> a
- nullForeignPtr, -- :: ForeignPtr Word8
-
- countOccurrences, -- :: (Storable a, Num a) => Ptr a -> Ptr Word8 -> Int -> IO ()
-
- -- * Standard C Functions
- c_strlen, -- :: CString -> IO CInt
- c_malloc, -- :: CInt -> IO (Ptr Word8)
- c_free, -- :: Ptr Word8 -> IO ()
- c_free_finalizer, -- :: FunPtr (Ptr Word8 -> IO ())
-
- memchr, -- :: Ptr Word8 -> Word8 -> CSize -> IO Ptr Word8
- memcmp, -- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt
- memcpy, -- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO ()
- memmove, -- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO ()
- memset, -- :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
-
- -- * cbits functions
- c_reverse, -- :: Ptr Word8 -> Ptr Word8 -> CInt -> IO ()
- c_intersperse, -- :: Ptr Word8 -> Ptr Word8 -> CInt -> Word8 -> IO ()
- c_maximum, -- :: Ptr Word8 -> CInt -> IO Word8
- c_minimum, -- :: Ptr Word8 -> CInt -> IO Word8
- c_count, -- :: Ptr Word8 -> CInt -> Word8 -> IO CInt
-
- -- * Internal GHC magic
-#if defined(__GLASGOW_HASKELL__)
- memcpy_ptr_baoff, -- :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
-#endif
-
- -- * Chars
- w2c, c2w, isSpaceWord8
-
- ) where
-
-import Foreign.ForeignPtr (ForeignPtr, newForeignPtr_, withForeignPtr)
-import Foreign.Ptr (Ptr, FunPtr, plusPtr, castPtr)
-import Foreign.Storable (Storable(..))
-import Foreign.C.Types (CInt, CSize, CULong)
-import Foreign.C.String (CString, CStringLen)
-
-import Control.Exception (assert)
-
-import Data.Char (ord)
-import Data.Word (Word8)
-
-#if defined(__GLASGOW_HASKELL__)
-import qualified Foreign.ForeignPtr as FC (finalizeForeignPtr)
-import qualified Foreign.Concurrent as FC (newForeignPtr)
-
-import Data.Generics (Data(..), Typeable(..))
-import GHC.Prim (Addr#)
-import GHC.Ptr (Ptr(..))
-import GHC.Base (realWorld#,unsafeChr)
-import GHC.IOBase (IO(IO), unsafePerformIO, RawBuffer)
-#else
-import Data.Char (chr)
-import System.IO.Unsafe (unsafePerformIO)
-#endif
-
-#if __GLASGOW_HASKELL__ >= 605 && !defined(SLOW_FOREIGN_PTR)
-import GHC.ForeignPtr (mallocPlainForeignPtrBytes)
-#else
-import Foreign.ForeignPtr (mallocForeignPtrBytes)
-#endif
-
-#if __GLASGOW_HASKELL__>=605
-import GHC.ForeignPtr (ForeignPtr(ForeignPtr))
-import GHC.Base (nullAddr#)
-#else
-import Foreign.Ptr (nullPtr)
-#endif
-
--- CFILES stuff is Hugs only
-{-# CFILES cbits/fpstring.c #-}
-
--- -----------------------------------------------------------------------------
---
--- Useful macros, until we have bang patterns
---
-
-#define STRICT1(f) f a | a `seq` False = undefined
-#define STRICT2(f) f a b | a `seq` b `seq` False = undefined
-#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
-#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined
-#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined
-
--- -----------------------------------------------------------------------------
-
--- | A space-efficient representation of a Word8 vector, supporting many
--- efficient operations. A 'ByteString' contains 8-bit characters only.
---
--- Instances of Eq, Ord, Read, Show, Data, Typeable
---
-data ByteString = PS {-# UNPACK #-} !(ForeignPtr Word8)
- {-# UNPACK #-} !Int -- offset
- {-# UNPACK #-} !Int -- length
-
-#if defined(__GLASGOW_HASKELL__)
- deriving (Data, Typeable)
-#endif
-
-instance Show ByteString where
- showsPrec p ps r = showsPrec p (unpackWith w2c ps) r
-
-instance Read ByteString where
- readsPrec p str = [ (packWith c2w x, y) | (x, y) <- readsPrec p str ]
-
--- | /O(n)/ Converts a 'ByteString' to a '[a]', using a conversion function.
-unpackWith :: (Word8 -> a) -> ByteString -> [a]
-unpackWith _ (PS _ _ 0) = []
-unpackWith k (PS ps s l) = inlinePerformIO $ withForeignPtr ps $ \p ->
- go (p `plusPtr` s) (l - 1) []
- where
- STRICT3(go)
- go p 0 acc = peek p >>= \e -> return (k e : acc)
- go p n acc = peekByteOff p n >>= \e -> go p (n-1) (k e : acc)
-{-# INLINE unpackWith #-}
-{-# SPECIALIZE unpackWith :: (Word8 -> Char) -> ByteString -> [Char] #-}
-
--- | /O(n)/ Convert a '[a]' into a 'ByteString' using some
--- conversion function
-packWith :: (a -> Word8) -> [a] -> ByteString
-packWith k str = unsafeCreate (length str) $ \p -> go p str
- where
- STRICT2(go)
- go _ [] = return ()
- go p (x:xs) = poke p (k x) >> go (p `plusPtr` 1) xs -- less space than pokeElemOff
-{-# INLINE packWith #-}
-{-# SPECIALIZE packWith :: (Char -> Word8) -> [Char] -> ByteString #-}
-
-------------------------------------------------------------------------
-
--- | A space-efficient representation of a Word8 vector, supporting many
--- efficient operations. A 'ByteString' contains 8-bit characters only.
---
--- Instances of Eq, Ord, Read, Show, Data, Typeable
---
-newtype LazyByteString = LPS [ByteString] -- LPS for lazy packed string
- deriving (Show,Read
-#if defined(__GLASGOW_HASKELL__)
- ,Data, Typeable
-#endif
- )
-
-------------------------------------------------------------------------
-
--- | /O(1)/ The empty 'ByteString'
-empty :: ByteString
-empty = PS nullForeignPtr 0 0
-
-nullForeignPtr :: ForeignPtr Word8
-#if __GLASGOW_HASKELL__>=605
-nullForeignPtr = ForeignPtr nullAddr# undefined --TODO: should ForeignPtrContents be strict?
-#else
-nullForeignPtr = unsafePerformIO $ newForeignPtr_ nullPtr
-{-# NOINLINE nullForeignPtr #-}
-#endif
-
--- ---------------------------------------------------------------------
---
--- Extensions to the basic interface
---
-
--- | A variety of 'head' for non-empty ByteStrings. 'unsafeHead' omits the
--- check for the empty case, so there is an obligation on the programmer
--- to provide a proof that the ByteString is non-empty.
-unsafeHead :: ByteString -> Word8
-unsafeHead (PS x s l) = assert (l > 0) $
- inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p s
-{-# INLINE unsafeHead #-}
-
--- | A variety of 'tail' for non-empty ByteStrings. 'unsafeTail' omits the
--- check for the empty case. As with 'unsafeHead', the programmer must
--- provide a separate proof that the ByteString is non-empty.
-unsafeTail :: ByteString -> ByteString
-unsafeTail (PS ps s l) = assert (l > 0) $ PS ps (s+1) (l-1)
-{-# INLINE unsafeTail #-}
-
--- | Unsafe 'ByteString' index (subscript) operator, starting from 0, returning a 'Word8'
--- This omits the bounds check, which means there is an accompanying
--- obligation on the programmer to ensure the bounds are checked in some
--- other way.
-unsafeIndex :: ByteString -> Int -> Word8
-unsafeIndex (PS x s l) i = assert (i >= 0 && i < l) $
- inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p (s+i)
-{-# INLINE unsafeIndex #-}
-
--- | A variety of 'take' which omits the checks on @n@ so there is an
--- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@.
-unsafeTake :: Int -> ByteString -> ByteString
-unsafeTake n (PS x s l) = assert (0 <= n && n <= l) $ PS x s n
-{-# INLINE unsafeTake #-}
-
--- | A variety of 'drop' which omits the checks on @n@ so there is an
--- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@.
-unsafeDrop :: Int -> ByteString -> ByteString
-unsafeDrop n (PS x s l) = assert (0 <= n && n <= l) $ PS x (s+n) (l-n)
-{-# INLINE unsafeDrop #-}
-
--- ---------------------------------------------------------------------
--- Low level constructors
-
--- | /O(1)/ Build a ByteString from a ForeignPtr
-fromForeignPtr :: ForeignPtr Word8 -> Int -> ByteString
-fromForeignPtr fp l = PS fp 0 l
-
--- | /O(1)/ Deconstruct a ForeignPtr from a ByteString
-toForeignPtr :: ByteString -> (ForeignPtr Word8, Int, Int)
-toForeignPtr (PS ps s l) = (ps, s, l)
-
--- | A way of creating ByteStrings outside the IO monad. The @Int@
--- argument gives the final size of the ByteString. Unlike
--- 'createAndTrim' the ByteString is not reallocated if the final size
--- is less than the estimated size.
-unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> ByteString
-unsafeCreate l f = unsafePerformIO (create l f)
-{-# INLINE unsafeCreate #-}
-
--- | Create ByteString of size @l@ and use action @f@ to fill it's contents.
-create :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString
-create l f = do
- fp <- mallocByteString l
- withForeignPtr fp $ \p -> f p
- return $! PS fp 0 l
-
--- | Given the maximum size needed and a function to make the contents
--- of a ByteString, createAndTrim makes the 'ByteString'. The generating
--- function is required to return the actual final size (<= the maximum
--- size), and the resulting byte array is realloced to this size.
---
--- createAndTrim is the main mechanism for creating custom, efficient
--- ByteString functions, using Haskell or C functions to fill the space.
---
-createAndTrim :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString
-createAndTrim l f = do
- fp <- mallocByteString l
- withForeignPtr fp $ \p -> do
- l' <- f p
- if assert (l' <= l) $ l' >= l
- then return $! PS fp 0 l
- else create l' $ \p' -> memcpy p' p (fromIntegral l')
-
-createAndTrim' :: Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a)
-createAndTrim' l f = do
- fp <- mallocByteString l
- withForeignPtr fp $ \p -> do
- (off, l', res) <- f p
- if assert (l' <= l) $ l' >= l
- then return $! (PS fp 0 l, res)
- else do ps <- create l' $ \p' ->
- memcpy p' (p `plusPtr` off) (fromIntegral l')
- return $! (ps, res)
-
--- | Wrapper of mallocForeignPtrBytes with faster implementation
--- for GHC 6.5 builds newer than 06/06/06
-mallocByteString :: Int -> IO (ForeignPtr a)
-mallocByteString l = do
-#if __GLASGOW_HASKELL__ >= 605 && !defined(SLOW_FOREIGN_PTR)
- mallocPlainForeignPtrBytes l
-#else
- mallocForeignPtrBytes l
-#endif
-
-#if defined(__GLASGOW_HASKELL__)
--- | /O(n)/ Pack a null-terminated sequence of bytes, pointed to by an
--- Addr\# (an arbitrary machine address assumed to point outside the
--- garbage-collected heap) into a @ByteString@. A much faster way to
--- create an Addr\# is with an unboxed string literal, than to pack a
--- boxed string. A unboxed string literal is compiled to a static @char
--- []@ by GHC. Establishing the length of the string requires a call to
--- @strlen(3)@, so the Addr# must point to a null-terminated buffer (as
--- is the case with "string"# literals in GHC). Use 'unsafePackAddress'
--- if you know the length of the string statically.
---
--- An example:
---
--- > literalFS = packAddress "literal"#
---
-packAddress :: Addr# -> ByteString
-packAddress addr# = inlinePerformIO $ do
- p <- newForeignPtr_ cstr
- l <- c_strlen cstr
- return $ PS p 0 (fromIntegral l)
- where
- cstr = Ptr addr#
-{-# INLINE packAddress #-}
-
--- | /O(1)/ 'unsafePackAddress' provides constant-time construction of
--- 'ByteStrings' -- which is ideal for string literals. It packs a
--- null-terminated sequence of bytes into a 'ByteString', given a raw
--- 'Addr\#' to the string, and the length of the string. Make sure the
--- length is correct, otherwise use the safer 'packAddress' (where the
--- length will be calculated once at runtime).
-unsafePackAddress :: Int -> Addr# -> ByteString
-unsafePackAddress len addr# = inlinePerformIO $ do
- p <- newForeignPtr_ cstr
- return $ PS p 0 len
- where cstr = Ptr addr#
-
--- | /O(1)/ Construct a 'ByteString' given a C Ptr Word8 buffer, a
--- length, and an IO action representing a finalizer. This function is
--- not available on Hugs.
---
-packCStringFinalizer :: Ptr Word8 -> Int -> IO () -> IO ByteString
-packCStringFinalizer p l f = do
- fp <- FC.newForeignPtr p f
- return $ PS fp 0 l
-
--- | Explicitly run the finaliser associated with a 'ByteString'.
--- Further references to this value may generate invalid memory
--- references. This operation is unsafe, as there may be other
--- 'ByteStrings' referring to the same underlying pages. If you use
--- this, you need to have a proof of some kind that all 'ByteString's
--- ever generated from the underlying byte array are no longer live.
-unsafeFinalize :: ByteString -> IO ()
-unsafeFinalize (PS p _ _) = FC.finalizeForeignPtr p
-
-#endif
-
-------------------------------------------------------------------------
-
--- | Conversion between 'Word8' and 'Char'. Should compile to a no-op.
-w2c :: Word8 -> Char
-#if !defined(__GLASGOW_HASKELL__)
-w2c = chr . fromIntegral
-#else
-w2c = unsafeChr . fromIntegral
-#endif
-{-# INLINE w2c #-}
-
--- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and
--- silently truncates to 8 bits Chars > '\255'. It is provided as
--- convenience for ByteString construction.
-c2w :: Char -> Word8
-c2w = fromIntegral . ord
-{-# INLINE c2w #-}
-
--- Selects white-space characters in the Latin-1 range
--- ordered by frequency
--- Idea from Ketil
-isSpaceWord8 :: Word8 -> Bool
-isSpaceWord8 w = case w of
- 0x20 -> True -- SPACE
- 0x0A -> True -- LF, \n
- 0x09 -> True -- HT, \t
- 0x0C -> True -- FF, \f
- 0x0D -> True -- CR, \r
- 0x0B -> True -- VT, \v
- 0xA0 -> True -- spotted by QC..
- _ -> False
-{-# INLINE isSpaceWord8 #-}
-
-------------------------------------------------------------------------
--- | Just like unsafePerformIO, but we inline it. Big performance gains as
--- it exposes lots of things to further inlining
---
-{-# INLINE inlinePerformIO #-}
-inlinePerformIO :: IO a -> a
-#if defined(__GLASGOW_HASKELL__)
-inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
-#else
-inlinePerformIO = unsafePerformIO
-#endif
-
--- | Count the number of occurrences of each byte.
---
-{-# SPECIALIZE countOccurrences :: Ptr CSize -> Ptr Word8 -> Int -> IO () #-}
-countOccurrences :: (Storable a, Num a) => Ptr a -> Ptr Word8 -> Int -> IO ()
-STRICT3(countOccurrences)
-countOccurrences counts str l = go 0
- where
- STRICT1(go)
- go i | i == l = return ()
- | otherwise = do k <- fromIntegral `fmap` peekElemOff str i
- x <- peekElemOff counts k
- pokeElemOff counts k (x + 1)
- go (i + 1)
-
--- | /O(1) construction/ Use a @ByteString@ with a function requiring a
--- @CString@. Warning: modifying the @CString@ will affect the
--- @ByteString@. Why is this function unsafe? It relies on the null
--- byte at the end of the ByteString to be there. Unless you can
--- guarantee the null byte, you should use the safe version, which will
--- copy the string first.
-unsafeUseAsCString :: ByteString -> (CString -> IO a) -> IO a
-unsafeUseAsCString (PS ps s _) ac = withForeignPtr ps $ \p -> ac (castPtr p `plusPtr` s)
-
--- | /O(1) construction/ Use a @ByteString@ with a function requiring a
--- @CStringLen@.
-unsafeUseAsCStringLen :: ByteString -> (CStringLen -> IO a) -> IO a
-unsafeUseAsCStringLen (PS ps s l) f = withForeignPtr ps $ \p -> f (castPtr p `plusPtr` s,l)
-
--- ---------------------------------------------------------------------
---
--- Standard C functions
---
-
-foreign import ccall unsafe "string.h strlen" c_strlen
- :: CString -> IO CSize
-
-foreign import ccall unsafe "stdlib.h malloc" c_malloc
- :: CSize -> IO (Ptr Word8)
-
-foreign import ccall unsafe "static stdlib.h free" c_free
- :: Ptr Word8 -> IO ()
-
-foreign import ccall unsafe "static stdlib.h &free" c_free_finalizer
- :: FunPtr (Ptr Word8 -> IO ())
-
-foreign import ccall unsafe "string.h memchr" c_memchr
- :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)
-
-memchr :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
-memchr p w s = c_memchr p (fromIntegral w) s
-
-foreign import ccall unsafe "string.h memcmp" memcmp
- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt
-
-foreign import ccall unsafe "string.h memcpy" c_memcpy
- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)
-
-memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO ()
-memcpy p q s = do c_memcpy p q s
- return ()
-
-foreign import ccall unsafe "string.h memmove" c_memmove
- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)
-
-memmove :: Ptr Word8 -> Ptr Word8 -> CSize -> IO ()
-memmove p q s = do c_memmove p q s
- return ()
-
-foreign import ccall unsafe "string.h memset" c_memset
- :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)
-
-memset :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
-memset p w s = c_memset p (fromIntegral w) s
-
--- ---------------------------------------------------------------------
---
--- Uses our C code
---
-
-foreign import ccall unsafe "static fpstring.h fps_reverse" c_reverse
- :: Ptr Word8 -> Ptr Word8 -> CULong -> IO ()
-
-foreign import ccall unsafe "static fpstring.h fps_intersperse" c_intersperse
- :: Ptr Word8 -> Ptr Word8 -> CULong -> Word8 -> IO ()
-
-foreign import ccall unsafe "static fpstring.h fps_maximum" c_maximum
- :: Ptr Word8 -> CULong -> IO Word8
-
-foreign import ccall unsafe "static fpstring.h fps_minimum" c_minimum
- :: Ptr Word8 -> CULong -> IO Word8
-
-foreign import ccall unsafe "static fpstring.h fps_count" c_count
- :: Ptr Word8 -> CULong -> Word8 -> IO CULong
-
--- ---------------------------------------------------------------------
--- Internal GHC Haskell magic
-
-#if defined(__GLASGOW_HASKELL__)
-foreign import ccall unsafe "__hscore_memcpy_src_off"
- memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
-#endif
+++ /dev/null
-{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
--- |
--- Module : Data.ByteString.Char8
--- Copyright : (c) Don Stewart 2006
--- License : BSD-style
---
--- Maintainer : dons@cse.unsw.edu.au
--- Stability : experimental
--- Portability : portable
---
--- Manipulate 'ByteString's using 'Char' operations. All Chars will be
--- truncated to 8 bits. It can be expected that these functions will run
--- at identical speeds to their 'Word8' equivalents in "Data.ByteString".
---
--- More specifically these byte strings are taken to be in the
--- subset of Unicode covered by code points 0-255. This covers
--- Unicode Basic Latin, Latin-1 Supplement and C0+C1 Controls.
---
--- See:
---
--- * <http://www.unicode.org/charts/>
---
--- * <http://www.unicode.org/charts/PDF/U0000.pdf>
---
--- * <http://www.unicode.org/charts/PDF/U0080.pdf>
---
--- This module is intended to be imported @qualified@, to avoid name
--- clashes with "Prelude" functions. eg.
---
--- > import qualified Data.ByteString.Char8 as B
---
-
-module Data.ByteString.Char8 (
-
- -- * The @ByteString@ type
- ByteString, -- abstract, instances: Eq, Ord, Show, Read, Data, Typeable, Monoid
-
- -- * Introducing and eliminating 'ByteString's
- empty, -- :: ByteString
- singleton, -- :: Char -> ByteString
- pack, -- :: String -> ByteString
- unpack, -- :: ByteString -> String
-
- -- * Basic interface
- cons, -- :: Char -> ByteString -> ByteString
- snoc, -- :: ByteString -> Char -> ByteString
- append, -- :: ByteString -> ByteString -> ByteString
- head, -- :: ByteString -> Char
- last, -- :: ByteString -> Char
- tail, -- :: ByteString -> ByteString
- init, -- :: ByteString -> ByteString
- null, -- :: ByteString -> Bool
- length, -- :: ByteString -> Int
-
- -- * Transformating ByteStrings
- map, -- :: (Char -> Char) -> ByteString -> ByteString
- reverse, -- :: ByteString -> ByteString
- intersperse, -- :: Char -> ByteString -> ByteString
- transpose, -- :: [ByteString] -> [ByteString]
-
- -- * Reducing 'ByteString's (folds)
- foldl, -- :: (a -> Char -> a) -> a -> ByteString -> a
- foldl', -- :: (a -> Char -> a) -> a -> ByteString -> a
- foldl1, -- :: (Char -> Char -> Char) -> ByteString -> Char
- foldl1', -- :: (Char -> Char -> Char) -> ByteString -> Char
-
- foldr, -- :: (Char -> a -> a) -> a -> ByteString -> a
- foldr', -- :: (Char -> a -> a) -> a -> ByteString -> a
- foldr1, -- :: (Char -> Char -> Char) -> ByteString -> Char
- foldr1', -- :: (Char -> Char -> Char) -> ByteString -> Char
-
- -- ** Special folds
- concat, -- :: [ByteString] -> ByteString
- concatMap, -- :: (Char -> ByteString) -> ByteString -> ByteString
- any, -- :: (Char -> Bool) -> ByteString -> Bool
- all, -- :: (Char -> Bool) -> ByteString -> Bool
- maximum, -- :: ByteString -> Char
- minimum, -- :: ByteString -> Char
-
- -- * Building ByteStrings
- -- ** Scans
- scanl, -- :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString
- scanl1, -- :: (Char -> Char -> Char) -> ByteString -> ByteString
- scanr, -- :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString
- scanr1, -- :: (Char -> Char -> Char) -> ByteString -> ByteString
-
- -- ** Accumulating maps
- mapAccumL, -- :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString)
- mapAccumR, -- :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString)
- mapIndexed, -- :: (Int -> Char -> Char) -> ByteString -> ByteString
-
- -- * Generating and unfolding ByteStrings
- replicate, -- :: Int -> Char -> ByteString
- unfoldr, -- :: (a -> Maybe (Char, a)) -> a -> ByteString
- unfoldrN, -- :: Int -> (a -> Maybe (Char, a)) -> a -> (ByteString, Maybe a)
-
- -- * Substrings
-
- -- ** Breaking strings
- take, -- :: Int -> ByteString -> ByteString
- drop, -- :: Int -> ByteString -> ByteString
- splitAt, -- :: Int -> ByteString -> (ByteString, ByteString)
- takeWhile, -- :: (Char -> Bool) -> ByteString -> ByteString
- dropWhile, -- :: (Char -> Bool) -> ByteString -> ByteString
- span, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
- spanEnd, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
- break, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
- breakEnd, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
- group, -- :: ByteString -> [ByteString]
- groupBy, -- :: (Char -> Char -> Bool) -> ByteString -> [ByteString]
- inits, -- :: ByteString -> [ByteString]
- tails, -- :: ByteString -> [ByteString]
-
- -- ** Breaking into many substrings
- split, -- :: Char -> ByteString -> [ByteString]
- splitWith, -- :: (Char -> Bool) -> ByteString -> [ByteString]
-
- -- ** Breaking into lines and words
- lines, -- :: ByteString -> [ByteString]
- words, -- :: ByteString -> [ByteString]
- unlines, -- :: [ByteString] -> ByteString
- unwords, -- :: ByteString -> [ByteString]
-
- -- ** Joining strings
- join, -- :: ByteString -> [ByteString] -> ByteString
-
- -- ** Searching for substrings
- isPrefixOf, -- :: ByteString -> ByteString -> Bool
- isSuffixOf, -- :: ByteString -> ByteString -> Bool
- isSubstringOf, -- :: ByteString -> ByteString -> Bool
- findSubstring, -- :: ByteString -> ByteString -> Maybe Int
- findSubstrings, -- :: ByteString -> ByteString -> [Int]
-
- -- * Searching ByteStrings
-
- -- ** Searching by equality
- elem, -- :: Char -> ByteString -> Bool
- notElem, -- :: Char -> ByteString -> Bool
-
- -- ** Searching with a predicate
- find, -- :: (Char -> Bool) -> ByteString -> Maybe Char
- filter, -- :: (Char -> Bool) -> ByteString -> ByteString
--- partition -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
-
- -- * Indexing ByteStrings
- index, -- :: ByteString -> Int -> Char
- elemIndex, -- :: Char -> ByteString -> Maybe Int
- elemIndices, -- :: Char -> ByteString -> [Int]
- elemIndexEnd, -- :: Char -> ByteString -> Maybe Int
- findIndex, -- :: (Char -> Bool) -> ByteString -> Maybe Int
- findIndices, -- :: (Char -> Bool) -> ByteString -> [Int]
- count, -- :: Char -> ByteString -> Int
-
- -- * Zipping and unzipping ByteStrings
- zip, -- :: ByteString -> ByteString -> [(Char,Char)]
- zipWith, -- :: (Char -> Char -> c) -> ByteString -> ByteString -> [c]
- unzip, -- :: [(Char,Char)] -> (ByteString,ByteString)
-
- -- * Ordered ByteStrings
- sort, -- :: ByteString -> ByteString
-
- -- * Reading from ByteStrings
- readInt, -- :: ByteString -> Maybe (Int, ByteString)
- readInteger, -- :: ByteString -> Maybe (Integer, ByteString)
-
- -- * Low level CString conversions
-
- -- ** Packing CStrings and pointers
- packCString, -- :: CString -> ByteString
- packCStringLen, -- :: CString -> ByteString
- packMallocCString, -- :: CString -> ByteString
-
- -- ** Using ByteStrings as CStrings
- useAsCString, -- :: ByteString -> (CString -> IO a) -> IO a
- useAsCStringLen, -- :: ByteString -> (CStringLen -> IO a) -> IO a
-
- -- * Copying ByteStrings
- copy, -- :: ByteString -> ByteString
- copyCString, -- :: CString -> IO ByteString
- copyCStringLen, -- :: CStringLen -> IO ByteString
-
- -- * I\/O with @ByteString@s
-
- -- ** Standard input and output
- getLine, -- :: IO ByteString
- getContents, -- :: IO ByteString
- putStr, -- :: ByteString -> IO ()
- putStrLn, -- :: ByteString -> IO ()
- interact, -- :: (ByteString -> ByteString) -> IO ()
-
- -- ** Files
- readFile, -- :: FilePath -> IO ByteString
- writeFile, -- :: FilePath -> ByteString -> IO ()
- appendFile, -- :: FilePath -> ByteString -> IO ()
--- mmapFile, -- :: FilePath -> IO ByteString
-
- -- ** I\/O with Handles
- hGetLine, -- :: Handle -> IO ByteString
- hGetNonBlocking, -- :: Handle -> Int -> IO ByteString
- hGetContents, -- :: Handle -> IO ByteString
- hGet, -- :: Handle -> Int -> IO ByteString
- hPut, -- :: Handle -> ByteString -> IO ()
- hPutStr, -- :: Handle -> ByteString -> IO ()
- hPutStrLn, -- :: Handle -> ByteString -> IO ()
-
-#if defined(__GLASGOW_HASKELL__)
- -- * Low level construction
- -- | For constructors from foreign language types see "Data.ByteString"
- packAddress, -- :: Addr# -> ByteString
- unsafePackAddress, -- :: Int -> Addr# -> ByteString
-#endif
-
- -- * Utilities (needed for array fusion)
-#if defined(__GLASGOW_HASKELL__)
- unpackList,
-#endif
-
- ) where
-
-import qualified Prelude as P
-import Prelude hiding (reverse,head,tail,last,init,null
- ,length,map,lines,foldl,foldr,unlines
- ,concat,any,take,drop,splitAt,takeWhile
- ,dropWhile,span,break,elem,filter,unwords
- ,words,maximum,minimum,all,concatMap
- ,scanl,scanl1,scanr,scanr1
- ,appendFile,readFile,writeFile
- ,foldl1,foldr1,replicate
- ,getContents,getLine,putStr,putStrLn,interact
- ,zip,zipWith,unzip,notElem)
-
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Base as B
-
--- Listy functions transparently exported
-import Data.ByteString (empty,null,length,tail,init,append
- ,inits,tails,reverse,transpose
- ,concat,take,drop,splitAt,join
- ,sort,isPrefixOf,isSuffixOf,isSubstringOf,findSubstring
- ,findSubstrings,copy,group
-
- ,getLine, getContents, putStr, putStrLn, interact
- ,hGetContents, hGet, hPut, hPutStr, hPutStrLn
- ,hGetLine, hGetNonBlocking
- ,packCString,packCStringLen, packMallocCString
- ,useAsCString,useAsCStringLen, copyCString,copyCStringLen
-#if defined(__GLASGOW_HASKELL__)
- ,unpackList
-#endif
- )
-
-import Data.ByteString.Base (
- ByteString(..)
-#if defined(__GLASGOW_HASKELL__)
- ,packAddress, unsafePackAddress
-#endif
- ,c2w, w2c, unsafeTail, isSpaceWord8, inlinePerformIO
- )
-
-import Data.Char ( isSpace )
-import qualified Data.List as List (intersperse)
-
-import System.IO (openFile,hClose,hFileSize,IOMode(..))
-import Control.Exception (bracket)
-import Foreign
-
-#if defined(__GLASGOW_HASKELL__)
-import GHC.Base (Char(..),unpackCString#,ord#,int2Word#)
-import GHC.IOBase (IO(..),stToIO)
-import GHC.Prim (Addr#,writeWord8OffAddr#,plusAddr#)
-import GHC.Ptr (Ptr(..))
-import GHC.ST (ST(..))
-#endif
-
-#define STRICT1(f) f a | a `seq` False = undefined
-#define STRICT2(f) f a b | a `seq` b `seq` False = undefined
-#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
-#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined
-
-------------------------------------------------------------------------
-
--- | /O(1)/ Convert a 'Char' into a 'ByteString'
-singleton :: Char -> ByteString
-singleton = B.singleton . c2w
-{-# INLINE singleton #-}
-
--- | /O(n)/ Convert a 'String' into a 'ByteString'
---
--- For applications with large numbers of string literals, pack can be a
--- bottleneck. In such cases, consider using packAddress (GHC only).
-pack :: String -> ByteString
-#if !defined(__GLASGOW_HASKELL__)
-
-pack str = B.unsafeCreate (P.length str) $ \p -> go p str
- where go _ [] = return ()
- go p (x:xs) = poke p (c2w x) >> go (p `plusPtr` 1) xs
-
-#else /* hack away */
-
-pack str = B.unsafeCreate (P.length str) $ \(Ptr p) -> stToIO (go p str)
- where
- go :: Addr# -> [Char] -> ST a ()
- go _ [] = return ()
- go p (C# c:cs) = writeByte p (int2Word# (ord# c)) >> go (p `plusAddr#` 1#) cs
-
- writeByte p c = ST $ \s# ->
- case writeWord8OffAddr# p 0# c s# of s2# -> (# s2#, () #)
- {-# INLINE writeByte #-}
-{-# INLINE [1] pack #-}
-
-{-# RULES
- "FPS pack/packAddress" forall s .
- pack (unpackCString# s) = B.packAddress s
- #-}
-
-#endif
-
--- | /O(n)/ Converts a 'ByteString' to a 'String'.
-unpack :: ByteString -> [Char]
-unpack = P.map w2c . B.unpack
-{-# INLINE unpack #-}
-
--- | /O(n)/ 'cons' is analogous to (:) for lists, but of different
--- complexity, as it requires a memcpy.
-cons :: Char -> ByteString -> ByteString
-cons = B.cons . c2w
-{-# INLINE cons #-}
-
--- | /O(n)/ Append a Char to the end of a 'ByteString'. Similar to
--- 'cons', this function performs a memcpy.
-snoc :: ByteString -> Char -> ByteString
-snoc p = B.snoc p . c2w
-{-# INLINE snoc #-}
-
--- | /O(1)/ Extract the first element of a ByteString, which must be non-empty.
-head :: ByteString -> Char
-head = w2c . B.head
-{-# INLINE head #-}
-
--- | /O(1)/ Extract the last element of a packed string, which must be non-empty.
-last :: ByteString -> Char
-last = w2c . B.last
-{-# INLINE last #-}
-
--- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each element of @xs@
-map :: (Char -> Char) -> ByteString -> ByteString
-map f = B.map (c2w . f . w2c)
-{-# INLINE map #-}
-
--- | /O(n)/ The 'intersperse' function takes a Char and a 'ByteString'
--- and \`intersperses\' that Char between the elements of the
--- 'ByteString'. It is analogous to the intersperse function on Lists.
-intersperse :: Char -> ByteString -> ByteString
-intersperse = B.intersperse . c2w
-{-# INLINE intersperse #-}
-
--- | 'foldl', applied to a binary operator, a starting value (typically
--- the left-identity of the operator), and a ByteString, reduces the
--- ByteString using the binary operator, from left to right.
-foldl :: (a -> Char -> a) -> a -> ByteString -> a
-foldl f = B.foldl (\a c -> f a (w2c c))
-{-# INLINE foldl #-}
-
--- | 'foldl\'' is like foldl, but strict in the accumulator.
-foldl' :: (a -> Char -> a) -> a -> ByteString -> a
-foldl' f = B.foldl' (\a c -> f a (w2c c))
-{-# INLINE foldl' #-}
-
--- | 'foldr', applied to a binary operator, a starting value
--- (typically the right-identity of the operator), and a packed string,
--- reduces the packed string using the binary operator, from right to left.
-foldr :: (Char -> a -> a) -> a -> ByteString -> a
-foldr f = B.foldr (\c a -> f (w2c c) a)
-{-# INLINE foldr #-}
-
--- | 'foldr\'' is a strict variant of foldr
-foldr' :: (Char -> a -> a) -> a -> ByteString -> a
-foldr' f = B.foldr' (\c a -> f (w2c c) a)
-{-# INLINE foldr' #-}
-
--- | 'foldl1' is a variant of 'foldl' that has no starting value
--- argument, and thus must be applied to non-empty 'ByteStrings'.
-foldl1 :: (Char -> Char -> Char) -> ByteString -> Char
-foldl1 f ps = w2c (B.foldl1 (\x y -> c2w (f (w2c x) (w2c y))) ps)
-{-# INLINE foldl1 #-}
-
--- | A strict version of 'foldl1'
-foldl1' :: (Char -> Char -> Char) -> ByteString -> Char
-foldl1' f ps = w2c (B.foldl1' (\x y -> c2w (f (w2c x) (w2c y))) ps)
-{-# INLINE foldl1' #-}
-
--- | 'foldr1' is a variant of 'foldr' that has no starting value argument,
--- and thus must be applied to non-empty 'ByteString's
-foldr1 :: (Char -> Char -> Char) -> ByteString -> Char
-foldr1 f ps = w2c (B.foldr1 (\x y -> c2w (f (w2c x) (w2c y))) ps)
-{-# INLINE foldr1 #-}
-
--- | A strict variant of foldr1
-foldr1' :: (Char -> Char -> Char) -> ByteString -> Char
-foldr1' f ps = w2c (B.foldr1' (\x y -> c2w (f (w2c x) (w2c y))) ps)
-{-# INLINE foldr1' #-}
-
--- | Map a function over a 'ByteString' and concatenate the results
-concatMap :: (Char -> ByteString) -> ByteString -> ByteString
-concatMap f = B.concatMap (f . w2c)
-{-# INLINE concatMap #-}
-
--- | Applied to a predicate and a ByteString, 'any' determines if
--- any element of the 'ByteString' satisfies the predicate.
-any :: (Char -> Bool) -> ByteString -> Bool
-any f = B.any (f . w2c)
-{-# INLINE any #-}
-
--- | Applied to a predicate and a 'ByteString', 'all' determines if
--- all elements of the 'ByteString' satisfy the predicate.
-all :: (Char -> Bool) -> ByteString -> Bool
-all f = B.all (f . w2c)
-{-# INLINE all #-}
-
--- | 'maximum' returns the maximum value from a 'ByteString'
-maximum :: ByteString -> Char
-maximum = w2c . B.maximum
-{-# INLINE maximum #-}
-
--- | 'minimum' returns the minimum value from a 'ByteString'
-minimum :: ByteString -> Char
-minimum = w2c . B.minimum
-{-# INLINE minimum #-}
-
--- | /O(n)/ map Char functions, provided with the index at each position
-mapIndexed :: (Int -> Char -> Char) -> ByteString -> ByteString
-mapIndexed f = B.mapIndexed (\i c -> c2w (f i (w2c c)))
-{-# INLINE mapIndexed #-}
-
--- | The 'mapAccumL' function behaves like a combination of 'map' and
--- 'foldl'; it applies a function to each element of a ByteString,
--- passing an accumulating parameter from left to right, and returning a
--- final value of this accumulator together with the new list.
-mapAccumL :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString)
-mapAccumL f = B.mapAccumL (\acc w -> case f acc (w2c w) of (acc', c) -> (acc', c2w c))
-
--- | The 'mapAccumR' function behaves like a combination of 'map' and
--- 'foldr'; it applies a function to each element of a ByteString,
--- passing an accumulating parameter from right to left, and returning a
--- final value of this accumulator together with the new ByteString.
-mapAccumR :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString)
-mapAccumR f = B.mapAccumR (\acc w -> case f acc (w2c w) of (acc', c) -> (acc', c2w c))
-
--- | 'scanl' is similar to 'foldl', but returns a list of successive
--- reduced values from the left:
---
--- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
---
--- Note that
---
--- > last (scanl f z xs) == foldl f z xs.
-scanl :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString
-scanl f z = B.scanl (\a b -> c2w (f (w2c a) (w2c b))) (c2w z)
-
--- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
---
--- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
-scanl1 :: (Char -> Char -> Char) -> ByteString -> ByteString
-scanl1 f = B.scanl1 (\a b -> c2w (f (w2c a) (w2c b)))
-
--- | scanr is the right-to-left dual of scanl.
-scanr :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString
-scanr f z = B.scanr (\a b -> c2w (f (w2c a) (w2c b))) (c2w z)
-
--- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
-scanr1 :: (Char -> Char -> Char) -> ByteString -> ByteString
-scanr1 f = B.scanr1 (\a b -> c2w (f (w2c a) (w2c b)))
-
--- | /O(n)/ 'replicate' @n x@ is a ByteString of length @n@ with @x@
--- the value of every element. The following holds:
---
--- > replicate w c = unfoldr w (\u -> Just (u,u)) c
---
--- This implemenation uses @memset(3)@
-replicate :: Int -> Char -> ByteString
-replicate w = B.replicate w . c2w
-{-# INLINE replicate #-}
-
--- | /O(n)/, where /n/ is the length of the result. The 'unfoldr'
--- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a
--- ByteString from a seed value. The function takes the element and
--- returns 'Nothing' if it is done producing the ByteString or returns
--- 'Just' @(a,b)@, in which case, @a@ is the next character in the string,
--- and @b@ is the seed value for further production.
---
--- Examples:
---
--- > unfoldr (\x -> if x <= '9' then Just (x, succ x) else Nothing) '0' == "0123456789"
-unfoldr :: (a -> Maybe (Char, a)) -> a -> ByteString
-unfoldr f x0 = B.unfoldr (fmap k . f) x0
- where k (i, j) = (c2w i, j)
-
--- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a ByteString from a seed
--- value. However, the length of the result is limited by the first
--- argument to 'unfoldrN'. This function is more efficient than 'unfoldr'
--- when the maximum length of the result is known.
---
--- The following equation relates 'unfoldrN' and 'unfoldr':
---
--- > unfoldrN n f s == take n (unfoldr f s)
-unfoldrN :: Int -> (a -> Maybe (Char, a)) -> a -> (ByteString, Maybe a)
-unfoldrN n f w = B.unfoldrN n ((k `fmap`) . f) w
- where k (i,j) = (c2w i, j)
-{-# INLINE unfoldrN #-}
-
--- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@,
--- returns the longest prefix (possibly empty) of @xs@ of elements that
--- satisfy @p@.
-takeWhile :: (Char -> Bool) -> ByteString -> ByteString
-takeWhile f = B.takeWhile (f . w2c)
-{-# INLINE takeWhile #-}
-
--- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@.
-dropWhile :: (Char -> Bool) -> ByteString -> ByteString
-dropWhile f = B.dropWhile (f . w2c)
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] dropWhile #-}
-#endif
-
--- | 'break' @p@ is equivalent to @'span' ('not' . p)@.
-break :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
-break f = B.break (f . w2c)
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] break #-}
-#endif
-
--- | 'span' @p xs@ breaks the ByteString into two segments. It is
--- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@
-span :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
-span f = B.span (f . w2c)
-{-# INLINE span #-}
-
--- | 'spanEnd' behaves like 'span' but from the end of the 'ByteString'.
--- We have
---
--- > spanEnd (not.isSpace) "x y z" == ("x y ","z")
---
--- and
---
--- > spanEnd (not . isSpace) ps
--- > ==
--- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x)
---
-spanEnd :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
-spanEnd f = B.spanEnd (f . w2c)
-{-# INLINE spanEnd #-}
-
--- | 'breakEnd' behaves like 'break' but from the end of the 'ByteString'
---
--- breakEnd p == spanEnd (not.p)
-breakEnd :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
-breakEnd f = B.breakEnd (f . w2c)
-{-# INLINE breakEnd #-}
-
-{-
--- | 'breakChar' breaks its ByteString argument at the first occurence
--- of the specified Char. It is more efficient than 'break' as it is
--- implemented with @memchr(3)@. I.e.
---
--- > break (=='c') "abcd" == breakChar 'c' "abcd"
---
-breakChar :: Char -> ByteString -> (ByteString, ByteString)
-breakChar = B.breakByte . c2w
-{-# INLINE breakChar #-}
-
--- | 'spanChar' breaks its ByteString argument at the first
--- occurence of a Char other than its argument. It is more efficient
--- than 'span (==)'
---
--- > span (=='c') "abcd" == spanByte 'c' "abcd"
---
-spanChar :: Char -> ByteString -> (ByteString, ByteString)
-spanChar = B.spanByte . c2w
-{-# INLINE spanChar #-}
--}
-
--- | /O(n)/ Break a 'ByteString' into pieces separated by the byte
--- argument, consuming the delimiter. I.e.
---
--- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"]
--- > split 'a' "aXaXaXa" == ["","X","X","X",""]
--- > split 'x' "x" == ["",""]
---
--- and
---
--- > join [c] . split c == id
--- > split == splitWith . (==)
---
--- As for all splitting functions in this library, this function does
--- not copy the substrings, it just constructs new 'ByteStrings' that
--- are slices of the original.
---
-split :: Char -> ByteString -> [ByteString]
-split = B.split . c2w
-{-# INLINE split #-}
-
--- | /O(n)/ Splits a 'ByteString' into components delimited by
--- separators, where the predicate returns True for a separator element.
--- The resulting components do not contain the separators. Two adjacent
--- separators result in an empty component in the output. eg.
---
--- > splitWith (=='a') "aabbaca" == ["","","bb","c",""]
---
-splitWith :: (Char -> Bool) -> ByteString -> [ByteString]
-splitWith f = B.splitWith (f . w2c)
-{-# INLINE splitWith #-}
--- the inline makes a big difference here.
-
-{-
--- | Like 'splitWith', except that sequences of adjacent separators are
--- treated as a single separator. eg.
---
--- > tokens (=='a') "aabbaca" == ["bb","c"]
---
-tokens :: (Char -> Bool) -> ByteString -> [ByteString]
-tokens f = B.tokens (f . w2c)
-{-# INLINE tokens #-}
--}
-
--- | The 'groupBy' function is the non-overloaded version of 'group'.
-groupBy :: (Char -> Char -> Bool) -> ByteString -> [ByteString]
-groupBy k = B.groupBy (\a b -> k (w2c a) (w2c b))
-
-{-
--- | /O(n)/ joinWithChar. An efficient way to join to two ByteStrings with a
--- char. Around 4 times faster than the generalised join.
---
-joinWithChar :: Char -> ByteString -> ByteString -> ByteString
-joinWithChar = B.joinWithByte . c2w
-{-# INLINE joinWithChar #-}
--}
-
--- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0.
-index :: ByteString -> Int -> Char
-index = (w2c .) . B.index
-{-# INLINE index #-}
-
--- | /O(n)/ The 'elemIndex' function returns the index of the first
--- element in the given 'ByteString' which is equal (by memchr) to the
--- query element, or 'Nothing' if there is no such element.
-elemIndex :: Char -> ByteString -> Maybe Int
-elemIndex = B.elemIndex . c2w
-{-# INLINE elemIndex #-}
-
--- | /O(n)/ The 'elemIndexEnd' function returns the last index of the
--- element in the given 'ByteString' which is equal to the query
--- element, or 'Nothing' if there is no such element. The following
--- holds:
---
--- > elemIndexEnd c xs ==
--- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs)
---
-elemIndexEnd :: Char -> ByteString -> Maybe Int
-elemIndexEnd = B.elemIndexEnd . c2w
-{-# INLINE elemIndexEnd #-}
-
--- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning
--- the indices of all elements equal to the query element, in ascending order.
-elemIndices :: Char -> ByteString -> [Int]
-elemIndices = B.elemIndices . c2w
-{-# INLINE elemIndices #-}
-
--- | The 'findIndex' function takes a predicate and a 'ByteString' and
--- returns the index of the first element in the ByteString satisfying the predicate.
-findIndex :: (Char -> Bool) -> ByteString -> Maybe Int
-findIndex f = B.findIndex (f . w2c)
-{-# INLINE findIndex #-}
-
--- | The 'findIndices' function extends 'findIndex', by returning the
--- indices of all elements satisfying the predicate, in ascending order.
-findIndices :: (Char -> Bool) -> ByteString -> [Int]
-findIndices f = B.findIndices (f . w2c)
-
--- | count returns the number of times its argument appears in the ByteString
---
--- > count = length . elemIndices
---
--- Also
---
--- > count '\n' == length . lines
---
--- But more efficiently than using length on the intermediate list.
-count :: Char -> ByteString -> Int
-count c = B.count (c2w c)
-
--- | /O(n)/ 'elem' is the 'ByteString' membership predicate. This
--- implementation uses @memchr(3)@.
-elem :: Char -> ByteString -> Bool
-elem c = B.elem (c2w c)
-{-# INLINE elem #-}
-
--- | /O(n)/ 'notElem' is the inverse of 'elem'
-notElem :: Char -> ByteString -> Bool
-notElem c = B.notElem (c2w c)
-{-# INLINE notElem #-}
-
--- | /O(n)/ 'filter', applied to a predicate and a ByteString,
--- returns a ByteString containing those characters that satisfy the
--- predicate.
-filter :: (Char -> Bool) -> ByteString -> ByteString
-filter f = B.filter (f . w2c)
-{-# INLINE filter #-}
-
--- | /O(n)/ The 'find' function takes a predicate and a ByteString,
--- and returns the first element in matching the predicate, or 'Nothing'
--- if there is no such element.
-find :: (Char -> Bool) -> ByteString -> Maybe Char
-find f ps = w2c `fmap` B.find (f . w2c) ps
-{-# INLINE find #-}
-
-{-
--- | /O(n)/ A first order equivalent of /filter . (==)/, for the common
--- case of filtering a single Char. It is more efficient to use
--- filterChar in this case.
---
--- > filterChar == filter . (==)
---
--- filterChar is around 10x faster, and uses much less space, than its
--- filter equivalent
---
-filterChar :: Char -> ByteString -> ByteString
-filterChar c = B.filterByte (c2w c)
-{-# INLINE filterChar #-}
-
--- | /O(n)/ A first order equivalent of /filter . (\/=)/, for the common
--- case of filtering a single Char out of a list. It is more efficient
--- to use /filterNotChar/ in this case.
---
--- > filterNotChar == filter . (/=)
---
--- filterNotChar is around 3x faster, and uses much less space, than its
--- filter equivalent
---
-filterNotChar :: Char -> ByteString -> ByteString
-filterNotChar c = B.filterNotByte (c2w c)
-{-# INLINE filterNotChar #-}
--}
-
--- | /O(n)/ 'zip' takes two ByteStrings and returns a list of
--- corresponding pairs of Chars. If one input ByteString is short,
--- excess elements of the longer ByteString are discarded. This is
--- equivalent to a pair of 'unpack' operations, and so space
--- usage may be large for multi-megabyte ByteStrings
-zip :: ByteString -> ByteString -> [(Char,Char)]
-zip ps qs
- | B.null ps || B.null qs = []
- | otherwise = (unsafeHead ps, unsafeHead qs) : zip (B.unsafeTail ps) (B.unsafeTail qs)
-
--- | 'zipWith' generalises 'zip' by zipping with the function given as
--- the first argument, instead of a tupling function. For example,
--- @'zipWith' (+)@ is applied to two ByteStrings to produce the list
--- of corresponding sums.
-zipWith :: (Char -> Char -> a) -> ByteString -> ByteString -> [a]
-zipWith f = B.zipWith ((. w2c) . f . w2c)
-
--- | 'unzip' transforms a list of pairs of Chars into a pair of
--- ByteStrings. Note that this performs two 'pack' operations.
-unzip :: [(Char,Char)] -> (ByteString,ByteString)
-unzip ls = (pack (P.map fst ls), pack (P.map snd ls))
-{-# INLINE unzip #-}
-
--- | A variety of 'head' for non-empty ByteStrings. 'unsafeHead' omits
--- the check for the empty case, which is good for performance, but
--- there is an obligation on the programmer to provide a proof that the
--- ByteString is non-empty.
-unsafeHead :: ByteString -> Char
-unsafeHead = w2c . B.unsafeHead
-{-# INLINE unsafeHead #-}
-
--- ---------------------------------------------------------------------
--- Things that depend on the encoding
-
-{-# RULES
- "FPS specialise break -> breakSpace"
- break isSpace = breakSpace
- #-}
-
--- | 'breakSpace' returns the pair of ByteStrings when the argument is
--- broken at the first whitespace byte. I.e.
---
--- > break isSpace == breakSpace
---
-breakSpace :: ByteString -> (ByteString,ByteString)
-breakSpace (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do
- i <- firstspace (p `plusPtr` s) 0 l
- return $! case () of {_
- | i == 0 -> (empty, PS x s l)
- | i == l -> (PS x s l, empty)
- | otherwise -> (PS x s i, PS x (s+i) (l-i))
- }
-{-# INLINE breakSpace #-}
-
-firstspace :: Ptr Word8 -> Int -> Int -> IO Int
-STRICT3(firstspace)
-firstspace ptr n m
- | n >= m = return n
- | otherwise = do w <- peekByteOff ptr n
- if (not . isSpaceWord8) w then firstspace ptr (n+1) m else return n
-
-{-# RULES
- "FPS specialise dropWhile isSpace -> dropSpace"
- dropWhile isSpace = dropSpace
- #-}
-
--- | 'dropSpace' efficiently returns the 'ByteString' argument with
--- white space Chars removed from the front. It is more efficient than
--- calling dropWhile for removing whitespace. I.e.
---
--- > dropWhile isSpace == dropSpace
---
-dropSpace :: ByteString -> ByteString
-dropSpace (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do
- i <- firstnonspace (p `plusPtr` s) 0 l
- return $! if i == l then empty else PS x (s+i) (l-i)
-{-# INLINE dropSpace #-}
-
-firstnonspace :: Ptr Word8 -> Int -> Int -> IO Int
-STRICT3(firstnonspace)
-firstnonspace ptr n m
- | n >= m = return n
- | otherwise = do w <- peekElemOff ptr n
- if isSpaceWord8 w then firstnonspace ptr (n+1) m else return n
-
-{-
--- | 'dropSpaceEnd' efficiently returns the 'ByteString' argument with
--- white space removed from the end. I.e.
---
--- > reverse . (dropWhile isSpace) . reverse == dropSpaceEnd
---
--- but it is more efficient than using multiple reverses.
---
-dropSpaceEnd :: ByteString -> ByteString
-dropSpaceEnd (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do
- i <- lastnonspace (p `plusPtr` s) (l-1)
- return $! if i == (-1) then empty else PS x s (i+1)
-{-# INLINE dropSpaceEnd #-}
-
-lastnonspace :: Ptr Word8 -> Int -> IO Int
-STRICT2(lastnonspace)
-lastnonspace ptr n
- | n < 0 = return n
- | otherwise = do w <- peekElemOff ptr n
- if isSpaceWord8 w then lastnonspace ptr (n-1) else return n
--}
-
--- | 'lines' breaks a ByteString up into a list of ByteStrings at
--- newline Chars. The resulting strings do not contain newlines.
---
-lines :: ByteString -> [ByteString]
-lines ps
- | null ps = []
- | otherwise = case search ps of
- Nothing -> [ps]
- Just n -> take n ps : lines (drop (n+1) ps)
- where search = elemIndex '\n'
-{-# INLINE lines #-}
-
-{-
--- Just as fast, but more complex. Should be much faster, I thought.
-lines :: ByteString -> [ByteString]
-lines (PS _ _ 0) = []
-lines (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do
- let ptr = p `plusPtr` s
-
- STRICT1(loop)
- loop n = do
- let q = memchr (ptr `plusPtr` n) 0x0a (fromIntegral (l-n))
- if q == nullPtr
- then return [PS x (s+n) (l-n)]
- else do let i = q `minusPtr` ptr
- ls <- loop (i+1)
- return $! PS x (s+n) (i-n) : ls
- loop 0
--}
-
--- | 'unlines' is an inverse operation to 'lines'. It joins lines,
--- after appending a terminating newline to each.
-unlines :: [ByteString] -> ByteString
-unlines [] = empty
-unlines ss = (concat $ List.intersperse nl ss) `append` nl -- half as much space
- where nl = singleton '\n'
-
--- | 'words' breaks a ByteString up into a list of words, which
--- were delimited by Chars representing white space. And
---
--- > tokens isSpace = words
---
-words :: ByteString -> [ByteString]
-words = P.filter (not . B.null) . B.splitWith isSpaceWord8
-{-# INLINE words #-}
-
--- | The 'unwords' function is analogous to the 'unlines' function, on words.
-unwords :: [ByteString] -> ByteString
-unwords = join (singleton ' ')
-{-# INLINE unwords #-}
-
--- ---------------------------------------------------------------------
--- Reading from ByteStrings
-
--- | readInt reads an Int from the beginning of the ByteString. If there is no
--- integer at the beginning of the string, it returns Nothing, otherwise
--- it just returns the int read, and the rest of the string.
-readInt :: ByteString -> Maybe (Int, ByteString)
-readInt as
- | null as = Nothing
- | otherwise =
- case unsafeHead as of
- '-' -> loop True 0 0 (unsafeTail as)
- '+' -> loop False 0 0 (unsafeTail as)
- _ -> loop False 0 0 as
-
- where loop :: Bool -> Int -> Int -> ByteString -> Maybe (Int, ByteString)
- STRICT4(loop)
- loop neg i n ps
- | null ps = end neg i n ps
- | otherwise =
- case B.unsafeHead ps of
- w | w >= 0x30
- && w <= 0x39 -> loop neg (i+1)
- (n * 10 + (fromIntegral w - 0x30))
- (unsafeTail ps)
- | otherwise -> end neg i n ps
-
- end _ 0 _ _ = Nothing
- end True _ n ps = Just (negate n, ps)
- end _ _ n ps = Just (n, ps)
-
--- | readInteger reads an Integer from the beginning of the ByteString. If
--- there is no integer at the beginning of the string, it returns Nothing,
--- otherwise it just returns the int read, and the rest of the string.
-readInteger :: ByteString -> Maybe (Integer, ByteString)
-readInteger as
- | null as = Nothing
- | otherwise =
- case unsafeHead as of
- '-' -> first (unsafeTail as) >>= \(n, bs) -> return (-n, bs)
- '+' -> first (unsafeTail as)
- _ -> first as
-
- where first ps | null ps = Nothing
- | otherwise =
- case B.unsafeHead ps of
- w | w >= 0x30 && w <= 0x39 -> Just $
- loop 1 (fromIntegral w - 0x30) [] (unsafeTail ps)
- | otherwise -> Nothing
-
- loop :: Int -> Int -> [Integer]
- -> ByteString -> (Integer, ByteString)
- STRICT4(loop)
- loop d acc ns ps
- | null ps = combine d acc ns empty
- | otherwise =
- case B.unsafeHead ps of
- w | w >= 0x30 && w <= 0x39 ->
- if d == 9 then loop 1 (fromIntegral w - 0x30)
- (toInteger acc : ns)
- (unsafeTail ps)
- else loop (d+1)
- (10*acc + (fromIntegral w - 0x30))
- ns (unsafeTail ps)
- | otherwise -> combine d acc ns ps
-
- combine _ acc [] ps = (toInteger acc, ps)
- combine d acc ns ps =
- ((10^d * combine1 1000000000 ns + toInteger acc), ps)
-
- combine1 _ [n] = n
- combine1 b ns = combine1 (b*b) $ combine2 b ns
-
- combine2 b (n:m:ns) = let t = m*b + n in t `seq` (t : combine2 b ns)
- combine2 _ ns = ns
-
--- | Read an entire file strictly into a 'ByteString'. This is far more
--- efficient than reading the characters into a 'String' and then using
--- 'pack'. It also may be more efficient than opening the file and
--- reading it using hGet.
-readFile :: FilePath -> IO ByteString
-readFile f = bracket (openFile f ReadMode) hClose
- (\h -> hFileSize h >>= hGet h . fromIntegral)
-
--- | Write a 'ByteString' to a file.
-writeFile :: FilePath -> ByteString -> IO ()
-writeFile f txt = bracket (openFile f WriteMode) hClose
- (\h -> hPut h txt)
-
--- | Append a 'ByteString' to a file.
-appendFile :: FilePath -> ByteString -> IO ()
-appendFile f txt = bracket (openFile f AppendMode) hClose
- (\h -> hPut h txt)
-
+++ /dev/null
-{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}
--- |
--- Module : Data.ByteString.Fusion
--- License : BSD-style
--- Maintainer : dons@cse.unsw.edu.au
--- Stability : experimental
--- Portability : portable
---
--- Functional array fusion for ByteStrings.
---
--- Originally based on code from the Data Parallel Haskell project,
--- <http://www.cse.unsw.edu.au/~chak/project/dph>
---
-
--- #hide
-module Data.ByteString.Fusion (
-
- -- * Fusion utilities
- loopU, loopL, fuseEFL,
- NoAcc(NoAcc), loopArr, loopAcc, loopSndAcc, unSP,
- mapEFL, filterEFL, foldEFL, foldEFL', scanEFL, mapAccumEFL, mapIndexEFL,
-
- -- ** Alternative Fusion stuff
- -- | This replaces 'loopU' with 'loopUp'
- -- and adds several further special cases of loops.
- loopUp, loopDown, loopNoAcc, loopMap, loopFilter,
- loopWrapper, sequenceLoops,
- doUpLoop, doDownLoop, doNoAccLoop, doMapLoop, doFilterLoop,
-
- -- | These are the special fusion cases for combining each loop form perfectly.
- fuseAccAccEFL, fuseAccNoAccEFL, fuseNoAccAccEFL, fuseNoAccNoAccEFL,
- fuseMapAccEFL, fuseAccMapEFL, fuseMapNoAccEFL, fuseNoAccMapEFL,
- fuseMapMapEFL, fuseAccFilterEFL, fuseFilterAccEFL, fuseNoAccFilterEFL,
- fuseFilterNoAccEFL, fuseFilterFilterEFL, fuseMapFilterEFL, fuseFilterMapEFL,
-
- -- * Strict pairs and sums
- PairS(..), MaybeS(..)
-
- ) where
-
-import Data.ByteString.Base
-
-import Foreign.ForeignPtr
-import Foreign.Ptr
-import Foreign.Storable (Storable(..))
-
-import Data.Word (Word8)
-import System.IO.Unsafe (unsafePerformIO)
-
--- -----------------------------------------------------------------------------
---
--- Useful macros, until we have bang patterns
---
-
-#define STRICT1(f) f a | a `seq` False = undefined
-#define STRICT2(f) f a b | a `seq` b `seq` False = undefined
-#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
-#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined
-#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined
-
-infixl 2 :*:
-
--- |Strict pair
-data PairS a b = !a :*: !b deriving (Eq,Ord,Show)
-
--- |Strict Maybe
-data MaybeS a = NothingS | JustS !a deriving (Eq,Ord,Show)
-
--- |Data type for accumulators which can be ignored. The rewrite rules rely on
--- the fact that no bottoms of this type are ever constructed; hence, we can
--- assume @(_ :: NoAcc) `seq` x = x@.
---
-data NoAcc = NoAcc
-
--- |Type of loop functions
-type AccEFL acc = acc -> Word8 -> (PairS acc (MaybeS Word8))
-type NoAccEFL = Word8 -> MaybeS Word8
-type MapEFL = Word8 -> Word8
-type FilterEFL = Word8 -> Bool
-
-infixr 9 `fuseEFL`
-
--- |Fuse to flat loop functions
-fuseEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2)
-fuseEFL f g (acc1 :*: acc2) e1 =
- case f acc1 e1 of
- acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS
- acc1' :*: JustS e2 ->
- case g acc2 e2 of
- acc2' :*: res -> (acc1' :*: acc2') :*: res
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] fuseEFL #-}
-#endif
-
--- | Special forms of loop arguments
---
--- * These are common special cases for the three function arguments of gen
--- and loop; we give them special names to make it easier to trigger RULES
--- applying in the special cases represented by these arguments. The
--- "INLINE [1]" makes sure that these functions are only inlined in the last
--- two simplifier phases.
---
--- * In the case where the accumulator is not needed, it is better to always
--- explicitly return a value `()', rather than just copy the input to the
--- output, as the former gives GHC better local information.
---
-
--- | Element function expressing a mapping only
-#if !defined(LOOPNOACC_FUSION)
-mapEFL :: (Word8 -> Word8) -> AccEFL NoAcc
-mapEFL f = \_ e -> (NoAcc :*: (JustS $ f e))
-#else
-mapEFL :: (Word8 -> Word8) -> NoAccEFL
-mapEFL f = \e -> JustS (f e)
-#endif
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] mapEFL #-}
-#endif
-
--- | Element function implementing a filter function only
-#if !defined(LOOPNOACC_FUSION)
-filterEFL :: (Word8 -> Bool) -> AccEFL NoAcc
-filterEFL p = \_ e -> if p e then (NoAcc :*: JustS e) else (NoAcc :*: NothingS)
-#else
-filterEFL :: (Word8 -> Bool) -> NoAccEFL
-filterEFL p = \e -> if p e then JustS e else NothingS
-#endif
-
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] filterEFL #-}
-#endif
-
--- |Element function expressing a reduction only
-foldEFL :: (acc -> Word8 -> acc) -> AccEFL acc
-foldEFL f = \a e -> (f a e :*: NothingS)
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] foldEFL #-}
-#endif
-
--- | A strict foldEFL.
-foldEFL' :: (acc -> Word8 -> acc) -> AccEFL acc
-foldEFL' f = \a e -> let a' = f a e in a' `seq` (a' :*: NothingS)
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] foldEFL' #-}
-#endif
-
--- | Element function expressing a prefix reduction only
---
-scanEFL :: (Word8 -> Word8 -> Word8) -> AccEFL Word8
-scanEFL f = \a e -> (f a e :*: JustS a)
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] scanEFL #-}
-#endif
-
--- | Element function implementing a map and fold
---
-mapAccumEFL :: (acc -> Word8 -> (acc, Word8)) -> AccEFL acc
-mapAccumEFL f = \a e -> case f a e of (a', e') -> (a' :*: JustS e')
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] mapAccumEFL #-}
-#endif
-
--- | Element function implementing a map with index
---
-mapIndexEFL :: (Int -> Word8 -> Word8) -> AccEFL Int
-mapIndexEFL f = \i e -> let i' = i+1 in i' `seq` (i' :*: JustS (f i e))
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] mapIndexEFL #-}
-#endif
-
--- | Projection functions that are fusion friendly (as in, we determine when
--- they are inlined)
-loopArr :: (PairS acc arr) -> arr
-loopArr (_ :*: arr) = arr
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] loopArr #-}
-#endif
-
-loopAcc :: (PairS acc arr) -> acc
-loopAcc (acc :*: _) = acc
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] loopAcc #-}
-#endif
-
-loopSndAcc :: (PairS (PairS acc1 acc2) arr) -> (PairS acc2 arr)
-loopSndAcc ((_ :*: acc) :*: arr) = (acc :*: arr)
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] loopSndAcc #-}
-#endif
-
-unSP :: (PairS acc arr) -> (acc, arr)
-unSP (acc :*: arr) = (acc, arr)
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] unSP #-}
-#endif
-
-------------------------------------------------------------------------
---
--- Loop combinator and fusion rules for flat arrays
--- |Iteration over over ByteStrings
-
--- | Iteration over over ByteStrings
-loopU :: AccEFL acc -- ^ mapping & folding, once per elem
- -> acc -- ^ initial acc value
- -> ByteString -- ^ input ByteString
- -> (PairS acc ByteString)
-
-loopU f start (PS z s i) = unsafePerformIO $ withForeignPtr z $ \a -> do
- (ps, acc) <- createAndTrim' i $ \p -> do
- (acc' :*: i') <- go (a `plusPtr` s) p start
- return (0, i', acc')
- return (acc :*: ps)
-
- where
- go p ma = trans 0 0
- where
- STRICT3(trans)
- trans a_off ma_off acc
- | a_off >= i = return (acc :*: ma_off)
- | otherwise = do
- x <- peekByteOff p a_off
- let (acc' :*: oe) = f acc x
- ma_off' <- case oe of
- NothingS -> return ma_off
- JustS e -> do pokeByteOff ma ma_off e
- return $ ma_off + 1
- trans (a_off+1) ma_off' acc'
-
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] loopU #-}
-#endif
-
-{-# RULES
-
-"FPS loop/loop fusion!" forall em1 em2 start1 start2 arr.
- loopU em2 start2 (loopArr (loopU em1 start1 arr)) =
- loopSndAcc (loopU (em1 `fuseEFL` em2) (start1 :*: start2) arr)
-
- #-}
-
---
--- Functional list/array fusion for lazy ByteStrings.
---
-loopL :: AccEFL acc -- ^ mapping & folding, once per elem
- -> acc -- ^ initial acc value
- -> [ByteString] -- ^ input ByteString
- -> PairS acc [ByteString]
-loopL f = loop
- where loop s [] = (s :*: [])
- loop s (x:xs)
- | l == 0 = (s'' :*: ys)
- | otherwise = (s'' :*: y:ys)
- where (s' :*: y@(PS _ _ l)) = loopU f s x -- avoid circular dep on P.null
- (s'' :*: ys) = loop s' xs
-
-#if defined(__GLASGOW_HASKELL__)
-{-# INLINE [1] loopL #-}
-#endif
-
-{-# RULES
-
-"FPS lazy loop/loop fusion!" forall em1 em2 start1 start2 arr.
- loopL em2 start2 (loopArr (loopL em1 start1 arr)) =
- loopSndAcc (loopL (em1 `fuseEFL` em2) (start1 :*: start2) arr)
-
- #-}
-
-
-{-
-
-Alternate experimental formulation of loopU which partitions it into
-an allocating wrapper and an imperitive array-mutating loop.
-
-The point in doing this split is that we might be able to fuse multiple
-loops into a single wrapper. This would save reallocating another buffer.
-It should also give better cache locality by reusing the buffer.
-
-Note that this stuff needs ghc-6.5 from May 26 or later for the RULES to
-really work reliably.
-
--}
-
-loopUp :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString
-loopUp f a arr = loopWrapper (doUpLoop f a) arr
-{-# INLINE loopUp #-}
-
-loopDown :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString
-loopDown f a arr = loopWrapper (doDownLoop f a) arr
-{-# INLINE loopDown #-}
-
-loopNoAcc :: NoAccEFL -> ByteString -> PairS NoAcc ByteString
-loopNoAcc f arr = loopWrapper (doNoAccLoop f NoAcc) arr
-{-# INLINE loopNoAcc #-}
-
-loopMap :: MapEFL -> ByteString -> PairS NoAcc ByteString
-loopMap f arr = loopWrapper (doMapLoop f NoAcc) arr
-{-# INLINE loopMap #-}
-
-loopFilter :: FilterEFL -> ByteString -> PairS NoAcc ByteString
-loopFilter f arr = loopWrapper (doFilterLoop f NoAcc) arr
-{-# INLINE loopFilter #-}
-
--- The type of imperitive loops that fill in a destination array by
--- reading a source array. They may not fill in the whole of the dest
--- array if the loop is behaving as a filter, this is why we return
--- the length that was filled in. The loop may also accumulate some
--- value as it loops over the source array.
---
-type ImperativeLoop acc =
- Ptr Word8 -- pointer to the start of the source byte array
- -> Ptr Word8 -- pointer to ther start of the destination byte array
- -> Int -- length of the source byte array
- -> IO (PairS (PairS acc Int) Int) -- result and offset, length of dest that was filled
-
-loopWrapper :: ImperativeLoop acc -> ByteString -> PairS acc ByteString
-loopWrapper body (PS srcFPtr srcOffset srcLen) = unsafePerformIO $
- withForeignPtr srcFPtr $ \srcPtr -> do
- (ps, acc) <- createAndTrim' srcLen $ \destPtr -> do
- (acc :*: destOffset :*: destLen) <-
- body (srcPtr `plusPtr` srcOffset) destPtr srcLen
- return (destOffset, destLen, acc)
- return (acc :*: ps)
-
-doUpLoop :: AccEFL acc -> acc -> ImperativeLoop acc
-doUpLoop f acc0 src dest len = loop 0 0 acc0
- where STRICT3(loop)
- loop src_off dest_off acc
- | src_off >= len = return (acc :*: 0 :*: dest_off)
- | otherwise = do
- x <- peekByteOff src src_off
- case f acc x of
- (acc' :*: NothingS) -> loop (src_off+1) dest_off acc'
- (acc' :*: JustS x') -> pokeByteOff dest dest_off x'
- >> loop (src_off+1) (dest_off+1) acc'
-
-doDownLoop :: AccEFL acc -> acc -> ImperativeLoop acc
-doDownLoop f acc0 src dest len = loop (len-1) (len-1) acc0
- where STRICT3(loop)
- loop src_off dest_off acc
- | src_off < 0 = return (acc :*: dest_off + 1 :*: len - (dest_off + 1))
- | otherwise = do
- x <- peekByteOff src src_off
- case f acc x of
- (acc' :*: NothingS) -> loop (src_off-1) dest_off acc'
- (acc' :*: JustS x') -> pokeByteOff dest dest_off x'
- >> loop (src_off-1) (dest_off-1) acc'
-
-doNoAccLoop :: NoAccEFL -> noAcc -> ImperativeLoop noAcc
-doNoAccLoop f noAcc src dest len = loop 0 0
- where STRICT2(loop)
- loop src_off dest_off
- | src_off >= len = return (noAcc :*: 0 :*: dest_off)
- | otherwise = do
- x <- peekByteOff src src_off
- case f x of
- NothingS -> loop (src_off+1) dest_off
- JustS x' -> pokeByteOff dest dest_off x'
- >> loop (src_off+1) (dest_off+1)
-
-doMapLoop :: MapEFL -> noAcc -> ImperativeLoop noAcc
-doMapLoop f noAcc src dest len = loop 0
- where STRICT1(loop)
- loop n
- | n >= len = return (noAcc :*: 0 :*: len)
- | otherwise = do
- x <- peekByteOff src n
- pokeByteOff dest n (f x)
- loop (n+1) -- offset always the same, only pass 1 arg
-
-doFilterLoop :: FilterEFL -> noAcc -> ImperativeLoop noAcc
-doFilterLoop f noAcc src dest len = loop 0 0
- where STRICT2(loop)
- loop src_off dest_off
- | src_off >= len = return (noAcc :*: 0 :*: dest_off)
- | otherwise = do
- x <- peekByteOff src src_off
- if f x
- then pokeByteOff dest dest_off x
- >> loop (src_off+1) (dest_off+1)
- else loop (src_off+1) dest_off
-
--- run two loops in sequence,
--- think of it as: loop1 >> loop2
-sequenceLoops :: ImperativeLoop acc1
- -> ImperativeLoop acc2
- -> ImperativeLoop (PairS acc1 acc2)
-sequenceLoops loop1 loop2 src dest len0 = do
- (acc1 :*: off1 :*: len1) <- loop1 src dest len0
- (acc2 :*: off2 :*: len2) <-
- let src' = dest `plusPtr` off1
- dest' = src' -- note that we are using dest == src
- -- for the second loop as we are
- -- mutating the dest array in-place!
- in loop2 src' dest' len1
- return ((acc1 :*: acc2) :*: off1 + off2 :*: len2)
-
- -- TODO: prove that this is associative! (I think it is)
- -- since we can't be sure how the RULES will combine loops.
-
-#if defined(__GLASGOW_HASKELL__)
-
-{-# INLINE [1] doUpLoop #-}
-{-# INLINE [1] doDownLoop #-}
-{-# INLINE [1] doNoAccLoop #-}
-{-# INLINE [1] doMapLoop #-}
-{-# INLINE [1] doFilterLoop #-}
-
-{-# INLINE [1] loopWrapper #-}
-{-# INLINE [1] sequenceLoops #-}
-
-{-# INLINE [1] fuseAccAccEFL #-}
-{-# INLINE [1] fuseAccNoAccEFL #-}
-{-# INLINE [1] fuseNoAccAccEFL #-}
-{-# INLINE [1] fuseNoAccNoAccEFL #-}
-{-# INLINE [1] fuseMapAccEFL #-}
-{-# INLINE [1] fuseAccMapEFL #-}
-{-# INLINE [1] fuseMapNoAccEFL #-}
-{-# INLINE [1] fuseNoAccMapEFL #-}
-{-# INLINE [1] fuseMapMapEFL #-}
-{-# INLINE [1] fuseAccFilterEFL #-}
-{-# INLINE [1] fuseFilterAccEFL #-}
-{-# INLINE [1] fuseNoAccFilterEFL #-}
-{-# INLINE [1] fuseFilterNoAccEFL #-}
-{-# INLINE [1] fuseFilterFilterEFL #-}
-{-# INLINE [1] fuseMapFilterEFL #-}
-{-# INLINE [1] fuseFilterMapEFL #-}
-
-#endif
-
-{-# RULES
-
-"FPS loopArr/loopSndAcc" forall x.
- loopArr (loopSndAcc x) = loopArr x
-
-"FPS seq/NoAcc" forall (u::NoAcc) e.
- u `seq` e = e
-
-"FPS loop/loop wrapper elimination" forall loop1 loop2 arr.
- loopWrapper loop2 (loopArr (loopWrapper loop1 arr)) =
- loopSndAcc (loopWrapper (sequenceLoops loop1 loop2) arr)
-
---
--- n.b in the following, when reading n/m fusion, recall sequenceLoops
--- is monadic, so its really n >> m fusion (i.e. m.n), not n . m fusion.
---
-
-"FPS up/up loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doUpLoop f1 acc1) (doUpLoop f2 acc2) =
- doUpLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)
-
-"FPS map/map loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doMapLoop f1 acc1) (doMapLoop f2 acc2) =
- doMapLoop (f1 `fuseMapMapEFL` f2) (acc1 :*: acc2)
-
-"FPS filter/filter loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doFilterLoop f1 acc1) (doFilterLoop f2 acc2) =
- doFilterLoop (f1 `fuseFilterFilterEFL` f2) (acc1 :*: acc2)
-
-"FPS map/filter loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doMapLoop f1 acc1) (doFilterLoop f2 acc2) =
- doNoAccLoop (f1 `fuseMapFilterEFL` f2) (acc1 :*: acc2)
-
-"FPS filter/map loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doFilterLoop f1 acc1) (doMapLoop f2 acc2) =
- doNoAccLoop (f1 `fuseFilterMapEFL` f2) (acc1 :*: acc2)
-
-"FPS map/up loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doMapLoop f1 acc1) (doUpLoop f2 acc2) =
- doUpLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)
-
-"FPS up/map loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doUpLoop f1 acc1) (doMapLoop f2 acc2) =
- doUpLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)
-
-"FPS filter/up loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doFilterLoop f1 acc1) (doUpLoop f2 acc2) =
- doUpLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)
-
-"FPS up/filter loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doUpLoop f1 acc1) (doFilterLoop f2 acc2) =
- doUpLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)
-
-"FPS down/down loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doDownLoop f1 acc1) (doDownLoop f2 acc2) =
- doDownLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)
-
-"FPS map/down fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doMapLoop f1 acc1) (doDownLoop f2 acc2) =
- doDownLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)
-
-"FPS down/map loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doDownLoop f1 acc1) (doMapLoop f2 acc2) =
- doDownLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)
-
-"FPS filter/down fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doFilterLoop f1 acc1) (doDownLoop f2 acc2) =
- doDownLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)
-
-"FPS down/filter loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doDownLoop f1 acc1) (doFilterLoop f2 acc2) =
- doDownLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)
-
-"FPS noAcc/noAcc loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doNoAccLoop f1 acc1) (doNoAccLoop f2 acc2) =
- doNoAccLoop (f1 `fuseNoAccNoAccEFL` f2) (acc1 :*: acc2)
-
-"FPS noAcc/up loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doNoAccLoop f1 acc1) (doUpLoop f2 acc2) =
- doUpLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)
-
-"FPS up/noAcc loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doUpLoop f1 acc1) (doNoAccLoop f2 acc2) =
- doUpLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)
-
-"FPS map/noAcc loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doMapLoop f1 acc1) (doNoAccLoop f2 acc2) =
- doNoAccLoop (f1 `fuseMapNoAccEFL` f2) (acc1 :*: acc2)
-
-"FPS noAcc/map loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doNoAccLoop f1 acc1) (doMapLoop f2 acc2) =
- doNoAccLoop (f1 `fuseNoAccMapEFL` f2) (acc1 :*: acc2)
-
-"FPS filter/noAcc loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doFilterLoop f1 acc1) (doNoAccLoop f2 acc2) =
- doNoAccLoop (f1 `fuseFilterNoAccEFL` f2) (acc1 :*: acc2)
-
-"FPS noAcc/filter loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doNoAccLoop f1 acc1) (doFilterLoop f2 acc2) =
- doNoAccLoop (f1 `fuseNoAccFilterEFL` f2) (acc1 :*: acc2)
-
-"FPS noAcc/down loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doNoAccLoop f1 acc1) (doDownLoop f2 acc2) =
- doDownLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)
-
-"FPS down/noAcc loop fusion" forall f1 f2 acc1 acc2.
- sequenceLoops (doDownLoop f1 acc1) (doNoAccLoop f2 acc2) =
- doDownLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)
-
- #-}
-
-{-
-
-up = up loop
-down = down loop
-map = map special case
-filter = filter special case
-noAcc = noAcc undirectional loop (unused)
-
-heirarchy:
- up down
- ^ ^
- \ /
- noAcc
- ^ ^
- / \
- map filter
-
-each is a special case of the things above
-
-so we get rules that combine things on the same level
-and rules that combine things on different levels
-to get something on the higher level
-
-so all the cases:
-up/up --> up fuseAccAccEFL
-down/down --> down fuseAccAccEFL
-noAcc/noAcc --> noAcc fuseNoAccNoAccEFL
-
-noAcc/up --> up fuseNoAccAccEFL
-up/noAcc --> up fuseAccNoAccEFL
-noAcc/down --> down fuseNoAccAccEFL
-down/noAcc --> down fuseAccNoAccEFL
-
-and if we do the map, filter special cases then it adds a load more:
-
-map/map --> map fuseMapMapEFL
-filter/filter --> filter fuseFilterFilterEFL
-
-map/filter --> noAcc fuseMapFilterEFL
-filter/map --> noAcc fuseFilterMapEFL
-
-map/noAcc --> noAcc fuseMapNoAccEFL
-noAcc/map --> noAcc fuseNoAccMapEFL
-
-map/up --> up fuseMapAccEFL
-up/map --> up fuseAccMapEFL
-
-map/down --> down fuseMapAccEFL
-down/map --> down fuseAccMapEFL
-
-filter/noAcc --> noAcc fuseNoAccFilterEFL
-noAcc/filter --> noAcc fuseFilterNoAccEFL
-
-filter/up --> up fuseFilterAccEFL
-up/filter --> up fuseAccFilterEFL
-
-filter/down --> down fuseFilterAccEFL
-down/filter --> down fuseAccFilterEFL
--}
-
-fuseAccAccEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2)
-fuseAccAccEFL f g (acc1 :*: acc2) e1 =
- case f acc1 e1 of
- acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS
- acc1' :*: JustS e2 ->
- case g acc2 e2 of
- acc2' :*: res -> (acc1' :*: acc2') :*: res
-
-fuseAccNoAccEFL :: AccEFL acc -> NoAccEFL -> AccEFL (PairS acc noAcc)
-fuseAccNoAccEFL f g (acc :*: noAcc) e1 =
- case f acc e1 of
- acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS
- acc' :*: JustS e2 -> (acc' :*: noAcc) :*: g e2
-
-fuseNoAccAccEFL :: NoAccEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
-fuseNoAccAccEFL f g (noAcc :*: acc) e1 =
- case f e1 of
- NothingS -> (noAcc :*: acc) :*: NothingS
- JustS e2 ->
- case g acc e2 of
- acc' :*: res -> (noAcc :*: acc') :*: res
-
-fuseNoAccNoAccEFL :: NoAccEFL -> NoAccEFL -> NoAccEFL
-fuseNoAccNoAccEFL f g e1 =
- case f e1 of
- NothingS -> NothingS
- JustS e2 -> g e2
-
-fuseMapAccEFL :: MapEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
-fuseMapAccEFL f g (noAcc :*: acc) e1 =
- case g acc (f e1) of
- (acc' :*: res) -> (noAcc :*: acc') :*: res
-
-fuseAccMapEFL :: AccEFL acc -> MapEFL -> AccEFL (PairS acc noAcc)
-fuseAccMapEFL f g (acc :*: noAcc) e1 =
- case f acc e1 of
- (acc' :*: NothingS) -> (acc' :*: noAcc) :*: NothingS
- (acc' :*: JustS e2) -> (acc' :*: noAcc) :*: JustS (g e2)
-
-fuseMapMapEFL :: MapEFL -> MapEFL -> MapEFL
-fuseMapMapEFL f g e1 = g (f e1) -- n.b. perfect fusion
-
-fuseMapNoAccEFL :: MapEFL -> NoAccEFL -> NoAccEFL
-fuseMapNoAccEFL f g e1 = g (f e1)
-
-fuseNoAccMapEFL :: NoAccEFL -> MapEFL -> NoAccEFL
-fuseNoAccMapEFL f g e1 =
- case f e1 of
- NothingS -> NothingS
- JustS e2 -> JustS (g e2)
-
-fuseAccFilterEFL :: AccEFL acc -> FilterEFL -> AccEFL (PairS acc noAcc)
-fuseAccFilterEFL f g (acc :*: noAcc) e1 =
- case f acc e1 of
- acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS
- acc' :*: JustS e2 ->
- case g e2 of
- False -> (acc' :*: noAcc) :*: NothingS
- True -> (acc' :*: noAcc) :*: JustS e2
-
-fuseFilterAccEFL :: FilterEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
-fuseFilterAccEFL f g (noAcc :*: acc) e1 =
- case f e1 of
- False -> (noAcc :*: acc) :*: NothingS
- True ->
- case g acc e1 of
- acc' :*: res -> (noAcc :*: acc') :*: res
-
-fuseNoAccFilterEFL :: NoAccEFL -> FilterEFL -> NoAccEFL
-fuseNoAccFilterEFL f g e1 =
- case f e1 of
- NothingS -> NothingS
- JustS e2 ->
- case g e2 of
- False -> NothingS
- True -> JustS e2
-
-fuseFilterNoAccEFL :: FilterEFL -> NoAccEFL -> NoAccEFL
-fuseFilterNoAccEFL f g e1 =
- case f e1 of
- False -> NothingS
- True -> g e1
-
-fuseFilterFilterEFL :: FilterEFL -> FilterEFL -> FilterEFL
-fuseFilterFilterEFL f g e1 = f e1 && g e1
-
-fuseMapFilterEFL :: MapEFL -> FilterEFL -> NoAccEFL
-fuseMapFilterEFL f g e1 =
- case f e1 of
- e2 -> case g e2 of
- False -> NothingS
- True -> JustS e2
-
-fuseFilterMapEFL :: FilterEFL -> MapEFL -> NoAccEFL
-fuseFilterMapEFL f g e1 =
- case f e1 of
- False -> NothingS
- True -> JustS (g e1)
-
+++ /dev/null
-{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fno-warn-incomplete-patterns #-}
--- |
--- Module : Data.ByteString.Lazy
--- Copyright : (c) Don Stewart 2006
--- (c) Duncan Coutts 2006
--- License : BSD-style
---
--- Maintainer : dons@cse.unsw.edu.au
--- Stability : experimental
--- Portability : non-portable (instance of type synonym)
---
--- A time and space-efficient implementation of lazy byte vectors
--- using lists of packed 'Word8' arrays, suitable for high performance
--- use, both in terms of large data quantities, or high speed
--- requirements. Byte vectors are encoded as lazy lists of strict 'Word8'
--- arrays of bytes. They provide a means to manipulate large byte vectors
--- without requiring the entire vector be resident in memory.
---
--- Some operations, such as concat, append, reverse and cons, have
--- better complexity than their "Data.ByteString" equivalents, due to
--- optimisations resulting from the list spine structure. And for other
--- operations lazy ByteStrings are usually within a few percent of
--- strict ones, but with better heap usage. For data larger than the
--- available memory, or if you have tight memory constraints, this
--- module will be the only option. The default chunk size is 64k, which
--- should be good in most circumstances. For people with large L2
--- caches, you may want to increase this to fit your cache.
---
--- This module is intended to be imported @qualified@, to avoid name
--- clashes with "Prelude" functions. eg.
---
--- > import qualified Data.ByteString.Lazy as B
---
--- Original GHC implementation by Bryan O\'Sullivan.
--- Rewritten to use 'Data.Array.Unboxed.UArray' by Simon Marlow.
--- Rewritten to support slices and use 'Foreign.ForeignPtr.ForeignPtr'
--- by David Roundy.
--- Polished and extended by Don Stewart.
--- Lazy variant by Duncan Coutts and Don Stewart.
---
-
-module Data.ByteString.Lazy (
-
- -- * The @ByteString@ type
- ByteString, -- instances: Eq, Ord, Show, Read, Data, Typeable
-
- -- * Introducing and eliminating 'ByteString's
- empty, -- :: ByteString
- singleton, -- :: Word8 -> ByteString
- pack, -- :: [Word8] -> ByteString
- unpack, -- :: ByteString -> [Word8]
- fromChunks, -- :: [Strict.ByteString] -> ByteString
- toChunks, -- :: ByteString -> [Strict.ByteString]
-
- -- * Basic interface
- cons, -- :: Word8 -> ByteString -> ByteString
- snoc, -- :: ByteString -> Word8 -> ByteString
- append, -- :: ByteString -> ByteString -> ByteString
- head, -- :: ByteString -> Word8
- last, -- :: ByteString -> Word8
- tail, -- :: ByteString -> ByteString
- init, -- :: ByteString -> ByteString
- null, -- :: ByteString -> Bool
- length, -- :: ByteString -> Int64
-
- -- * Transformating ByteStrings
- map, -- :: (Word8 -> Word8) -> ByteString -> ByteString
- reverse, -- :: ByteString -> ByteString
--- intersperse, -- :: Word8 -> ByteString -> ByteString
- transpose, -- :: [ByteString] -> [ByteString]
-
- -- * Reducing 'ByteString's (folds)
- foldl, -- :: (a -> Word8 -> a) -> a -> ByteString -> a
- foldl', -- :: (a -> Word8 -> a) -> a -> ByteString -> a
- foldl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
- foldl1', -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
- foldr, -- :: (Word8 -> a -> a) -> a -> ByteString -> a
- foldr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
-
- -- ** Special folds
- concat, -- :: [ByteString] -> ByteString
- concatMap, -- :: (Word8 -> ByteString) -> ByteString -> ByteString
- any, -- :: (Word8 -> Bool) -> ByteString -> Bool
- all, -- :: (Word8 -> Bool) -> ByteString -> Bool
- maximum, -- :: ByteString -> Word8
- minimum, -- :: ByteString -> Word8
-
- -- * Building ByteStrings
- -- ** Scans
- scanl, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString
--- scanl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString
--- scanr, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString
--- scanr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString
-
- -- ** Accumulating maps
- mapAccumL, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString)
- mapIndexed, -- :: (Int64 -> Word8 -> Word8) -> ByteString -> ByteString
-
- -- ** Infinite ByteStrings
- repeat, -- :: Word8 -> ByteString
- replicate, -- :: Int64 -> Word8 -> ByteString
- cycle, -- :: ByteString -> ByteString
- iterate, -- :: (Word8 -> Word8) -> Word8 -> ByteString
-
- -- ** Unfolding
- unfoldr, -- :: (a -> Maybe (Word8, a)) -> a -> ByteString
-
- -- * Substrings
-
- -- ** Breaking strings
- take, -- :: Int64 -> ByteString -> ByteString
- drop, -- :: Int64 -> ByteString -> ByteString
- splitAt, -- :: Int64 -> ByteString -> (ByteString, ByteString)
- takeWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString
- dropWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString
- span, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
- break, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
- group, -- :: ByteString -> [ByteString]
- groupBy, -- :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString]
- inits, -- :: ByteString -> [ByteString]
- tails, -- :: ByteString -> [ByteString]
-
- -- ** Breaking into many substrings
- split, -- :: Word8 -> ByteString -> [ByteString]
- splitWith, -- :: (Word8 -> Bool) -> ByteString -> [ByteString]
-
- -- ** Joining strings
- join, -- :: ByteString -> [ByteString] -> ByteString
-
- -- * Predicates
- isPrefixOf, -- :: ByteString -> ByteString -> Bool
--- isSuffixOf, -- :: ByteString -> ByteString -> Bool
-
- -- * Searching ByteStrings
-
- -- ** Searching by equality
- elem, -- :: Word8 -> ByteString -> Bool
- notElem, -- :: Word8 -> ByteString -> Bool
-
- -- ** Searching with a predicate
- find, -- :: (Word8 -> Bool) -> ByteString -> Maybe Word8
- filter, -- :: (Word8 -> Bool) -> ByteString -> ByteString
--- partition -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
-
- -- * Indexing ByteStrings
- index, -- :: ByteString -> Int64 -> Word8
- elemIndex, -- :: Word8 -> ByteString -> Maybe Int64
- elemIndices, -- :: Word8 -> ByteString -> [Int64]
- findIndex, -- :: (Word8 -> Bool) -> ByteString -> Maybe Int64
- findIndices, -- :: (Word8 -> Bool) -> ByteString -> [Int64]
- count, -- :: Word8 -> ByteString -> Int64
-
- -- * Zipping and unzipping ByteStrings
- zip, -- :: ByteString -> ByteString -> [(Word8,Word8)]
- zipWith, -- :: (Word8 -> Word8 -> c) -> ByteString -> ByteString -> [c]
--- unzip, -- :: [(Word8,Word8)] -> (ByteString,ByteString)
-
- -- * Ordered ByteStrings
--- sort, -- :: ByteString -> ByteString
-
- copy, -- :: ByteString -> ByteString
-
- -- * I\/O with 'ByteString's
-
- -- ** Standard input and output
- getContents, -- :: IO ByteString
- putStr, -- :: ByteString -> IO ()
- putStrLn, -- :: ByteString -> IO ()
- interact, -- :: (ByteString -> ByteString) -> IO ()
-
- -- ** Files
- readFile, -- :: FilePath -> IO ByteString
- writeFile, -- :: FilePath -> ByteString -> IO ()
- appendFile, -- :: FilePath -> ByteString -> IO ()
-
- -- ** I\/O with Handles
- hGetContents, -- :: Handle -> IO ByteString
- hGet, -- :: Handle -> Int -> IO ByteString
- hPut, -- :: Handle -> ByteString -> IO ()
- hGetNonBlocking, -- :: Handle -> IO ByteString
-
--- hGetN, -- :: Int -> Handle -> Int -> IO ByteString
--- hGetContentsN, -- :: Int -> Handle -> IO ByteString
--- hGetNonBlockingN, -- :: Int -> Handle -> IO ByteString
-
- ) where
-
-import qualified Prelude
-import Prelude hiding
- (reverse,head,tail,last,init,null,length,map,lines,foldl,foldr,unlines
- ,concat,any,take,drop,splitAt,takeWhile,dropWhile,span,break,elem,filter,maximum
- ,minimum,all,concatMap,foldl1,foldr1,scanl, scanl1, scanr, scanr1
- ,repeat, cycle, interact, iterate,readFile,writeFile,appendFile,replicate
- ,getContents,getLine,putStr,putStrLn ,zip,zipWith,unzip,notElem)
-
-import qualified Data.List as L -- L for list/lazy
-import qualified Data.ByteString as P -- P for packed
-import qualified Data.ByteString.Base as P
-import Data.ByteString.Base (LazyByteString(..))
-import qualified Data.ByteString.Fusion as P
-import Data.ByteString.Fusion (PairS(..),loopL)
-
-import Data.Monoid (Monoid(..))
-
-import Data.Word (Word8)
-import Data.Int (Int64)
-import System.IO (Handle,stdin,stdout,openBinaryFile,IOMode(..)
- ,hClose,hWaitForInput,hIsEOF)
-import System.IO.Unsafe
-import Control.Exception (bracket)
-
-import Foreign.ForeignPtr (withForeignPtr)
-import Foreign.Ptr
-import Foreign.Storable
-
--- -----------------------------------------------------------------------------
---
--- Useful macros, until we have bang patterns
---
-
-#define STRICT1(f) f a | a `seq` False = undefined
-#define STRICT2(f) f a b | a `seq` b `seq` False = undefined
-#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
-#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined
-#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined
-
--- -----------------------------------------------------------------------------
-
-type ByteString = LazyByteString
-
---
--- hmm, what about getting the PS constructor unpacked into the cons cell?
---
--- data List = Nil | Cons {-# UNPACK #-} !P.ByteString List
---
--- Would avoid one indirection per chunk.
---
-
-unLPS :: ByteString -> [P.ByteString]
-unLPS (LPS xs) = xs
-{-# INLINE unLPS #-}
-
-instance Eq ByteString
- where (==) = eq
-
-instance Ord ByteString
- where compare = compareBytes
-
-instance Monoid ByteString where
- mempty = empty
- mappend = append
- mconcat = concat
-
-------------------------------------------------------------------------
-
--- XXX
--- The data type invariant:
--- Every ByteString is either empty or consists of non-null ByteStrings.
--- All functions must preserve this, and the QC properties must check this.
---
-_invariant :: ByteString -> Bool
-_invariant (LPS []) = True
-_invariant (LPS xs) = L.all (not . P.null) xs
-
--- In a form useful for QC testing
-_checkInvariant :: ByteString -> ByteString
-_checkInvariant lps
- | _invariant lps = lps
- | otherwise = moduleError "invariant" ("violation: " ++ show lps)
-
--- The Data abstraction function
---
-_abstr :: ByteString -> P.ByteString
-_abstr (LPS []) = P.empty
-_abstr (LPS xs) = P.concat xs
-
--- The representation uses lists of packed chunks. When we have to convert from
--- a lazy list to the chunked representation, then by default we'll use this
--- chunk size. Some functions give you more control over the chunk size.
---
--- Measurements here:
--- http://www.cse.unsw.edu.au/~dons/tmp/chunksize_v_cache.png
---
--- indicate that a value around 0.5 to 1 x your L2 cache is best.
--- The following value assumes people have something greater than 128k,
--- and need to share the cache with other programs.
---
-defaultChunkSize :: Int
-defaultChunkSize = 32 * k - overhead
- where k = 1024
- overhead = 2 * sizeOf (undefined :: Int)
-
-smallChunkSize :: Int
-smallChunkSize = 4 * k - overhead
- where k = 1024
- overhead = 2 * sizeOf (undefined :: Int)
-
--- defaultChunkSize = 1
-
-------------------------------------------------------------------------
-
-eq :: ByteString -> ByteString -> Bool
-eq (LPS xs) (LPS ys) = eq' xs ys
- where eq' [] [] = True
- eq' [] _ = False
- eq' _ [] = False
- eq' (a:as) (b:bs) =
- case compare (P.length a) (P.length b) of
- LT -> a == (P.take (P.length a) b) && eq' as (P.drop (P.length a) b : bs)
- EQ -> a == b && eq' as bs
- GT -> (P.take (P.length b) a) == b && eq' (P.drop (P.length b) a : as) bs
-
-compareBytes :: ByteString -> ByteString -> Ordering
-compareBytes (LPS xs) (LPS ys) = cmp xs ys
- where cmp [] [] = EQ
- cmp [] _ = LT
- cmp _ [] = GT
- cmp (a:as) (b:bs) =
- case compare (P.length a) (P.length b) of
- LT -> case compare a (P.take (P.length a) b) of
- EQ -> cmp as (P.drop (P.length a) b : bs)
- result -> result
- EQ -> case compare a b of
- EQ -> cmp as bs
- result -> result
- GT -> case compare (P.take (P.length b) a) b of
- EQ -> cmp (P.drop (P.length b) a : as) bs
- result -> result
-
--- -----------------------------------------------------------------------------
--- Introducing and eliminating 'ByteString's
-
--- | /O(1)/ The empty 'ByteString'
-empty :: ByteString
-empty = LPS []
-{-# NOINLINE empty #-}
-
--- | /O(1)/ Convert a 'Word8' into a 'ByteString'
-singleton :: Word8 -> ByteString
-singleton c = LPS [P.singleton c]
-{-# NOINLINE singleton #-}
-
--- | /O(n)/ Convert a '[Word8]' into a 'ByteString'.
-pack :: [Word8] -> ByteString
-pack str = LPS $ L.map P.pack (chunk defaultChunkSize str)
-
--- ?
-chunk :: Int -> [a] -> [[a]]
-chunk _ [] = []
-chunk size xs = case L.splitAt size xs of (xs', xs'') -> xs' : chunk size xs''
-
--- | /O(n)/ Converts a 'ByteString' to a '[Word8]'.
-unpack :: ByteString -> [Word8]
-unpack (LPS ss) = L.concatMap P.unpack ss
-{-# INLINE unpack #-}
-
--- | /O(c)/ Convert a list of strict 'ByteString' into a lazy 'ByteString'
-fromChunks :: [P.ByteString] -> ByteString
-fromChunks ls = LPS $ L.filter (not . P.null) ls
-
--- | /O(n)/ Convert a lazy 'ByteString' into a list of strict 'ByteString'
-toChunks :: ByteString -> [P.ByteString]
-toChunks (LPS s) = s
-
-------------------------------------------------------------------------
-
-{-
--- | /O(n)/ Convert a '[a]' into a 'ByteString' using some
--- conversion function
-packWith :: (a -> Word8) -> [a] -> ByteString
-packWith k str = LPS $ L.map (P.packWith k) (chunk defaultChunkSize str)
-{-# INLINE packWith #-}
-{-# SPECIALIZE packWith :: (Char -> Word8) -> [Char] -> ByteString #-}
-
--- | /O(n)/ Converts a 'ByteString' to a '[a]', using a conversion function.
-unpackWith :: (Word8 -> a) -> ByteString -> [a]
-unpackWith k (LPS ss) = L.concatMap (P.unpackWith k) ss
-{-# INLINE unpackWith #-}
-{-# SPECIALIZE unpackWith :: (Word8 -> Char) -> ByteString -> [Char] #-}
--}
-
--- ---------------------------------------------------------------------
--- Basic interface
-
--- | /O(1)/ Test whether a ByteString is empty.
-null :: ByteString -> Bool
-null (LPS []) = True
-null (_) = False
-{-# INLINE null #-}
-
--- | /O(n\/c)/ 'length' returns the length of a ByteString as an 'Int64'
-length :: ByteString -> Int64
-length (LPS ss) = L.foldl' (\n ps -> n + fromIntegral (P.length ps)) 0 ss
-
--- avoid the intermediate list?
--- length (LPS ss) = L.foldl lengthF 0 ss
--- where lengthF n s = let m = n + fromIntegral (P.length s) in m `seq` m
-{-# INLINE length #-}
-
--- | /O(1)/ 'cons' is analogous to '(:)' for lists. Unlike '(:)' however it is
--- strict in the ByteString that we are consing onto. More precisely, it forces
--- the head and the first chunk. It does this because, for space efficiency, it
--- may coalesce the new byte onto the first \'chunk\' rather than starting a
--- new \'chunk\'.
---
--- So that means you can't use a lazy recursive contruction like this:
---
--- > let xs = cons c xs in xs
---
--- You can however use 'repeat' and 'cycle' to build infinite lazy ByteStrings.
---
-cons :: Word8 -> ByteString -> ByteString
-cons c (LPS (s:ss)) | P.length s < 16 = LPS (P.cons c s : ss)
-cons c (LPS ss) = LPS (P.singleton c : ss)
-{-# INLINE cons #-}
-
--- | /O(n\/c)/ Append a byte to the end of a 'ByteString'
-snoc :: ByteString -> Word8 -> ByteString
-snoc (LPS ss) c = LPS (ss ++ [P.singleton c])
-{-# INLINE snoc #-}
-
--- | /O(1)/ Extract the first element of a ByteString, which must be non-empty.
-head :: ByteString -> Word8
-head (LPS []) = errorEmptyList "head"
-head (LPS (x:_)) = P.unsafeHead x
-{-# INLINE head #-}
-
--- | /O(1)/ Extract the elements after the head of a ByteString, which must be non-empty.
-tail :: ByteString -> ByteString
-tail (LPS []) = errorEmptyList "tail"
-tail (LPS (x:xs))
- | P.length x == 1 = LPS xs
- | otherwise = LPS (P.unsafeTail x : xs)
-{-# INLINE tail #-}
-
--- | /O(n\/c)/ Extract the last element of a ByteString, which must be finite and non-empty.
-last :: ByteString -> Word8
-last (LPS []) = errorEmptyList "last"
-last (LPS xs) = P.last (L.last xs)
-{-# INLINE last #-}
-
--- | /O(n\/c)/ Return all the elements of a 'ByteString' except the last one.
-init :: ByteString -> ByteString
-init (LPS []) = errorEmptyList "init"
-init (LPS xs)
- | P.length y == 1 = LPS ys
- | otherwise = LPS (ys ++ [P.init y])
- where (y,ys) = (L.last xs, L.init xs)
-{-# INLINE init #-}
-
--- | /O(n)/ Append two ByteStrings
-append :: ByteString -> ByteString -> ByteString
-append (LPS []) (LPS ys) = LPS ys
-append (LPS xs) (LPS []) = LPS xs
-append (LPS xs) (LPS ys) = LPS (xs ++ ys)
-{-# INLINE append #-}
-
--- ---------------------------------------------------------------------
--- Transformations
-
--- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each
--- element of @xs@.
-map :: (Word8 -> Word8) -> ByteString -> ByteString
---map f (LPS xs) = LPS (L.map (P.map' f) xs)
-map f = LPS . P.loopArr . loopL (P.mapEFL f) P.NoAcc . unLPS
-{-# INLINE map #-}
-
--- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order.
-reverse :: ByteString -> ByteString
-reverse (LPS ps) = LPS (rev [] ps)
- where rev a [] = a
- rev a (x:xs) = rev (P.reverse x:a) xs
--- note, here is one example where the extra element lazyness is an advantage.
--- we can reerse the list of chunks strictly but reverse each chunk lazily
--- so while we may force the whole lot into memory we do not need to copy
--- each chunk until it is used.
-{-# INLINE reverse #-}
-
--- The 'intersperse' function takes a 'Word8' and a 'ByteString' and
--- \`intersperses\' that byte between the elements of the 'ByteString'.
--- It is analogous to the intersperse function on Lists.
--- intersperse :: Word8 -> ByteString -> ByteString
--- intersperse = error "FIXME: not yet implemented"
-
-{-
-intersperse c (LPS []) = LPS []
-intersperse c (LPS (x:xs)) = LPS (P.intersperse c x : L.map intersperse')
- where intersperse' c ps@(PS x s l) =
- P.create (2*l) $ \p -> withForeignPtr x $ \f ->
- poke p c
- c_intersperse (p `plusPtr` 1) (f `plusPtr` s) l c
--}
-
--- | The 'transpose' function transposes the rows and columns of its
--- 'ByteString' argument.
-transpose :: [ByteString] -> [ByteString]
-transpose s = L.map (\ss -> LPS [P.pack ss]) (L.transpose (L.map unpack s))
-
--- ---------------------------------------------------------------------
--- Reducing 'ByteString's
-
--- | 'foldl', applied to a binary operator, a starting value (typically
--- the left-identity of the operator), and a ByteString, reduces the
--- ByteString using the binary operator, from left to right.
-foldl :: (a -> Word8 -> a) -> a -> ByteString -> a
---foldl f z (LPS xs) = L.foldl (P.foldl f) z xs
-foldl f z = P.loopAcc . loopL (P.foldEFL f) z . unLPS
-{-# INLINE foldl #-}
-
--- | 'foldl\'' is like 'foldl', but strict in the accumulator.
-foldl' :: (a -> Word8 -> a) -> a -> ByteString -> a
---foldl' f z (LPS xs) = L.foldl' (P.foldl' f) z xs
-foldl' f z = P.loopAcc . loopL (P.foldEFL' f) z . unLPS
-{-# INLINE foldl' #-}
-
--- | 'foldr', applied to a binary operator, a starting value
--- (typically the right-identity of the operator), and a ByteString,
--- reduces the ByteString using the binary operator, from right to left.
-foldr :: (Word8 -> a -> a) -> a -> ByteString -> a
-foldr k z (LPS xs) = L.foldr (flip (P.foldr k)) z xs
-{-# INLINE foldr #-}
-
--- | 'foldl1' is a variant of 'foldl' that has no starting value
--- argument, and thus must be applied to non-empty 'ByteStrings'.
--- This function is subject to array fusion.
-foldl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
-foldl1 _ (LPS []) = errorEmptyList "foldl1"
-foldl1 f (LPS (x:xs)) = foldl f (P.unsafeHead x) (LPS (P.unsafeTail x : xs))
-
--- | 'foldl1\'' is like 'foldl1', but strict in the accumulator.
-foldl1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
-foldl1' _ (LPS []) = errorEmptyList "foldl1'"
-foldl1' f (LPS (x:xs)) = foldl' f (P.unsafeHead x) (LPS (P.unsafeTail x : xs))
-
--- | 'foldr1' is a variant of 'foldr' that has no starting value argument,
--- and thus must be applied to non-empty 'ByteString's
-foldr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
-foldr1 _ (LPS []) = errorEmptyList "foldr1"
-foldr1 f (LPS ps) = foldr1' ps
- where foldr1' (x:[]) = P.foldr1 f x
- foldr1' (x:xs) = P.foldr f (foldr1' xs) x
-
--- ---------------------------------------------------------------------
--- Special folds
-
--- | /O(n)/ Concatenate a list of ByteStrings.
-concat :: [ByteString] -> ByteString
-concat lpss = LPS (L.concatMap (\(LPS xs) -> xs) lpss)
-
--- | Map a function over a 'ByteString' and concatenate the results
-concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString
-concatMap f (LPS lps) = LPS (filterMap (P.concatMap k) lps)
- where
- k w = case f w of LPS xs -> P.concat xs
-
--- | /O(n)/ Applied to a predicate and a ByteString, 'any' determines if
--- any element of the 'ByteString' satisfies the predicate.
-any :: (Word8 -> Bool) -> ByteString -> Bool
-any f (LPS xs) = L.or (L.map (P.any f) xs)
--- todo fuse
-
--- | /O(n)/ Applied to a predicate and a 'ByteString', 'all' determines
--- if all elements of the 'ByteString' satisfy the predicate.
-all :: (Word8 -> Bool) -> ByteString -> Bool
-all f (LPS xs) = L.and (L.map (P.all f) xs)
--- todo fuse
-
--- | /O(n)/ 'maximum' returns the maximum value from a 'ByteString'
-maximum :: ByteString -> Word8
-maximum (LPS []) = errorEmptyList "maximum"
-maximum (LPS (x:xs)) = L.foldl' (\n ps -> n `max` P.maximum ps) (P.maximum x) xs
-{-# INLINE maximum #-}
-
--- | /O(n)/ 'minimum' returns the minimum value from a 'ByteString'
-minimum :: ByteString -> Word8
-minimum (LPS []) = errorEmptyList "minimum"
-minimum (LPS (x:xs)) = L.foldl' (\n ps -> n `min` P.minimum ps) (P.minimum x) xs
-{-# INLINE minimum #-}
-
--- | The 'mapAccumL' function behaves like a combination of 'map' and
--- 'foldl'; it applies a function to each element of a ByteString,
--- passing an accumulating parameter from left to right, and returning a
--- final value of this accumulator together with the new ByteString.
-mapAccumL :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString)
-mapAccumL f z = (\(a :*: ps) -> (a, LPS ps)) . loopL (P.mapAccumEFL f) z . unLPS
-
--- | /O(n)/ map Word8 functions, provided with the index at each position
-mapIndexed :: (Int -> Word8 -> Word8) -> ByteString -> ByteString
-mapIndexed f = LPS . P.loopArr . loopL (P.mapIndexEFL f) 0 . unLPS
-
--- ---------------------------------------------------------------------
--- Building ByteStrings
-
--- | 'scanl' is similar to 'foldl', but returns a list of successive
--- reduced values from the left. This function will fuse.
---
--- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
---
--- Note that
---
--- > last (scanl f z xs) == foldl f z xs.
-scanl :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString
-scanl f z ps = LPS . P.loopArr . loopL (P.scanEFL f) z . unLPS $ (ps `snoc` 0)
-{-# INLINE scanl #-}
-
--- ---------------------------------------------------------------------
--- Unfolds and replicates
-
--- | @'iterate' f x@ returns an infinite ByteString of repeated applications
--- of @f@ to @x@:
---
--- > iterate f x == [x, f x, f (f x), ...]
---
-iterate :: (Word8 -> Word8) -> Word8 -> ByteString
-iterate f = unfoldr (\x -> case f x of x' -> x' `seq` Just (x', x'))
-
--- | @'repeat' x@ is an infinite ByteString, with @x@ the value of every
--- element.
---
-repeat :: Word8 -> ByteString
-repeat c = LPS (L.repeat block)
- where block = P.replicate smallChunkSize c
-
--- | /O(n)/ @'replicate' n x@ is a ByteString of length @n@ with @x@
--- the value of every element.
---
-replicate :: Int64 -> Word8 -> ByteString
-replicate w c
- | w <= 0 = empty
- | w < fromIntegral smallChunkSize = LPS [P.replicate (fromIntegral w) c]
- | r == 0 = LPS (L.genericReplicate q s) -- preserve invariant
- | otherwise = LPS (P.unsafeTake (fromIntegral r) s : L.genericReplicate q s)
- where
- s = P.replicate smallChunkSize c
- (q, r) = quotRem w (fromIntegral smallChunkSize)
-
--- | 'cycle' ties a finite ByteString into a circular one, or equivalently,
--- the infinite repetition of the original ByteString.
---
-cycle :: ByteString -> ByteString
-cycle (LPS []) = errorEmptyList "cycle"
-cycle (LPS xs) = LPS (L.cycle xs)
-
--- | /O(n)/ The 'unfoldr' function is analogous to the List \'unfoldr\'.
--- 'unfoldr' builds a ByteString from a seed value. The function takes
--- the element and returns 'Nothing' if it is done producing the
--- ByteString or returns 'Just' @(a,b)@, in which case, @a@ is a
--- prepending to the ByteString and @b@ is used as the next element in a
--- recursive call.
-unfoldr :: (a -> Maybe (Word8, a)) -> a -> ByteString
-unfoldr f = LPS . unfoldChunk 32
- where unfoldChunk n x =
- case P.unfoldrN n f x of
- (s, Nothing)
- | P.null s -> []
- | otherwise -> s : []
- (s, Just x') -> s : unfoldChunk ((n*2) `min` smallChunkSize) x'
-
--- ---------------------------------------------------------------------
--- Substrings
-
--- | /O(n\/c)/ 'take' @n@, applied to a ByteString @xs@, returns the prefix
--- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@.
-take :: Int64 -> ByteString -> ByteString
-take i _ | i <= 0 = empty
-take i (LPS ps) = LPS (take' i ps)
- where take' 0 _ = []
- take' _ [] = []
- take' n (x:xs) =
- if n < fromIntegral (P.length x)
- then P.take (fromIntegral n) x : []
- else x : take' (n - fromIntegral (P.length x)) xs
-
--- | /O(n\/c)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@
--- elements, or @[]@ if @n > 'length' xs@.
-drop :: Int64 -> ByteString -> ByteString
-drop i p | i <= 0 = p
-drop i (LPS ps) = LPS (drop' i ps)
- where drop' 0 xs = xs
- drop' _ [] = []
- drop' n (x:xs) =
- if n < fromIntegral (P.length x)
- then P.drop (fromIntegral n) x : xs
- else drop' (n - fromIntegral (P.length x)) xs
-
--- | /O(n\/c)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@.
-splitAt :: Int64 -> ByteString -> (ByteString, ByteString)
-splitAt i p | i <= 0 = (empty, p)
-splitAt i (LPS ps) = case splitAt' i ps of (a,b) -> (LPS a, LPS b)
- where splitAt' 0 xs = ([], xs)
- splitAt' _ [] = ([], [])
- splitAt' n (x:xs) =
- if n < fromIntegral (P.length x)
- then (P.take (fromIntegral n) x : [],
- P.drop (fromIntegral n) x : xs)
- else let (xs', xs'') = splitAt' (n - fromIntegral (P.length x)) xs
- in (x:xs', xs'')
-
-
--- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@,
--- returns the longest prefix (possibly empty) of @xs@ of elements that
--- satisfy @p@.
-takeWhile :: (Word8 -> Bool) -> ByteString -> ByteString
-takeWhile f (LPS ps) = LPS (takeWhile' ps)
- where takeWhile' [] = []
- takeWhile' (x:xs) =
- case findIndexOrEnd (not . f) x of
- 0 -> []
- n | n < P.length x -> P.take n x : []
- | otherwise -> x : takeWhile' xs
-
--- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@.
-dropWhile :: (Word8 -> Bool) -> ByteString -> ByteString
-dropWhile f (LPS ps) = LPS (dropWhile' ps)
- where dropWhile' [] = []
- dropWhile' (x:xs) =
- case findIndexOrEnd (not . f) x of
- n | n < P.length x -> P.drop n x : xs
- | otherwise -> dropWhile' xs
-
--- | 'break' @p@ is equivalent to @'span' ('not' . p)@.
-break :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
-break f (LPS ps) = case (break' ps) of (a,b) -> (LPS a, LPS b)
- where break' [] = ([], [])
- break' (x:xs) =
- case findIndexOrEnd f x of
- 0 -> ([], x : xs)
- n | n < P.length x -> (P.take n x : [], P.drop n x : xs)
- | otherwise -> let (xs', xs'') = break' xs
- in (x : xs', xs'')
-
---
--- TODO
---
--- Add rules
---
-
-{-
--- | 'breakByte' breaks its ByteString argument at the first occurence
--- of the specified byte. It is more efficient than 'break' as it is
--- implemented with @memchr(3)@. I.e.
---
--- > break (=='c') "abcd" == breakByte 'c' "abcd"
---
-breakByte :: Word8 -> ByteString -> (ByteString, ByteString)
-breakByte c (LPS ps) = case (breakByte' ps) of (a,b) -> (LPS a, LPS b)
- where breakByte' [] = ([], [])
- breakByte' (x:xs) =
- case P.elemIndex c x of
- Just 0 -> ([], x : xs)
- Just n -> (P.take n x : [], P.drop n x : xs)
- Nothing -> let (xs', xs'') = breakByte' xs
- in (x : xs', xs'')
-
--- | 'spanByte' breaks its ByteString argument at the first
--- occurence of a byte other than its argument. It is more efficient
--- than 'span (==)'
---
--- > span (=='c') "abcd" == spanByte 'c' "abcd"
---
-spanByte :: Word8 -> ByteString -> (ByteString, ByteString)
-spanByte c (LPS ps) = case (spanByte' ps) of (a,b) -> (LPS a, LPS b)
- where spanByte' [] = ([], [])
- spanByte' (x:xs) =
- case P.spanByte c x of
- (x', x'') | P.null x' -> ([], x : xs)
- | P.null x'' -> let (xs', xs'') = spanByte' xs
- in (x : xs', xs'')
- | otherwise -> (x' : [], x'' : xs)
--}
-
--- | 'span' @p xs@ breaks the ByteString into two segments. It is
--- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@
-span :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
-span p = break (not . p)
-
--- | /O(n)/ Splits a 'ByteString' into components delimited by
--- separators, where the predicate returns True for a separator element.
--- The resulting components do not contain the separators. Two adjacent
--- separators result in an empty component in the output. eg.
---
--- > splitWith (=='a') "aabbaca" == ["","","bb","c",""]
--- > splitWith (=='a') [] == []
---
-splitWith :: (Word8 -> Bool) -> ByteString -> [ByteString]
-splitWith _ (LPS []) = []
-splitWith p (LPS (a:as)) = comb [] (P.splitWith p a) as
-
- where comb :: [P.ByteString] -> [P.ByteString] -> [P.ByteString] -> [ByteString]
- comb acc (s:[]) [] = LPS (L.reverse (cons' s acc)) : []
- comb acc (s:[]) (x:xs) = comb (cons' s acc) (P.splitWith p x) xs
- comb acc (s:ss) xs = LPS (L.reverse (cons' s acc)) : comb [] ss xs
-
- cons' x xs | P.null x = xs
- | otherwise = x:xs
- {-# INLINE cons' #-}
-{-# INLINE splitWith #-}
-
--- | /O(n)/ Break a 'ByteString' into pieces separated by the byte
--- argument, consuming the delimiter. I.e.
---
--- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"]
--- > split 'a' "aXaXaXa" == ["","X","X","X",""]
--- > split 'x' "x" == ["",""]
---
--- and
---
--- > join [c] . split c == id
--- > split == splitWith . (==)
---
--- As for all splitting functions in this library, this function does
--- not copy the substrings, it just constructs new 'ByteStrings' that
--- are slices of the original.
---
-split :: Word8 -> ByteString -> [ByteString]
-split _ (LPS []) = []
-split c (LPS (a:as)) = comb [] (P.split c a) as
-
- where comb :: [P.ByteString] -> [P.ByteString] -> [P.ByteString] -> [ByteString]
- comb acc (s:[]) [] = LPS (L.reverse (cons' s acc)) : []
- comb acc (s:[]) (x:xs) = comb (cons' s acc) (P.split c x) xs
- comb acc (s:ss) xs = LPS (L.reverse (cons' s acc)) : comb [] ss xs
-
- cons' x xs | P.null x = xs
- | otherwise = x:xs
- {-# INLINE cons' #-}
-{-# INLINE split #-}
-
-{-
--- | Like 'splitWith', except that sequences of adjacent separators are
--- treated as a single separator. eg.
---
--- > tokens (=='a') "aabbaca" == ["bb","c"]
---
-tokens :: (Word8 -> Bool) -> ByteString -> [ByteString]
-tokens f = L.filter (not.null) . splitWith f
--}
-
--- | The 'group' function takes a ByteString and returns a list of
--- ByteStrings such that the concatenation of the result is equal to the
--- argument. Moreover, each sublist in the result contains only equal
--- elements. For example,
---
--- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"]
---
--- It is a special case of 'groupBy', which allows the programmer to
--- supply their own equality test.
-group :: ByteString -> [ByteString]
-group (LPS []) = []
-group (LPS (a:as)) = group' [] (P.group a) as
- where group' :: [P.ByteString] -> [P.ByteString] -> [P.ByteString] -> [ByteString]
- group' acc@(s':_) ss@(s:_) xs
- | P.unsafeHead s'
- /= P.unsafeHead s = LPS (L.reverse acc) : group' [] ss xs
- group' acc (s:[]) [] = LPS (L.reverse (s : acc)) : []
- group' acc (s:[]) (x:xs) = group' (s:acc) (P.group x) xs
- group' acc (s:ss) xs = LPS (L.reverse (s : acc)) : group' [] ss xs
-
-{-
-TODO: check if something like this might be faster
-
-group :: ByteString -> [ByteString]
-group xs
- | null xs = []
- | otherwise = ys : group zs
- where
- (ys, zs) = spanByte (unsafeHead xs) xs
--}
-
--- | The 'groupBy' function is the non-overloaded version of 'group'.
---
-groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString]
-groupBy = error "Data.ByteString.Lazy.groupBy: unimplemented"
-{-
-groupBy _ (LPS []) = []
-groupBy k (LPS (a:as)) = groupBy' [] 0 (P.groupBy k a) as
- where groupBy' :: [P.ByteString] -> Word8 -> [P.ByteString] -> [P.ByteString] -> [ByteString]
- groupBy' acc@(_:_) c ss@(s:_) xs
- | not (c `k` P.unsafeHead s) = LPS (L.reverse acc) : groupBy' [] 0 ss xs
- groupBy' acc _ (s:[]) [] = LPS (L.reverse (s : acc)) : []
- groupBy' [] _ (s:[]) (x:xs) = groupBy' (s:[]) (P.unsafeHead s) (P.groupBy k x) xs
- groupBy' acc c (s:[]) (x:xs) = groupBy' (s:acc) c (P.groupBy k x) xs
- groupBy' acc _ (s:ss) xs = LPS (L.reverse (s : acc)) : groupBy' [] 0 ss xs
--}
-
-{-
-TODO: check if something like this might be faster
-
-groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString]
-groupBy k xs
- | null xs = []
- | otherwise = take n xs : groupBy k (drop n xs)
- where
- n = 1 + findIndexOrEnd (not . k (head xs)) (tail xs)
--}
-
--- | /O(n)/ The 'join' function takes a 'ByteString' and a list of
--- 'ByteString's and concatenates the list after interspersing the first
--- argument between each element of the list.
-join :: ByteString -> [ByteString] -> ByteString
-join s = concat . (L.intersperse s)
-
--- ---------------------------------------------------------------------
--- Indexing ByteStrings
-
--- | /O(c)/ 'ByteString' index (subscript) operator, starting from 0.
-index :: ByteString -> Int64 -> Word8
-index _ i | i < 0 = moduleError "index" ("negative index: " ++ show i)
-index (LPS ps) i = index' ps i
- where index' [] n = moduleError "index" ("index too large: " ++ show n)
- index' (x:xs) n
- | n >= fromIntegral (P.length x) =
- index' xs (n - fromIntegral (P.length x))
- | otherwise = P.unsafeIndex x (fromIntegral n)
-
--- | /O(n)/ The 'elemIndex' function returns the index of the first
--- element in the given 'ByteString' which is equal to the query
--- element, or 'Nothing' if there is no such element.
--- This implementation uses memchr(3).
-elemIndex :: Word8 -> ByteString -> Maybe Int64
-elemIndex c (LPS ps) = elemIndex' 0 ps
- where elemIndex' _ [] = Nothing
- elemIndex' n (x:xs) =
- case P.elemIndex c x of
- Nothing -> elemIndex' (n + fromIntegral (P.length x)) xs
- Just i -> Just (n + fromIntegral i)
-
-{-
--- | /O(n)/ The 'elemIndexEnd' function returns the last index of the
--- element in the given 'ByteString' which is equal to the query
--- element, or 'Nothing' if there is no such element. The following
--- holds:
---
--- > elemIndexEnd c xs ==
--- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs)
---
-elemIndexEnd :: Word8 -> ByteString -> Maybe Int
-elemIndexEnd ch (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p ->
- go (p `plusPtr` s) (l-1)
- where
- STRICT2(go)
- go p i | i < 0 = return Nothing
- | otherwise = do ch' <- peekByteOff p i
- if ch == ch'
- then return $ Just i
- else go p (i-1)
--}
--- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning
--- the indices of all elements equal to the query element, in ascending order.
--- This implementation uses memchr(3).
-elemIndices :: Word8 -> ByteString -> [Int64]
-elemIndices c (LPS ps) = elemIndices' 0 ps
- where elemIndices' _ [] = []
- elemIndices' n (x:xs) = L.map ((+n).fromIntegral) (P.elemIndices c x)
- ++ elemIndices' (n + fromIntegral (P.length x)) xs
-
--- | count returns the number of times its argument appears in the ByteString
---
--- > count = length . elemIndices
---
--- But more efficiently than using length on the intermediate list.
-count :: Word8 -> ByteString -> Int64
-count w (LPS xs) = L.foldl' (\n ps -> n + fromIntegral (P.count w ps)) 0 xs
-
--- | The 'findIndex' function takes a predicate and a 'ByteString' and
--- returns the index of the first element in the ByteString
--- satisfying the predicate.
-findIndex :: (Word8 -> Bool) -> ByteString -> Maybe Int64
-findIndex k (LPS ps) = findIndex' 0 ps
- where findIndex' _ [] = Nothing
- findIndex' n (x:xs) =
- case P.findIndex k x of
- Nothing -> findIndex' (n + fromIntegral (P.length x)) xs
- Just i -> Just (n + fromIntegral i)
-{-# INLINE findIndex #-}
-
--- | /O(n)/ The 'find' function takes a predicate and a ByteString,
--- and returns the first element in matching the predicate, or 'Nothing'
--- if there is no such element.
---
--- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing
---
-find :: (Word8 -> Bool) -> ByteString -> Maybe Word8
-find f (LPS ps) = find' ps
- where find' [] = Nothing
- find' (x:xs) = case P.find f x of
- Nothing -> find' xs
- Just w -> Just w
-{-# INLINE find #-}
-
--- | The 'findIndices' function extends 'findIndex', by returning the
--- indices of all elements satisfying the predicate, in ascending order.
-findIndices :: (Word8 -> Bool) -> ByteString -> [Int64]
-findIndices k (LPS ps) = findIndices' 0 ps
- where findIndices' _ [] = []
- findIndices' n (x:xs) = L.map ((+n).fromIntegral) (P.findIndices k x)
- ++ findIndices' (n + fromIntegral (P.length x)) xs
-
--- ---------------------------------------------------------------------
--- Searching ByteStrings
-
--- | /O(n)/ 'elem' is the 'ByteString' membership predicate.
-elem :: Word8 -> ByteString -> Bool
-elem c ps = case elemIndex c ps of Nothing -> False ; _ -> True
-
--- | /O(n)/ 'notElem' is the inverse of 'elem'
-notElem :: Word8 -> ByteString -> Bool
-notElem c ps = not (elem c ps)
-
--- | /O(n)/ 'filter', applied to a predicate and a ByteString,
--- returns a ByteString containing those characters that satisfy the
--- predicate.
-filter :: (Word8 -> Bool) -> ByteString -> ByteString
---filter f (LPS xs) = LPS (filterMap (P.filter' f) xs)
-filter p = LPS . P.loopArr . loopL (P.filterEFL p) P.NoAcc . unLPS
-{-# INLINE filter #-}
-
-{-
--- | /O(n)/ and /O(n\/c) space/ A first order equivalent of /filter .
--- (==)/, for the common case of filtering a single byte. It is more
--- efficient to use /filterByte/ in this case.
---
--- > filterByte == filter . (==)
---
--- filterByte is around 10x faster, and uses much less space, than its
--- filter equivalent
-filterByte :: Word8 -> ByteString -> ByteString
-filterByte w ps = replicate (count w ps) w
--- filterByte w (LPS xs) = LPS (filterMap (P.filterByte w) xs)
-
--- | /O(n)/ A first order equivalent of /filter . (\/=)/, for the common
--- case of filtering a single byte out of a list. It is more efficient
--- to use /filterNotByte/ in this case.
---
--- > filterNotByte == filter . (/=)
---
--- filterNotByte is around 2x faster than its filter equivalent.
-filterNotByte :: Word8 -> ByteString -> ByteString
-filterNotByte w (LPS xs) = LPS (filterMap (P.filterNotByte w) xs)
--}
-
--- ---------------------------------------------------------------------
--- Searching for substrings
-
--- | /O(n)/ The 'isPrefixOf' function takes two ByteStrings and returns 'True'
--- iff the first is a prefix of the second.
-isPrefixOf :: ByteString -> ByteString -> Bool
-isPrefixOf (LPS as) (LPS bs) = isPrefixL as bs
- where isPrefixL [] _ = True
- isPrefixL _ [] = False
- isPrefixL (x:xs) (y:ys) | P.length x == P.length y = x == y && isPrefixL xs ys
- | P.length x < P.length y = x == yh && isPrefixL xs (yt:ys)
- | otherwise = xh == y && isPrefixL (xt:xs) ys
- where (xh,xt) = P.splitAt (P.length y) x
- (yh,yt) = P.splitAt (P.length x) y
-
--- | /O(n)/ The 'isSuffixOf' function takes two ByteStrings and returns 'True'
--- iff the first is a suffix of the second.
---
--- The following holds:
---
--- > isSuffixOf x y == reverse x `isPrefixOf` reverse y
---
--- However, the real implemenation uses memcmp to compare the end of the
--- string only, with no reverse required..
---
---isSuffixOf :: ByteString -> ByteString -> Bool
---isSuffixOf = error "not yet implemented"
-
--- ---------------------------------------------------------------------
--- Zipping
-
--- | /O(n)/ 'zip' takes two ByteStrings and returns a list of
--- corresponding pairs of bytes. If one input ByteString is short,
--- excess elements of the longer ByteString are discarded. This is
--- equivalent to a pair of 'unpack' operations.
-zip :: ByteString -> ByteString -> [(Word8,Word8)]
-zip = zipWith (,)
-
--- | 'zipWith' generalises 'zip' by zipping with the function given as
--- the first argument, instead of a tupling function. For example,
--- @'zipWith' (+)@ is applied to two ByteStrings to produce the list of
--- corresponding sums.
-zipWith :: (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a]
-zipWith _ (LPS []) (LPS _) = []
-zipWith _ (LPS _) (LPS []) = []
-zipWith f (LPS (a:as)) (LPS (b:bs)) = zipWith' a as b bs
- where zipWith' x xs y ys =
- (f (P.unsafeHead x) (P.unsafeHead y) : zipWith'' (P.unsafeTail x) xs (P.unsafeTail y) ys)
-
- zipWith'' x [] _ _ | P.null x = []
- zipWith'' _ _ y [] | P.null y = []
- zipWith'' x xs y ys | not (P.null x)
- && not (P.null y) = zipWith' x xs y ys
- zipWith'' x xs _ (y':ys) | not (P.null x) = zipWith' x xs y' ys
- zipWith'' _ (x':xs) y ys | not (P.null y) = zipWith' x' xs y ys
- zipWith'' _ (x':xs) _ (y':ys) = zipWith' x' xs y' ys
-
--- | /O(n)/ 'unzip' transforms a list of pairs of bytes into a pair of
--- ByteStrings. Note that this performs two 'pack' operations.
-{-
-unzip :: [(Word8,Word8)] -> (ByteString,ByteString)
-unzip _ls = error "not yet implemented"
-{-# INLINE unzip #-}
--}
-
--- ---------------------------------------------------------------------
--- Special lists
-
--- | /O(n)/ Return all initial segments of the given 'ByteString', shortest first.
-inits :: ByteString -> [ByteString]
-inits = (LPS [] :) . inits' . unLPS
- where inits' [] = []
- inits' (x:xs) = L.map (\x' -> LPS [x']) (L.tail (P.inits x))
- ++ L.map (\(LPS xs') -> LPS (x:xs')) (inits' xs)
-
--- | /O(n)/ Return all final segments of the given 'ByteString', longest first.
-tails :: ByteString -> [ByteString]
-tails = tails' . unLPS
- where tails' [] = LPS [] : []
- tails' xs@(x:xs')
- | P.length x == 1 = LPS xs : tails' xs'
- | otherwise = LPS xs : tails' (P.unsafeTail x : xs')
-
--- ---------------------------------------------------------------------
--- Low level constructors
-
--- | /O(n)/ Make a copy of the 'ByteString' with its own storage.
--- This is mainly useful to allow the rest of the data pointed
--- to by the 'ByteString' to be garbage collected, for example
--- if a large string has been read in, and only a small part of it
--- is needed in the rest of the program.
-copy :: ByteString -> ByteString
-copy (LPS lps) = LPS (L.map P.copy lps)
---TODO, we could coalese small blocks here
---FIXME: probably not strict enough, if we're doing this to avoid retaining
--- the parent blocks then we'd better copy strictly.
-
--- ---------------------------------------------------------------------
-
--- TODO defrag func that concatenates block together that are below a threshold
--- defrag :: Int -> ByteString -> ByteString
-
--- ---------------------------------------------------------------------
--- Lazy ByteString IO
-
--- | Read entire handle contents /lazily/ into a 'ByteString'. Chunks
--- are read on demand, in at most @k@-sized chunks. It does not block
--- waiting for a whole @k@-sized chunk, so if less than @k@ bytes are
--- available then they will be returned immediately as a smaller chunk.
-hGetContentsN :: Int -> Handle -> IO ByteString
-hGetContentsN k h = lazyRead >>= return . LPS
- where
- lazyRead = unsafeInterleaveIO loop
-
- loop = do
- ps <- P.hGetNonBlocking h k
- --TODO: I think this should distinguish EOF from no data available
- -- the otherlying POSIX call makes this distincion, returning either
- -- 0 or EAGAIN
- if P.null ps
- then do eof <- hIsEOF h
- if eof then return []
- else hWaitForInput h (-1)
- >> loop
- else do pss <- lazyRead
- return (ps : pss)
-
--- | Read @n@ bytes into a 'ByteString', directly from the
--- specified 'Handle', in chunks of size @k@.
-hGetN :: Int -> Handle -> Int -> IO ByteString
-hGetN _ _ 0 = return empty
-hGetN k h n = readChunks n >>= return . LPS
- where
- STRICT1(readChunks)
- readChunks i = do
- ps <- P.hGet h (min k i)
- case P.length ps of
- 0 -> return []
- m -> do pss <- readChunks (i - m)
- return (ps : pss)
-
--- | hGetNonBlockingN is similar to 'hGetContentsN', except that it will never block
--- waiting for data to become available, instead it returns only whatever data
--- is available. Chunks are read on demand, in @k@-sized chunks.
-hGetNonBlockingN :: Int -> Handle -> Int -> IO ByteString
-#if defined(__GLASGOW_HASKELL__)
-hGetNonBlockingN _ _ 0 = return empty
-hGetNonBlockingN k h n = readChunks n >>= return . LPS
- where
- STRICT1(readChunks)
- readChunks i = do
- ps <- P.hGetNonBlocking h (min k i)
- case P.length ps of
- 0 -> return []
- m -> do pss <- readChunks (i - m)
- return (ps : pss)
-#else
-hGetNonBlockingN = hGetN
-#endif
-
--- | Read entire handle contents /lazily/ into a 'ByteString'. Chunks
--- are read on demand, using the default chunk size.
-hGetContents :: Handle -> IO ByteString
-hGetContents = hGetContentsN defaultChunkSize
-
--- | Read @n@ bytes into a 'ByteString', directly from the specified 'Handle'.
-hGet :: Handle -> Int -> IO ByteString
-hGet = hGetN defaultChunkSize
-
--- | hGetNonBlocking is similar to 'hGet', except that it will never block
--- waiting for data to become available, instead it returns only whatever data
--- is available.
-#if defined(__GLASGOW_HASKELL__)
-hGetNonBlocking :: Handle -> Int -> IO ByteString
-hGetNonBlocking = hGetNonBlockingN defaultChunkSize
-#else
-hGetNonBlocking = hGet
-#endif
-
--- | Read an entire file /lazily/ into a 'ByteString'.
-readFile :: FilePath -> IO ByteString
-readFile f = openBinaryFile f ReadMode >>= hGetContents
-
--- | Write a 'ByteString' to a file.
-writeFile :: FilePath -> ByteString -> IO ()
-writeFile f txt = bracket (openBinaryFile f WriteMode) hClose
- (\hdl -> hPut hdl txt)
-
--- | Append a 'ByteString' to a file.
-appendFile :: FilePath -> ByteString -> IO ()
-appendFile f txt = bracket (openBinaryFile f AppendMode) hClose
- (\hdl -> hPut hdl txt)
-
--- | getContents. Equivalent to hGetContents stdin. Will read /lazily/
-getContents :: IO ByteString
-getContents = hGetContents stdin
-
--- | Outputs a 'ByteString' to the specified 'Handle'.
-hPut :: Handle -> ByteString -> IO ()
-hPut h (LPS xs) = mapM_ (P.hPut h) xs
-
--- | Write a ByteString to stdout
-putStr :: ByteString -> IO ()
-putStr = hPut stdout
-
--- | Write a ByteString to stdout, appending a newline byte
-putStrLn :: ByteString -> IO ()
-putStrLn ps = hPut stdout ps >> hPut stdout (singleton 0x0a)
-
--- | The interact function takes a function of type @ByteString -> ByteString@
--- as its argument. The entire input from the standard input device is passed
--- to this function as its argument, and the resulting string is output on the
--- standard output device. It's great for writing one line programs!
-interact :: (ByteString -> ByteString) -> IO ()
-interact transformer = putStr . transformer =<< getContents
-
--- ---------------------------------------------------------------------
--- Internal utilities
-
--- Common up near identical calls to `error' to reduce the number
--- constant strings created when compiled:
-errorEmptyList :: String -> a
-errorEmptyList fun = moduleError fun "empty ByteString"
-
-moduleError :: String -> String -> a
-moduleError fun msg = error ("Data.ByteString.Lazy." ++ fun ++ ':':' ':msg)
-
--- A manually fused version of "filter (not.null) . map f", since they
--- don't seem to fuse themselves. Really helps out filter*, concatMap.
---
--- TODO fuse.
---
-filterMap :: (P.ByteString -> P.ByteString) -> [P.ByteString] -> [P.ByteString]
-filterMap _ [] = []
-filterMap f (x:xs) = case f x of
- y | P.null y -> filterMap f xs -- manually fuse the invariant filter
- | otherwise -> y : filterMap f xs
-{-# INLINE filterMap #-}
-
-
--- | 'findIndexOrEnd' is a variant of findIndex, that returns the length
--- of the string if no element is found, rather than Nothing.
-findIndexOrEnd :: (Word8 -> Bool) -> P.ByteString -> Int
-findIndexOrEnd k (P.PS x s l) = P.inlinePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0
- where
- STRICT2(go)
- go ptr n | n >= l = return l
- | otherwise = do w <- peek ptr
- if k w
- then return n
- else go (ptr `plusPtr` 1) (n+1)
-{-# INLINE findIndexOrEnd #-}
+++ /dev/null
-{-# OPTIONS_GHC -cpp -fno-warn-orphans #-}
--- |
--- Module : Data.ByteString.Lazy.Char8
--- Copyright : (c) Don Stewart 2006
--- License : BSD-style
---
--- Maintainer : dons@cse.unsw.edu.au
--- Stability : experimental
--- Portability : non-portable (imports Data.ByteString.Lazy)
---
--- Manipulate /lazy/ 'ByteString's using 'Char' operations. All Chars will
--- be truncated to 8 bits. It can be expected that these functions will
--- run at identical speeds to their 'Data.Word.Word8' equivalents in
--- "Data.ByteString.Lazy".
---
--- This module is intended to be imported @qualified@, to avoid name
--- clashes with "Prelude" functions. eg.
---
--- > import qualified Data.ByteString.Lazy.Char8 as C
---
-
-module Data.ByteString.Lazy.Char8 (
-
- -- * The @ByteString@ type
- ByteString, -- instances: Eq, Ord, Show, Read, Data, Typeable
-
- -- * Introducing and eliminating 'ByteString's
- empty, -- :: ByteString
- singleton, -- :: Char -> ByteString
- pack, -- :: String -> ByteString
- unpack, -- :: ByteString -> String
- fromChunks, -- :: [Strict.ByteString] -> ByteString
- toChunks, -- :: ByteString -> [Strict.ByteString]
-
- -- * Basic interface
- cons, -- :: Char -> ByteString -> ByteString
- snoc, -- :: ByteString -> Char -> ByteString
- append, -- :: ByteString -> ByteString -> ByteString
- head, -- :: ByteString -> Char
- last, -- :: ByteString -> Char
- tail, -- :: ByteString -> ByteString
- init, -- :: ByteString -> ByteString
- null, -- :: ByteString -> Bool
- length, -- :: ByteString -> Int64
-
- -- * Transformating ByteStrings
- map, -- :: (Char -> Char) -> ByteString -> ByteString
- reverse, -- :: ByteString -> ByteString
--- intersperse, -- :: Char -> ByteString -> ByteString
- transpose, -- :: [ByteString] -> [ByteString]
-
- -- * Reducing 'ByteString's (folds)
- foldl, -- :: (a -> Char -> a) -> a -> ByteString -> a
- foldl', -- :: (a -> Char -> a) -> a -> ByteString -> a
- foldl1, -- :: (Char -> Char -> Char) -> ByteString -> Char
- foldl1', -- :: (Char -> Char -> Char) -> ByteString -> Char
- foldr, -- :: (Char -> a -> a) -> a -> ByteString -> a
- foldr1, -- :: (Char -> Char -> Char) -> ByteString -> Char
-
- -- ** Special folds
- concat, -- :: [ByteString] -> ByteString
- concatMap, -- :: (Char -> ByteString) -> ByteString -> ByteString
- any, -- :: (Char -> Bool) -> ByteString -> Bool
- all, -- :: (Char -> Bool) -> ByteString -> Bool
- maximum, -- :: ByteString -> Char
- minimum, -- :: ByteString -> Char
-
- -- * Building ByteStrings
- -- ** Scans
- scanl, -- :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString
--- scanl1, -- :: (Char -> Char -> Char) -> ByteString -> ByteString
--- scanr, -- :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString
--- scanr1, -- :: (Char -> Char -> Char) -> ByteString -> ByteString
-
- -- ** Accumulating maps
- mapAccumL, -- :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString)
- mapIndexed, -- :: (Int64 -> Char -> Char) -> ByteString -> ByteString
-
- -- ** Infinite ByteStrings
- repeat, -- :: Char -> ByteString
- replicate, -- :: Int64 -> Char -> ByteString
- cycle, -- :: ByteString -> ByteString
- iterate, -- :: (Char -> Char) -> Char -> ByteString
-
- -- ** Unfolding
- unfoldr, -- :: (a -> Maybe (Char, a)) -> a -> ByteString
-
- -- * Substrings
-
- -- ** Breaking strings
- take, -- :: Int64 -> ByteString -> ByteString
- drop, -- :: Int64 -> ByteString -> ByteString
- splitAt, -- :: Int64 -> ByteString -> (ByteString, ByteString)
- takeWhile, -- :: (Char -> Bool) -> ByteString -> ByteString
- dropWhile, -- :: (Char -> Bool) -> ByteString -> ByteString
- span, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
- break, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
- group, -- :: ByteString -> [ByteString]
- groupBy, -- :: (Char -> Char -> Bool) -> ByteString -> [ByteString]
- inits, -- :: ByteString -> [ByteString]
- tails, -- :: ByteString -> [ByteString]
-
- -- ** Breaking into many substrings
- split, -- :: Char -> ByteString -> [ByteString]
- splitWith, -- :: (Char -> Bool) -> ByteString -> [ByteString]
-
- -- ** Breaking into lines and words
- lines, -- :: ByteString -> [ByteString]
- words, -- :: ByteString -> [ByteString]
- unlines, -- :: [ByteString] -> ByteString
- unwords, -- :: ByteString -> [ByteString]
-
- -- ** Joining strings
- join, -- :: ByteString -> [ByteString] -> ByteString
-
- -- * Predicates
- isPrefixOf, -- :: ByteString -> ByteString -> Bool
--- isSuffixOf, -- :: ByteString -> ByteString -> Bool
-
- -- * Searching ByteStrings
-
- -- ** Searching by equality
- elem, -- :: Char -> ByteString -> Bool
- notElem, -- :: Char -> ByteString -> Bool
-
- -- ** Searching with a predicate
- find, -- :: (Char -> Bool) -> ByteString -> Maybe Char
- filter, -- :: (Char -> Bool) -> ByteString -> ByteString
--- partition -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
-
- -- * Indexing ByteStrings
- index, -- :: ByteString -> Int64 -> Char
- elemIndex, -- :: Char -> ByteString -> Maybe Int64
- elemIndices, -- :: Char -> ByteString -> [Int64]
- findIndex, -- :: (Char -> Bool) -> ByteString -> Maybe Int64
- findIndices, -- :: (Char -> Bool) -> ByteString -> [Int64]
- count, -- :: Char -> ByteString -> Int64
-
- -- * Zipping and unzipping ByteStrings
- zip, -- :: ByteString -> ByteString -> [(Char,Char)]
- zipWith, -- :: (Char -> Char -> c) -> ByteString -> ByteString -> [c]
--- unzip, -- :: [(Char,Char)] -> (ByteString,ByteString)
-
- -- * Ordered ByteStrings
--- sort, -- :: ByteString -> ByteString
-
- copy, -- :: ByteString -> ByteString
-
- -- * Reading from ByteStrings
- readInt,
- readInteger,
-
- -- * I\/O with 'ByteString's
-
- -- ** Standard input and output
- getContents, -- :: IO ByteString
- putStr, -- :: ByteString -> IO ()
- putStrLn, -- :: ByteString -> IO ()
- interact, -- :: (ByteString -> ByteString) -> IO ()
-
- -- ** Files
- readFile, -- :: FilePath -> IO ByteString
- writeFile, -- :: FilePath -> ByteString -> IO ()
- appendFile, -- :: FilePath -> ByteString -> IO ()
-
- -- ** I\/O with Handles
- hGetContents, -- :: Handle -> IO ByteString
- hGet, -- :: Handle -> Int64 -> IO ByteString
- hPut, -- :: Handle -> ByteString -> IO ()
- hGetNonBlocking, -- :: Handle -> IO ByteString
-
--- hGetN, -- :: Int -> Handle -> Int64 -> IO ByteString
--- hGetContentsN, -- :: Int -> Handle -> IO ByteString
--- hGetNonBlockingN, -- :: Int -> Handle -> IO ByteString
- ) where
-
--- Functions transparently exported
-import Data.ByteString.Lazy
- (ByteString, fromChunks, toChunks
- ,empty,null,length,tail,init,append,reverse,transpose,cycle
- ,concat,take,drop,splitAt,join,isPrefixOf,group,inits,tails,copy
- ,hGetContents, hGet, hPut, getContents
- ,hGetNonBlocking
- ,putStr, putStrLn, interact)
-
--- Functions we need to wrap.
-import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Base as B
-import Data.ByteString.Base (LazyByteString(LPS))
-
-import Data.ByteString.Base (w2c, c2w, isSpaceWord8)
-
-import Data.Int (Int64)
-import qualified Data.List as List (intersperse)
-
-import qualified Prelude as P
-import Prelude hiding
- (reverse,head,tail,last,init,null,length,map,lines,foldl,foldr,unlines
- ,concat,any,take,drop,splitAt,takeWhile,dropWhile,span,break,elem,filter
- ,unwords,words,maximum,minimum,all,concatMap,scanl,scanl1,foldl1,foldr1
- ,readFile,writeFile,appendFile,replicate,getContents,getLine,putStr,putStrLn
- ,zip,zipWith,unzip,notElem,repeat,iterate,interact,cycle)
-
-import System.IO (hClose,openFile,IOMode(..))
-import Control.Exception (bracket)
-
-#define STRICT1(f) f a | a `seq` False = undefined
-#define STRICT2(f) f a b | a `seq` b `seq` False = undefined
-#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
-#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined
-#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined
-
-------------------------------------------------------------------------
-
--- | /O(1)/ Convert a 'Char' into a 'ByteString'
-singleton :: Char -> ByteString
-singleton = L.singleton . c2w
-{-# INLINE singleton #-}
-
--- | /O(n)/ Convert a 'String' into a 'ByteString'.
-pack :: [Char] -> ByteString
-pack = L.pack. P.map c2w
-
--- | /O(n)/ Converts a 'ByteString' to a 'String'.
-unpack :: ByteString -> [Char]
-unpack = P.map w2c . L.unpack
-{-# INLINE unpack #-}
-
--- | /O(n)/ 'cons' is analogous to (:) for lists, but of different
--- complexity, as it requires a memcpy.
-cons :: Char -> ByteString -> ByteString
-cons = L.cons . c2w
-{-# INLINE cons #-}
-
--- | /O(n)/ Append a Char to the end of a 'ByteString'. Similar to
--- 'cons', this function performs a memcpy.
-snoc :: ByteString -> Char -> ByteString
-snoc p = L.snoc p . c2w
-{-# INLINE snoc #-}
-
--- | /O(1)/ Extract the first element of a ByteString, which must be non-empty.
-head :: ByteString -> Char
-head = w2c . L.head
-{-# INLINE head #-}
-
--- | /O(1)/ Extract the last element of a packed string, which must be non-empty.
-last :: ByteString -> Char
-last = w2c . L.last
-{-# INLINE last #-}
-
--- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each element of @xs@
-map :: (Char -> Char) -> ByteString -> ByteString
-map f = L.map (c2w . f . w2c)
-{-# INLINE map #-}
-
--- | 'foldl', applied to a binary operator, a starting value (typically
--- the left-identity of the operator), and a ByteString, reduces the
--- ByteString using the binary operator, from left to right.
-foldl :: (a -> Char -> a) -> a -> ByteString -> a
-foldl f = L.foldl (\a c -> f a (w2c c))
-{-# INLINE foldl #-}
-
--- | 'foldl\'' is like foldl, but strict in the accumulator.
-foldl' :: (a -> Char -> a) -> a -> ByteString -> a
-foldl' f = L.foldl' (\a c -> f a (w2c c))
-{-# INLINE foldl' #-}
-
--- | 'foldr', applied to a binary operator, a starting value
--- (typically the right-identity of the operator), and a packed string,
--- reduces the packed string using the binary operator, from right to left.
-foldr :: (Char -> a -> a) -> a -> ByteString -> a
-foldr f = L.foldr (\c a -> f (w2c c) a)
-{-# INLINE foldr #-}
-
--- | 'foldl1' is a variant of 'foldl' that has no starting value
--- argument, and thus must be applied to non-empty 'ByteStrings'.
-foldl1 :: (Char -> Char -> Char) -> ByteString -> Char
-foldl1 f ps = w2c (L.foldl1 (\x y -> c2w (f (w2c x) (w2c y))) ps)
-{-# INLINE foldl1 #-}
-
--- | 'foldl1\'' is like 'foldl1', but strict in the accumulator.
-foldl1' :: (Char -> Char -> Char) -> ByteString -> Char
-foldl1' f ps = w2c (L.foldl1' (\x y -> c2w (f (w2c x) (w2c y))) ps)
-
--- | 'foldr1' is a variant of 'foldr' that has no starting value argument,
--- and thus must be applied to non-empty 'ByteString's
-foldr1 :: (Char -> Char -> Char) -> ByteString -> Char
-foldr1 f ps = w2c (L.foldr1 (\x y -> c2w (f (w2c x) (w2c y))) ps)
-{-# INLINE foldr1 #-}
-
--- | Map a function over a 'ByteString' and concatenate the results
-concatMap :: (Char -> ByteString) -> ByteString -> ByteString
-concatMap f = L.concatMap (f . w2c)
-{-# INLINE concatMap #-}
-
--- | Applied to a predicate and a ByteString, 'any' determines if
--- any element of the 'ByteString' satisfies the predicate.
-any :: (Char -> Bool) -> ByteString -> Bool
-any f = L.any (f . w2c)
-{-# INLINE any #-}
-
--- | Applied to a predicate and a 'ByteString', 'all' determines if
--- all elements of the 'ByteString' satisfy the predicate.
-all :: (Char -> Bool) -> ByteString -> Bool
-all f = L.all (f . w2c)
-{-# INLINE all #-}
-
--- | 'maximum' returns the maximum value from a 'ByteString'
-maximum :: ByteString -> Char
-maximum = w2c . L.maximum
-{-# INLINE maximum #-}
-
--- | 'minimum' returns the minimum value from a 'ByteString'
-minimum :: ByteString -> Char
-minimum = w2c . L.minimum
-{-# INLINE minimum #-}
-
--- ---------------------------------------------------------------------
--- Building ByteStrings
-
--- | 'scanl' is similar to 'foldl', but returns a list of successive
--- reduced values from the left. This function will fuse.
---
--- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
---
--- Note that
---
--- > last (scanl f z xs) == foldl f z xs.
-scanl :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString
-scanl f z = L.scanl (\a b -> c2w (f (w2c a) (w2c b))) (c2w z)
-
--- | The 'mapAccumL' function behaves like a combination of 'map' and
--- 'foldl'; it applies a function to each element of a ByteString,
--- passing an accumulating parameter from left to right, and returning a
--- final value of this accumulator together with the new ByteString.
-mapAccumL :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString)
-mapAccumL f = L.mapAccumL (\a w -> case f a (w2c w) of (a',c) -> (a', c2w c))
-
--- | /O(n)/ map Char functions, provided with the index at each position
-mapIndexed :: (Int -> Char -> Char) -> ByteString -> ByteString
-mapIndexed f = L.mapIndexed (\i w -> c2w (f i (w2c w)))
-
-------------------------------------------------------------------------
--- Generating and unfolding ByteStrings
-
--- | @'iterate' f x@ returns an infinite ByteString of repeated applications
--- of @f@ to @x@:
---
--- > iterate f x == [x, f x, f (f x), ...]
---
-iterate :: (Char -> Char) -> Char -> ByteString
-iterate f = L.iterate (c2w . f . w2c) . c2w
-
--- | @'repeat' x@ is an infinite ByteString, with @x@ the value of every
--- element.
---
-repeat :: Char -> ByteString
-repeat = L.repeat . c2w
-
--- | /O(n)/ @'replicate' n x@ is a ByteString of length @n@ with @x@
--- the value of every element.
---
-replicate :: Int64 -> Char -> ByteString
-replicate w c = L.replicate w (c2w c)
-
--- | /O(n)/ The 'unfoldr' function is analogous to the List \'unfoldr\'.
--- 'unfoldr' builds a ByteString from a seed value. The function takes
--- the element and returns 'Nothing' if it is done producing the
--- ByteString or returns 'Just' @(a,b)@, in which case, @a@ is a
--- prepending to the ByteString and @b@ is used as the next element in a
--- recursive call.
-unfoldr :: (a -> Maybe (Char, a)) -> a -> ByteString
-unfoldr f = L.unfoldr $ \a -> case f a of
- Nothing -> Nothing
- Just (c, a') -> Just (c2w c, a')
-
-------------------------------------------------------------------------
-
--- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@,
--- returns the longest prefix (possibly empty) of @xs@ of elements that
--- satisfy @p@.
-takeWhile :: (Char -> Bool) -> ByteString -> ByteString
-takeWhile f = L.takeWhile (f . w2c)
-{-# INLINE takeWhile #-}
-
--- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@.
-dropWhile :: (Char -> Bool) -> ByteString -> ByteString
-dropWhile f = L.dropWhile (f . w2c)
-{-# INLINE dropWhile #-}
-
--- | 'break' @p@ is equivalent to @'span' ('not' . p)@.
-break :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
-break f = L.break (f . w2c)
-{-# INLINE break #-}
-
--- | 'span' @p xs@ breaks the ByteString into two segments. It is
--- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@
-span :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)
-span f = L.span (f . w2c)
-{-# INLINE span #-}
-
-{-
--- | 'breakChar' breaks its ByteString argument at the first occurence
--- of the specified Char. It is more efficient than 'break' as it is
--- implemented with @memchr(3)@. I.e.
---
--- > break (=='c') "abcd" == breakChar 'c' "abcd"
---
-breakChar :: Char -> ByteString -> (ByteString, ByteString)
-breakChar = L.breakByte . c2w
-{-# INLINE breakChar #-}
-
--- | 'spanChar' breaks its ByteString argument at the first
--- occurence of a Char other than its argument. It is more efficient
--- than 'span (==)'
---
--- > span (=='c') "abcd" == spanByte 'c' "abcd"
---
-spanChar :: Char -> ByteString -> (ByteString, ByteString)
-spanChar = L.spanByte . c2w
-{-# INLINE spanChar #-}
--}
-
---
--- TODO, more rules for breakChar*
---
-
--- | /O(n)/ Break a 'ByteString' into pieces separated by the byte
--- argument, consuming the delimiter. I.e.
---
--- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"]
--- > split 'a' "aXaXaXa" == ["","X","X","X"]
--- > split 'x' "x" == ["",""]
---
--- and
---
--- > join [c] . split c == id
--- > split == splitWith . (==)
---
--- As for all splitting functions in this library, this function does
--- not copy the substrings, it just constructs new 'ByteStrings' that
--- are slices of the original.
---
-split :: Char -> ByteString -> [ByteString]
-split = L.split . c2w
-{-# INLINE split #-}
-
--- | /O(n)/ Splits a 'ByteString' into components delimited by
--- separators, where the predicate returns True for a separator element.
--- The resulting components do not contain the separators. Two adjacent
--- separators result in an empty component in the output. eg.
---
--- > splitWith (=='a') "aabbaca" == ["","","bb","c",""]
---
-splitWith :: (Char -> Bool) -> ByteString -> [ByteString]
-splitWith f = L.splitWith (f . w2c)
-{-# INLINE splitWith #-}
-
--- | The 'groupBy' function is the non-overloaded version of 'group'.
-groupBy :: (Char -> Char -> Bool) -> ByteString -> [ByteString]
-groupBy k = L.groupBy (\a b -> k (w2c a) (w2c b))
-
--- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0.
-index :: ByteString -> Int64 -> Char
-index = (w2c .) . L.index
-{-# INLINE index #-}
-
--- | /O(n)/ The 'elemIndex' function returns the index of the first
--- element in the given 'ByteString' which is equal (by memchr) to the
--- query element, or 'Nothing' if there is no such element.
-elemIndex :: Char -> ByteString -> Maybe Int64
-elemIndex = L.elemIndex . c2w
-{-# INLINE elemIndex #-}
-
--- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning
--- the indices of all elements equal to the query element, in ascending order.
-elemIndices :: Char -> ByteString -> [Int64]
-elemIndices = L.elemIndices . c2w
-{-# INLINE elemIndices #-}
-
--- | The 'findIndex' function takes a predicate and a 'ByteString' and
--- returns the index of the first element in the ByteString satisfying the predicate.
-findIndex :: (Char -> Bool) -> ByteString -> Maybe Int64
-findIndex f = L.findIndex (f . w2c)
-{-# INLINE findIndex #-}
-
--- | The 'findIndices' function extends 'findIndex', by returning the
--- indices of all elements satisfying the predicate, in ascending order.
-findIndices :: (Char -> Bool) -> ByteString -> [Int64]
-findIndices f = L.findIndices (f . w2c)
-
--- | count returns the number of times its argument appears in the ByteString
---
--- > count == length . elemIndices
--- > count '\n' == length . lines
---
--- But more efficiently than using length on the intermediate list.
-count :: Char -> ByteString -> Int64
-count c = L.count (c2w c)
-
--- | /O(n)/ 'elem' is the 'ByteString' membership predicate. This
--- implementation uses @memchr(3)@.
-elem :: Char -> ByteString -> Bool
-elem c = L.elem (c2w c)
-{-# INLINE elem #-}
-
--- | /O(n)/ 'notElem' is the inverse of 'elem'
-notElem :: Char -> ByteString -> Bool
-notElem c = L.notElem (c2w c)
-{-# INLINE notElem #-}
-
--- | /O(n)/ 'filter', applied to a predicate and a ByteString,
--- returns a ByteString containing those characters that satisfy the
--- predicate.
-filter :: (Char -> Bool) -> ByteString -> ByteString
-filter f = L.filter (f . w2c)
-{-# INLINE filter #-}
-
--- | /O(n)/ The 'find' function takes a predicate and a ByteString,
--- and returns the first element in matching the predicate, or 'Nothing'
--- if there is no such element.
-find :: (Char -> Bool) -> ByteString -> Maybe Char
-find f ps = w2c `fmap` L.find (f . w2c) ps
-{-# INLINE find #-}
-
-{-
--- | /O(n)/ A first order equivalent of /filter . (==)/, for the common
--- case of filtering a single Char. It is more efficient to use
--- filterChar in this case.
---
--- > filterChar == filter . (==)
---
--- filterChar is around 10x faster, and uses much less space, than its
--- filter equivalent
---
-filterChar :: Char -> ByteString -> ByteString
-filterChar c = L.filterByte (c2w c)
-{-# INLINE filterChar #-}
-
--- | /O(n)/ A first order equivalent of /filter . (\/=)/, for the common
--- case of filtering a single Char out of a list. It is more efficient
--- to use /filterNotChar/ in this case.
---
--- > filterNotChar == filter . (/=)
---
--- filterNotChar is around 3x faster, and uses much less space, than its
--- filter equivalent
---
-filterNotChar :: Char -> ByteString -> ByteString
-filterNotChar c = L.filterNotByte (c2w c)
-{-# INLINE filterNotChar #-}
--}
-
--- | /O(n)/ 'zip' takes two ByteStrings and returns a list of
--- corresponding pairs of Chars. If one input ByteString is short,
--- excess elements of the longer ByteString are discarded. This is
--- equivalent to a pair of 'unpack' operations, and so space
--- usage may be large for multi-megabyte ByteStrings
-zip :: ByteString -> ByteString -> [(Char,Char)]
-zip ps qs
- | L.null ps || L.null qs = []
- | otherwise = (head ps, head qs) : zip (L.tail ps) (L.tail qs)
-
--- | 'zipWith' generalises 'zip' by zipping with the function given as
--- the first argument, instead of a tupling function. For example,
--- @'zipWith' (+)@ is applied to two ByteStrings to produce the list
--- of corresponding sums.
-zipWith :: (Char -> Char -> a) -> ByteString -> ByteString -> [a]
-zipWith f = L.zipWith ((. w2c) . f . w2c)
-
--- | 'lines' breaks a ByteString up into a list of ByteStrings at
--- newline Chars. The resulting strings do not contain newlines.
---
-lines :: ByteString -> [ByteString]
-lines (LPS []) = []
-lines (LPS (x:xs)) = loop0 x xs
- where
- -- this is a really performance sensitive function but the
- -- chunked representation makes the general case a bit expensive
- -- however assuming a large chunk size and normalish line lengths
- -- we will find line endings much more frequently than chunk
- -- endings so it makes sense to optimise for that common case.
- -- So we partition into two special cases depending on whether we
- -- are keeping back a list of chunks that will eventually be output
- -- once we get to the end of the current line.
-
- -- the common special case where we have no existing chunks of
- -- the current line
- loop0 :: B.ByteString -> [B.ByteString] -> [ByteString]
- STRICT2(loop0)
- loop0 ps pss =
- case B.elemIndex (c2w '\n') ps of
- Nothing -> case pss of
- [] | B.null ps -> []
- | otherwise -> LPS [ps] : []
- (ps':pss')
- | B.null ps -> loop0 ps' pss'
- | otherwise -> loop ps' [ps] pss'
-
- Just n | n /= 0 -> LPS [B.unsafeTake n ps]
- : loop0 (B.unsafeDrop (n+1) ps) pss
- | otherwise -> loop0 (B.unsafeTail ps) pss
-
- -- the general case when we are building a list of chunks that are
- -- part of the same line
- loop :: B.ByteString -> [B.ByteString] -> [B.ByteString] -> [ByteString]
- STRICT3(loop)
- loop ps line pss =
- case B.elemIndex (c2w '\n') ps of
- Nothing ->
- case pss of
- [] -> let ps' | B.null ps = P.reverse line
- | otherwise = P.reverse (ps : line)
- in ps' `seq` (LPS ps' : [])
-
- (ps':pss')
- | B.null ps -> loop ps' line pss'
- | otherwise -> loop ps' (ps : line) pss'
-
- Just n ->
- let ps' | n == 0 = P.reverse line
- | otherwise = P.reverse (B.unsafeTake n ps : line)
- in ps' `seq` (LPS ps' : loop0 (B.unsafeDrop (n+1) ps) pss)
-
--- | 'unlines' is an inverse operation to 'lines'. It joins lines,
--- after appending a terminating newline to each.
-unlines :: [ByteString] -> ByteString
-unlines [] = empty
-unlines ss = (concat $ List.intersperse nl ss) `append` nl -- half as much space
- where nl = singleton '\n'
-
--- | 'words' breaks a ByteString up into a list of words, which
--- were delimited by Chars representing white space. And
---
--- > tokens isSpace = words
---
-words :: ByteString -> [ByteString]
-words = P.filter (not . L.null) . L.splitWith isSpaceWord8
-{-# INLINE words #-}
-
--- | The 'unwords' function is analogous to the 'unlines' function, on words.
-unwords :: [ByteString] -> ByteString
-unwords = join (singleton ' ')
-{-# INLINE unwords #-}
-
--- | readInt reads an Int from the beginning of the ByteString. If
--- there is no integer at the beginning of the string, it returns
--- Nothing, otherwise it just returns the int read, and the rest of the
--- string.
-readInt :: ByteString -> Maybe (Int, ByteString)
-readInt (LPS []) = Nothing
-readInt (LPS (x:xs)) =
- case w2c (B.unsafeHead x) of
- '-' -> loop True 0 0 (B.unsafeTail x) xs
- '+' -> loop False 0 0 (B.unsafeTail x) xs
- _ -> loop False 0 0 x xs
-
- where loop :: Bool -> Int -> Int -> B.ByteString -> [B.ByteString] -> Maybe (Int, ByteString)
- STRICT5(loop)
- loop neg i n ps pss
- | B.null ps = case pss of
- [] -> end neg i n ps pss
- (ps':pss') -> loop neg i n ps' pss'
- | otherwise =
- case B.unsafeHead ps of
- w | w >= 0x30
- && w <= 0x39 -> loop neg (i+1)
- (n * 10 + (fromIntegral w - 0x30))
- (B.unsafeTail ps) pss
- | otherwise -> end neg i n ps pss
-
- end _ 0 _ _ _ = Nothing
- end neg _ n ps pss = let n' | neg = negate n
- | otherwise = n
- ps' | B.null ps = pss
- | otherwise = ps:pss
- in n' `seq` ps' `seq` Just $! (n', LPS ps')
-
-
--- | readInteger reads an Integer from the beginning of the ByteString. If
--- there is no integer at the beginning of the string, it returns Nothing,
--- otherwise it just returns the int read, and the rest of the string.
-readInteger :: ByteString -> Maybe (Integer, ByteString)
-readInteger (LPS []) = Nothing
-readInteger (LPS (x:xs)) =
- case w2c (B.unsafeHead x) of
- '-' -> first (B.unsafeTail x) xs >>= \(n, bs) -> return (-n, bs)
- '+' -> first (B.unsafeTail x) xs
- _ -> first x xs
-
- where first ps pss
- | B.null ps = case pss of
- [] -> Nothing
- (ps':pss') -> first' ps' pss'
- | otherwise = first' ps pss
-
- first' ps pss = case B.unsafeHead ps of
- w | w >= 0x30 && w <= 0x39 -> Just $
- loop 1 (fromIntegral w - 0x30) [] (B.unsafeTail ps) pss
- | otherwise -> Nothing
-
- loop :: Int -> Int -> [Integer]
- -> B.ByteString -> [B.ByteString] -> (Integer, ByteString)
- STRICT5(loop)
- loop d acc ns ps pss
- | B.null ps = case pss of
- [] -> combine d acc ns ps pss
- (ps':pss') -> loop d acc ns ps' pss'
- | otherwise =
- case B.unsafeHead ps of
- w | w >= 0x30 && w <= 0x39 ->
- if d < 9 then loop (d+1)
- (10*acc + (fromIntegral w - 0x30))
- ns (B.unsafeTail ps) pss
- else loop 1 (fromIntegral w - 0x30)
- (fromIntegral acc : ns)
- (B.unsafeTail ps) pss
- | otherwise -> combine d acc ns ps pss
-
- combine _ acc [] ps pss = end (fromIntegral acc) ps pss
- combine d acc ns ps pss =
- end (10^d * combine1 1000000000 ns + fromIntegral acc) ps pss
-
- combine1 _ [n] = n
- combine1 b ns = combine1 (b*b) $ combine2 b ns
-
- combine2 b (n:m:ns) = let t = n+m*b in t `seq` (t : combine2 b ns)
- combine2 _ ns = ns
-
- end n ps pss = let ps' | B.null ps = pss
- | otherwise = ps:pss
- in ps' `seq` (n, LPS ps')
-
--- | Read an entire file /lazily/ into a 'ByteString'. Use 'text mode'
--- on Windows to interpret newlines
-readFile :: FilePath -> IO ByteString
-readFile f = openFile f ReadMode >>= hGetContents
-
--- | Write a 'ByteString' to a file.
-writeFile :: FilePath -> ByteString -> IO ()
-writeFile f txt = bracket (openFile f WriteMode) hClose
- (\hdl -> hPut hdl txt)
-
--- | Append a 'ByteString' to a file.
-appendFile :: FilePath -> ByteString -> IO ()
-appendFile f txt = bracket (openFile f AppendMode) hClose
- (\hdl -> hPut hdl txt)
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Char
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : stable
--- Portability : portable
---
--- The Char type and associated operations.
---
------------------------------------------------------------------------------
-
-module Data.Char
- (
- Char
-
- , String
-
- -- * Character classification
- -- | Unicode characters are divided into letters, numbers, marks,
- -- punctuation, symbols, separators (including spaces) and others
- -- (including control characters).
- , isControl, isSpace
- , isLower, isUpper, isAlpha, isAlphaNum, isPrint
- , isDigit, isOctDigit, isHexDigit
- , isLetter, isMark, isNumber, isPunctuation, isSymbol, isSeparator
-
- -- ** Subranges
- , isAscii, isLatin1
- , isAsciiUpper, isAsciiLower
-
- -- ** Unicode general categories
- , GeneralCategory(..), generalCategory
-
- -- * Case conversion
- , toUpper, toLower, toTitle -- :: Char -> Char
-
- -- * Single digit characters
- , digitToInt -- :: Char -> Int
- , intToDigit -- :: Int -> Char
-
- -- * Numeric representations
- , ord -- :: Char -> Int
- , chr -- :: Int -> Char
-
- -- * String representations
- , showLitChar -- :: Char -> ShowS
- , lexLitChar -- :: ReadS String
- , readLitChar -- :: ReadS Char
-
- -- Implementation checked wrt. Haskell 98 lib report, 1/99.
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.Arr (Ix)
-import GHC.Real (fromIntegral)
-import GHC.Show
-import GHC.Read (Read, readLitChar, lexLitChar)
-import GHC.Unicode
-import GHC.Num
-import GHC.Enum
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude (Ix)
-import Hugs.Char
-#endif
-
-#ifdef __NHC__
-import Prelude
-import Prelude(Char,String)
-import Char
-import Ix
-import NHC.FFI (CInt)
-foreign import ccall unsafe "WCsubst.h u_gencat" wgencat :: CInt -> CInt
-#endif
-
--- | Convert a single digit 'Char' to the corresponding 'Int'.
--- This function fails unless its argument satisfies 'isHexDigit',
--- but recognises both upper and lower-case hexadecimal digits
--- (i.e. @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@).
-digitToInt :: Char -> Int
-digitToInt c
- | isDigit c = ord c - ord '0'
- | c >= 'a' && c <= 'f' = ord c - ord 'a' + 10
- | c >= 'A' && c <= 'F' = ord c - ord 'A' + 10
- | otherwise = error ("Char.digitToInt: not a digit " ++ show c) -- sigh
-
-#ifndef __GLASGOW_HASKELL__
-isAsciiUpper, isAsciiLower :: Char -> Bool
-isAsciiLower c = c >= 'a' && c <= 'z'
-isAsciiUpper c = c >= 'A' && c <= 'Z'
-#endif
-
--- | Unicode General Categories (column 2 of the UnicodeData table)
--- in the order they are listed in the Unicode standard.
-
-data GeneralCategory
- = UppercaseLetter -- ^ Lu: Letter, Uppercase
- | LowercaseLetter -- ^ Ll: Letter, Lowercase
- | TitlecaseLetter -- ^ Lt: Letter, Titlecase
- | ModifierLetter -- ^ Lm: Letter, Modifier
- | OtherLetter -- ^ Lo: Letter, Other
- | NonSpacingMark -- ^ Mn: Mark, Non-Spacing
- | SpacingCombiningMark -- ^ Mc: Mark, Spacing Combining
- | EnclosingMark -- ^ Me: Mark, Enclosing
- | DecimalNumber -- ^ Nd: Number, Decimal
- | LetterNumber -- ^ Nl: Number, Letter
- | OtherNumber -- ^ No: Number, Other
- | ConnectorPunctuation -- ^ Pc: Punctuation, Connector
- | DashPunctuation -- ^ Pd: Punctuation, Dash
- | OpenPunctuation -- ^ Ps: Punctuation, Open
- | ClosePunctuation -- ^ Pe: Punctuation, Close
- | InitialQuote -- ^ Pi: Punctuation, Initial quote
- | FinalQuote -- ^ Pf: Punctuation, Final quote
- | OtherPunctuation -- ^ Po: Punctuation, Other
- | MathSymbol -- ^ Sm: Symbol, Math
- | CurrencySymbol -- ^ Sc: Symbol, Currency
- | ModifierSymbol -- ^ Sk: Symbol, Modifier
- | OtherSymbol -- ^ So: Symbol, Other
- | Space -- ^ Zs: Separator, Space
- | LineSeparator -- ^ Zl: Separator, Line
- | ParagraphSeparator -- ^ Zp: Separator, Paragraph
- | Control -- ^ Cc: Other, Control
- | Format -- ^ Cf: Other, Format
- | Surrogate -- ^ Cs: Other, Surrogate
- | PrivateUse -- ^ Co: Other, Private Use
- | NotAssigned -- ^ Cn: Other, Not Assigned
- deriving (Eq, Ord, Enum, Read, Show, Bounded, Ix)
-
--- | The Unicode general category of the character.
-generalCategory :: Char -> GeneralCategory
-#if defined(__GLASGOW_HASKELL__) || defined(__NHC__)
-generalCategory c = toEnum $ fromIntegral $ wgencat $ fromIntegral $ ord c
-#endif
-#ifdef __HUGS__
-generalCategory c = toEnum (primUniGenCat c)
-#endif
-
--- derived character classifiers
-
--- | Selects alphabetic Unicode characters (lower-case, upper-case and
--- title-case letters, plus letters of caseless scripts and modifiers letters).
--- This function is equivalent to 'Data.Char.isAlpha'.
-isLetter :: Char -> Bool
-isLetter c = case generalCategory c of
- UppercaseLetter -> True
- LowercaseLetter -> True
- TitlecaseLetter -> True
- ModifierLetter -> True
- OtherLetter -> True
- _ -> False
-
--- | Selects Unicode mark characters, e.g. accents and the like, which
--- combine with preceding letters.
-isMark :: Char -> Bool
-isMark c = case generalCategory c of
- NonSpacingMark -> True
- SpacingCombiningMark -> True
- EnclosingMark -> True
- _ -> False
-
--- | Selects Unicode numeric characters, including digits from various
--- scripts, Roman numerals, etc.
-isNumber :: Char -> Bool
-isNumber c = case generalCategory c of
- DecimalNumber -> True
- LetterNumber -> True
- OtherNumber -> True
- _ -> False
-
--- | Selects Unicode punctuation characters, including various kinds
--- of connectors, brackets and quotes.
-isPunctuation :: Char -> Bool
-isPunctuation c = case generalCategory c of
- ConnectorPunctuation -> True
- DashPunctuation -> True
- OpenPunctuation -> True
- ClosePunctuation -> True
- InitialQuote -> True
- FinalQuote -> True
- OtherPunctuation -> True
- _ -> False
-
--- | Selects Unicode symbol characters, including mathematical and
--- currency symbols.
-isSymbol :: Char -> Bool
-isSymbol c = case generalCategory c of
- MathSymbol -> True
- CurrencySymbol -> True
- ModifierSymbol -> True
- OtherSymbol -> True
- _ -> False
-
--- | Selects Unicode space and separator characters.
-isSeparator :: Char -> Bool
-isSeparator c = case generalCategory c of
- Space -> True
- LineSeparator -> True
- ParagraphSeparator -> True
- _ -> False
-
-#ifdef __NHC__
--- dummy implementation
-toTitle :: Char -> Char
-toTitle = toUpper
-#endif
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Complex
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Complex numbers.
---
------------------------------------------------------------------------------
-
-module Data.Complex
- (
- -- * Rectangular form
- Complex((:+))
-
- , realPart -- :: (RealFloat a) => Complex a -> a
- , imagPart -- :: (RealFloat a) => Complex a -> a
- -- * Polar form
- , mkPolar -- :: (RealFloat a) => a -> a -> Complex a
- , cis -- :: (RealFloat a) => a -> Complex a
- , polar -- :: (RealFloat a) => Complex a -> (a,a)
- , magnitude -- :: (RealFloat a) => Complex a -> a
- , phase -- :: (RealFloat a) => Complex a -> a
- -- * Conjugate
- , conjugate -- :: (RealFloat a) => Complex a -> Complex a
-
- -- Complex instances:
- --
- -- (RealFloat a) => Eq (Complex a)
- -- (RealFloat a) => Read (Complex a)
- -- (RealFloat a) => Show (Complex a)
- -- (RealFloat a) => Num (Complex a)
- -- (RealFloat a) => Fractional (Complex a)
- -- (RealFloat a) => Floating (Complex a)
- --
- -- Implementation checked wrt. Haskell 98 lib report, 1/99.
-
- ) where
-
-import Prelude
-
-import Data.Typeable
-#ifdef __GLASGOW_HASKELL__
-import Data.Generics.Basics( Data )
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude(Num(fromInt), Fractional(fromDouble))
-#endif
-
-infix 6 :+
-
--- -----------------------------------------------------------------------------
--- The Complex type
-
--- | Complex numbers are an algebraic type.
---
--- For a complex number @z@, @'abs' z@ is a number with the magnitude of @z@,
--- but oriented in the positive real direction, whereas @'signum' z@
--- has the phase of @z@, but unit magnitude.
-data (RealFloat a) => Complex a
- = !a :+ !a -- ^ forms a complex number from its real and imaginary
- -- rectangular components.
-# if __GLASGOW_HASKELL__
- deriving (Eq, Show, Read, Data)
-# else
- deriving (Eq, Show, Read)
-# endif
-
--- -----------------------------------------------------------------------------
--- Functions over Complex
-
--- | Extracts the real part of a complex number.
-realPart :: (RealFloat a) => Complex a -> a
-realPart (x :+ _) = x
-
--- | Extracts the imaginary part of a complex number.
-imagPart :: (RealFloat a) => Complex a -> a
-imagPart (_ :+ y) = y
-
--- | The conjugate of a complex number.
-{-# SPECIALISE conjugate :: Complex Double -> Complex Double #-}
-conjugate :: (RealFloat a) => Complex a -> Complex a
-conjugate (x:+y) = x :+ (-y)
-
--- | Form a complex number from polar components of magnitude and phase.
-{-# SPECIALISE mkPolar :: Double -> Double -> Complex Double #-}
-mkPolar :: (RealFloat a) => a -> a -> Complex a
-mkPolar r theta = r * cos theta :+ r * sin theta
-
--- | @'cis' t@ is a complex value with magnitude @1@
--- and phase @t@ (modulo @2*'pi'@).
-{-# SPECIALISE cis :: Double -> Complex Double #-}
-cis :: (RealFloat a) => a -> Complex a
-cis theta = cos theta :+ sin theta
-
--- | The function 'polar' takes a complex number and
--- returns a (magnitude, phase) pair in canonical form:
--- the magnitude is nonnegative, and the phase in the range @(-'pi', 'pi']@;
--- if the magnitude is zero, then so is the phase.
-{-# SPECIALISE polar :: Complex Double -> (Double,Double) #-}
-polar :: (RealFloat a) => Complex a -> (a,a)
-polar z = (magnitude z, phase z)
-
--- | The nonnegative magnitude of a complex number.
-{-# SPECIALISE magnitude :: Complex Double -> Double #-}
-magnitude :: (RealFloat a) => Complex a -> a
-magnitude (x:+y) = scaleFloat k
- (sqrt ((scaleFloat mk x)^(2::Int) + (scaleFloat mk y)^(2::Int)))
- where k = max (exponent x) (exponent y)
- mk = - k
-
--- | The phase of a complex number, in the range @(-'pi', 'pi']@.
--- If the magnitude is zero, then so is the phase.
-{-# SPECIALISE phase :: Complex Double -> Double #-}
-phase :: (RealFloat a) => Complex a -> a
-phase (0 :+ 0) = 0 -- SLPJ July 97 from John Peterson
-phase (x:+y) = atan2 y x
-
-
--- -----------------------------------------------------------------------------
--- Instances of Complex
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(Complex,complexTc,"Complex")
-
-instance (RealFloat a) => Num (Complex a) where
- {-# SPECIALISE instance Num (Complex Float) #-}
- {-# SPECIALISE instance Num (Complex Double) #-}
- (x:+y) + (x':+y') = (x+x') :+ (y+y')
- (x:+y) - (x':+y') = (x-x') :+ (y-y')
- (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x')
- negate (x:+y) = negate x :+ negate y
- abs z = magnitude z :+ 0
- signum (0:+0) = 0
- signum z@(x:+y) = x/r :+ y/r where r = magnitude z
- fromInteger n = fromInteger n :+ 0
-#ifdef __HUGS__
- fromInt n = fromInt n :+ 0
-#endif
-
-instance (RealFloat a) => Fractional (Complex a) where
- {-# SPECIALISE instance Fractional (Complex Float) #-}
- {-# SPECIALISE instance Fractional (Complex Double) #-}
- (x:+y) / (x':+y') = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d
- where x'' = scaleFloat k x'
- y'' = scaleFloat k y'
- k = - max (exponent x') (exponent y')
- d = x'*x'' + y'*y''
-
- fromRational a = fromRational a :+ 0
-#ifdef __HUGS__
- fromDouble a = fromDouble a :+ 0
-#endif
-
-instance (RealFloat a) => Floating (Complex a) where
- {-# SPECIALISE instance Floating (Complex Float) #-}
- {-# SPECIALISE instance Floating (Complex Double) #-}
- pi = pi :+ 0
- exp (x:+y) = expx * cos y :+ expx * sin y
- where expx = exp x
- log z = log (magnitude z) :+ phase z
-
- sqrt (0:+0) = 0
- sqrt z@(x:+y) = u :+ (if y < 0 then -v else v)
- where (u,v) = if x < 0 then (v',u') else (u',v')
- v' = abs y / (u'*2)
- u' = sqrt ((magnitude z + abs x) / 2)
-
- sin (x:+y) = sin x * cosh y :+ cos x * sinh y
- cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y)
- tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))
- where sinx = sin x
- cosx = cos x
- sinhy = sinh y
- coshy = cosh y
-
- sinh (x:+y) = cos y * sinh x :+ sin y * cosh x
- cosh (x:+y) = cos y * cosh x :+ sin y * sinh x
- tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)
- where siny = sin y
- cosy = cos y
- sinhx = sinh x
- coshx = cosh x
-
- asin z@(x:+y) = y':+(-x')
- where (x':+y') = log (((-y):+x) + sqrt (1 - z*z))
- acos z = y'':+(-x'')
- where (x'':+y'') = log (z + ((-y'):+x'))
- (x':+y') = sqrt (1 - z*z)
- atan z@(x:+y) = y':+(-x')
- where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))
-
- asinh z = log (z + sqrt (1+z*z))
- acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1)))
- atanh z = log ((1+z) / sqrt (1-z*z))
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Dynamic
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- The Dynamic interface provides basic support for dynamic types.
---
--- Operations for injecting values of arbitrary type into
--- a dynamically typed value, Dynamic, are provided, together
--- with operations for converting dynamic values into a concrete
--- (monomorphic) type.
---
------------------------------------------------------------------------------
-
-module Data.Dynamic
- (
-
- -- Module Data.Typeable re-exported for convenience
- module Data.Typeable,
-
- -- * The @Dynamic@ type
- Dynamic, -- abstract, instance of: Show, Typeable
-
- -- * Converting to and from @Dynamic@
- toDyn, -- :: Typeable a => a -> Dynamic
- fromDyn, -- :: Typeable a => Dynamic -> a -> a
- fromDynamic, -- :: Typeable a => Dynamic -> Maybe a
-
- -- * Applying functions of dynamic type
- dynApply,
- dynApp,
- dynTypeRep
-
- ) where
-
-
-import Data.Typeable
-import Data.Maybe
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.Show
-import GHC.Err
-import GHC.Num
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude
-import Hugs.IO
-import Hugs.IORef
-import Hugs.IOExts
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-unsafeCoerce :: a -> b
-unsafeCoerce = unsafeCoerce#
-#endif
-
-#ifdef __NHC__
-import NonStdUnsafeCoerce (unsafeCoerce)
-import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
-#endif
-
-#include "Typeable.h"
-
--------------------------------------------------------------
---
--- The type Dynamic
---
--------------------------------------------------------------
-
-{-|
- A value of type 'Dynamic' is an object encapsulated together with its type.
-
- A 'Dynamic' may only represent a monomorphic value; an attempt to
- create a value of type 'Dynamic' from a polymorphically-typed
- expression will result in an ambiguity error (see 'toDyn').
-
- 'Show'ing a value of type 'Dynamic' returns a pretty-printed representation
- of the object\'s type; useful for debugging.
--}
-#ifndef __HUGS__
-data Dynamic = Dynamic TypeRep Obj
-#endif
-
-INSTANCE_TYPEABLE0(Dynamic,dynamicTc,"Dynamic")
-
-instance Show Dynamic where
- -- the instance just prints the type representation.
- showsPrec _ (Dynamic t _) =
- showString "<<" .
- showsPrec 0 t .
- showString ">>"
-
-#ifdef __GLASGOW_HASKELL__
-type Obj = Any
- -- Use GHC's primitive 'Any' type to hold the dynamically typed value.
- --
- -- In GHC's new eval/apply execution model this type must not look
- -- like a data type. If it did, GHC would use the constructor convention
- -- when evaluating it, and this will go wrong if the object is really a
- -- function. Using Any forces GHC to use
- -- a fallback convention for evaluating it that works for all types.
-#elif !defined(__HUGS__)
-data Obj = Obj
-#endif
-
--- | Converts an arbitrary value into an object of type 'Dynamic'.
---
--- The type of the object must be an instance of 'Typeable', which
--- ensures that only monomorphically-typed objects may be converted to
--- 'Dynamic'. To convert a polymorphic object into 'Dynamic', give it
--- a monomorphic type signature. For example:
---
--- > toDyn (id :: Int -> Int)
---
-toDyn :: Typeable a => a -> Dynamic
-toDyn v = Dynamic (typeOf v) (unsafeCoerce v)
-
--- | Converts a 'Dynamic' object back into an ordinary Haskell value of
--- the correct type. See also 'fromDynamic'.
-fromDyn :: Typeable a
- => Dynamic -- ^ the dynamically-typed object
- -> a -- ^ a default value
- -> a -- ^ returns: the value of the first argument, if
- -- it has the correct type, otherwise the value of
- -- the second argument.
-fromDyn (Dynamic t v) def
- | typeOf def == t = unsafeCoerce v
- | otherwise = def
-
--- | Converts a 'Dynamic' object back into an ordinary Haskell value of
--- the correct type. See also 'fromDyn'.
-fromDynamic
- :: Typeable a
- => Dynamic -- ^ the dynamically-typed object
- -> Maybe a -- ^ returns: @'Just' a@, if the dynamically-typed
- -- object has the correct type (and @a@ is its value),
- -- or 'Nothing' otherwise.
-fromDynamic (Dynamic t v) =
- case unsafeCoerce v of
- r | t == typeOf r -> Just r
- | otherwise -> Nothing
-
--- (f::(a->b)) `dynApply` (x::a) = (f a)::b
-dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
-dynApply (Dynamic t1 f) (Dynamic t2 x) =
- case funResultTy t1 t2 of
- Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x))
- Nothing -> Nothing
-
-dynApp :: Dynamic -> Dynamic -> Dynamic
-dynApp f x = case dynApply f x of
- Just r -> r
- Nothing -> error ("Type error in dynamic application.\n" ++
- "Can't apply function " ++ show f ++
- " to argument " ++ show x)
-
-dynTypeRep :: Dynamic -> TypeRep
-dynTypeRep (Dynamic tr _) = tr
+++ /dev/null
-{-# OPTIONS -fno-implicit-prelude #-}
-module Data.Dynamic where
-import {-# SOURCE #-} Data.Typeable (TypeRep)
-data Dynamic
-dynTypeRep :: Dynamic -> TypeRep
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Either
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- The Either type, and associated operations.
---
------------------------------------------------------------------------------
-
-module Data.Either (
- Either(..),
- either -- :: (a -> c) -> (b -> c) -> Either a b -> c
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-
-{-|
-
-The 'Either' type represents values with two possibilities: a value of
-type @'Either' a b@ is either @'Left' a@ or @'Right' b@.
-
-The 'Either' type is sometimes used to represent a value which is
-either correct or an error; by convention, the 'Left' constructor is
-used to hold an error value and the 'Right' constructor is used to
-hold a correct value (mnemonic: \"right\" also means \"correct\").
--}
-data Either a b = Left a | Right b deriving (Eq, Ord )
-
--- | Case analysis for the 'Either' type.
--- If the value is @'Left' a@, apply the first function to @a@;
--- if it is @'Right' b@, apply the second function to @b@.
-either :: (a -> c) -> (b -> c) -> Either a b -> c
-either f _ (Left x) = f x
-either _ g (Right y) = g y
-#endif /* __GLASGOW_HASKELL__ */
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Eq
--- Copyright : (c) The University of Glasgow 2005
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : stable
--- Portability : portable
---
--- Equality
---
------------------------------------------------------------------------------
-
-module Data.Eq (
- Eq(..),
- ) where
-
-#if __GLASGOW_HASKELL__
-import GHC.Base
-#endif
+++ /dev/null
-{-# OPTIONS -Wall -fno-warn-unused-binds #-}
-
------------------------------------------------------------------------------
--- |
--- Module : Data.Fixed
--- Copyright : (c) Ashley Yakeley 2005, 2006
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : Ashley Yakeley <ashley@semantic.org>
--- Stability : experimental
--- Portability : portable
---
--- This module defines a "Fixed" type for fixed-precision arithmetic.
--- The parameter to Fixed is any type that's an instance of HasResolution.
--- HasResolution has a single method that gives the resolution of the Fixed type.
--- Parameter types E6 and E12 (for 10^6 and 10^12) are defined, as well as
--- type synonyms for Fixed E6 and Fixed E12.
---
--- This module also contains generalisations of div, mod, and divmod to work
--- with any Real instance.
---
------------------------------------------------------------------------------
-
-module Data.Fixed
-(
- div',mod',divMod',
-
- Fixed,HasResolution(..),
- showFixed,
- E6,Micro,
- E12,Pico
-) where
-
-import Prelude -- necessary to get dependencies right
-
--- | generalisation of 'div' to any instance of Real
-div' :: (Real a,Integral b) => a -> a -> b
-div' n d = floor ((toRational n) / (toRational d))
-
--- | generalisation of 'divMod' to any instance of Real
-divMod' :: (Real a,Integral b) => a -> a -> (b,a)
-divMod' n d = (f,n - (fromIntegral f) * d) where
- f = div' n d
-
--- | generalisation of 'mod' to any instance of Real
-mod' :: (Real a) => a -> a -> a
-mod' n d = n - (fromInteger f) * d where
- f = div' n d
-
-newtype Fixed a = MkFixed Integer deriving (Eq,Ord)
-
-class HasResolution a where
- resolution :: a -> Integer
-
-fixedResolution :: (HasResolution a) => Fixed a -> Integer
-fixedResolution fa = resolution (uf fa) where
- uf :: Fixed a -> a
- uf _ = undefined
-
-withType :: (a -> f a) -> f a
-withType foo = foo undefined
-
-withResolution :: (HasResolution a) => (Integer -> f a) -> f a
-withResolution foo = withType (foo . resolution)
-
-instance Enum (Fixed a) where
- succ (MkFixed a) = MkFixed (succ a)
- pred (MkFixed a) = MkFixed (pred a)
- toEnum = MkFixed . toEnum
- fromEnum (MkFixed a) = fromEnum a
- enumFrom (MkFixed a) = fmap MkFixed (enumFrom a)
- enumFromThen (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromThen a b)
- enumFromTo (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromTo a b)
- enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c)
-
-instance (HasResolution a) => Num (Fixed a) where
- (MkFixed a) + (MkFixed b) = MkFixed (a + b)
- (MkFixed a) - (MkFixed b) = MkFixed (a - b)
- fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (fixedResolution fa))
- negate (MkFixed a) = MkFixed (negate a)
- abs (MkFixed a) = MkFixed (abs a)
- signum (MkFixed a) = fromInteger (signum a)
- fromInteger i = withResolution (\res -> MkFixed (i * res))
-
-instance (HasResolution a) => Real (Fixed a) where
- toRational fa@(MkFixed a) = (toRational a) / (toRational (fixedResolution fa))
-
-instance (HasResolution a) => Fractional (Fixed a) where
- fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (fixedResolution fa)) b)
- recip fa@(MkFixed a) = MkFixed (div (res * res) a) where
- res = fixedResolution fa
- fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))
-
-instance (HasResolution a) => RealFrac (Fixed a) where
- properFraction a = (i,a - (fromIntegral i)) where
- i = truncate a
- truncate f = truncate (toRational f)
- round f = round (toRational f)
- ceiling f = ceiling (toRational f)
- floor f = floor (toRational f)
-
-chopZeros :: Integer -> String
-chopZeros 0 = ""
-chopZeros a | mod a 10 == 0 = chopZeros (div a 10)
-chopZeros a = show a
-
--- only works for positive a
-showIntegerZeros :: Bool -> Int -> Integer -> String
-showIntegerZeros True _ 0 = ""
-showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where
- s = show a
- s' = if chopTrailingZeros then chopZeros a else s
-
-withDot :: String -> String
-withDot "" = ""
-withDot s = '.':s
-
--- | First arg is whether to chop off trailing zeros
-showFixed :: (HasResolution a) => Bool -> Fixed a -> String
-showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa))
-showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where
- res = fixedResolution fa
- (i,d) = divMod a res
- -- enough digits to be unambiguous
- digits = ceiling (logBase 10 (fromInteger res) :: Double)
- maxnum = 10 ^ digits
- fracNum = div (d * maxnum) res
-
-instance (HasResolution a) => Show (Fixed a) where
- show = showFixed False
-
-
-
-data E6 = E6
-
-instance HasResolution E6 where
- resolution _ = 1000000
-
-type Micro = Fixed E6
-
-
-data E12 = E12
-
-instance HasResolution E12 where
- resolution _ = 1000000000000
-
-type Pico = Fixed E12
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Foldable
--- Copyright : Ross Paterson 2005
--- License : BSD-style (see the LICENSE file in the distribution)
---
--- Maintainer : ross@soi.city.ac.uk
--- Stability : experimental
--- Portability : portable
---
--- Class of data structures that can be folded to a summary value.
---
--- Many of these functions generalize "Prelude", "Control.Monad" and
--- "Data.List" functions of the same names from lists to any 'Foldable'
--- functor. To avoid ambiguity, either import those modules hiding
--- these names or qualify uses of these function names with an alias
--- for this module.
-
-module Data.Foldable (
- -- * Folds
- Foldable(..),
- -- ** Special biased folds
- foldr',
- foldl',
- foldrM,
- foldlM,
- -- ** Folding actions
- -- *** Applicative actions
- traverse_,
- for_,
- sequenceA_,
- asum,
- -- *** Monadic actions
- mapM_,
- forM_,
- sequence_,
- msum,
- -- ** Specialized folds
- toList,
- concat,
- concatMap,
- and,
- or,
- any,
- all,
- sum,
- product,
- maximum,
- maximumBy,
- minimum,
- minimumBy,
- -- ** Searches
- elem,
- notElem,
- find
- ) where
-
-import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_,
- elem, notElem, concat, concatMap, and, or, any, all,
- sum, product, maximum, minimum)
-import qualified Prelude (foldl, foldr, foldl1, foldr1)
-import Control.Applicative
-import Control.Monad (MonadPlus(..))
-import Data.Maybe (fromMaybe, listToMaybe)
-import Data.Monoid
-import Data.Array
-
-#ifdef __NHC__
-import Control.Arrow (ArrowZero(..)) -- work around nhc98 typechecker problem
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Exts (build)
-#endif
-
--- | Data structures that can be folded.
---
--- Minimal complete definition: 'foldMap' or 'foldr'.
---
--- For example, given a data type
---
--- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)
---
--- a suitable instance would be
---
--- > instance Foldable Tree
--- > foldMap f Empty = mempty
--- > foldMap f (Leaf x) = f x
--- > foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r
---
--- This is suitable even for abstract types, as the monoid is assumed
--- to satisfy the monoid laws.
---
-class Foldable t where
- -- | Combine the elements of a structure using a monoid.
- fold :: Monoid m => t m -> m
- fold = foldMap id
-
- -- | Map each element of the structure to a monoid,
- -- and combine the results.
- foldMap :: Monoid m => (a -> m) -> t a -> m
- foldMap f = foldr (mappend . f) mempty
-
- -- | Right-associative fold of a structure.
- --
- -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@
- foldr :: (a -> b -> b) -> b -> t a -> b
- foldr f z t = appEndo (foldMap (Endo . f) t) z
-
- -- | Left-associative fold of a structure.
- --
- -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@
- foldl :: (a -> b -> a) -> a -> t b -> a
- foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z
-
- -- | A variant of 'foldr' that has no base case,
- -- and thus may only be applied to non-empty structures.
- --
- -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@
- foldr1 :: (a -> a -> a) -> t a -> a
- foldr1 f xs = fromMaybe (error "foldr1: empty structure")
- (foldr mf Nothing xs)
- where mf x Nothing = Just x
- mf x (Just y) = Just (f x y)
-
- -- | A variant of 'foldl' that has no base case,
- -- and thus may only be applied to non-empty structures.
- --
- -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@
- foldl1 :: (a -> a -> a) -> t a -> a
- foldl1 f xs = fromMaybe (error "foldl1: empty structure")
- (foldl mf Nothing xs)
- where mf Nothing y = Just y
- mf (Just x) y = Just (f x y)
-
--- instances for Prelude types
-
-instance Foldable Maybe where
- foldr f z Nothing = z
- foldr f z (Just x) = f x z
-
- foldl f z Nothing = z
- foldl f z (Just x) = f z x
-
-instance Foldable [] where
- foldr = Prelude.foldr
- foldl = Prelude.foldl
- foldr1 = Prelude.foldr1
- foldl1 = Prelude.foldl1
-
-instance Ix i => Foldable (Array i) where
- foldr f z = Prelude.foldr f z . elems
-
--- | Fold over the elements of a structure,
--- associating to the right, but strictly.
-foldr' :: Foldable t => (a -> b -> b) -> b -> t a -> b
-foldr' f z xs = foldl f' id xs z
- where f' k x z = k $! f x z
-
--- | Monadic fold over the elements of a structure,
--- associating to the right, i.e. from right to left.
-foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b
-foldrM f z xs = foldl f' return xs z
- where f' k x z = f x z >>= k
-
--- | Fold over the elements of a structure,
--- associating to the left, but strictly.
-foldl' :: Foldable t => (a -> b -> a) -> a -> t b -> a
-foldl' f z xs = foldr f' id xs z
- where f' x k z = k $! f z x
-
--- | Monadic fold over the elements of a structure,
--- associating to the left, i.e. from left to right.
-foldlM :: (Foldable t, Monad m) => (a -> b -> m a) -> a -> t b -> m a
-foldlM f z xs = foldr f' return xs z
- where f' x k z = f z x >>= k
-
--- | Map each element of a structure to an action, evaluate
--- these actions from left to right, and ignore the results.
-traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()
-traverse_ f = foldr ((*>) . f) (pure ())
-
--- | 'for_' is 'traverse_' with its arguments flipped.
-for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f ()
-{-# INLINE for_ #-}
-for_ = flip traverse_
-
--- | Map each element of a structure to a monadic action, evaluate
--- these actions from left to right, and ignore the results.
-mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m ()
-mapM_ f = foldr ((>>) . f) (return ())
-
--- | 'forM_' is 'mapM_' with its arguments flipped.
-forM_ :: (Foldable t, Monad m) => t a -> (a -> m b) -> m ()
-{-# INLINE forM_ #-}
-forM_ = flip mapM_
-
--- | Evaluate each action in the structure from left to right,
--- and ignore the results.
-sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f ()
-sequenceA_ = foldr (*>) (pure ())
-
--- | Evaluate each monadic action in the structure from left to right,
--- and ignore the results.
-sequence_ :: (Foldable t, Monad m) => t (m a) -> m ()
-sequence_ = foldr (>>) (return ())
-
--- | The sum of a collection of actions, generalizing 'concat'.
-asum :: (Foldable t, Alternative f) => t (f a) -> f a
-{-# INLINE asum #-}
-asum = foldr (<|>) empty
-
--- | The sum of a collection of actions, generalizing 'concat'.
-msum :: (Foldable t, MonadPlus m) => t (m a) -> m a
-{-# INLINE msum #-}
-msum = foldr mplus mzero
-
--- These use foldr rather than foldMap to avoid repeated concatenation.
-
--- | List of elements of a structure.
-toList :: Foldable t => t a -> [a]
-#ifdef __GLASGOW_HASKELL__
-toList t = build (\ c n -> foldr c n t)
-#else
-toList = foldr (:) []
-#endif
-
--- | The concatenation of all the elements of a container of lists.
-concat :: Foldable t => t [a] -> [a]
-concat = fold
-
--- | Map a function over all the elements of a container and concatenate
--- the resulting lists.
-concatMap :: Foldable t => (a -> [b]) -> t a -> [b]
-concatMap = foldMap
-
--- | 'and' returns the conjunction of a container of Bools. For the
--- result to be 'True', the container must be finite; 'False', however,
--- results from a 'False' value finitely far from the left end.
-and :: Foldable t => t Bool -> Bool
-and = getAll . foldMap All
-
--- | 'or' returns the disjunction of a container of Bools. For the
--- result to be 'False', the container must be finite; 'True', however,
--- results from a 'True' value finitely far from the left end.
-or :: Foldable t => t Bool -> Bool
-or = getAny . foldMap Any
-
--- | Determines whether any element of the structure satisfies the predicate.
-any :: Foldable t => (a -> Bool) -> t a -> Bool
-any p = getAny . foldMap (Any . p)
-
--- | Determines whether all elements of the structure satisfy the predicate.
-all :: Foldable t => (a -> Bool) -> t a -> Bool
-all p = getAll . foldMap (All . p)
-
--- | The 'sum' function computes the sum of the numbers of a structure.
-sum :: (Foldable t, Num a) => t a -> a
-sum = getSum . foldMap Sum
-
--- | The 'product' function computes the product of the numbers of a structure.
-product :: (Foldable t, Num a) => t a -> a
-product = getProduct . foldMap Product
-
--- | The largest element of a non-empty structure.
-maximum :: (Foldable t, Ord a) => t a -> a
-maximum = foldr1 max
-
--- | The largest element of a non-empty structure with respect to the
--- given comparison function.
-maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a
-maximumBy cmp = foldr1 max'
- where max' x y = case cmp x y of
- GT -> x
- _ -> y
-
--- | The least element of a non-empty structure.
-minimum :: (Foldable t, Ord a) => t a -> a
-minimum = foldr1 min
-
--- | The least element of a non-empty structure with respect to the
--- given comparison function.
-minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a
-minimumBy cmp = foldr1 min'
- where min' x y = case cmp x y of
- GT -> y
- _ -> x
-
--- | Does the element occur in the structure?
-elem :: (Foldable t, Eq a) => a -> t a -> Bool
-elem = any . (==)
-
--- | 'notElem' is the negation of 'elem'.
-notElem :: (Foldable t, Eq a) => a -> t a -> Bool
-notElem x = not . elem x
-
--- | The 'find' function takes a predicate and a structure and returns
--- the leftmost element of the structure matching the predicate, or
--- 'Nothing' if there is no such element.
-find :: Foldable t => (a -> Bool) -> t a -> Maybe a
-find p = listToMaybe . concatMap (\ x -> if p x then [x] else [])
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Function
--- Copyright : Nils Anders Danielsson 2006
--- License : BSD-style (see the LICENSE file in the distribution)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Simple combinators working solely on and with functions.
-
-module Data.Function
- ( -- * "Prelude" re-exports
- id, const, (.), flip, ($)
- -- * Other combinators
- , fix
- , on
- ) where
-
-import Prelude
-
-infixl 0 `on`
-
--- | @'fix' f@ is the least fixed point of the function @f@,
--- i.e. the least defined @x@ such that @f x = x@.
-fix :: (a -> a) -> a
-fix f = let x = f x in x
-
--- | @(*) \`on\` f = \\x y -> f x * f y@.
---
--- Typical usage: @'Data.List.sortBy' ('compare' \`on\` 'fst')@.
---
--- Algebraic properties:
---
--- * @(*) \`on\` 'id' = (*)@ (if @(*) ∉ {⊥, 'const' ⊥}@)
---
--- * @((*) \`on\` f) \`on\` g = (*) \`on\` (f . g)@
---
--- * @'flip' on f . 'flip' on g = 'flip' on (g . f)@
-
--- Proofs (so that I don't have to edit the test-suite):
-
--- (*) `on` id
--- =
--- \x y -> id x * id y
--- =
--- \x y -> x * y
--- = { If (*) /= _|_ or const _|_. }
--- (*)
-
--- (*) `on` f `on` g
--- =
--- ((*) `on` f) `on` g
--- =
--- \x y -> ((*) `on` f) (g x) (g y)
--- =
--- \x y -> (\x y -> f x * f y) (g x) (g y)
--- =
--- \x y -> f (g x) * f (g y)
--- =
--- \x y -> (f . g) x * (f . g) y
--- =
--- (*) `on` (f . g)
--- =
--- (*) `on` f . g
-
--- flip on f . flip on g
--- =
--- (\h (*) -> (*) `on` h) f . (\h (*) -> (*) `on` h) g
--- =
--- (\(*) -> (*) `on` f) . (\(*) -> (*) `on` g)
--- =
--- \(*) -> (*) `on` g `on` f
--- = { See above. }
--- \(*) -> (*) `on` g . f
--- =
--- (\h (*) -> (*) `on` h) (g . f)
--- =
--- flip on (g . f)
-
-on :: (b -> b -> c) -> (a -> b) -> a -> a -> c
-(*) `on` f = \x y -> f x * f y
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Generics
--- Copyright : (c) The University of Glasgow, CWI 2001--2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Data.Generics.Basics)
---
--- \"Scrap your boilerplate\" --- Generic programming in Haskell
--- See <http://www.cs.vu.nl/boilerplate/>. To scrap your boilerplate it
--- is sufficient to import the present module, which simply re-exports all
--- themes of the Data.Generics library.
---
------------------------------------------------------------------------------
-
-module Data.Generics (
-
- -- * All Data.Generics modules
- module Data.Generics.Basics, -- primitives
- module Data.Generics.Instances, -- instances of Data class
- module Data.Generics.Aliases, -- aliases for type case, generic types
- module Data.Generics.Schemes, -- traversal schemes (everywhere etc.)
- module Data.Generics.Text, -- generic read and show
- module Data.Generics.Twins, -- twin traversal, e.g., generic eq
-
-#ifndef __HADDOCK__
- -- Data types for the sum-of-products type encoding;
- -- included for backwards compatibility; maybe obsolete.
- (:*:)(..), (:+:)(..), Unit(..)
-#endif
-
- ) where
-
-------------------------------------------------------------------------------
-
-import Prelude -- So that 'make depend' works
-
-#ifdef __GLASGOW_HASKELL__
-#ifndef __HADDOCK__
- -- Data types for the sum-of-products type encoding;
- -- included for backwards compatibility; maybe obsolete.
-import GHC.Base ( (:*:)(..), (:+:)(..), Unit(..) )
-#endif
-#endif
-
-import Data.Generics.Basics
-import Data.Generics.Instances
-import Data.Generics.Aliases
-import Data.Generics.Schemes
-import Data.Generics.Text
-import Data.Generics.Twins
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Generics.Aliases
--- Copyright : (c) The University of Glasgow, CWI 2001--2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (local universal quantification)
---
--- \"Scrap your boilerplate\" --- Generic programming in Haskell
--- See <http://www.cs.vu.nl/boilerplate/>. The present module provides
--- a number of declarations for typical generic function types,
--- corresponding type case, and others.
---
------------------------------------------------------------------------------
-
-module Data.Generics.Aliases (
-
- -- * Combinators to \"make\" generic functions via cast
- mkT, mkQ, mkM, mkMp, mkR,
- ext0, extT, extQ, extM, extMp, extB, extR,
-
- -- * Type synonyms for generic function types
- GenericT,
- GenericQ,
- GenericM,
- GenericB,
- GenericR,
- Generic,
- Generic'(..),
- GenericT'(..),
- GenericQ'(..),
- GenericM'(..),
-
- -- * Inredients of generic functions
- orElse,
-
- -- * Function combinators on generic functions
- recoverMp,
- recoverQ,
- choiceMp,
- choiceQ,
-
- -- * Type extension for unary type constructors
- ext1T,
- ext1M,
- ext1Q,
- ext1R
-
- ) where
-
-#ifdef __HADDOCK__
-import Prelude
-#endif
-import Control.Monad
-import Data.Generics.Basics
-
-------------------------------------------------------------------------------
---
--- Combinators to "make" generic functions
--- We use type-safe cast in a number of ways to make generic functions.
---
-------------------------------------------------------------------------------
-
--- | Make a generic transformation;
--- start from a type-specific case;
--- preserve the term otherwise
---
-mkT :: ( Typeable a
- , Typeable b
- )
- => (b -> b)
- -> a
- -> a
-mkT = extT id
-
-
--- | Make a generic query;
--- start from a type-specific case;
--- return a constant otherwise
---
-mkQ :: ( Typeable a
- , Typeable b
- )
- => r
- -> (b -> r)
- -> a
- -> r
-(r `mkQ` br) a = case cast a of
- Just b -> br b
- Nothing -> r
-
-
--- | Make a generic monadic transformation;
--- start from a type-specific case;
--- resort to return otherwise
---
-mkM :: ( Monad m
- , Typeable a
- , Typeable b
- )
- => (b -> m b)
- -> a
- -> m a
-mkM = extM return
-
-
-{-
-
-For the remaining definitions, we stick to a more concise style, i.e.,
-we fold maybies with "maybe" instead of case ... of ..., and we also
-use a point-free style whenever possible.
-
--}
-
-
--- | Make a generic monadic transformation for MonadPlus;
--- use \"const mzero\" (i.e., failure) instead of return as default.
---
-mkMp :: ( MonadPlus m
- , Typeable a
- , Typeable b
- )
- => (b -> m b)
- -> a
- -> m a
-mkMp = extM (const mzero)
-
-
--- | Make a generic builder;
--- start from a type-specific ase;
--- resort to no build (i.e., mzero) otherwise
---
-mkR :: ( MonadPlus m
- , Typeable a
- , Typeable b
- )
- => m b -> m a
-mkR f = mzero `extR` f
-
-
--- | Flexible type extension
-ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a
-ext0 def ext = maybe def id (gcast ext)
-
-
--- | Extend a generic transformation by a type-specific case
-extT :: ( Typeable a
- , Typeable b
- )
- => (a -> a)
- -> (b -> b)
- -> a
- -> a
-extT def ext = unT ((T def) `ext0` (T ext))
-
-
--- | Extend a generic query by a type-specific case
-extQ :: ( Typeable a
- , Typeable b
- )
- => (a -> q)
- -> (b -> q)
- -> a
- -> q
-extQ f g a = maybe (f a) g (cast a)
-
-
--- | Extend a generic monadic transformation by a type-specific case
-extM :: ( Monad m
- , Typeable a
- , Typeable b
- )
- => (a -> m a) -> (b -> m b) -> a -> m a
-extM def ext = unM ((M def) `ext0` (M ext))
-
-
--- | Extend a generic MonadPlus transformation by a type-specific case
-extMp :: ( MonadPlus m
- , Typeable a
- , Typeable b
- )
- => (a -> m a) -> (b -> m b) -> a -> m a
-extMp = extM
-
-
--- | Extend a generic builder
-extB :: ( Typeable a
- , Typeable b
- )
- => a -> b -> a
-extB a = maybe a id . cast
-
-
--- | Extend a generic reader
-extR :: ( Monad m
- , Typeable a
- , Typeable b
- )
- => m a -> m b -> m a
-extR def ext = unR ((R def) `ext0` (R ext))
-
-
-
-------------------------------------------------------------------------------
---
--- Type synonyms for generic function types
---
-------------------------------------------------------------------------------
-
-
--- | Generic transformations,
--- i.e., take an \"a\" and return an \"a\"
---
-type GenericT = forall a. Data a => a -> a
-
-
--- | Generic queries of type \"r\",
--- i.e., take any \"a\" and return an \"r\"
---
-type GenericQ r = forall a. Data a => a -> r
-
-
--- | Generic monadic transformations,
--- i.e., take an \"a\" and compute an \"a\"
---
-type GenericM m = forall a. Data a => a -> m a
-
-
--- | Generic builders
--- i.e., produce an \"a\".
---
-type GenericB = forall a. Data a => a
-
-
--- | Generic readers, say monadic builders,
--- i.e., produce an \"a\" with the help of a monad \"m\".
---
-type GenericR m = forall a. Data a => m a
-
-
--- | The general scheme underlying generic functions
--- assumed by gfoldl; there are isomorphisms such as
--- GenericT = Generic T.
---
-type Generic c = forall a. Data a => a -> c a
-
-
--- | Wrapped generic functions;
--- recall: [Generic c] would be legal but [Generic' c] not.
---
-data Generic' c = Generic' { unGeneric' :: Generic c }
-
-
--- | Other first-class polymorphic wrappers
-newtype GenericT' = GT { unGT :: Data a => a -> a }
-newtype GenericQ' r = GQ { unGQ :: GenericQ r }
-newtype GenericM' m = GM { unGM :: Data a => a -> m a }
-
-
--- | Left-biased choice on maybies
-orElse :: Maybe a -> Maybe a -> Maybe a
-x `orElse` y = case x of
- Just _ -> x
- Nothing -> y
-
-
-{-
-
-The following variations take "orElse" to the function
-level. Furthermore, we generalise from "Maybe" to any
-"MonadPlus". This makes sense for monadic transformations and
-queries. We say that the resulting combinators modell choice. We also
-provide a prime example of choice, that is, recovery from failure. In
-the case of transformations, we recover via return whereas for
-queries a given constant is returned.
-
--}
-
--- | Choice for monadic transformations
-choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m
-choiceMp f g x = f x `mplus` g x
-
-
--- | Choice for monadic queries
-choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r)
-choiceQ f g x = f x `mplus` g x
-
-
--- | Recover from the failure of monadic transformation by identity
-recoverMp :: MonadPlus m => GenericM m -> GenericM m
-recoverMp f = f `choiceMp` return
-
-
--- | Recover from the failure of monadic query by a constant
-recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r)
-recoverQ r f = f `choiceQ` const (return r)
-
-
-
-------------------------------------------------------------------------------
---
--- Type extension for unary type constructors
---
-------------------------------------------------------------------------------
-
-
-
--- | Flexible type extension
-ext1 :: (Data a, Typeable1 t)
- => c a
- -> (forall a. Data a => c (t a))
- -> c a
-ext1 def ext = maybe def id (dataCast1 ext)
-
-
--- | Type extension of transformations for unary type constructors
-ext1T :: (Data d, Typeable1 t)
- => (forall d. Data d => d -> d)
- -> (forall d. Data d => t d -> t d)
- -> d -> d
-ext1T def ext = unT ((T def) `ext1` (T ext))
-
-
--- | Type extension of monadic transformations for type constructors
-ext1M :: (Monad m, Data d, Typeable1 t)
- => (forall d. Data d => d -> m d)
- -> (forall d. Data d => t d -> m (t d))
- -> d -> m d
-ext1M def ext = unM ((M def) `ext1` (M ext))
-
-
--- | Type extension of queries for type constructors
-ext1Q :: (Data d, Typeable1 t)
- => (d -> q)
- -> (forall d. Data d => t d -> q)
- -> d -> q
-ext1Q def ext = unQ ((Q def) `ext1` (Q ext))
-
-
--- | Type extension of readers for type constructors
-ext1R :: (Monad m, Data d, Typeable1 t)
- => m d
- -> (forall d. Data d => m (t d))
- -> m d
-ext1R def ext = unR ((R def) `ext1` (R ext))
-
-
-
-------------------------------------------------------------------------------
---
--- Type constructors for type-level lambdas
---
-------------------------------------------------------------------------------
-
-
--- | The type constructor for transformations
-newtype T x = T { unT :: x -> x }
-
--- | The type constructor for transformations
-newtype M m x = M { unM :: x -> m x }
-
--- | The type constructor for queries
-newtype Q q x = Q { unQ :: x -> q }
-
--- | The type constructor for readers
-newtype R m x = R { unR :: m x }
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Generics.Basics
--- Copyright : (c) The University of Glasgow, CWI 2001--2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (local universal quantification)
---
--- \"Scrap your boilerplate\" --- Generic programming in Haskell.
--- See <http://www.cs.vu.nl/boilerplate/>. This module provides
--- the 'Data' class with its primitives for generic programming.
---
------------------------------------------------------------------------------
-
-module Data.Generics.Basics (
-
- -- * Module Data.Typeable re-exported for convenience
- module Data.Typeable,
-
- -- * The Data class for processing constructor applications
- Data(
- gfoldl, -- :: ... -> a -> c a
- gunfold, -- :: ... -> Constr -> c a
- toConstr, -- :: a -> Constr
- dataTypeOf, -- :: a -> DataType
- dataCast1, -- mediate types and unary type constructors
- dataCast2, -- mediate types and binary type constructors
- -- Generic maps defined in terms of gfoldl
- gmapT,
- gmapQ,
- gmapQl,
- gmapQr,
- gmapQi,
- gmapM,
- gmapMp,
- gmapMo
- ),
-
- -- * Datatype representations
- DataType, -- abstract, instance of: Show
- -- ** Constructors
- mkDataType, -- :: String -> [Constr] -> DataType
- mkIntType, -- :: String -> DataType
- mkFloatType, -- :: String -> DataType
- mkStringType, -- :: String -> DataType
- mkNorepType, -- :: String -> DataType
- -- ** Observers
- dataTypeName, -- :: DataType -> String
- DataRep(..), -- instance of: Eq, Show
- dataTypeRep, -- :: DataType -> DataRep
- -- ** Convenience functions
- repConstr, -- :: DataType -> ConstrRep -> Constr
- isAlgType, -- :: DataType -> Bool
- dataTypeConstrs,-- :: DataType -> [Constr]
- indexConstr, -- :: DataType -> ConIndex -> Constr
- maxConstrIndex, -- :: DataType -> ConIndex
- isNorepType, -- :: DataType -> Bool
-
- -- * Data constructor representations
- Constr, -- abstract, instance of: Eq, Show
- ConIndex, -- alias for Int, start at 1
- Fixity(..), -- instance of: Eq, Show
- -- ** Constructors
- mkConstr, -- :: DataType -> String -> Fixity -> Constr
- mkIntConstr, -- :: DataType -> Integer -> Constr
- mkFloatConstr, -- :: DataType -> Double -> Constr
- mkStringConstr, -- :: DataType -> String -> Constr
- -- ** Observers
- constrType, -- :: Constr -> DataType
- ConstrRep(..), -- instance of: Eq, Show
- constrRep, -- :: Constr -> ConstrRep
- constrFields, -- :: Constr -> [String]
- constrFixity, -- :: Constr -> Fixity
- -- ** Convenience function: algebraic data types
- constrIndex, -- :: Constr -> ConIndex
- -- ** From strings to constructors and vice versa: all data types
- showConstr, -- :: Constr -> String
- readConstr, -- :: DataType -> String -> Maybe Constr
-
- -- * Convenience functions: take type constructors apart
- tyconUQname, -- :: String -> String
- tyconModule, -- :: String -> String
-
- -- * Generic operations defined in terms of 'gunfold'
- fromConstr, -- :: Constr -> a
- fromConstrB, -- :: ... -> Constr -> a
- fromConstrM -- :: Monad m => ... -> Constr -> m a
-
- ) where
-
-
-------------------------------------------------------------------------------
-
-import Prelude -- necessary to get dependencies right
-
-import Data.Typeable
-import Data.Maybe
-import Control.Monad
-
-
-
-------------------------------------------------------------------------------
---
--- The Data class
---
-------------------------------------------------------------------------------
-
-{- |
-The 'Data' class comprehends a fundamental primitive 'gfoldl' for
-folding over constructor applications, say terms. This primitive can
-be instantiated in several ways to map over the immediate subterms
-of a term; see the @gmap@ combinators later in this class. Indeed, a
-generic programmer does not necessarily need to use the ingenious gfoldl
-primitive but rather the intuitive @gmap@ combinators. The 'gfoldl'
-primitive is completed by means to query top-level constructors, to
-turn constructor representations into proper terms, and to list all
-possible datatype constructors. This completion allows us to serve
-generic programming scenarios like read, show, equality, term generation.
-
-The combinators 'gmapT', 'gmapQ', 'gmapM', etc are all provided with
-default definitions in terms of 'gfoldl', leaving open the opportunity
-to provide datatype-specific definitions.
-(The inclusion of the @gmap@ combinators as members of class 'Data'
-allows the programmer or the compiler to derive specialised, and maybe
-more efficient code per datatype. /Note/: 'gfoldl' is more higher-order
-than the @gmap@ combinators. This is subject to ongoing benchmarking
-experiments. It might turn out that the @gmap@ combinators will be
-moved out of the class 'Data'.)
-
-Conceptually, the definition of the @gmap@ combinators in terms of the
-primitive 'gfoldl' requires the identification of the 'gfoldl' function
-arguments. Technically, we also need to identify the type constructor
-@c@ for the construction of the result type from the folded term type.
-
-In the definition of @gmapQ@/x/ combinators, we use phantom type
-constructors for the @c@ in the type of 'gfoldl' because the result type
-of a query does not involve the (polymorphic) type of the term argument.
-In the definition of 'gmapQl' we simply use the plain constant type
-constructor because 'gfoldl' is left-associative anyway and so it is
-readily suited to fold a left-associative binary operation over the
-immediate subterms. In the definition of gmapQr, extra effort is
-needed. We use a higher-order accumulation trick to mediate between
-left-associative constructor application vs. right-associative binary
-operation (e.g., @(:)@). When the query is meant to compute a value
-of type @r@, then the result type withing generic folding is @r -> r@.
-So the result of folding is a function to which we finally pass the
-right unit.
-
-With the @-fglasgow-exts@ option, GHC can generate instances of the
-'Data' class automatically. For example, given the declaration
-
-> data T a b = C1 a b | C2 deriving (Typeable, Data)
-
-GHC will generate an instance that is equivalent to
-
-> instance (Data a, Data b) => Data (T a b) where
-> gfoldl k z (C1 a b) = z C1 `k` a `k` b
-> gfoldl k z C2 = z C2
->
-> gunfold k z c = case constrIndex c of
-> 1 -> k (k (z C1))
-> 2 -> z C2
->
-> toConstr (C1 _ _) = con_C1
-> toConstr C2 = con_C2
->
-> dataTypeOf _ = ty_T
->
-> con_C1 = mkConstr ty_T "C1" [] Prefix
-> con_C2 = mkConstr ty_T "C2" [] Prefix
-> ty_T = mkDataType "Module.T" [con_C1, con_C2]
-
-This is suitable for datatypes that are exported transparently.
-
--}
-
-class Typeable a => Data a where
-
- -- | Left-associative fold operation for constructor applications.
- --
- -- The type of 'gfoldl' is a headache, but operationally it is a simple
- -- generalisation of a list fold.
- --
- -- The default definition for 'gfoldl' is @'const' 'id'@, which is
- -- suitable for abstract datatypes with no substructures.
- gfoldl :: (forall a b. Data a => c (a -> b) -> a -> c b)
- -- ^ defines how nonempty constructor applications are
- -- folded. It takes the folded tail of the constructor
- -- application and its head, i.e., an immediate subterm,
- -- and combines them in some way.
- -> (forall g. g -> c g)
- -- ^ defines how the empty constructor application is
- -- folded, like the neutral \/ start element for list
- -- folding.
- -> a
- -- ^ structure to be folded.
- -> c a
- -- ^ result, with a type defined in terms of @a@, but
- -- variability is achieved by means of type constructor
- -- @c@ for the construction of the actual result type.
-
- -- See the 'Data' instances in this file for an illustration of 'gfoldl'.
-
- gfoldl _ z = z
-
- -- | Unfolding constructor applications
- gunfold :: (forall b r. Data b => c (b -> r) -> c r)
- -> (forall r. r -> c r)
- -> Constr
- -> c a
-
- -- | Obtaining the constructor from a given datum.
- -- For proper terms, this is meant to be the top-level constructor.
- -- Primitive datatypes are here viewed as potentially infinite sets of
- -- values (i.e., constructors).
- toConstr :: a -> Constr
-
-
- -- | The outer type constructor of the type
- dataTypeOf :: a -> DataType
-
-
-
-------------------------------------------------------------------------------
---
--- Mediate types and type constructors
---
-------------------------------------------------------------------------------
-
- -- | Mediate types and unary type constructors.
- -- In 'Data' instances of the form @T a@, 'dataCast1' should be defined
- -- as 'gcast1'.
- --
- -- The default definition is @'const' 'Nothing'@, which is appropriate
- -- for non-unary type constructors.
- dataCast1 :: Typeable1 t
- => (forall a. Data a => c (t a))
- -> Maybe (c a)
- dataCast1 _ = Nothing
-
- -- | Mediate types and binary type constructors.
- -- In 'Data' instances of the form @T a b@, 'dataCast2' should be
- -- defined as 'gcast2'.
- --
- -- The default definition is @'const' 'Nothing'@, which is appropriate
- -- for non-binary type constructors.
- dataCast2 :: Typeable2 t
- => (forall a b. (Data a, Data b) => c (t a b))
- -> Maybe (c a)
- dataCast2 _ = Nothing
-
-
-
-------------------------------------------------------------------------------
---
--- Typical generic maps defined in terms of gfoldl
---
-------------------------------------------------------------------------------
-
-
- -- | A generic transformation that maps over the immediate subterms
- --
- -- The default definition instantiates the type constructor @c@ in the
- -- type of 'gfoldl' to an identity datatype constructor, using the
- -- isomorphism pair as injection and projection.
- gmapT :: (forall b. Data b => b -> b) -> a -> a
-
- -- Use an identity datatype constructor ID (see below)
- -- to instantiate the type constructor c in the type of gfoldl,
- -- and perform injections ID and projections unID accordingly.
- --
- gmapT f x = unID (gfoldl k ID x)
- where
- k (ID c) x = ID (c (f x))
-
-
- -- | A generic query with a left-associative binary operator
- gmapQl :: (r -> r' -> r) -> r -> (forall a. Data a => a -> r') -> a -> r
- gmapQl o r f = unCONST . gfoldl k z
- where
- k c x = CONST $ (unCONST c) `o` f x
- z _ = CONST r
-
- -- | A generic query with a right-associative binary operator
- gmapQr :: (r' -> r -> r) -> r -> (forall a. Data a => a -> r') -> a -> r
- gmapQr o r f x = unQr (gfoldl k (const (Qr id)) x) r
- where
- k (Qr c) x = Qr (\r -> c (f x `o` r))
-
-
- -- | A generic query that processes the immediate subterms and returns a list
- -- of results. The list is given in the same order as originally specified
- -- in the declaratoin of the data constructors.
- gmapQ :: (forall a. Data a => a -> u) -> a -> [u]
- gmapQ f = gmapQr (:) [] f
-
-
- -- | A generic query that processes one child by index (zero-based)
- gmapQi :: Int -> (forall a. Data a => a -> u) -> a -> u
- gmapQi i f x = case gfoldl k z x of { Qi _ q -> fromJust q }
- where
- k (Qi i' q) a = Qi (i'+1) (if i==i' then Just (f a) else q)
- z f = Qi 0 Nothing
-
-
- -- | A generic monadic transformation that maps over the immediate subterms
- --
- -- The default definition instantiates the type constructor @c@ in
- -- the type of 'gfoldl' to the monad datatype constructor, defining
- -- injection and projection using 'return' and '>>='.
- gmapM :: Monad m => (forall a. Data a => a -> m a) -> a -> m a
-
- -- Use immediately the monad datatype constructor
- -- to instantiate the type constructor c in the type of gfoldl,
- -- so injection and projection is done by return and >>=.
- --
- gmapM f = gfoldl k return
- where
- k c x = do c' <- c
- x' <- f x
- return (c' x')
-
-
- -- | Transformation of at least one immediate subterm does not fail
- gmapMp :: MonadPlus m => (forall a. Data a => a -> m a) -> a -> m a
-
-{-
-
-The type constructor that we use here simply keeps track of the fact
-if we already succeeded for an immediate subterm; see Mp below. To
-this end, we couple the monadic computation with a Boolean.
-
--}
-
- gmapMp f x = unMp (gfoldl k z x) >>= \(x',b) ->
- if b then return x' else mzero
- where
- z g = Mp (return (g,False))
- k (Mp c) x
- = Mp ( c >>= \(h,b) ->
- (f x >>= \x' -> return (h x',True))
- `mplus` return (h x,b)
- )
-
- -- | Transformation of one immediate subterm with success
- gmapMo :: MonadPlus m => (forall a. Data a => a -> m a) -> a -> m a
-
-{-
-
-We use the same pairing trick as for gmapMp,
-i.e., we use an extra Bool component to keep track of the
-fact whether an immediate subterm was processed successfully.
-However, we cut of mapping over subterms once a first subterm
-was transformed successfully.
-
--}
-
- gmapMo f x = unMp (gfoldl k z x) >>= \(x',b) ->
- if b then return x' else mzero
- where
- z g = Mp (return (g,False))
- k (Mp c) x
- = Mp ( c >>= \(h,b) -> if b
- then return (h x,b)
- else (f x >>= \x' -> return (h x',True))
- `mplus` return (h x,b)
- )
-
-
--- | The identity type constructor needed for the definition of gmapT
-newtype ID x = ID { unID :: x }
-
-
--- | The constant type constructor needed for the definition of gmapQl
-newtype CONST c a = CONST { unCONST :: c }
-
-
--- | Type constructor for adding counters to queries
-data Qi q a = Qi Int (Maybe q)
-
-
--- | The type constructor used in definition of gmapQr
-newtype Qr r a = Qr { unQr :: r -> r }
-
-
--- | The type constructor used in definition of gmapMp
-newtype Mp m x = Mp { unMp :: m (x, Bool) }
-
-
-
-------------------------------------------------------------------------------
---
--- Generic unfolding
---
-------------------------------------------------------------------------------
-
-
--- | Build a term skeleton
-fromConstr :: Data a => Constr -> a
-fromConstr = fromConstrB undefined
-
-
--- | Build a term and use a generic function for subterms
-fromConstrB :: Data a
- => (forall a. Data a => a)
- -> Constr
- -> a
-fromConstrB f = unID . gunfold k z
- where
- k c = ID (unID c f)
- z = ID
-
-
--- | Monadic variation on 'fromConstrB'
-fromConstrM :: (Monad m, Data a)
- => (forall a. Data a => m a)
- -> Constr
- -> m a
-fromConstrM f = gunfold k z
- where
- k c = do { c' <- c; b <- f; return (c' b) }
- z = return
-
-
-
-------------------------------------------------------------------------------
---
--- Datatype and constructor representations
---
-------------------------------------------------------------------------------
-
-
---
--- | Representation of datatypes.
--- A package of constructor representations with names of type and module.
---
-data DataType = DataType
- { tycon :: String
- , datarep :: DataRep
- }
-
- deriving Show
-
-
--- | Representation of constructors
-data Constr = Constr
- { conrep :: ConstrRep
- , constring :: String
- , confields :: [String] -- for AlgRep only
- , confixity :: Fixity -- for AlgRep only
- , datatype :: DataType
- }
-
-instance Show Constr where
- show = constring
-
-
--- | Equality of constructors
-instance Eq Constr where
- c == c' = constrRep c == constrRep c'
-
-
--- | Public representation of datatypes
-data DataRep = AlgRep [Constr]
- | IntRep
- | FloatRep
- | StringRep
- | NoRep
-
- deriving (Eq,Show)
--- The list of constructors could be an array, a balanced tree, or others.
-
-
--- | Public representation of constructors
-data ConstrRep = AlgConstr ConIndex
- | IntConstr Integer
- | FloatConstr Double
- | StringConstr String
-
- deriving (Eq,Show)
-
-
--- | Unique index for datatype constructors,
--- counting from 1 in the order they are given in the program text.
-type ConIndex = Int
-
-
--- | Fixity of constructors
-data Fixity = Prefix
- | Infix -- Later: add associativity and precedence
-
- deriving (Eq,Show)
-
-
-------------------------------------------------------------------------------
---
--- Observers for datatype representations
---
-------------------------------------------------------------------------------
-
-
--- | Gets the type constructor including the module
-dataTypeName :: DataType -> String
-dataTypeName = tycon
-
-
-
--- | Gets the public presentation of a datatype
-dataTypeRep :: DataType -> DataRep
-dataTypeRep = datarep
-
-
--- | Gets the datatype of a constructor
-constrType :: Constr -> DataType
-constrType = datatype
-
-
--- | Gets the public presentation of constructors
-constrRep :: Constr -> ConstrRep
-constrRep = conrep
-
-
--- | Look up a constructor by its representation
-repConstr :: DataType -> ConstrRep -> Constr
-repConstr dt cr =
- case (dataTypeRep dt, cr) of
- (AlgRep cs, AlgConstr i) -> cs !! (i-1)
- (IntRep, IntConstr i) -> mkIntConstr dt i
- (FloatRep, FloatConstr f) -> mkFloatConstr dt f
- (StringRep, StringConstr str) -> mkStringConstr dt str
- _ -> error "repConstr"
-
-
-
-------------------------------------------------------------------------------
---
--- Representations of algebraic data types
---
-------------------------------------------------------------------------------
-
-
--- | Constructs an algebraic datatype
-mkDataType :: String -> [Constr] -> DataType
-mkDataType str cs = DataType
- { tycon = str
- , datarep = AlgRep cs
- }
-
-
--- | Constructs a constructor
-mkConstr :: DataType -> String -> [String] -> Fixity -> Constr
-mkConstr dt str fields fix =
- Constr
- { conrep = AlgConstr idx
- , constring = str
- , confields = fields
- , confixity = fix
- , datatype = dt
- }
- where
- idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..],
- showConstr c == str ]
-
-
--- | Gets the constructors of an algebraic datatype
-dataTypeConstrs :: DataType -> [Constr]
-dataTypeConstrs dt = case datarep dt of
- (AlgRep cons) -> cons
- _ -> error "dataTypeConstrs"
-
-
--- | Gets the field labels of a constructor. The list of labels
--- is returned in the same order as they were given in the original
--- constructor declaration.
-constrFields :: Constr -> [String]
-constrFields = confields
-
-
--- | Gets the fixity of a constructor
-constrFixity :: Constr -> Fixity
-constrFixity = confixity
-
-
-
-------------------------------------------------------------------------------
---
--- From strings to constr's and vice versa: all data types
---
-------------------------------------------------------------------------------
-
-
--- | Gets the string for a constructor
-showConstr :: Constr -> String
-showConstr = constring
-
-
--- | Lookup a constructor via a string
-readConstr :: DataType -> String -> Maybe Constr
-readConstr dt str =
- case dataTypeRep dt of
- AlgRep cons -> idx cons
- IntRep -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i)))
- FloatRep -> mkReadCon (\f -> (mkPrimCon dt str (FloatConstr f)))
- StringRep -> Just (mkStringConstr dt str)
- NoRep -> Nothing
- where
-
- -- Read a value and build a constructor
- mkReadCon :: Read t => (t -> Constr) -> Maybe Constr
- mkReadCon f = case (reads str) of
- [(t,"")] -> Just (f t)
- _ -> Nothing
-
- -- Traverse list of algebraic datatype constructors
- idx :: [Constr] -> Maybe Constr
- idx cons = let fit = filter ((==) str . showConstr) cons
- in if fit == []
- then Nothing
- else Just (head fit)
-
-
-------------------------------------------------------------------------------
---
--- Convenience funtions: algebraic data types
---
-------------------------------------------------------------------------------
-
-
--- | Test for an algebraic type
-isAlgType :: DataType -> Bool
-isAlgType dt = case datarep dt of
- (AlgRep _) -> True
- _ -> False
-
-
--- | Gets the constructor for an index (algebraic datatypes only)
-indexConstr :: DataType -> ConIndex -> Constr
-indexConstr dt idx = case datarep dt of
- (AlgRep cs) -> cs !! (idx-1)
- _ -> error "indexConstr"
-
-
--- | Gets the index of a constructor (algebraic datatypes only)
-constrIndex :: Constr -> ConIndex
-constrIndex con = case constrRep con of
- (AlgConstr idx) -> idx
- _ -> error "constrIndex"
-
-
--- | Gets the maximum constructor index of an algebraic datatype
-maxConstrIndex :: DataType -> ConIndex
-maxConstrIndex dt = case dataTypeRep dt of
- AlgRep cs -> length cs
- _ -> error "maxConstrIndex"
-
-
-
-------------------------------------------------------------------------------
---
--- Representation of primitive types
---
-------------------------------------------------------------------------------
-
-
--- | Constructs the 'Int' type
-mkIntType :: String -> DataType
-mkIntType = mkPrimType IntRep
-
-
--- | Constructs the 'Float' type
-mkFloatType :: String -> DataType
-mkFloatType = mkPrimType FloatRep
-
-
--- | Constructs the 'String' type
-mkStringType :: String -> DataType
-mkStringType = mkPrimType StringRep
-
-
--- | Helper for 'mkIntType', 'mkFloatType', 'mkStringType'
-mkPrimType :: DataRep -> String -> DataType
-mkPrimType dr str = DataType
- { tycon = str
- , datarep = dr
- }
-
-
--- Makes a constructor for primitive types
-mkPrimCon :: DataType -> String -> ConstrRep -> Constr
-mkPrimCon dt str cr = Constr
- { datatype = dt
- , conrep = cr
- , constring = str
- , confields = error "constrFields"
- , confixity = error "constrFixity"
- }
-
-
-mkIntConstr :: DataType -> Integer -> Constr
-mkIntConstr dt i = case datarep dt of
- IntRep -> mkPrimCon dt (show i) (IntConstr i)
- _ -> error "mkIntConstr"
-
-
-mkFloatConstr :: DataType -> Double -> Constr
-mkFloatConstr dt f = case datarep dt of
- FloatRep -> mkPrimCon dt (show f) (FloatConstr f)
- _ -> error "mkFloatConstr"
-
-
-mkStringConstr :: DataType -> String -> Constr
-mkStringConstr dt str = case datarep dt of
- StringRep -> mkPrimCon dt str (StringConstr str)
- _ -> error "mkStringConstr"
-
-
-------------------------------------------------------------------------------
---
--- Non-representations for non-presentable types
---
-------------------------------------------------------------------------------
-
-
--- | Constructs a non-representation for a non-presentable type
-mkNorepType :: String -> DataType
-mkNorepType str = DataType
- { tycon = str
- , datarep = NoRep
- }
-
-
--- | Test for a non-representable type
-isNorepType :: DataType -> Bool
-isNorepType dt = case datarep dt of
- NoRep -> True
- _ -> False
-
-
-
-------------------------------------------------------------------------------
---
--- Convenience for qualified type constructors
---
-------------------------------------------------------------------------------
-
-
--- | Gets the unqualified type constructor:
--- drop *.*.*... before name
---
-tyconUQname :: String -> String
-tyconUQname x = let x' = dropWhile (not . (==) '.') x
- in if x' == [] then x else tyconUQname (tail x')
-
-
--- | Gets the module of a type constructor:
--- take *.*.*... before name
-tyconModule :: String -> String
-tyconModule x = let (a,b) = break ((==) '.') x
- in if b == ""
- then b
- else a ++ tyconModule' (tail b)
- where
- tyconModule' x = let x' = tyconModule x
- in if x' == "" then "" else ('.':x')
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Generics.Instances
--- Copyright : (c) The University of Glasgow, CWI 2001--2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Data.Generics.Basics)
---
--- \"Scrap your boilerplate\" --- Generic programming in Haskell
--- See <http://www.cs.vu.nl/boilerplate/>. The present module
--- instantiates the class Data for Prelude-like datatypes.
--- (This module does not export anything. It really just defines instances.)
---
------------------------------------------------------------------------------
-
-module Data.Generics.Instances
-
-where
-
-
-------------------------------------------------------------------------------
-
-#ifdef __HADDOCK__
-import Prelude
-#endif
-
-import Data.Generics.Basics
-
-import Data.Typeable
-import Data.Int -- So we can give Data instance for Int8, ...
-import Data.Word -- So we can give Data instance for Word8, ...
-import GHC.Real( Ratio(..) ) -- So we can give Data instance for Ratio
-import GHC.IOBase -- So we can give Data instance for IO, Handle
-import GHC.Ptr -- So we can give Data instance for Ptr
-import GHC.ForeignPtr -- So we can give Data instance for ForeignPtr
-import GHC.Stable -- So we can give Data instance for StablePtr
-import GHC.ST -- So we can give Data instance for ST
-import GHC.Conc -- So we can give Data instance for MVar & Co.
-import GHC.Arr -- So we can give Data instance for Array
-
-#include "Typeable.h"
-
-
-
-------------------------------------------------------------------------------
---
--- Instances of the Data class for Prelude-like types.
--- We define top-level definitions for representations.
---
-------------------------------------------------------------------------------
-
-
-falseConstr = mkConstr boolDataType "False" [] Prefix
-trueConstr = mkConstr boolDataType "True" [] Prefix
-boolDataType = mkDataType "Prelude.Bool" [falseConstr,trueConstr]
-
-
-instance Data Bool where
- toConstr False = falseConstr
- toConstr True = trueConstr
- gunfold k z c = case constrIndex c of
- 1 -> z False
- 2 -> z True
- _ -> error "gunfold"
- dataTypeOf _ = boolDataType
-
-
-------------------------------------------------------------------------------
-
-
-charType = mkStringType "Prelude.Char"
-
-instance Data Char where
- toConstr x = mkStringConstr charType [x]
- gunfold k z c = case constrRep c of
- (StringConstr [x]) -> z x
- _ -> error "gunfold"
- dataTypeOf _ = charType
-
-
-------------------------------------------------------------------------------
-
-
-floatType = mkFloatType "Prelude.Float"
-
-instance Data Float where
- toConstr x = mkFloatConstr floatType (realToFrac x)
- gunfold k z c = case constrRep c of
- (FloatConstr x) -> z (realToFrac x)
- _ -> error "gunfold"
- dataTypeOf _ = floatType
-
-
-------------------------------------------------------------------------------
-
-
-doubleType = mkFloatType "Prelude.Double"
-
-instance Data Double where
- toConstr = mkFloatConstr floatType
- gunfold k z c = case constrRep c of
- (FloatConstr x) -> z x
- _ -> error "gunfold"
- dataTypeOf _ = doubleType
-
-
-------------------------------------------------------------------------------
-
-
-intType = mkIntType "Prelude.Int"
-
-instance Data Int where
- toConstr x = mkIntConstr intType (fromIntegral x)
- gunfold k z c = case constrRep c of
- (IntConstr x) -> z (fromIntegral x)
- _ -> error "gunfold"
- dataTypeOf _ = intType
-
-
-------------------------------------------------------------------------------
-
-
-integerType = mkIntType "Prelude.Integer"
-
-instance Data Integer where
- toConstr = mkIntConstr integerType
- gunfold k z c = case constrRep c of
- (IntConstr x) -> z x
- _ -> error "gunfold"
- dataTypeOf _ = integerType
-
-
-------------------------------------------------------------------------------
-
-
-int8Type = mkIntType "Data.Int.Int8"
-
-instance Data Int8 where
- toConstr x = mkIntConstr int8Type (fromIntegral x)
- gunfold k z c = case constrRep c of
- (IntConstr x) -> z (fromIntegral x)
- _ -> error "gunfold"
- dataTypeOf _ = int8Type
-
-
-------------------------------------------------------------------------------
-
-
-int16Type = mkIntType "Data.Int.Int16"
-
-instance Data Int16 where
- toConstr x = mkIntConstr int16Type (fromIntegral x)
- gunfold k z c = case constrRep c of
- (IntConstr x) -> z (fromIntegral x)
- _ -> error "gunfold"
- dataTypeOf _ = int16Type
-
-
-------------------------------------------------------------------------------
-
-
-int32Type = mkIntType "Data.Int.Int32"
-
-instance Data Int32 where
- toConstr x = mkIntConstr int32Type (fromIntegral x)
- gunfold k z c = case constrRep c of
- (IntConstr x) -> z (fromIntegral x)
- _ -> error "gunfold"
- dataTypeOf _ = int32Type
-
-
-------------------------------------------------------------------------------
-
-
-int64Type = mkIntType "Data.Int.Int64"
-
-instance Data Int64 where
- toConstr x = mkIntConstr int64Type (fromIntegral x)
- gunfold k z c = case constrRep c of
- (IntConstr x) -> z (fromIntegral x)
- _ -> error "gunfold"
- dataTypeOf _ = int64Type
-
-
-------------------------------------------------------------------------------
-
-
-wordType = mkIntType "Data.Word.Word"
-
-instance Data Word where
- toConstr x = mkIntConstr wordType (fromIntegral x)
- gunfold k z c = case constrRep c of
- (IntConstr x) -> z (fromIntegral x)
- _ -> error "gunfold"
- dataTypeOf _ = wordType
-
-
-------------------------------------------------------------------------------
-
-
-word8Type = mkIntType "Data.Word.Word8"
-
-instance Data Word8 where
- toConstr x = mkIntConstr word8Type (fromIntegral x)
- gunfold k z c = case constrRep c of
- (IntConstr x) -> z (fromIntegral x)
- _ -> error "gunfold"
- dataTypeOf _ = word8Type
-
-
-------------------------------------------------------------------------------
-
-
-word16Type = mkIntType "Data.Word.Word16"
-
-instance Data Word16 where
- toConstr x = mkIntConstr word16Type (fromIntegral x)
- gunfold k z c = case constrRep c of
- (IntConstr x) -> z (fromIntegral x)
- _ -> error "gunfold"
- dataTypeOf _ = word16Type
-
-
-------------------------------------------------------------------------------
-
-
-word32Type = mkIntType "Data.Word.Word32"
-
-instance Data Word32 where
- toConstr x = mkIntConstr word32Type (fromIntegral x)
- gunfold k z c = case constrRep c of
- (IntConstr x) -> z (fromIntegral x)
- _ -> error "gunfold"
- dataTypeOf _ = word32Type
-
-
-------------------------------------------------------------------------------
-
-
-word64Type = mkIntType "Data.Word.Word64"
-
-instance Data Word64 where
- toConstr x = mkIntConstr word64Type (fromIntegral x)
- gunfold k z c = case constrRep c of
- (IntConstr x) -> z (fromIntegral x)
- _ -> error "gunfold"
- dataTypeOf _ = word64Type
-
-
-------------------------------------------------------------------------------
-
-
-ratioConstr = mkConstr ratioDataType ":%" [] Infix
-ratioDataType = mkDataType "GHC.Real.Ratio" [ratioConstr]
-
-instance (Data a, Integral a) => Data (Ratio a) where
- toConstr _ = ratioConstr
- gunfold k z c | constrIndex c == 1 = k (k (z (:%)))
- gunfold _ _ _ = error "gunfold"
- dataTypeOf _ = ratioDataType
-
-
-------------------------------------------------------------------------------
-
-
-nilConstr = mkConstr listDataType "[]" [] Prefix
-consConstr = mkConstr listDataType "(:)" [] Infix
-listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr]
-
-instance Data a => Data [a] where
- gfoldl f z [] = z []
- gfoldl f z (x:xs) = z (:) `f` x `f` xs
- toConstr [] = nilConstr
- toConstr (_:_) = consConstr
- gunfold k z c = case constrIndex c of
- 1 -> z []
- 2 -> k (k (z (:)))
- _ -> error "gunfold"
- dataTypeOf _ = listDataType
- dataCast1 f = gcast1 f
-
---
--- The gmaps are given as an illustration.
--- This shows that the gmaps for lists are different from list maps.
---
- gmapT f [] = []
- gmapT f (x:xs) = (f x:f xs)
- gmapQ f [] = []
- gmapQ f (x:xs) = [f x,f xs]
- gmapM f [] = return []
- gmapM f (x:xs) = f x >>= \x' -> f xs >>= \xs' -> return (x':xs')
-
-
-------------------------------------------------------------------------------
-
-
-nothingConstr = mkConstr maybeDataType "Nothing" [] Prefix
-justConstr = mkConstr maybeDataType "Just" [] Prefix
-maybeDataType = mkDataType "Prelude.Maybe" [nothingConstr,justConstr]
-
-instance Data a => Data (Maybe a) where
- gfoldl f z Nothing = z Nothing
- gfoldl f z (Just x) = z Just `f` x
- toConstr Nothing = nothingConstr
- toConstr (Just _) = justConstr
- gunfold k z c = case constrIndex c of
- 1 -> z Nothing
- 2 -> k (z Just)
- _ -> error "gunfold"
- dataTypeOf _ = maybeDataType
- dataCast1 f = gcast1 f
-
-
-------------------------------------------------------------------------------
-
-
-ltConstr = mkConstr orderingDataType "LT" [] Prefix
-eqConstr = mkConstr orderingDataType "EQ" [] Prefix
-gtConstr = mkConstr orderingDataType "GT" [] Prefix
-orderingDataType = mkDataType "Prelude.Ordering" [ltConstr,eqConstr,gtConstr]
-
-instance Data Ordering where
- gfoldl f z LT = z LT
- gfoldl f z EQ = z EQ
- gfoldl f z GT = z GT
- toConstr LT = ltConstr
- toConstr EQ = eqConstr
- toConstr GT = gtConstr
- gunfold k z c = case constrIndex c of
- 1 -> z LT
- 2 -> z EQ
- 3 -> z GT
- _ -> error "gunfold"
- dataTypeOf _ = orderingDataType
-
-
-------------------------------------------------------------------------------
-
-
-leftConstr = mkConstr eitherDataType "Left" [] Prefix
-rightConstr = mkConstr eitherDataType "Right" [] Prefix
-eitherDataType = mkDataType "Prelude.Either" [leftConstr,rightConstr]
-
-instance (Data a, Data b) => Data (Either a b) where
- gfoldl f z (Left a) = z Left `f` a
- gfoldl f z (Right a) = z Right `f` a
- toConstr (Left _) = leftConstr
- toConstr (Right _) = rightConstr
- gunfold k z c = case constrIndex c of
- 1 -> k (z Left)
- 2 -> k (z Right)
- _ -> error "gunfold"
- dataTypeOf _ = eitherDataType
- dataCast2 f = gcast2 f
-
-
-------------------------------------------------------------------------------
-
-
---
--- A last resort for functions
---
-
-instance (Data a, Data b) => Data (a -> b) where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Prelude.(->)"
- dataCast2 f = gcast2 f
-
-
-------------------------------------------------------------------------------
-
-
-tuple0Constr = mkConstr tuple0DataType "()" [] Prefix
-tuple0DataType = mkDataType "Prelude.()" [tuple0Constr]
-
-instance Data () where
- toConstr () = tuple0Constr
- gunfold k z c | constrIndex c == 1 = z ()
- gunfold _ _ _ = error "gunfold"
- dataTypeOf _ = tuple0DataType
-
-
-------------------------------------------------------------------------------
-
-
-tuple2Constr = mkConstr tuple2DataType "(,)" [] Infix
-tuple2DataType = mkDataType "Prelude.(,)" [tuple2Constr]
-
-instance (Data a, Data b) => Data (a,b) where
- gfoldl f z (a,b) = z (,) `f` a `f` b
- toConstr (a,b) = tuple2Constr
- gunfold k z c | constrIndex c == 1 = k (k (z (,)))
- gunfold _ _ _ = error "gunfold"
- dataTypeOf _ = tuple2DataType
- dataCast2 f = gcast2 f
-
-
-------------------------------------------------------------------------------
-
-
-tuple3Constr = mkConstr tuple3DataType "(,,)" [] Infix
-tuple3DataType = mkDataType "Prelude.(,)" [tuple3Constr]
-
-instance (Data a, Data b, Data c) => Data (a,b,c) where
- gfoldl f z (a,b,c) = z (,,) `f` a `f` b `f` c
- toConstr (a,b,c) = tuple3Constr
- gunfold k z c | constrIndex c == 1 = k (k (k (z (,,))))
- gunfold _ _ _ = error "gunfold"
- dataTypeOf _ = tuple3DataType
-
-
-------------------------------------------------------------------------------
-
-
-tuple4Constr = mkConstr tuple4DataType "(,,,)" [] Infix
-tuple4DataType = mkDataType "Prelude.(,,,)" [tuple4Constr]
-
-instance (Data a, Data b, Data c, Data d)
- => Data (a,b,c,d) where
- gfoldl f z (a,b,c,d) = z (,,,) `f` a `f` b `f` c `f` d
- toConstr (a,b,c,d) = tuple4Constr
- gunfold k z c = case constrIndex c of
- 1 -> k (k (k (k (z (,,,)))))
- _ -> error "gunfold"
- dataTypeOf _ = tuple4DataType
-
-
-------------------------------------------------------------------------------
-
-
-tuple5Constr = mkConstr tuple5DataType "(,,,,)" [] Infix
-tuple5DataType = mkDataType "Prelude.(,,,,)" [tuple5Constr]
-
-instance (Data a, Data b, Data c, Data d, Data e)
- => Data (a,b,c,d,e) where
- gfoldl f z (a,b,c,d,e) = z (,,,,) `f` a `f` b `f` c `f` d `f` e
- toConstr (a,b,c,d,e) = tuple5Constr
- gunfold k z c = case constrIndex c of
- 1 -> k (k (k (k (k (z (,,,,))))))
- _ -> error "gunfold"
- dataTypeOf _ = tuple5DataType
-
-
-------------------------------------------------------------------------------
-
-
-tuple6Constr = mkConstr tuple6DataType "(,,,,,)" [] Infix
-tuple6DataType = mkDataType "Prelude.(,,,,,)" [tuple6Constr]
-
-instance (Data a, Data b, Data c, Data d, Data e, Data f)
- => Data (a,b,c,d,e,f) where
- gfoldl f z (a,b,c,d,e,f') = z (,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f'
- toConstr (a,b,c,d,e,f) = tuple6Constr
- gunfold k z c = case constrIndex c of
- 1 -> k (k (k (k (k (k (z (,,,,,)))))))
- _ -> error "gunfold"
- dataTypeOf _ = tuple6DataType
-
-
-------------------------------------------------------------------------------
-
-
-tuple7Constr = mkConstr tuple7DataType "(,,,,,,)" [] Infix
-tuple7DataType = mkDataType "Prelude.(,,,,,,)" [tuple7Constr]
-
-instance (Data a, Data b, Data c, Data d, Data e, Data f, Data g)
- => Data (a,b,c,d,e,f,g) where
- gfoldl f z (a,b,c,d,e,f',g) =
- z (,,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f' `f` g
- toConstr (a,b,c,d,e,f,g) = tuple7Constr
- gunfold k z c = case constrIndex c of
- 1 -> k (k (k (k (k (k (k (z (,,,,,,))))))))
- _ -> error "gunfold"
- dataTypeOf _ = tuple7DataType
-
-
-------------------------------------------------------------------------------
-
-
-instance Data TypeRep where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.Typeable.TypeRep"
-
-
-------------------------------------------------------------------------------
-
-
-instance Data TyCon where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.Typeable.TyCon"
-
-
-------------------------------------------------------------------------------
-
-
-INSTANCE_TYPEABLE0(DataType,dataTypeTc,"DataType")
-
-instance Data DataType where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.Generics.Basics.DataType"
-
-
-------------------------------------------------------------------------------
-
-
-instance Typeable a => Data (IO a) where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "GHC.IOBase.IO"
-
-
-------------------------------------------------------------------------------
-
-
-instance Data Handle where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "GHC.IOBase.Handle"
-
-
-------------------------------------------------------------------------------
-
-
-instance Typeable a => Data (Ptr a) where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "GHC.Ptr.Ptr"
-
-
-------------------------------------------------------------------------------
-
-
-instance Typeable a => Data (StablePtr a) where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "GHC.Stable.StablePtr"
-
-
-------------------------------------------------------------------------------
-
-
-instance Typeable a => Data (IORef a) where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "GHC.IOBase.IORef"
-
-
-------------------------------------------------------------------------------
-
-
-instance Typeable a => Data (ForeignPtr a) where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "GHC.ForeignPtr.ForeignPtr"
-
-
-------------------------------------------------------------------------------
-
-
-instance (Typeable s, Typeable a) => Data (ST s a) where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "GHC.ST.ST"
-
-
-------------------------------------------------------------------------------
-
-
-instance Data ThreadId where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "GHC.Conc.ThreadId"
-
-
-------------------------------------------------------------------------------
-
-
-instance Typeable a => Data (TVar a) where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "GHC.Conc.TVar"
-
-
-------------------------------------------------------------------------------
-
-
-instance Typeable a => Data (MVar a) where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "GHC.Conc.MVar"
-
-
-------------------------------------------------------------------------------
-
-
-instance Typeable a => Data (STM a) where
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "GHC.Conc.STM"
-
-
-------------------------------------------------------------------------------
--- The Data instance for Array preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
-instance (Typeable a, Data b, Ix a) => Data (Array a b)
- where
- gfoldl f z a = z (listArray (bounds a)) `f` (elems a)
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.Array.Array"
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Generics.Schemes
--- Copyright : (c) The University of Glasgow, CWI 2001--2003
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (local universal quantification)
---
--- \"Scrap your boilerplate\" --- Generic programming in Haskell
--- See <http://www.cs.vu.nl/boilerplate/>. The present module provides
--- frequently used generic traversal schemes.
---
------------------------------------------------------------------------------
-
-module Data.Generics.Schemes (
-
- everywhere,
- everywhere',
- everywhereBut,
- everywhereM,
- somewhere,
- everything,
- listify,
- something,
- synthesize,
- gsize,
- glength,
- gdepth,
- gcount,
- gnodecount,
- gtypecount,
- gfindtype
-
- ) where
-
-------------------------------------------------------------------------------
-
-#ifdef __HADDOCK__
-import Prelude
-#endif
-import Data.Generics.Basics
-import Data.Generics.Aliases
-import Control.Monad
-
-
--- | Apply a transformation everywhere in bottom-up manner
-everywhere :: (forall a. Data a => a -> a)
- -> (forall a. Data a => a -> a)
-
--- Use gmapT to recurse into immediate subterms;
--- recall: gmapT preserves the outermost constructor;
--- post-process recursively transformed result via f
---
-everywhere f = f . gmapT (everywhere f)
-
-
--- | Apply a transformation everywhere in top-down manner
-everywhere' :: (forall a. Data a => a -> a)
- -> (forall a. Data a => a -> a)
-
--- Arguments of (.) are flipped compared to everywhere
-everywhere' f = gmapT (everywhere' f) . f
-
-
--- | Variation on everywhere with an extra stop condition
-everywhereBut :: GenericQ Bool -> GenericT -> GenericT
-
--- Guarded to let traversal cease if predicate q holds for x
-everywhereBut q f x
- | q x = x
- | otherwise = f (gmapT (everywhereBut q f) x)
-
-
--- | Monadic variation on everywhere
-everywhereM :: Monad m => GenericM m -> GenericM m
-
--- Bottom-up order is also reflected in order of do-actions
-everywhereM f x = do x' <- gmapM (everywhereM f) x
- f x'
-
-
--- | Apply a monadic transformation at least somewhere
-somewhere :: MonadPlus m => GenericM m -> GenericM m
-
--- We try "f" in top-down manner, but descent into "x" when we fail
--- at the root of the term. The transformation fails if "f" fails
--- everywhere, say succeeds nowhere.
---
-somewhere f x = f x `mplus` gmapMp (somewhere f) x
-
-
--- | Summarise all nodes in top-down, left-to-right order
-everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
-
--- Apply f to x to summarise top-level node;
--- use gmapQ to recurse into immediate subterms;
--- use ordinary foldl to reduce list of intermediate results
---
-everything k f x
- = foldl k (f x) (gmapQ (everything k f) x)
-
-
--- | Get a list of all entities that meet a predicate
-listify :: Typeable r => (r -> Bool) -> GenericQ [r]
-listify p
- = everything (++) ([] `mkQ` (\x -> if p x then [x] else []))
-
-
--- | Look up a subterm by means of a maybe-typed filter
-something :: GenericQ (Maybe u) -> GenericQ (Maybe u)
-
--- "something" can be defined in terms of "everything"
--- when a suitable "choice" operator is used for reduction
---
-something = everything orElse
-
-
--- | Bottom-up synthesis of a data structure;
--- 1st argument z is the initial element for the synthesis;
--- 2nd argument o is for reduction of results from subterms;
--- 3rd argument f updates the synthesised data according to the given term
---
-synthesize :: s -> (s -> s -> s) -> GenericQ (s -> s) -> GenericQ s
-synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x))
-
-
--- | Compute size of an arbitrary data structure
-gsize :: Data a => a -> Int
-gsize t = 1 + sum (gmapQ gsize t)
-
-
--- | Count the number of immediate subterms of the given term
-glength :: GenericQ Int
-glength = length . gmapQ (const ())
-
-
--- | Determine depth of the given term
-gdepth :: GenericQ Int
-gdepth = (+) 1 . foldr max 0 . gmapQ gdepth
-
-
--- | Determine the number of all suitable nodes in a given term
-gcount :: GenericQ Bool -> GenericQ Int
-gcount p = everything (+) (\x -> if p x then 1 else 0)
-
-
--- | Determine the number of all nodes in a given term
-gnodecount :: GenericQ Int
-gnodecount = gcount (const True)
-
-
--- | Determine the number of nodes of a given type in a given term
-gtypecount :: Typeable a => a -> GenericQ Int
-gtypecount (_::a) = gcount (False `mkQ` (\(_::a) -> True))
-
-
--- | Find (unambiguously) an immediate subterm of a given type
-gfindtype :: (Data x, Typeable y) => x -> Maybe y
-gfindtype = singleton
- . foldl unJust []
- . gmapQ (Nothing `mkQ` Just)
- where
- unJust l (Just x) = x:l
- unJust l Nothing = l
- singleton [s] = Just s
- singleton _ = Nothing
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Generics.Text
--- Copyright : (c) The University of Glasgow, CWI 2001--2003
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Data.Generics.Basics)
---
--- \"Scrap your boilerplate\" --- Generic programming in Haskell
--- See <http://www.cs.vu.nl/boilerplate/>. The present module provides
--- generic operations for text serialisation of terms.
---
------------------------------------------------------------------------------
-
-module Data.Generics.Text (
-
- gshow,
- gread
-
- ) where
-
-------------------------------------------------------------------------------
-
-#ifdef __HADDOCK__
-import Prelude
-#endif
-import Control.Monad
-import Data.Maybe
-import Data.Generics.Basics
-import Data.Generics.Aliases
-import Text.ParserCombinators.ReadP
-
-------------------------------------------------------------------------------
-
-
--- | Generic show: an alternative to \"deriving Show\"
-gshow :: Data a => a -> String
-
--- This is a prefix-show using surrounding "(" and ")",
--- where we recurse into subterms with gmapQ.
---
-gshow = ( \t ->
- "("
- ++ showConstr (toConstr t)
- ++ concat (gmapQ ((++) " " . gshow) t)
- ++ ")"
- ) `extQ` (show :: String -> String)
-
-
-
--- | Generic read: an alternative to \"deriving Read\"
-gread :: Data a => ReadS a
-
-{-
-
-This is a read operation which insists on prefix notation. (The
-Haskell 98 read deals with infix operators subject to associativity
-and precedence as well.) We use fromConstrM to "parse" the input. To be
-precise, fromConstrM is used for all types except String. The
-type-specific case for String uses basic String read.
-
--}
-
-gread = readP_to_S gread'
-
- where
-
- -- Helper for recursive read
- gread' :: Data a' => ReadP a'
- gread' = allButString `extR` stringCase
-
- where
-
- -- A specific case for strings
- stringCase :: ReadP String
- stringCase = readS_to_P reads
-
- -- Determine result type
- myDataType = dataTypeOf (getArg allButString)
- where
- getArg :: ReadP a'' -> a''
- getArg = undefined
-
- -- The generic default for gread
- allButString =
- do
- -- Drop " ( "
- skipSpaces -- Discard leading space
- char '(' -- Parse '('
- skipSpaces -- Discard following space
-
- -- Do the real work
- str <- parseConstr -- Get a lexeme for the constructor
- con <- str2con str -- Convert it to a Constr (may fail)
- x <- fromConstrM gread' con -- Read the children
-
- -- Drop " ) "
- skipSpaces -- Discard leading space
- char ')' -- Parse ')'
- skipSpaces -- Discard following space
-
- return x
-
- -- Turn string into constructor driven by the requested result type,
- -- failing in the monad if it isn't a constructor of this data type
- str2con :: String -> ReadP Constr
- str2con = maybe mzero return
- . readConstr myDataType
-
- -- Get a Constr's string at the front of an input string
- parseConstr :: ReadP String
- parseConstr =
- string "[]" -- Compound lexeme "[]"
- <++ infixOp -- Infix operator in parantheses
- <++ readS_to_P lex -- Ordinary constructors and literals
-
- -- Handle infix operators such as (:)
- infixOp :: ReadP String
- infixOp = do c1 <- char '('
- str <- munch1 (not . (==) ')')
- c2 <- char ')'
- return $ [c1] ++ str ++ [c2]
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Generics.Twins
--- Copyright : (c) The University of Glasgow, CWI 2001--2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (local universal quantification)
---
--- \"Scrap your boilerplate\" --- Generic programming in Haskell
--- See <http://www.cs.vu.nl/boilerplate/>. The present module
--- provides support for multi-parameter traversal, which is also
--- demonstrated with generic operations like equality.
---
------------------------------------------------------------------------------
-
-module Data.Generics.Twins (
-
- -- * Generic folds and maps that also accumulate
- gfoldlAccum,
- gmapAccumT,
- gmapAccumM,
- gmapAccumQl,
- gmapAccumQr,
- gmapAccumQ,
-
- -- * Mapping combinators for twin traversal
- gzipWithT,
- gzipWithM,
- gzipWithQ,
-
- -- * Typical twin traversals
- geq,
- gzip
-
- ) where
-
-
-------------------------------------------------------------------------------
-
-#ifdef __HADDOCK__
-import Prelude
-#endif
-import Data.Generics.Basics
-import Data.Generics.Aliases
-
-#ifdef __GLASGOW_HASKELL__
-import Prelude hiding ( GT )
-#endif
-
-------------------------------------------------------------------------------
-
-
-------------------------------------------------------------------------------
---
--- Generic folds and maps that also accumulate
---
-------------------------------------------------------------------------------
-
-{--------------------------------------------------------------
-
-A list map can be elaborated to perform accumulation.
-In the same sense, we can elaborate generic maps over terms.
-
-We recall the type of map:
-map :: (a -> b) -> [a] -> [b]
-
-We recall the type of an accumulating map (see Data.List):
-mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
-
-Applying the same scheme we obtain an accumulating gfoldl.
-
---------------------------------------------------------------}
-
--- | gfoldl with accumulation
-
-gfoldlAccum :: Data d
- => (forall d r. Data d => a -> c (d -> r) -> d -> (a, c r))
- -> (forall g. a -> g -> (a, c g))
- -> a -> d -> (a, c d)
-
-gfoldlAccum k z a d = unA (gfoldl k' z' d) a
- where
- k' c y = A (\a -> let (a', c') = unA c a in k a' c' y)
- z' f = A (\a -> z a f)
-
-
--- | A type constructor for accumulation
-newtype A a c d = A { unA :: a -> (a, c d) }
-
-
--- | gmapT with accumulation
-gmapAccumT :: Data d
- => (forall d. Data d => a -> d -> (a,d))
- -> a -> d -> (a, d)
-gmapAccumT f a d = let (a',d') = gfoldlAccum k z a d
- in (a',unID d')
- where
- k a (ID c) d = let (a',d') = f a d
- in (a', ID (c d'))
- z a x = (a, ID x)
-
-
--- | gmapM with accumulation
-gmapAccumM :: (Data d, Monad m)
- => (forall d. Data d => a -> d -> (a, m d))
- -> a -> d -> (a, m d)
-gmapAccumM f = gfoldlAccum k z
- where
- k a c d = let (a',d') = f a d
- in (a', d' >>= \d'' -> c >>= \c' -> return (c' d''))
- z a x = (a, return x)
-
-
--- | gmapQl with accumulation
-gmapAccumQl :: Data d
- => (r -> r' -> r)
- -> r
- -> (forall d. Data d => a -> d -> (a,r'))
- -> a -> d -> (a, r)
-gmapAccumQl o r f a d = let (a',r) = gfoldlAccum k z a d
- in (a',unCONST r)
- where
- k a (CONST c) d = let (a',r') = f a d
- in (a', CONST (c `o` r'))
- z a _ = (a, CONST r)
-
-
--- | gmapQr with accumulation
-gmapAccumQr :: Data d
- => (r' -> r -> r)
- -> r
- -> (forall d. Data d => a -> d -> (a,r'))
- -> a -> d -> (a, r)
-gmapAccumQr o r f a d = let (a',l) = gfoldlAccum k z a d
- in (a',unQr l r)
- where
- k a (Qr c) d = let (a',r') = f a d
- in (a', Qr (\r -> c (r' `o` r)))
- z a _ = (a, Qr id)
-
-
--- | gmapQ with accumulation
-gmapAccumQ :: Data d
- => (forall d. Data d => a -> d -> (a,q))
- -> a -> d -> (a, [q])
-gmapAccumQ f = gmapAccumQr (:) [] f
-
-
-
-------------------------------------------------------------------------------
---
--- Helper type constructors
---
-------------------------------------------------------------------------------
-
-
--- | The identity type constructor needed for the definition of gmapAccumT
-newtype ID x = ID { unID :: x }
-
-
--- | The constant type constructor needed for the definition of gmapAccumQl
-newtype CONST c a = CONST { unCONST :: c }
-
-
--- | The type constructor needed for the definition of gmapAccumQr
-newtype Qr r a = Qr { unQr :: r -> r }
-
-
-
-------------------------------------------------------------------------------
---
--- Mapping combinators for twin traversal
---
-------------------------------------------------------------------------------
-
-
--- | Twin map for transformation
-gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT)
-gzipWithT f x y = case gmapAccumT perkid funs y of
- ([], c) -> c
- _ -> error "gzipWithT"
- where
- perkid a d = (tail a, unGT (head a) d)
- funs = gmapQ (\k -> GT (f k)) x
-
-
-
--- | Twin map for monadic transformation
-gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m)
-gzipWithM f x y = case gmapAccumM perkid funs y of
- ([], c) -> c
- _ -> error "gzipWithM"
- where
- perkid a d = (tail a, unGM (head a) d)
- funs = gmapQ (\k -> GM (f k)) x
-
-
--- | Twin map for queries
-gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
-gzipWithQ f x y = case gmapAccumQ perkid funs y of
- ([], r) -> r
- _ -> error "gzipWithQ"
- where
- perkid a d = (tail a, unGQ (head a) d)
- funs = gmapQ (\k -> GQ (f k)) x
-
-
-
-------------------------------------------------------------------------------
---
--- Typical twin traversals
---
-------------------------------------------------------------------------------
-
--- | Generic equality: an alternative to \"deriving Eq\"
-geq :: Data a => a -> a -> Bool
-
-{-
-
-Testing for equality of two terms goes like this. Firstly, we
-establish the equality of the two top-level datatype
-constructors. Secondly, we use a twin gmap combinator, namely tgmapQ,
-to compare the two lists of immediate subterms.
-
-(Note for the experts: the type of the worker geq' is rather general
-but precision is recovered via the restrictive type of the top-level
-operation geq. The imprecision of geq' is caused by the type system's
-unability to express the type equivalence for the corresponding
-couples of immediate subterms from the two given input terms.)
-
--}
-
-geq x y = geq' x y
- where
- geq' :: GenericQ (GenericQ Bool)
- geq' x y = (toConstr x == toConstr y)
- && and (gzipWithQ geq' x y)
-
-
--- | Generic zip controlled by a function with type-specific branches
-gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe)
--- See testsuite/.../Generics/gzip.hs for an illustration
-gzip f x y =
- f x y
- `orElse`
- if toConstr x == toConstr y
- then gzipWithM (gzip f) x y
- else Nothing
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Graph
--- Copyright : (c) The University of Glasgow 2002
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- A version of the graph algorithms described in:
---
--- /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/,
--- by David King and John Launchbury.
---
------------------------------------------------------------------------------
-
-module Data.Graph(
-
- -- * External interface
-
- -- At present the only one with a "nice" external interface
- stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs,
-
- -- * Graphs
-
- Graph, Table, Bounds, Edge, Vertex,
-
- -- ** Building graphs
-
- graphFromEdges, graphFromEdges', buildG, transposeG,
- -- reverseE,
-
- -- ** Graph properties
-
- vertices, edges,
- outdegree, indegree,
-
- -- * Algorithms
-
- dfs, dff,
- topSort,
- components,
- scc,
- bcc,
- -- tree, back, cross, forward,
- reachable, path,
-
- module Data.Tree
-
- ) where
-
-#if __GLASGOW_HASKELL__
-# define USE_ST_MONAD 1
-#endif
-
--- Extensions
-#if USE_ST_MONAD
-import Control.Monad.ST
-import Data.Array.ST (STArray, newArray, readArray, writeArray)
-#else
-import Data.IntSet (IntSet)
-import qualified Data.IntSet as Set
-#endif
-import Data.Tree (Tree(Node), Forest)
-
--- std interfaces
-import Data.Maybe
-import Data.Array
-import Data.List
-
-#ifdef __HADDOCK__
-import Prelude
-#endif
-
--------------------------------------------------------------------------
--- -
--- External interface
--- -
--------------------------------------------------------------------------
-
--- | Strongly connected component.
-data SCC vertex = AcyclicSCC vertex -- ^ A single vertex that is not
- -- in any cycle.
- | CyclicSCC [vertex] -- ^ A maximal set of mutually
- -- reachable vertices.
-
--- | The vertices of a list of strongly connected components.
-flattenSCCs :: [SCC a] -> [a]
-flattenSCCs = concatMap flattenSCC
-
--- | The vertices of a strongly connected component.
-flattenSCC :: SCC vertex -> [vertex]
-flattenSCC (AcyclicSCC v) = [v]
-flattenSCC (CyclicSCC vs) = vs
-
--- | The strongly connected components of a directed graph, topologically
--- sorted.
-stronglyConnComp
- :: Ord key
- => [(node, key, [key])]
- -- ^ The graph: a list of nodes uniquely identified by keys,
- -- with a list of keys of nodes this node has edges to.
- -- The out-list may contain keys that don't correspond to
- -- nodes of the graph; such edges are ignored.
- -> [SCC node]
-
-stronglyConnComp edges0
- = map get_node (stronglyConnCompR edges0)
- where
- get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
- get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples]
-
--- | The strongly connected components of a directed graph, topologically
--- sorted. The function is the same as 'stronglyConnComp', except that
--- all the information about each node retained.
--- This interface is used when you expect to apply 'SCC' to
--- (some of) the result of 'SCC', so you don't want to lose the
--- dependency information.
-stronglyConnCompR
- :: Ord key
- => [(node, key, [key])]
- -- ^ The graph: a list of nodes uniquely identified by keys,
- -- with a list of keys of nodes this node has edges to.
- -- The out-list may contain keys that don't correspond to
- -- nodes of the graph; such edges are ignored.
- -> [SCC (node, key, [key])] -- ^ Topologically sorted
-
-stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF
-stronglyConnCompR edges0
- = map decode forest
- where
- (graph, vertex_fn,_) = graphFromEdges edges0
- forest = scc graph
- decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
- | otherwise = AcyclicSCC (vertex_fn v)
- decode other = CyclicSCC (dec other [])
- where
- dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
- mentions_itself v = v `elem` (graph ! v)
-
--------------------------------------------------------------------------
--- -
--- Graphs
--- -
--------------------------------------------------------------------------
-
--- | Abstract representation of vertices.
-type Vertex = Int
--- | Table indexed by a contiguous set of vertices.
-type Table a = Array Vertex a
--- | Adjacency list representation of a graph, mapping each vertex to its
--- list of successors.
-type Graph = Table [Vertex]
--- | The bounds of a 'Table'.
-type Bounds = (Vertex, Vertex)
--- | An edge from the first vertex to the second.
-type Edge = (Vertex, Vertex)
-
--- | All vertices of a graph.
-vertices :: Graph -> [Vertex]
-vertices = indices
-
--- | All edges of a graph.
-edges :: Graph -> [Edge]
-edges g = [ (v, w) | v <- vertices g, w <- g!v ]
-
-mapT :: (Vertex -> a -> b) -> Table a -> Table b
-mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]
-
--- | Build a graph from a list of edges.
-buildG :: Bounds -> [Edge] -> Graph
-buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0
-
--- | The graph obtained by reversing all edges.
-transposeG :: Graph -> Graph
-transposeG g = buildG (bounds g) (reverseE g)
-
-reverseE :: Graph -> [Edge]
-reverseE g = [ (w, v) | (v, w) <- edges g ]
-
--- | A table of the count of edges from each node.
-outdegree :: Graph -> Table Int
-outdegree = mapT numEdges
- where numEdges _ ws = length ws
-
--- | A table of the count of edges into each node.
-indegree :: Graph -> Table Int
-indegree = outdegree . transposeG
-
--- | Identical to 'graphFromEdges', except that the return value
--- does not include the function which maps keys to vertices. This
--- version of 'graphFromEdges' is for backwards compatibility.
-graphFromEdges'
- :: Ord key
- => [(node, key, [key])]
- -> (Graph, Vertex -> (node, key, [key]))
-graphFromEdges' x = (a,b) where
- (a,b,_) = graphFromEdges x
-
--- | Build a graph from a list of nodes uniquely identified by keys,
--- with a list of keys of nodes this node should have edges to.
--- The out-list may contain keys that don't correspond to
--- nodes of the graph; they are ignored.
-graphFromEdges
- :: Ord key
- => [(node, key, [key])]
- -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
-graphFromEdges edges0
- = (graph, \v -> vertex_map ! v, key_vertex)
- where
- max_v = length edges0 - 1
- bounds0 = (0,max_v) :: (Vertex, Vertex)
- sorted_edges = sortBy lt edges0
- edges1 = zipWith (,) [0..] sorted_edges
-
- graph = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]
- key_map = array bounds0 [(,) v k | (,) v (_, k, _ ) <- edges1]
- vertex_map = array bounds0 edges1
-
- (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2
-
- -- key_vertex :: key -> Maybe Vertex
- -- returns Nothing for non-interesting vertices
- key_vertex k = findVertex 0 max_v
- where
- findVertex a b | a > b
- = Nothing
- findVertex a b = case compare k (key_map ! mid) of
- LT -> findVertex a (mid-1)
- EQ -> Just mid
- GT -> findVertex (mid+1) b
- where
- mid = (a + b) `div` 2
-
--------------------------------------------------------------------------
--- -
--- Depth first search
--- -
--------------------------------------------------------------------------
-
--- | A spanning forest of the graph, obtained from a depth-first search of
--- the graph starting from each vertex in an unspecified order.
-dff :: Graph -> Forest Vertex
-dff g = dfs g (vertices g)
-
--- | A spanning forest of the part of the graph reachable from the listed
--- vertices, obtained from a depth-first search of the graph starting at
--- each of the listed vertices in order.
-dfs :: Graph -> [Vertex] -> Forest Vertex
-dfs g vs = prune (bounds g) (map (generate g) vs)
-
-generate :: Graph -> Vertex -> Tree Vertex
-generate g v = Node v (map (generate g) (g!v))
-
-prune :: Bounds -> Forest Vertex -> Forest Vertex
-prune bnds ts = run bnds (chop ts)
-
-chop :: Forest Vertex -> SetM s (Forest Vertex)
-chop [] = return []
-chop (Node v ts : us)
- = do
- visited <- contains v
- if visited then
- chop us
- else do
- include v
- as <- chop ts
- bs <- chop us
- return (Node v as : bs)
-
--- A monad holding a set of vertices visited so far.
-#if USE_ST_MONAD
-
--- Use the ST monad if available, for constant-time primitives.
-
-newtype SetM s a = SetM { runSetM :: STArray s Vertex Bool -> ST s a }
-
-instance Monad (SetM s) where
- return x = SetM $ const (return x)
- SetM v >>= f = SetM $ \ s -> do { x <- v s; runSetM (f x) s }
-
-run :: Bounds -> (forall s. SetM s a) -> a
-run bnds act = runST (newArray bnds False >>= runSetM act)
-
-contains :: Vertex -> SetM s Bool
-contains v = SetM $ \ m -> readArray m v
-
-include :: Vertex -> SetM s ()
-include v = SetM $ \ m -> writeArray m v True
-
-#else /* !USE_ST_MONAD */
-
--- Portable implementation using IntSet.
-
-newtype SetM s a = SetM { runSetM :: IntSet -> (a, IntSet) }
-
-instance Monad (SetM s) where
- return x = SetM $ \ s -> (x, s)
- SetM v >>= f = SetM $ \ s -> case v s of (x, s') -> runSetM (f x) s'
-
-run :: Bounds -> SetM s a -> a
-run _ act = fst (runSetM act Set.empty)
-
-contains :: Vertex -> SetM s Bool
-contains v = SetM $ \ m -> (Set.member v m, m)
-
-include :: Vertex -> SetM s ()
-include v = SetM $ \ m -> ((), Set.insert v m)
-
-#endif /* !USE_ST_MONAD */
-
--------------------------------------------------------------------------
--- -
--- Algorithms
--- -
--------------------------------------------------------------------------
-
-------------------------------------------------------------
--- Algorithm 1: depth first search numbering
-------------------------------------------------------------
-
-preorder :: Tree a -> [a]
-preorder (Node a ts) = a : preorderF ts
-
-preorderF :: Forest a -> [a]
-preorderF ts = concat (map preorder ts)
-
-tabulate :: Bounds -> [Vertex] -> Table Int
-tabulate bnds vs = array bnds (zipWith (,) vs [1..])
-
-preArr :: Bounds -> Forest Vertex -> Table Int
-preArr bnds = tabulate bnds . preorderF
-
-------------------------------------------------------------
--- Algorithm 2: topological sorting
-------------------------------------------------------------
-
-postorder :: Tree a -> [a]
-postorder (Node a ts) = postorderF ts ++ [a]
-
-postorderF :: Forest a -> [a]
-postorderF ts = concat (map postorder ts)
-
-postOrd :: Graph -> [Vertex]
-postOrd = postorderF . dff
-
--- | A topological sort of the graph.
--- The order is partially specified by the condition that a vertex /i/
--- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa.
-topSort :: Graph -> [Vertex]
-topSort = reverse . postOrd
-
-------------------------------------------------------------
--- Algorithm 3: connected components
-------------------------------------------------------------
-
--- | The connected components of a graph.
--- Two vertices are connected if there is a path between them, traversing
--- edges in either direction.
-components :: Graph -> Forest Vertex
-components = dff . undirected
-
-undirected :: Graph -> Graph
-undirected g = buildG (bounds g) (edges g ++ reverseE g)
-
--- Algorithm 4: strongly connected components
-
--- | The strongly connected components of a graph.
-scc :: Graph -> Forest Vertex
-scc g = dfs g (reverse (postOrd (transposeG g)))
-
-------------------------------------------------------------
--- Algorithm 5: Classifying edges
-------------------------------------------------------------
-
-tree :: Bounds -> Forest Vertex -> Graph
-tree bnds ts = buildG bnds (concat (map flat ts))
- where flat (Node v ts) = [ (v, w) | Node w _us <- ts ] ++ concat (map flat ts)
-
-back :: Graph -> Table Int -> Graph
-back g post = mapT select g
- where select v ws = [ w | w <- ws, post!v < post!w ]
-
-cross :: Graph -> Table Int -> Table Int -> Graph
-cross g pre post = mapT select g
- where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
-
-forward :: Graph -> Graph -> Table Int -> Graph
-forward g tree pre = mapT select g
- where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
-
-------------------------------------------------------------
--- Algorithm 6: Finding reachable vertices
-------------------------------------------------------------
-
--- | A list of vertices reachable from a given vertex.
-reachable :: Graph -> Vertex -> [Vertex]
-reachable g v = preorderF (dfs g [v])
-
--- | Is the second vertex reachable from the first?
-path :: Graph -> Vertex -> Vertex -> Bool
-path g v w = w `elem` (reachable g v)
-
-------------------------------------------------------------
--- Algorithm 7: Biconnected components
-------------------------------------------------------------
-
--- | The biconnected components of a graph.
--- An undirected graph is biconnected if the deletion of any vertex
--- leaves it connected.
-bcc :: Graph -> Forest [Vertex]
-bcc g = (concat . map bicomps . map (do_label g dnum)) forest
- where forest = dff g
- dnum = preArr (bounds g) forest
-
-do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
-do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
- where us = map (do_label g dnum) ts
- lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
- ++ [lu | Node (u,du,lu) xs <- us])
-
-bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
-bicomps (Node (v,_,_) ts)
- = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]
-
-collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
-collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
- where collected = map collect ts
- vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
- cs = concat [ if lw<dv then us else [Node (v:ws) us]
- | (lw, Node ws us) <- collected ]
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
-
------------------------------------------------------------------------------
--- |
--- Module : Data.HashTable
--- Copyright : (c) The University of Glasgow 2003
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- An implementation of extensible hash tables, as described in
--- Per-Ake Larson, /Dynamic Hash Tables/, CACM 31(4), April 1988,
--- pp. 446--457. The implementation is also derived from the one
--- in GHC's runtime system (@ghc\/rts\/Hash.{c,h}@).
---
------------------------------------------------------------------------------
-
-module Data.HashTable (
- -- * Basic hash table operations
- HashTable, new, insert, delete, lookup, update,
- -- * Converting to and from lists
- fromList, toList,
- -- * Hash functions
- -- $hash_functions
- hashInt, hashString,
- prime,
- -- * Diagnostics
- longestChain
- ) where
-
--- This module is imported by Data.Dynamic, which is pretty low down in the
--- module hierarchy, so don't import "high-level" modules
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-#else
-import Prelude hiding ( lookup )
-#endif
-import Data.Tuple ( fst )
-import Data.Bits
-import Data.Maybe
-import Data.List ( maximumBy, length, concat, foldl', partition )
-import Data.Int ( Int32 )
-
-#if defined(__GLASGOW_HASKELL__)
-import GHC.Num
-import GHC.Real ( fromIntegral )
-import GHC.Show ( Show(..) )
-import GHC.Int ( Int64 )
-
-import GHC.IOBase ( IO, IOArray, newIOArray,
- unsafeReadIOArray, unsafeWriteIOArray, unsafePerformIO,
- IORef, newIORef, readIORef, writeIORef )
-#else
-import Data.Char ( ord )
-import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
-import System.IO.Unsafe ( unsafePerformIO )
-import Data.Int ( Int64 )
-# if defined(__HUGS__)
-import Hugs.IOArray ( IOArray, newIOArray,
- unsafeReadIOArray, unsafeWriteIOArray )
-# elif defined(__NHC__)
-import NHC.IOExtras ( IOArray, newIOArray, readIOArray, writeIOArray )
-# endif
-#endif
-import Control.Monad ( mapM, mapM_, sequence_ )
-
-
------------------------------------------------------------------------
-
-iNSTRUMENTED :: Bool
-iNSTRUMENTED = False
-
------------------------------------------------------------------------
-
-readHTArray :: HTArray a -> Int32 -> IO a
-writeMutArray :: MutArray a -> Int32 -> a -> IO ()
-freezeArray :: MutArray a -> IO (HTArray a)
-thawArray :: HTArray a -> IO (MutArray a)
-newMutArray :: (Int32, Int32) -> a -> IO (MutArray a)
-#if defined(DEBUG) || defined(__NHC__)
-type MutArray a = IOArray Int32 a
-type HTArray a = MutArray a
-newMutArray = newIOArray
-readHTArray = readIOArray
-writeMutArray = writeIOArray
-freezeArray = return
-thawArray = return
-#else
-type MutArray a = IOArray Int32 a
-type HTArray a = MutArray a -- Array Int32 a
-newMutArray = newIOArray
-readHTArray arr i = readMutArray arr i -- return $! (unsafeAt arr (fromIntegral i))
-readMutArray :: MutArray a -> Int32 -> IO a
-readMutArray arr i = unsafeReadIOArray arr (fromIntegral i)
-writeMutArray arr i x = unsafeWriteIOArray arr (fromIntegral i) x
-freezeArray = return -- unsafeFreeze
-thawArray = return -- unsafeThaw
-#endif
-
-data HashTable key val = HashTable {
- cmp :: !(key -> key -> Bool),
- hash_fn :: !(key -> Int32),
- tab :: !(IORef (HT key val))
- }
--- TODO: the IORef should really be an MVar.
-
-data HT key val
- = HT {
- kcount :: !Int32, -- Total number of keys.
- bmask :: !Int32,
- buckets :: !(HTArray [(key,val)])
- }
-
--- ------------------------------------------------------------
--- Instrumentation for performance tuning
-
--- This ought to be roundly ignored after optimization when
--- iNSTRUMENTED=False.
-
--- STRICT version of modifyIORef!
-modifyIORef :: IORef a -> (a -> a) -> IO ()
-modifyIORef r f = do
- v <- readIORef r
- let z = f v in z `seq` writeIORef r z
-
-data HashData = HD {
- tables :: !Integer,
- insertions :: !Integer,
- lookups :: !Integer,
- totBuckets :: !Integer,
- maxEntries :: !Int32,
- maxChain :: !Int,
- maxBuckets :: !Int32
-} deriving (Eq, Show)
-
-{-# NOINLINE hashData #-}
-hashData :: IORef HashData
-hashData = unsafePerformIO (newIORef (HD { tables=0, insertions=0, lookups=0,
- totBuckets=0, maxEntries=0,
- maxChain=0, maxBuckets=tABLE_MIN } ))
-
-instrument :: (HashData -> HashData) -> IO ()
-instrument i | iNSTRUMENTED = modifyIORef hashData i
- | otherwise = return ()
-
-recordNew :: IO ()
-recordNew = instrument rec
- where rec hd@HD{ tables=t, totBuckets=b } =
- hd{ tables=t+1, totBuckets=b+fromIntegral tABLE_MIN }
-
-recordIns :: Int32 -> Int32 -> [a] -> IO ()
-recordIns i sz bkt = instrument rec
- where rec hd@HD{ insertions=ins, maxEntries=mx, maxChain=mc } =
- hd{ insertions=ins+fromIntegral i, maxEntries=mx `max` sz,
- maxChain=mc `max` length bkt }
-
-recordResize :: Int32 -> Int32 -> IO ()
-recordResize older newer = instrument rec
- where rec hd@HD{ totBuckets=b, maxBuckets=mx } =
- hd{ totBuckets=b+fromIntegral (newer-older),
- maxBuckets=mx `max` newer }
-
-recordLookup :: IO ()
-recordLookup = instrument lkup
- where lkup hd@HD{ lookups=l } = hd{ lookups=l+1 }
-
--- stats :: IO String
--- stats = fmap show $ readIORef hashData
-
--- -----------------------------------------------------------------------------
--- Sample hash functions
-
--- $hash_functions
---
--- This implementation of hash tables uses the low-order /n/ bits of the hash
--- value for a key, where /n/ varies as the hash table grows. A good hash
--- function therefore will give an even distribution regardless of /n/.
---
--- If your keyspace is integrals such that the low-order bits between
--- keys are highly variable, then you could get away with using 'id'
--- as the hash function.
---
--- We provide some sample hash functions for 'Int' and 'String' below.
-
-golden :: Int32
-golden = -1640531527
-
--- | A sample (and useful) hash function for Int and Int32,
--- implemented by extracting the uppermost 32 bits of the 64-bit
--- result of multiplying by a 32-bit constant. The constant is from
--- Knuth, derived from the golden ratio:
---
--- > golden = round ((sqrt 5 - 1) * 2^31) :: Int
-hashInt :: Int -> Int32
-hashInt x = mulHi (fromIntegral x) golden
-
--- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply
-mulHi :: Int32 -> Int32 -> Int32
-mulHi a b = fromIntegral (r `shiftR` 32)
- where r :: Int64
- r = fromIntegral a * fromIntegral b :: Int64
-
--- | A sample hash function for Strings. We keep multiplying by the
--- golden ratio and adding. The implementation is:
---
--- > hashString = foldl' f 0
--- > where f m c = fromIntegral (fromEnum c + 1) * golden + mulHi m golden
---
--- Note that this has not been extensively tested for reasonability,
--- but Knuth argues that repeated multiplication by the golden ratio
--- will minimize gaps in the hash space.
-hashString :: String -> Int32
-hashString = foldl' f 0
- where f m c = fromIntegral (ord c + 1) * golden + mulHi m golden
-
--- | A prime larger than the maximum hash table size
-prime :: Int32
-prime = 33554467
-
--- -----------------------------------------------------------------------------
--- Parameters
-
-tABLE_MAX :: Int32
-tABLE_MAX = 32 * 1024 * 1024 -- Maximum size of hash table
-tABLE_MIN :: Int32
-tABLE_MIN = 8
-
-hLOAD :: Int32
-hLOAD = 7 -- Maximum average load of a single hash bucket
-
-hYSTERESIS :: Int32
-hYSTERESIS = 64 -- entries to ignore in load computation
-
-{- Hysteresis favors long association-list-like behavior for small tables. -}
-
--- -----------------------------------------------------------------------------
--- Creating a new hash table
-
--- | Creates a new hash table. The following property should hold for the @eq@
--- and @hash@ functions passed to 'new':
---
--- > eq A B => hash A == hash B
---
-new
- :: (key -> key -> Bool) -- ^ @eq@: An equality comparison on keys
- -> (key -> Int32) -- ^ @hash@: A hash function on keys
- -> IO (HashTable key val) -- ^ Returns: an empty hash table
-
-new cmpr hash = do
- recordNew
- -- make a new hash table with a single, empty, segment
- let mask = tABLE_MIN-1
- bkts' <- newMutArray (0,mask) []
- bkts <- freezeArray bkts'
-
- let
- kcnt = 0
- ht = HT { buckets=bkts, kcount=kcnt, bmask=mask }
-
- table <- newIORef ht
- return (HashTable { tab=table, hash_fn=hash, cmp=cmpr })
-
--- -----------------------------------------------------------------------------
--- Inserting a key\/value pair into the hash table
-
--- | Inserts a key\/value mapping into the hash table.
---
--- Note that 'insert' doesn't remove the old entry from the table -
--- the behaviour is like an association list, where 'lookup' returns
--- the most-recently-inserted mapping for a key in the table. The
--- reason for this is to keep 'insert' as efficient as possible. If
--- you need to update a mapping, then we provide 'update'.
---
-insert :: HashTable key val -> key -> val -> IO ()
-
-insert ht key val =
- updatingBucket CanInsert (\bucket -> ((key,val):bucket, 1, ())) ht key
-
-
--- ------------------------------------------------------------
--- The core of the implementation is lurking down here, in findBucket,
--- updatingBucket, and expandHashTable.
-
-tooBig :: Int32 -> Int32 -> Bool
-tooBig k b = k-hYSTERESIS > hLOAD * b
-
--- index of bucket within table.
-bucketIndex :: Int32 -> Int32 -> Int32
-bucketIndex mask h = h .&. mask
-
--- find the bucket in which the key belongs.
--- returns (key equality, bucket index, bucket)
---
--- This rather grab-bag approach gives enough power to do pretty much
--- any bucket-finding thing you might want to do. We rely on inlining
--- to throw away the stuff we don't want. I'm proud to say that this
--- plus updatingBucket below reduce most of the other definitions to a
--- few lines of code, while actually speeding up the hashtable
--- implementation when compared with a version which does everything
--- from scratch.
-{-# INLINE findBucket #-}
-findBucket :: HashTable key val -> key -> IO (HT key val, Int32, [(key,val)])
-findBucket HashTable{ tab=ref, hash_fn=hash} key = do
- table@HT{ buckets=bkts, bmask=b } <- readIORef ref
- let indx = bucketIndex b (hash key)
- bucket <- readHTArray bkts indx
- return (table, indx, bucket)
-
-data Inserts = CanInsert
- | Can'tInsert
- deriving (Eq)
-
--- updatingBucket is the real workhorse of all single-element table
--- updates. It takes a hashtable and a key, along with a function
--- describing what to do with the bucket in which that key belongs. A
--- flag indicates whether this function may perform table insertions.
--- The function returns the new contents of the bucket, the number of
--- bucket entries inserted (negative if entries were deleted), and a
--- value which becomes the return value for the function as a whole.
--- The table sizing is enforced here, calling out to expandSubTable as
--- necessary.
-
--- This function is intended to be inlined and specialized for every
--- calling context (eg every provided bucketFn).
-{-# INLINE updatingBucket #-}
-
-updatingBucket :: Inserts -> ([(key,val)] -> ([(key,val)], Int32, a)) ->
- HashTable key val -> key ->
- IO a
-updatingBucket canEnlarge bucketFn
- ht@HashTable{ tab=ref, hash_fn=hash } key = do
- (table@HT{ kcount=k, buckets=bkts, bmask=b },
- indx, bckt) <- findBucket ht key
- (bckt', inserts, result) <- return $ bucketFn bckt
- let k' = k + inserts
- table1 = table { kcount=k' }
- bkts' <- thawArray bkts
- writeMutArray bkts' indx bckt'
- freezeArray bkts'
- table2 <- if canEnlarge == CanInsert && inserts > 0 then do
- recordIns inserts k' bckt'
- if tooBig k' b
- then expandHashTable hash table1
- else return table1
- else return table1
- writeIORef ref table2
- return result
-
-expandHashTable :: (key -> Int32) -> HT key val -> IO (HT key val)
-expandHashTable hash table@HT{ buckets=bkts, bmask=mask } = do
- let
- oldsize = mask + 1
- newmask = mask + mask + 1
- recordResize oldsize (newmask+1)
- --
- if newmask > tABLE_MAX-1
- then return table
- else do
- --
- newbkts' <- newMutArray (0,newmask) []
-
- let
- splitBucket oldindex = do
- bucket <- readHTArray bkts oldindex
- let (oldb,newb) =
- partition ((oldindex==). bucketIndex newmask . hash . fst) bucket
- writeMutArray newbkts' oldindex oldb
- writeMutArray newbkts' (oldindex + oldsize) newb
- mapM_ splitBucket [0..mask]
-
- newbkts <- freezeArray newbkts'
-
- return ( table{ buckets=newbkts, bmask=newmask } )
-
--- -----------------------------------------------------------------------------
--- Deleting a mapping from the hash table
-
--- Remove a key from a bucket
-deleteBucket :: (key -> Bool) -> [(key,val)] -> ([(key, val)], Int32, ())
-deleteBucket _ [] = ([],0,())
-deleteBucket del (pair@(k,_):bucket) =
- case deleteBucket del bucket of
- (bucket', dels, _) | del k -> dels' `seq` (bucket', dels', ())
- | otherwise -> (pair:bucket', dels, ())
- where dels' = dels - 1
-
--- | Remove an entry from the hash table.
-delete :: HashTable key val -> key -> IO ()
-
-delete ht@HashTable{ cmp=eq } key =
- updatingBucket Can'tInsert (deleteBucket (eq key)) ht key
-
--- -----------------------------------------------------------------------------
--- Updating a mapping in the hash table
-
--- | Updates an entry in the hash table, returning 'True' if there was
--- already an entry for this key, or 'False' otherwise. After 'update'
--- there will always be exactly one entry for the given key in the table.
---
--- 'insert' is more efficient than 'update' if you don't care about
--- multiple entries, or you know for sure that multiple entries can't
--- occur. However, 'update' is more efficient than 'delete' followed
--- by 'insert'.
-update :: HashTable key val -> key -> val -> IO Bool
-
-update ht@HashTable{ cmp=eq } key val =
- updatingBucket CanInsert
- (\bucket -> let (bucket', dels, _) = deleteBucket (eq key) bucket
- in ((key,val):bucket', 1+dels, dels/=0))
- ht key
-
--- -----------------------------------------------------------------------------
--- Looking up an entry in the hash table
-
--- | Looks up the value of a key in the hash table.
-lookup :: HashTable key val -> key -> IO (Maybe val)
-
-lookup ht@HashTable{ cmp=eq } key = do
- recordLookup
- (_, _, bucket) <- findBucket ht key
- let firstHit (k,v) r | eq key k = Just v
- | otherwise = r
- return (foldr firstHit Nothing bucket)
-
--- -----------------------------------------------------------------------------
--- Converting to/from lists
-
--- | Convert a list of key\/value pairs into a hash table. Equality on keys
--- is taken from the Eq instance for the key type.
---
-fromList :: (Eq key) => (key -> Int32) -> [(key,val)] -> IO (HashTable key val)
-fromList hash list = do
- table <- new (==) hash
- sequence_ [ insert table k v | (k,v) <- list ]
- return table
-
--- | Converts a hash table to a list of key\/value pairs.
---
-toList :: HashTable key val -> IO [(key,val)]
-toList = mapReduce id concat
-
-{-# INLINE mapReduce #-}
-mapReduce :: ([(key,val)] -> r) -> ([r] -> r) -> HashTable key val -> IO r
-mapReduce m r HashTable{ tab=ref } = do
- HT{ buckets=bckts, bmask=b } <- readIORef ref
- fmap r (mapM (fmap m . readHTArray bckts) [0..b])
-
--- -----------------------------------------------------------------------------
--- Diagnostics
-
--- | This function is useful for determining whether your hash
--- function is working well for your data set. It returns the longest
--- chain of key\/value pairs in the hash table for which all the keys
--- hash to the same bucket. If this chain is particularly long (say,
--- longer than 14 elements or so), then it might be a good idea to try
--- a different hash function.
---
-longestChain :: HashTable key val -> IO [(key,val)]
-longestChain = mapReduce id (maximumBy lengthCmp)
- where lengthCmp (_:x)(_:y) = lengthCmp x y
- lengthCmp [] [] = EQ
- lengthCmp [] _ = LT
- lengthCmp _ [] = GT
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.IORef
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Mutable references in the IO monad.
---
------------------------------------------------------------------------------
-
-module Data.IORef
- (
- -- * IORefs
- IORef, -- abstract, instance of: Eq, Typeable
- newIORef, -- :: a -> IO (IORef a)
- readIORef, -- :: IORef a -> IO a
- writeIORef, -- :: IORef a -> a -> IO ()
- modifyIORef, -- :: IORef a -> (a -> a) -> IO ()
- atomicModifyIORef, -- :: IORef a -> (a -> (a,b)) -> IO b
-
-#if !defined(__PARALLEL_HASKELL__) && defined(__GLASGOW_HASKELL__)
- mkWeakIORef, -- :: IORef a -> IO () -> IO (Weak (IORef a))
-#endif
- ) where
-
-import Prelude -- Explicit dependency helps 'make depend' do the right thing
-
-#ifdef __HUGS__
-import Hugs.IORef
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base ( mkWeak#, atomicModifyMutVar# )
-import GHC.STRef
-import GHC.IOBase
-#if !defined(__PARALLEL_HASKELL__)
-import GHC.Weak
-#endif
-#endif /* __GLASGOW_HASKELL__ */
-
-#ifdef __NHC__
-import NHC.IOExtras
- ( IORef
- , newIORef
- , readIORef
- , writeIORef
- , excludeFinalisers
- )
-#endif
-
-#if defined(__GLASGOW_HASKELL__) && !defined(__PARALLEL_HASKELL__)
--- |Make a 'Weak' pointer to an 'IORef'
-mkWeakIORef :: IORef a -> IO () -> IO (Weak (IORef a))
-mkWeakIORef r@(IORef (STRef r#)) f = IO $ \s ->
- case mkWeak# r# r f s of (# s1, w #) -> (# s1, Weak w #)
-#endif
-
--- |Mutate the contents of an 'IORef'
-modifyIORef :: IORef a -> (a -> a) -> IO ()
-modifyIORef ref f = writeIORef ref . f =<< readIORef ref
-
-
--- |Atomically modifies the contents of an 'IORef'.
---
--- This function is useful for using 'IORef' in a safe way in a multithreaded
--- program. If you only have one 'IORef', then using 'atomicModifyIORef' to
--- access and modify it will prevent race conditions.
---
--- Extending the atomicity to multiple 'IORef's is problematic, so it
--- is recommended that if you need to do anything more complicated
--- then using 'Control.Concurrent.MVar.MVar' instead is a good idea.
---
-atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b
-#if defined(__GLASGOW_HASKELL__)
-atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s
-
-#elif defined(__HUGS__)
-atomicModifyIORef = plainModifyIORef -- Hugs has no preemption
- where plainModifyIORef r f = do
- a <- readIORef r
- case f a of (a',b) -> writeIORef r a' >> return b
-#elif defined(__NHC__)
-atomicModifyIORef r f =
- excludeFinalisers $ do
- a <- readIORef r
- let (a',b) = f a
- writeIORef r a'
- return b
-#endif
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Int
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Signed integer types
---
------------------------------------------------------------------------------
-
-module Data.Int
- (
- -- * Signed integer types
- Int,
- Int8, Int16, Int32, Int64,
-
- -- * Notes
-
- -- $notes
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base ( Int )
-import GHC.Int ( Int8, Int16, Int32, Int64 )
-#endif
-
-#ifdef __HUGS__
-import Hugs.Int ( Int8, Int16, Int32, Int64 )
-#endif
-
-#ifdef __NHC__
-import Prelude
-import Prelude (Int)
-import NHC.FFI (Int8, Int16, Int32, Int64)
-import NHC.SizedTypes (Int8, Int16, Int32, Int64) -- instances of Bits
-#endif
-
-{- $notes
-
-* All arithmetic is performed modulo 2^n, where @n@ is the number of
- bits in the type.
-
-* For coercing between any two integer types, use 'Prelude.fromIntegral',
- which is specialized for all the common cases so should be fast
- enough. Coercing word types (see "Data.Word") to and from integer
- types preserves representation, not sign.
-
-* The rules that hold for 'Prelude.Enum' instances over a
- bounded type such as 'Int' (see the section of the
- Haskell report dealing with arithmetic sequences) also hold for the
- 'Prelude.Enum' instances over the various
- 'Int' types defined here.
-
-* Right and left shifts by amounts greater than or equal to the width
- of the type result in either zero or -1, depending on the sign of
- the value being shifted. This is contrary to the behaviour in C,
- which is undefined; a common interpretation is to truncate the shift
- count to the width of the type, for example @1 \<\< 32
- == 1@ in some C implementations.
--}
+++ /dev/null
-{-# OPTIONS -cpp -fglasgow-exts -fno-bang-patterns #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.IntMap
--- Copyright : (c) Daan Leijen 2002
--- License : BSD-style
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- An efficient implementation of maps from integer keys to values.
---
--- Since many function names (but not the type name) clash with
--- "Prelude" names, this module is usually imported @qualified@, e.g.
---
--- > import Data.IntMap (IntMap)
--- > import qualified Data.IntMap as IntMap
---
--- The implementation is based on /big-endian patricia trees/. This data
--- structure performs especially well on binary operations like 'union'
--- and 'intersection'. However, my benchmarks show that it is also
--- (much) faster on insertions and deletions when compared to a generic
--- size-balanced map implementation (see "Data.Map" and "Data.FiniteMap").
---
--- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
--- Workshop on ML, September 1998, pages 77-86,
--- <http://www.cse.ogi.edu/~andy/pub/finite.htm>
---
--- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve
--- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),
--- October 1968, pages 514-534.
---
--- Many operations have a worst-case complexity of /O(min(n,W))/.
--- This means that the operation can become linear in the number of
--- elements with a maximum of /W/ -- the number of bits in an 'Int'
--- (32 or 64).
------------------------------------------------------------------------------
-
-module Data.IntMap (
- -- * Map type
- IntMap, Key -- instance Eq,Show
-
- -- * Operators
- , (!), (\\)
-
- -- * Query
- , null
- , size
- , member
- , notMember
- , lookup
- , findWithDefault
-
- -- * Construction
- , empty
- , singleton
-
- -- ** Insertion
- , insert
- , insertWith, insertWithKey, insertLookupWithKey
-
- -- ** Delete\/Update
- , delete
- , adjust
- , adjustWithKey
- , update
- , updateWithKey
- , updateLookupWithKey
- , alter
-
- -- * Combine
-
- -- ** Union
- , union
- , unionWith
- , unionWithKey
- , unions
- , unionsWith
-
- -- ** Difference
- , difference
- , differenceWith
- , differenceWithKey
-
- -- ** Intersection
- , intersection
- , intersectionWith
- , intersectionWithKey
-
- -- * Traversal
- -- ** Map
- , map
- , mapWithKey
- , mapAccum
- , mapAccumWithKey
-
- -- ** Fold
- , fold
- , foldWithKey
-
- -- * Conversion
- , elems
- , keys
- , keysSet
- , assocs
-
- -- ** Lists
- , toList
- , fromList
- , fromListWith
- , fromListWithKey
-
- -- ** Ordered lists
- , toAscList
- , fromAscList
- , fromAscListWith
- , fromAscListWithKey
- , fromDistinctAscList
-
- -- * Filter
- , filter
- , filterWithKey
- , partition
- , partitionWithKey
-
- , mapMaybe
- , mapMaybeWithKey
- , mapEither
- , mapEitherWithKey
-
- , split
- , splitLookup
-
- -- * Submap
- , isSubmapOf, isSubmapOfBy
- , isProperSubmapOf, isProperSubmapOfBy
-
- -- * Min\/Max
-
- , maxView
- , minView
- , findMin
- , findMax
- , deleteMin
- , deleteMax
- , deleteFindMin
- , deleteFindMax
- , updateMin
- , updateMax
- , updateMinWithKey
- , updateMaxWithKey
- , minViewWithKey
- , maxViewWithKey
-
- -- * Debugging
- , showTree
- , showTreeWith
- ) where
-
-
-import Prelude hiding (lookup,map,filter,foldr,foldl,null)
-import Data.Bits
-import qualified Data.IntSet as IntSet
-import Data.Monoid (Monoid(..))
-import Data.Typeable
-import Data.Foldable (Foldable(foldMap))
-import Control.Monad ( liftM )
-import Control.Arrow (ArrowZero)
-{-
--- just for testing
-import qualified Prelude
-import Debug.QuickCheck
-import List (nub,sort)
-import qualified List
--}
-
-#if __GLASGOW_HASKELL__
-import Text.Read
-import Data.Generics.Basics (Data(..), mkNorepType)
-import Data.Generics.Instances ()
-#endif
-
-#if __GLASGOW_HASKELL__ >= 503
-import GHC.Exts ( Word(..), Int(..), shiftRL# )
-#elif __GLASGOW_HASKELL__
-import Word
-import GlaExts ( Word(..), Int(..), shiftRL# )
-#else
-import Data.Word
-#endif
-
-infixl 9 \\{-This comment teaches CPP correct behaviour -}
-
--- A "Nat" is a natural machine word (an unsigned Int)
-type Nat = Word
-
-natFromInt :: Key -> Nat
-natFromInt i = fromIntegral i
-
-intFromNat :: Nat -> Key
-intFromNat w = fromIntegral w
-
-shiftRL :: Nat -> Key -> Nat
-#if __GLASGOW_HASKELL__
-{--------------------------------------------------------------------
- GHC: use unboxing to get @shiftRL@ inlined.
---------------------------------------------------------------------}
-shiftRL (W# x) (I# i)
- = W# (shiftRL# x i)
-#else
-shiftRL x i = shiftR x i
-#endif
-
-{--------------------------------------------------------------------
- Operators
---------------------------------------------------------------------}
-
--- | /O(min(n,W))/. Find the value at a key.
--- Calls 'error' when the element can not be found.
-
-(!) :: IntMap a -> Key -> a
-m ! k = find' k m
-
--- | /O(n+m)/. See 'difference'.
-(\\) :: IntMap a -> IntMap b -> IntMap a
-m1 \\ m2 = difference m1 m2
-
-{--------------------------------------------------------------------
- Types
---------------------------------------------------------------------}
--- | A map of integers to values @a@.
-data IntMap a = Nil
- | Tip {-# UNPACK #-} !Key a
- | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(IntMap a) !(IntMap a)
-
-type Prefix = Int
-type Mask = Int
-type Key = Int
-
-instance Monoid (IntMap a) where
- mempty = empty
- mappend = union
- mconcat = unions
-
-instance Foldable IntMap where
- foldMap f Nil = mempty
- foldMap f (Tip _k v) = f v
- foldMap f (Bin _ _ l r) = foldMap f l `mappend` foldMap f r
-
-#if __GLASGOW_HASKELL__
-
-{--------------------------------------------------------------------
- A Data instance
---------------------------------------------------------------------}
-
--- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
-
-instance Data a => Data (IntMap a) where
- gfoldl f z im = z fromList `f` (toList im)
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.IntMap.IntMap"
- dataCast1 f = gcast1 f
-
-#endif
-
-{--------------------------------------------------------------------
- Query
---------------------------------------------------------------------}
--- | /O(1)/. Is the map empty?
-null :: IntMap a -> Bool
-null Nil = True
-null other = False
-
--- | /O(n)/. Number of elements in the map.
-size :: IntMap a -> Int
-size t
- = case t of
- Bin p m l r -> size l + size r
- Tip k x -> 1
- Nil -> 0
-
--- | /O(min(n,W))/. Is the key a member of the map?
-member :: Key -> IntMap a -> Bool
-member k m
- = case lookup k m of
- Nothing -> False
- Just x -> True
-
--- | /O(log n)/. Is the key not a member of the map?
-notMember :: Key -> IntMap a -> Bool
-notMember k m = not $ member k m
-
--- | /O(min(n,W))/. Lookup the value at a key in the map.
-lookup :: (Monad m) => Key -> IntMap a -> m a
-lookup k t = case lookup' k t of
- Just x -> return x
- Nothing -> fail "Data.IntMap.lookup: Key not found"
-
-lookup' :: Key -> IntMap a -> Maybe a
-lookup' k t
- = let nk = natFromInt k in seq nk (lookupN nk t)
-
-lookupN :: Nat -> IntMap a -> Maybe a
-lookupN k t
- = case t of
- Bin p m l r
- | zeroN k (natFromInt m) -> lookupN k l
- | otherwise -> lookupN k r
- Tip kx x
- | (k == natFromInt kx) -> Just x
- | otherwise -> Nothing
- Nil -> Nothing
-
-find' :: Key -> IntMap a -> a
-find' k m
- = case lookup k m of
- Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")
- Just x -> x
-
-
--- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@
--- returns the value at key @k@ or returns @def@ when the key is not an
--- element of the map.
-findWithDefault :: a -> Key -> IntMap a -> a
-findWithDefault def k m
- = case lookup k m of
- Nothing -> def
- Just x -> x
-
-{--------------------------------------------------------------------
- Construction
---------------------------------------------------------------------}
--- | /O(1)/. The empty map.
-empty :: IntMap a
-empty
- = Nil
-
--- | /O(1)/. A map of one element.
-singleton :: Key -> a -> IntMap a
-singleton k x
- = Tip k x
-
-{--------------------------------------------------------------------
- Insert
---------------------------------------------------------------------}
--- | /O(min(n,W))/. Insert a new key\/value pair in the map.
--- If the key is already present in the map, the associated value is
--- replaced with the supplied value, i.e. 'insert' is equivalent to
--- @'insertWith' 'const'@.
-insert :: Key -> a -> IntMap a -> IntMap a
-insert k x t
- = case t of
- Bin p m l r
- | nomatch k p m -> join k (Tip k x) p t
- | zero k m -> Bin p m (insert k x l) r
- | otherwise -> Bin p m l (insert k x r)
- Tip ky y
- | k==ky -> Tip k x
- | otherwise -> join k (Tip k x) ky t
- Nil -> Tip k x
-
--- right-biased insertion, used by 'union'
--- | /O(min(n,W))/. Insert with a combining function.
--- @'insertWith' f key value mp@
--- will insert the pair (key, value) into @mp@ if key does
--- not exist in the map. If the key does exist, the function will
--- insert @f new_value old_value@.
-insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
-insertWith f k x t
- = insertWithKey (\k x y -> f x y) k x t
-
--- | /O(min(n,W))/. Insert with a combining function.
--- @'insertWithKey' f key value mp@
--- will insert the pair (key, value) into @mp@ if key does
--- not exist in the map. If the key does exist, the function will
--- insert @f key new_value old_value@.
-insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
-insertWithKey f k x t
- = case t of
- Bin p m l r
- | nomatch k p m -> join k (Tip k x) p t
- | zero k m -> Bin p m (insertWithKey f k x l) r
- | otherwise -> Bin p m l (insertWithKey f k x r)
- Tip ky y
- | k==ky -> Tip k (f k x y)
- | otherwise -> join k (Tip k x) ky t
- Nil -> Tip k x
-
-
--- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)
--- is a pair where the first element is equal to (@'lookup' k map@)
--- and the second element equal to (@'insertWithKey' f k x map@).
-insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)
-insertLookupWithKey f k x t
- = case t of
- Bin p m l r
- | nomatch k p m -> (Nothing,join k (Tip k x) p t)
- | zero k m -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)
- | otherwise -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')
- Tip ky y
- | k==ky -> (Just y,Tip k (f k x y))
- | otherwise -> (Nothing,join k (Tip k x) ky t)
- Nil -> (Nothing,Tip k x)
-
-
-{--------------------------------------------------------------------
- Deletion
- [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
---------------------------------------------------------------------}
--- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not
--- a member of the map, the original map is returned.
-delete :: Key -> IntMap a -> IntMap a
-delete k t
- = case t of
- Bin p m l r
- | nomatch k p m -> t
- | zero k m -> bin p m (delete k l) r
- | otherwise -> bin p m l (delete k r)
- Tip ky y
- | k==ky -> Nil
- | otherwise -> t
- Nil -> Nil
-
--- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
--- a member of the map, the original map is returned.
-adjust :: (a -> a) -> Key -> IntMap a -> IntMap a
-adjust f k m
- = adjustWithKey (\k x -> f x) k m
-
--- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
--- a member of the map, the original map is returned.
-adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a
-adjustWithKey f k m
- = updateWithKey (\k x -> Just (f k x)) k m
-
--- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@
--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
-update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a
-update f k m
- = updateWithKey (\k x -> f x) k m
-
--- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@
--- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is
--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
-updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a
-updateWithKey f k t
- = case t of
- Bin p m l r
- | nomatch k p m -> t
- | zero k m -> bin p m (updateWithKey f k l) r
- | otherwise -> bin p m l (updateWithKey f k r)
- Tip ky y
- | k==ky -> case (f k y) of
- Just y' -> Tip ky y'
- Nothing -> Nil
- | otherwise -> t
- Nil -> Nil
-
--- | /O(min(n,W))/. Lookup and update.
-updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)
-updateLookupWithKey f k t
- = case t of
- Bin p m l r
- | nomatch k p m -> (Nothing,t)
- | zero k m -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)
- | otherwise -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')
- Tip ky y
- | k==ky -> case (f k y) of
- Just y' -> (Just y,Tip ky y')
- Nothing -> (Just y,Nil)
- | otherwise -> (Nothing,t)
- Nil -> (Nothing,Nil)
-
-
-
--- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
--- 'alter' can be used to insert, delete, or update a value in a 'Map'.
--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@
-alter f k t
- = case t of
- Bin p m l r
- | nomatch k p m -> case f Nothing of
- Nothing -> t
- Just x -> join k (Tip k x) p t
- | zero k m -> bin p m (alter f k l) r
- | otherwise -> bin p m l (alter f k r)
- Tip ky y
- | k==ky -> case f (Just y) of
- Just x -> Tip ky x
- Nothing -> Nil
- | otherwise -> case f Nothing of
- Just x -> join k (Tip k x) ky t
- Nothing -> Tip ky y
- Nil -> case f Nothing of
- Just x -> Tip k x
- Nothing -> Nil
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
--- | The union of a list of maps.
-unions :: [IntMap a] -> IntMap a
-unions xs
- = foldlStrict union empty xs
-
--- | The union of a list of maps, with a combining operation
-unionsWith :: (a->a->a) -> [IntMap a] -> IntMap a
-unionsWith f ts
- = foldlStrict (unionWith f) empty ts
-
--- | /O(n+m)/. The (left-biased) union of two maps.
--- It prefers the first map when duplicate keys are encountered,
--- i.e. (@'union' == 'unionWith' 'const'@).
-union :: IntMap a -> IntMap a -> IntMap a
-union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = union1
- | shorter m2 m1 = union2
- | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)
- | otherwise = join p1 t1 p2 t2
- where
- union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
- | zero p2 m1 = Bin p1 m1 (union l1 t2) r1
- | otherwise = Bin p1 m1 l1 (union r1 t2)
-
- union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
- | zero p1 m2 = Bin p2 m2 (union t1 l2) r2
- | otherwise = Bin p2 m2 l2 (union t1 r2)
-
-union (Tip k x) t = insert k x t
-union t (Tip k x) = insertWith (\x y -> y) k x t -- right bias
-union Nil t = t
-union t Nil = t
-
--- | /O(n+m)/. The union with a combining function.
-unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
-unionWith f m1 m2
- = unionWithKey (\k x y -> f x y) m1 m2
-
--- | /O(n+m)/. The union with a combining function.
-unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
-unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = union1
- | shorter m2 m1 = union2
- | p1 == p2 = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)
- | otherwise = join p1 t1 p2 t2
- where
- union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
- | zero p2 m1 = Bin p1 m1 (unionWithKey f l1 t2) r1
- | otherwise = Bin p1 m1 l1 (unionWithKey f r1 t2)
-
- union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
- | zero p1 m2 = Bin p2 m2 (unionWithKey f t1 l2) r2
- | otherwise = Bin p2 m2 l2 (unionWithKey f t1 r2)
-
-unionWithKey f (Tip k x) t = insertWithKey f k x t
-unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t -- right bias
-unionWithKey f Nil t = t
-unionWithKey f t Nil = t
-
-{--------------------------------------------------------------------
- Difference
---------------------------------------------------------------------}
--- | /O(n+m)/. Difference between two maps (based on keys).
-difference :: IntMap a -> IntMap b -> IntMap a
-difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = difference1
- | shorter m2 m1 = difference2
- | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)
- | otherwise = t1
- where
- difference1 | nomatch p2 p1 m1 = t1
- | zero p2 m1 = bin p1 m1 (difference l1 t2) r1
- | otherwise = bin p1 m1 l1 (difference r1 t2)
-
- difference2 | nomatch p1 p2 m2 = t1
- | zero p1 m2 = difference t1 l2
- | otherwise = difference t1 r2
-
-difference t1@(Tip k x) t2
- | member k t2 = Nil
- | otherwise = t1
-
-difference Nil t = Nil
-difference t (Tip k x) = delete k t
-difference t Nil = t
-
--- | /O(n+m)/. Difference with a combining function.
-differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
-differenceWith f m1 m2
- = differenceWithKey (\k x y -> f x y) m1 m2
-
--- | /O(n+m)/. Difference with a combining function. When two equal keys are
--- encountered, the combining function is applied to the key and both values.
--- If it returns 'Nothing', the element is discarded (proper set difference).
--- If it returns (@'Just' y@), the element is updated with a new value @y@.
-differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
-differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = difference1
- | shorter m2 m1 = difference2
- | p1 == p2 = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)
- | otherwise = t1
- where
- difference1 | nomatch p2 p1 m1 = t1
- | zero p2 m1 = bin p1 m1 (differenceWithKey f l1 t2) r1
- | otherwise = bin p1 m1 l1 (differenceWithKey f r1 t2)
-
- difference2 | nomatch p1 p2 m2 = t1
- | zero p1 m2 = differenceWithKey f t1 l2
- | otherwise = differenceWithKey f t1 r2
-
-differenceWithKey f t1@(Tip k x) t2
- = case lookup k t2 of
- Just y -> case f k x y of
- Just y' -> Tip k y'
- Nothing -> Nil
- Nothing -> t1
-
-differenceWithKey f Nil t = Nil
-differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t
-differenceWithKey f t Nil = t
-
-
-{--------------------------------------------------------------------
- Intersection
---------------------------------------------------------------------}
--- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).
-intersection :: IntMap a -> IntMap b -> IntMap a
-intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = intersection1
- | shorter m2 m1 = intersection2
- | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
- | otherwise = Nil
- where
- intersection1 | nomatch p2 p1 m1 = Nil
- | zero p2 m1 = intersection l1 t2
- | otherwise = intersection r1 t2
-
- intersection2 | nomatch p1 p2 m2 = Nil
- | zero p1 m2 = intersection t1 l2
- | otherwise = intersection t1 r2
-
-intersection t1@(Tip k x) t2
- | member k t2 = t1
- | otherwise = Nil
-intersection t (Tip k x)
- = case lookup k t of
- Just y -> Tip k y
- Nothing -> Nil
-intersection Nil t = Nil
-intersection t Nil = Nil
-
--- | /O(n+m)/. The intersection with a combining function.
-intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
-intersectionWith f m1 m2
- = intersectionWithKey (\k x y -> f x y) m1 m2
-
--- | /O(n+m)/. The intersection with a combining function.
-intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
-intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = intersection1
- | shorter m2 m1 = intersection2
- | p1 == p2 = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)
- | otherwise = Nil
- where
- intersection1 | nomatch p2 p1 m1 = Nil
- | zero p2 m1 = intersectionWithKey f l1 t2
- | otherwise = intersectionWithKey f r1 t2
-
- intersection2 | nomatch p1 p2 m2 = Nil
- | zero p1 m2 = intersectionWithKey f t1 l2
- | otherwise = intersectionWithKey f t1 r2
-
-intersectionWithKey f t1@(Tip k x) t2
- = case lookup k t2 of
- Just y -> Tip k (f k x y)
- Nothing -> Nil
-intersectionWithKey f t1 (Tip k y)
- = case lookup k t1 of
- Just x -> Tip k (f k x y)
- Nothing -> Nil
-intersectionWithKey f Nil t = Nil
-intersectionWithKey f t Nil = Nil
-
-
-{--------------------------------------------------------------------
- Min\/Max
---------------------------------------------------------------------}
-
--- | /O(log n)/. Update the value at the minimal key.
-updateMinWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a
-updateMinWithKey f t
- = case t of
- Bin p m l r | m < 0 -> let t' = updateMinWithKeyUnsigned f l in Bin p m t' r
- Bin p m l r -> let t' = updateMinWithKeyUnsigned f r in Bin p m l t'
- Tip k y -> Tip k (f k y)
- Nil -> error "maxView: empty map has no maximal element"
-
-updateMinWithKeyUnsigned f t
- = case t of
- Bin p m l r -> let t' = updateMinWithKeyUnsigned f r in Bin p m l t'
- Tip k y -> Tip k (f k y)
-
--- | /O(log n)/. Update the value at the maximal key.
-updateMaxWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a
-updateMaxWithKey f t
- = case t of
- Bin p m l r | m < 0 -> let t' = updateMaxWithKeyUnsigned f r in Bin p m r t'
- Bin p m l r -> let t' = updateMaxWithKeyUnsigned f l in Bin p m t' l
- Tip k y -> Tip k (f k y)
- Nil -> error "maxView: empty map has no maximal element"
-
-updateMaxWithKeyUnsigned f t
- = case t of
- Bin p m l r -> let t' = updateMaxWithKeyUnsigned f r in Bin p m l t'
- Tip k y -> Tip k (f k y)
-
-
--- | /O(log n)/. Retrieves the maximal (key,value) couple of the map, and the map stripped from that element.
--- @fail@s (in the monad) when passed an empty map.
-maxViewWithKey :: (Monad m) => IntMap a -> m ((Key, a), IntMap a)
-maxViewWithKey t
- = case t of
- Bin p m l r | m < 0 -> let (result, t') = maxViewUnsigned l in return (result, bin p m t' r)
- Bin p m l r -> let (result, t') = maxViewUnsigned r in return (result, bin p m l t')
- Tip k y -> return ((k,y), Nil)
- Nil -> fail "maxView: empty map has no maximal element"
-
-maxViewUnsigned t
- = case t of
- Bin p m l r -> let (result,t') = maxViewUnsigned r in (result,bin p m l t')
- Tip k y -> ((k,y), Nil)
-
--- | /O(log n)/. Retrieves the minimal (key,value) couple of the map, and the map stripped from that element.
--- @fail@s (in the monad) when passed an empty map.
-minViewWithKey :: (Monad m) => IntMap a -> m ((Key, a), IntMap a)
-minViewWithKey t
- = case t of
- Bin p m l r | m < 0 -> let (result, t') = minViewUnsigned r in return (result, bin p m l t')
- Bin p m l r -> let (result, t') = minViewUnsigned l in return (result, bin p m t' r)
- Tip k y -> return ((k,y),Nil)
- Nil -> fail "minView: empty map has no minimal element"
-
-minViewUnsigned t
- = case t of
- Bin p m l r -> let (result,t') = minViewUnsigned l in (result,bin p m t' r)
- Tip k y -> ((k,y),Nil)
-
-
--- | /O(log n)/. Update the value at the maximal key.
-updateMax :: (a -> a) -> IntMap a -> IntMap a
-updateMax f = updateMaxWithKey (const f)
-
--- | /O(log n)/. Update the value at the minimal key.
-updateMin :: (a -> a) -> IntMap a -> IntMap a
-updateMin f = updateMinWithKey (const f)
-
-
--- Duplicate the Identity monad here because base < mtl.
-newtype Identity a = Identity { runIdentity :: a }
-instance Monad Identity where
- return a = Identity a
- m >>= k = k (runIdentity m)
--- Similar to the Arrow instance.
-first f (x,y) = (f x,y)
-
-
--- | /O(log n)/. Retrieves the maximal key of the map, and the map stripped from that element.
--- @fail@s (in the monad) when passed an empty map.
-maxView t = liftM (first snd) (maxViewWithKey t)
-
--- | /O(log n)/. Retrieves the minimal key of the map, and the map stripped from that element.
--- @fail@s (in the monad) when passed an empty map.
-minView t = liftM (first snd) (minViewWithKey t)
-
--- | /O(log n)/. Delete and find the maximal element.
-deleteFindMax = runIdentity . maxView
-
--- | /O(log n)/. Delete and find the minimal element.
-deleteFindMin = runIdentity . minView
-
--- | /O(log n)/. The minimal key of the map.
-findMin = fst . runIdentity . minView
-
--- | /O(log n)/. The maximal key of the map.
-findMax = fst . runIdentity . maxView
-
--- | /O(log n)/. Delete the minimal key.
-deleteMin = snd . runIdentity . minView
-
--- | /O(log n)/. Delete the maximal key.
-deleteMax = snd . runIdentity . maxView
-
-
-{--------------------------------------------------------------------
- Submap
---------------------------------------------------------------------}
--- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
--- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
-isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
-isProperSubmapOf m1 m2
- = isProperSubmapOfBy (==) m1 m2
-
-{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
- @m1@ and @m2@ are not equal,
- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
- applied to their respective values. For example, the following
- expressions are all 'True':
-
- > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
- > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
-
- But the following are all 'False':
-
- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
- > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
--}
-isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
-isProperSubmapOfBy pred t1 t2
- = case submapCmp pred t1 t2 of
- LT -> True
- ge -> False
-
-submapCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = GT
- | shorter m2 m1 = submapCmpLt
- | p1 == p2 = submapCmpEq
- | otherwise = GT -- disjoint
- where
- submapCmpLt | nomatch p1 p2 m2 = GT
- | zero p1 m2 = submapCmp pred t1 l2
- | otherwise = submapCmp pred t1 r2
- submapCmpEq = case (submapCmp pred l1 l2, submapCmp pred r1 r2) of
- (GT,_ ) -> GT
- (_ ,GT) -> GT
- (EQ,EQ) -> EQ
- other -> LT
-
-submapCmp pred (Bin p m l r) t = GT
-submapCmp pred (Tip kx x) (Tip ky y)
- | (kx == ky) && pred x y = EQ
- | otherwise = GT -- disjoint
-submapCmp pred (Tip k x) t
- = case lookup k t of
- Just y | pred x y -> LT
- other -> GT -- disjoint
-submapCmp pred Nil Nil = EQ
-submapCmp pred Nil t = LT
-
--- | /O(n+m)/. Is this a submap?
--- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
-isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
-isSubmapOf m1 m2
- = isSubmapOfBy (==) m1 m2
-
-{- | /O(n+m)/.
- The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if
- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
- applied to their respective values. For example, the following
- expressions are all 'True':
-
- > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
- > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
- > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
-
- But the following are all 'False':
-
- > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])
- > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
- > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
--}
-
-isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
-isSubmapOfBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = False
- | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy pred t1 l2
- else isSubmapOfBy pred t1 r2)
- | otherwise = (p1==p2) && isSubmapOfBy pred l1 l2 && isSubmapOfBy pred r1 r2
-isSubmapOfBy pred (Bin p m l r) t = False
-isSubmapOfBy pred (Tip k x) t = case lookup k t of
- Just y -> pred x y
- Nothing -> False
-isSubmapOfBy pred Nil t = True
-
-{--------------------------------------------------------------------
- Mapping
---------------------------------------------------------------------}
--- | /O(n)/. Map a function over all values in the map.
-map :: (a -> b) -> IntMap a -> IntMap b
-map f m
- = mapWithKey (\k x -> f x) m
-
--- | /O(n)/. Map a function over all values in the map.
-mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b
-mapWithKey f t
- = case t of
- Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)
- Tip k x -> Tip k (f k x)
- Nil -> Nil
-
--- | /O(n)/. The function @'mapAccum'@ threads an accumulating
--- argument through the map in ascending order of keys.
-mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
-mapAccum f a m
- = mapAccumWithKey (\a k x -> f a x) a m
-
--- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating
--- argument through the map in ascending order of keys.
-mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
-mapAccumWithKey f a t
- = mapAccumL f a t
-
--- | /O(n)/. The function @'mapAccumL'@ threads an accumulating
--- argument through the map in ascending order of keys.
-mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
-mapAccumL f a t
- = case t of
- Bin p m l r -> let (a1,l') = mapAccumL f a l
- (a2,r') = mapAccumL f a1 r
- in (a2,Bin p m l' r')
- Tip k x -> let (a',x') = f a k x in (a',Tip k x')
- Nil -> (a,Nil)
-
-
--- | /O(n)/. The function @'mapAccumR'@ threads an accumulating
--- argument throught the map in descending order of keys.
-mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
-mapAccumR f a t
- = case t of
- Bin p m l r -> let (a1,r') = mapAccumR f a r
- (a2,l') = mapAccumR f a1 l
- in (a2,Bin p m l' r')
- Tip k x -> let (a',x') = f a k x in (a',Tip k x')
- Nil -> (a,Nil)
-
-{--------------------------------------------------------------------
- Filter
---------------------------------------------------------------------}
--- | /O(n)/. Filter all values that satisfy some predicate.
-filter :: (a -> Bool) -> IntMap a -> IntMap a
-filter p m
- = filterWithKey (\k x -> p x) m
-
--- | /O(n)/. Filter all keys\/values that satisfy some predicate.
-filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a
-filterWithKey pred t
- = case t of
- Bin p m l r
- -> bin p m (filterWithKey pred l) (filterWithKey pred r)
- Tip k x
- | pred k x -> t
- | otherwise -> Nil
- Nil -> Nil
-
--- | /O(n)/. partition the map according to some predicate. The first
--- map contains all elements that satisfy the predicate, the second all
--- elements that fail the predicate. See also 'split'.
-partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
-partition p m
- = partitionWithKey (\k x -> p x) m
-
--- | /O(n)/. partition the map according to some predicate. The first
--- map contains all elements that satisfy the predicate, the second all
--- elements that fail the predicate. See also 'split'.
-partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
-partitionWithKey pred t
- = case t of
- Bin p m l r
- -> let (l1,l2) = partitionWithKey pred l
- (r1,r2) = partitionWithKey pred r
- in (bin p m l1 r1, bin p m l2 r2)
- Tip k x
- | pred k x -> (t,Nil)
- | otherwise -> (Nil,t)
- Nil -> (Nil,Nil)
-
--- | /O(n)/. Map values and collect the 'Just' results.
-mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b
-mapMaybe f m
- = mapMaybeWithKey (\k x -> f x) m
-
--- | /O(n)/. Map keys\/values and collect the 'Just' results.
-mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b
-mapMaybeWithKey f (Bin p m l r)
- = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)
-mapMaybeWithKey f (Tip k x) = case f k x of
- Just y -> Tip k y
- Nothing -> Nil
-mapMaybeWithKey f Nil = Nil
-
--- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
-mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)
-mapEither f m
- = mapEitherWithKey (\k x -> f x) m
-
--- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
-mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)
-mapEitherWithKey f (Bin p m l r)
- = (bin p m l1 r1, bin p m l2 r2)
- where
- (l1,l2) = mapEitherWithKey f l
- (r1,r2) = mapEitherWithKey f r
-mapEitherWithKey f (Tip k x) = case f k x of
- Left y -> (Tip k y, Nil)
- Right z -> (Nil, Tip k z)
-mapEitherWithKey f Nil = (Nil, Nil)
-
--- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@
--- where all keys in @map1@ are lower than @k@ and all keys in
--- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
-split :: Key -> IntMap a -> (IntMap a,IntMap a)
-split k t
- = case t of
- Bin p m l r
- | m < 0 -> (if k >= 0 -- handle negative numbers.
- then let (lt,gt) = split' k l in (union r lt, gt)
- else let (lt,gt) = split' k r in (lt, union gt l))
- | otherwise -> split' k t
- Tip ky y
- | k>ky -> (t,Nil)
- | k<ky -> (Nil,t)
- | otherwise -> (Nil,Nil)
- Nil -> (Nil,Nil)
-
-split' :: Key -> IntMap a -> (IntMap a,IntMap a)
-split' k t
- = case t of
- Bin p m l r
- | nomatch k p m -> if k>p then (t,Nil) else (Nil,t)
- | zero k m -> let (lt,gt) = split k l in (lt,union gt r)
- | otherwise -> let (lt,gt) = split k r in (union l lt,gt)
- Tip ky y
- | k>ky -> (t,Nil)
- | k<ky -> (Nil,t)
- | otherwise -> (Nil,Nil)
- Nil -> (Nil,Nil)
-
--- | /O(log n)/. Performs a 'split' but also returns whether the pivot
--- key was found in the original map.
-splitLookup :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)
-splitLookup k t
- = case t of
- Bin p m l r
- | m < 0 -> (if k >= 0 -- handle negative numbers.
- then let (lt,found,gt) = splitLookup' k l in (union r lt,found, gt)
- else let (lt,found,gt) = splitLookup' k r in (lt,found, union gt l))
- | otherwise -> splitLookup' k t
- Tip ky y
- | k>ky -> (t,Nothing,Nil)
- | k<ky -> (Nil,Nothing,t)
- | otherwise -> (Nil,Just y,Nil)
- Nil -> (Nil,Nothing,Nil)
-
-splitLookup' :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)
-splitLookup' k t
- = case t of
- Bin p m l r
- | nomatch k p m -> if k>p then (t,Nothing,Nil) else (Nil,Nothing,t)
- | zero k m -> let (lt,found,gt) = splitLookup k l in (lt,found,union gt r)
- | otherwise -> let (lt,found,gt) = splitLookup k r in (union l lt,found,gt)
- Tip ky y
- | k>ky -> (t,Nothing,Nil)
- | k<ky -> (Nil,Nothing,t)
- | otherwise -> (Nil,Just y,Nil)
- Nil -> (Nil,Nothing,Nil)
-
-{--------------------------------------------------------------------
- Fold
---------------------------------------------------------------------}
--- | /O(n)/. Fold the values in the map, such that
--- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
--- For example,
---
--- > elems map = fold (:) [] map
---
-fold :: (a -> b -> b) -> b -> IntMap a -> b
-fold f z t
- = foldWithKey (\k x y -> f x y) z t
-
--- | /O(n)/. Fold the keys and values in the map, such that
--- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
--- For example,
---
--- > keys map = foldWithKey (\k x ks -> k:ks) [] map
---
-foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
-foldWithKey f z t
- = foldr f z t
-
-foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b
-foldr f z t
- = case t of
- Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r -- put negative numbers before.
- Bin _ _ _ _ -> foldr' f z t
- Tip k x -> f k x z
- Nil -> z
-
-foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b
-foldr' f z t
- = case t of
- Bin p m l r -> foldr' f (foldr' f z r) l
- Tip k x -> f k x z
- Nil -> z
-
-
-
-{--------------------------------------------------------------------
- List variations
---------------------------------------------------------------------}
--- | /O(n)/.
--- Return all elements of the map in the ascending order of their keys.
-elems :: IntMap a -> [a]
-elems m
- = foldWithKey (\k x xs -> x:xs) [] m
-
--- | /O(n)/. Return all keys of the map in ascending order.
-keys :: IntMap a -> [Key]
-keys m
- = foldWithKey (\k x ks -> k:ks) [] m
-
--- | /O(n*min(n,W))/. The set of all keys of the map.
-keysSet :: IntMap a -> IntSet.IntSet
-keysSet m = IntSet.fromDistinctAscList (keys m)
-
-
--- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
-assocs :: IntMap a -> [(Key,a)]
-assocs m
- = toList m
-
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
--- | /O(n)/. Convert the map to a list of key\/value pairs.
-toList :: IntMap a -> [(Key,a)]
-toList t
- = foldWithKey (\k x xs -> (k,x):xs) [] t
-
--- | /O(n)/. Convert the map to a list of key\/value pairs where the
--- keys are in ascending order.
-toAscList :: IntMap a -> [(Key,a)]
-toAscList t
- = -- NOTE: the following algorithm only works for big-endian trees
- let (pos,neg) = span (\(k,x) -> k >=0) (foldr (\k x xs -> (k,x):xs) [] t) in neg ++ pos
-
--- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.
-fromList :: [(Key,a)] -> IntMap a
-fromList xs
- = foldlStrict ins empty xs
- where
- ins t (k,x) = insert k x t
-
--- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
-fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
-fromListWith f xs
- = fromListWithKey (\k x y -> f x y) xs
-
--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.
-fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
-fromListWithKey f xs
- = foldlStrict ins empty xs
- where
- ins t (k,x) = insertWithKey f k x t
-
--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
--- the keys are in ascending order.
-fromAscList :: [(Key,a)] -> IntMap a
-fromAscList xs
- = fromList xs
-
--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
--- the keys are in ascending order, with a combining function on equal keys.
-fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
-fromAscListWith f xs
- = fromListWith f xs
-
--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
--- the keys are in ascending order, with a combining function on equal keys.
-fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
-fromAscListWithKey f xs
- = fromListWithKey f xs
-
--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
--- the keys are in ascending order and all distinct.
-fromDistinctAscList :: [(Key,a)] -> IntMap a
-fromDistinctAscList xs
- = fromList xs
-
-
-{--------------------------------------------------------------------
- Eq
---------------------------------------------------------------------}
-instance Eq a => Eq (IntMap a) where
- t1 == t2 = equal t1 t2
- t1 /= t2 = nequal t1 t2
-
-equal :: Eq a => IntMap a -> IntMap a -> Bool
-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
- = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
-equal (Tip kx x) (Tip ky y)
- = (kx == ky) && (x==y)
-equal Nil Nil = True
-equal t1 t2 = False
-
-nequal :: Eq a => IntMap a -> IntMap a -> Bool
-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
- = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
-nequal (Tip kx x) (Tip ky y)
- = (kx /= ky) || (x/=y)
-nequal Nil Nil = False
-nequal t1 t2 = True
-
-{--------------------------------------------------------------------
- Ord
---------------------------------------------------------------------}
-
-instance Ord a => Ord (IntMap a) where
- compare m1 m2 = compare (toList m1) (toList m2)
-
-{--------------------------------------------------------------------
- Functor
---------------------------------------------------------------------}
-
-instance Functor IntMap where
- fmap = map
-
-{--------------------------------------------------------------------
- Show
---------------------------------------------------------------------}
-
-instance Show a => Show (IntMap a) where
- showsPrec d m = showParen (d > 10) $
- showString "fromList " . shows (toList m)
-
-showMap :: (Show a) => [(Key,a)] -> ShowS
-showMap []
- = showString "{}"
-showMap (x:xs)
- = showChar '{' . showElem x . showTail xs
- where
- showTail [] = showChar '}'
- showTail (x:xs) = showChar ',' . showElem x . showTail xs
-
- showElem (k,x) = shows k . showString ":=" . shows x
-
-{--------------------------------------------------------------------
- Read
---------------------------------------------------------------------}
-instance (Read e) => Read (IntMap e) where
-#ifdef __GLASGOW_HASKELL__
- readPrec = parens $ prec 10 $ do
- Ident "fromList" <- lexP
- xs <- readPrec
- return (fromList xs)
-
- readListPrec = readListPrecDefault
-#else
- readsPrec p = readParen (p > 10) $ \ r -> do
- ("fromList",s) <- lex r
- (xs,t) <- reads s
- return (fromList xs,t)
-#endif
-
-{--------------------------------------------------------------------
- Typeable
---------------------------------------------------------------------}
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(IntMap,intMapTc,"IntMap")
-
-{--------------------------------------------------------------------
- Debugging
---------------------------------------------------------------------}
--- | /O(n)/. Show the tree that implements the map. The tree is shown
--- in a compressed, hanging format.
-showTree :: Show a => IntMap a -> String
-showTree s
- = showTreeWith True False s
-
-
-{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows
- the tree that implements the map. If @hang@ is
- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
- @wide@ is 'True', an extra wide version is shown.
--}
-showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String
-showTreeWith hang wide t
- | hang = (showsTreeHang wide [] t) ""
- | otherwise = (showsTree wide [] [] t) ""
-
-showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS
-showsTree wide lbars rbars t
- = case t of
- Bin p m l r
- -> showsTree wide (withBar rbars) (withEmpty rbars) r .
- showWide wide rbars .
- showsBars lbars . showString (showBin p m) . showString "\n" .
- showWide wide lbars .
- showsTree wide (withEmpty lbars) (withBar lbars) l
- Tip k x
- -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n"
- Nil -> showsBars lbars . showString "|\n"
-
-showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS
-showsTreeHang wide bars t
- = case t of
- Bin p m l r
- -> showsBars bars . showString (showBin p m) . showString "\n" .
- showWide wide bars .
- showsTreeHang wide (withBar bars) l .
- showWide wide bars .
- showsTreeHang wide (withEmpty bars) r
- Tip k x
- -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n"
- Nil -> showsBars bars . showString "|\n"
-
-showBin p m
- = "*" -- ++ show (p,m)
-
-showWide wide bars
- | wide = showString (concat (reverse bars)) . showString "|\n"
- | otherwise = id
-
-showsBars :: [String] -> ShowS
-showsBars bars
- = case bars of
- [] -> id
- _ -> showString (concat (reverse (tail bars))) . showString node
-
-node = "+--"
-withBar bars = "| ":bars
-withEmpty bars = " ":bars
-
-
-{--------------------------------------------------------------------
- Helpers
---------------------------------------------------------------------}
-{--------------------------------------------------------------------
- Join
---------------------------------------------------------------------}
-join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
-join p1 t1 p2 t2
- | zero p1 m = Bin p m t1 t2
- | otherwise = Bin p m t2 t1
- where
- m = branchMask p1 p2
- p = mask p1 m
-
-{--------------------------------------------------------------------
- @bin@ assures that we never have empty trees within a tree.
---------------------------------------------------------------------}
-bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
-bin p m l Nil = l
-bin p m Nil r = r
-bin p m l r = Bin p m l r
-
-
-{--------------------------------------------------------------------
- Endian independent bit twiddling
---------------------------------------------------------------------}
-zero :: Key -> Mask -> Bool
-zero i m
- = (natFromInt i) .&. (natFromInt m) == 0
-
-nomatch,match :: Key -> Prefix -> Mask -> Bool
-nomatch i p m
- = (mask i m) /= p
-
-match i p m
- = (mask i m) == p
-
-mask :: Key -> Mask -> Prefix
-mask i m
- = maskW (natFromInt i) (natFromInt m)
-
-
-zeroN :: Nat -> Nat -> Bool
-zeroN i m = (i .&. m) == 0
-
-{--------------------------------------------------------------------
- Big endian operations
---------------------------------------------------------------------}
-maskW :: Nat -> Nat -> Prefix
-maskW i m
- = intFromNat (i .&. (complement (m-1) `xor` m))
-
-shorter :: Mask -> Mask -> Bool
-shorter m1 m2
- = (natFromInt m1) > (natFromInt m2)
-
-branchMask :: Prefix -> Prefix -> Mask
-branchMask p1 p2
- = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
-
-{----------------------------------------------------------------------
- Finding the highest bit (mask) in a word [x] can be done efficiently in
- three ways:
- * convert to a floating point value and the mantissa tells us the
- [log2(x)] that corresponds with the highest bit position. The mantissa
- is retrieved either via the standard C function [frexp] or by some bit
- twiddling on IEEE compatible numbers (float). Note that one needs to
- use at least [double] precision for an accurate mantissa of 32 bit
- numbers.
- * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
- * use processor specific assembler instruction (asm).
-
- The most portable way would be [bit], but is it efficient enough?
- I have measured the cycle counts of the different methods on an AMD
- Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
-
- highestBitMask: method cycles
- --------------
- frexp 200
- float 33
- bit 11
- asm 12
-
- highestBit: method cycles
- --------------
- frexp 195
- float 33
- bit 11
- asm 11
-
- Wow, the bit twiddling is on today's RISC like machines even faster
- than a single CISC instruction (BSR)!
-----------------------------------------------------------------------}
-
-{----------------------------------------------------------------------
- [highestBitMask] returns a word where only the highest bit is set.
- It is found by first setting all bits in lower positions than the
- highest bit and than taking an exclusive or with the original value.
- Allthough the function may look expensive, GHC compiles this into
- excellent C code that subsequently compiled into highly efficient
- machine code. The algorithm is derived from Jorg Arndt's FXT library.
-----------------------------------------------------------------------}
-highestBitMask :: Nat -> Nat
-highestBitMask x
- = case (x .|. shiftRL x 1) of
- x -> case (x .|. shiftRL x 2) of
- x -> case (x .|. shiftRL x 4) of
- x -> case (x .|. shiftRL x 8) of
- x -> case (x .|. shiftRL x 16) of
- x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms
- x -> (x `xor` (shiftRL x 1))
-
-
-{--------------------------------------------------------------------
- Utilities
---------------------------------------------------------------------}
-foldlStrict f z xs
- = case xs of
- [] -> z
- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
-
-{-
-{--------------------------------------------------------------------
- Testing
---------------------------------------------------------------------}
-testTree :: [Int] -> IntMap Int
-testTree xs = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]
-test1 = testTree [1..20]
-test2 = testTree [30,29..10]
-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
-
-{--------------------------------------------------------------------
- QuickCheck
---------------------------------------------------------------------}
-qcheck prop
- = check config prop
- where
- config = Config
- { configMaxTest = 500
- , configMaxFail = 5000
- , configSize = \n -> (div n 2 + 3)
- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
- }
-
-
-{--------------------------------------------------------------------
- Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-instance Arbitrary a => Arbitrary (IntMap a) where
- arbitrary = do{ ks <- arbitrary
- ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks
- ; return (fromList xs)
- }
-
-
-{--------------------------------------------------------------------
- Single, Insert, Delete
---------------------------------------------------------------------}
-prop_Single :: Key -> Int -> Bool
-prop_Single k x
- = (insert k x empty == singleton k x)
-
-prop_InsertDelete :: Key -> Int -> IntMap Int -> Property
-prop_InsertDelete k x t
- = not (member k t) ==> delete k (insert k x t) == t
-
-prop_UpdateDelete :: Key -> IntMap Int -> Bool
-prop_UpdateDelete k t
- = update (const Nothing) k t == delete k t
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
-prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool
-prop_UnionInsert k x t
- = union (singleton k x) t == insert k x t
-
-prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool
-prop_UnionAssoc t1 t2 t3
- = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_UnionComm :: IntMap Int -> IntMap Int -> Bool
-prop_UnionComm t1 t2
- = (union t1 t2 == unionWith (\x y -> y) t2 t1)
-
-
-prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool
-prop_Diff xs ys
- = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
- == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
-
-prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool
-prop_Int xs ys
- = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
- == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [(x,()) | x <- [0..n::Int]]
- in fromAscList xs == fromList xs
-
-prop_List :: [Key] -> Bool
-prop_List xs
- = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])
--}
+++ /dev/null
-{-# OPTIONS -cpp -fglasgow-exts #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.IntSet
--- Copyright : (c) Daan Leijen 2002
--- License : BSD-style
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- An efficient implementation of integer sets.
---
--- Since many function names (but not the type name) clash with
--- "Prelude" names, this module is usually imported @qualified@, e.g.
---
--- > import Data.IntSet (IntSet)
--- > import qualified Data.IntSet as IntSet
---
--- The implementation is based on /big-endian patricia trees/. This data
--- structure performs especially well on binary operations like 'union'
--- and 'intersection'. However, my benchmarks show that it is also
--- (much) faster on insertions and deletions when compared to a generic
--- size-balanced set implementation (see "Data.Set").
---
--- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
--- Workshop on ML, September 1998, pages 77-86,
--- <http://www.cse.ogi.edu/~andy/pub/finite.htm>
---
--- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve
--- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),
--- October 1968, pages 514-534.
---
--- Many operations have a worst-case complexity of /O(min(n,W))/.
--- This means that the operation can become linear in the number of
--- elements with a maximum of /W/ -- the number of bits in an 'Int'
--- (32 or 64).
------------------------------------------------------------------------------
-
-module Data.IntSet (
- -- * Set type
- IntSet -- instance Eq,Show
-
- -- * Operators
- , (\\)
-
- -- * Query
- , null
- , size
- , member
- , notMember
- , isSubsetOf
- , isProperSubsetOf
-
- -- * Construction
- , empty
- , singleton
- , insert
- , delete
-
- -- * Combine
- , union, unions
- , difference
- , intersection
-
- -- * Filter
- , filter
- , partition
- , split
- , splitMember
-
- -- * Min\/Max
- , findMin
- , findMax
- , deleteMin
- , deleteMax
- , deleteFindMin
- , deleteFindMax
- , maxView
- , minView
-
- -- * Map
- , map
-
- -- * Fold
- , fold
-
- -- * Conversion
- -- ** List
- , elems
- , toList
- , fromList
-
- -- ** Ordered list
- , toAscList
- , fromAscList
- , fromDistinctAscList
-
- -- * Debugging
- , showTree
- , showTreeWith
- ) where
-
-
-import Prelude hiding (lookup,filter,foldr,foldl,null,map)
-import Data.Bits
-
-import qualified Data.List as List
-import Data.Monoid (Monoid(..))
-import Data.Typeable
-
-{-
--- just for testing
-import QuickCheck
-import List (nub,sort)
-import qualified List
--}
-
-#if __GLASGOW_HASKELL__
-import Text.Read
-import Data.Generics.Basics (Data(..), mkNorepType)
-import Data.Generics.Instances ()
-#endif
-
-#if __GLASGOW_HASKELL__ >= 503
-import GHC.Exts ( Word(..), Int(..), shiftRL# )
-#elif __GLASGOW_HASKELL__
-import Word
-import GlaExts ( Word(..), Int(..), shiftRL# )
-#else
-import Data.Word
-#endif
-
-infixl 9 \\{-This comment teaches CPP correct behaviour -}
-
--- A "Nat" is a natural machine word (an unsigned Int)
-type Nat = Word
-
-natFromInt :: Int -> Nat
-natFromInt i = fromIntegral i
-
-intFromNat :: Nat -> Int
-intFromNat w = fromIntegral w
-
-shiftRL :: Nat -> Int -> Nat
-#if __GLASGOW_HASKELL__
-{--------------------------------------------------------------------
- GHC: use unboxing to get @shiftRL@ inlined.
---------------------------------------------------------------------}
-shiftRL (W# x) (I# i)
- = W# (shiftRL# x i)
-#else
-shiftRL x i = shiftR x i
-#endif
-
-{--------------------------------------------------------------------
- Operators
---------------------------------------------------------------------}
--- | /O(n+m)/. See 'difference'.
-(\\) :: IntSet -> IntSet -> IntSet
-m1 \\ m2 = difference m1 m2
-
-{--------------------------------------------------------------------
- Types
---------------------------------------------------------------------}
--- | A set of integers.
-data IntSet = Nil
- | Tip {-# UNPACK #-} !Int
- | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !IntSet !IntSet
--- Invariant: Nil is never found as a child of Bin.
-
-
-type Prefix = Int
-type Mask = Int
-
-instance Monoid IntSet where
- mempty = empty
- mappend = union
- mconcat = unions
-
-#if __GLASGOW_HASKELL__
-
-{--------------------------------------------------------------------
- A Data instance
---------------------------------------------------------------------}
-
--- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
-
-instance Data IntSet where
- gfoldl f z is = z fromList `f` (toList is)
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.IntSet.IntSet"
-
-#endif
-
-{--------------------------------------------------------------------
- Query
---------------------------------------------------------------------}
--- | /O(1)/. Is the set empty?
-null :: IntSet -> Bool
-null Nil = True
-null other = False
-
--- | /O(n)/. Cardinality of the set.
-size :: IntSet -> Int
-size t
- = case t of
- Bin p m l r -> size l + size r
- Tip y -> 1
- Nil -> 0
-
--- | /O(min(n,W))/. Is the value a member of the set?
-member :: Int -> IntSet -> Bool
-member x t
- = case t of
- Bin p m l r
- | nomatch x p m -> False
- | zero x m -> member x l
- | otherwise -> member x r
- Tip y -> (x==y)
- Nil -> False
-
--- | /O(min(n,W))/. Is the element not in the set?
-notMember :: Int -> IntSet -> Bool
-notMember k = not . member k
-
--- 'lookup' is used by 'intersection' for left-biasing
-lookup :: Int -> IntSet -> Maybe Int
-lookup k t
- = let nk = natFromInt k in seq nk (lookupN nk t)
-
-lookupN :: Nat -> IntSet -> Maybe Int
-lookupN k t
- = case t of
- Bin p m l r
- | zeroN k (natFromInt m) -> lookupN k l
- | otherwise -> lookupN k r
- Tip kx
- | (k == natFromInt kx) -> Just kx
- | otherwise -> Nothing
- Nil -> Nothing
-
-{--------------------------------------------------------------------
- Construction
---------------------------------------------------------------------}
--- | /O(1)/. The empty set.
-empty :: IntSet
-empty
- = Nil
-
--- | /O(1)/. A set of one element.
-singleton :: Int -> IntSet
-singleton x
- = Tip x
-
-{--------------------------------------------------------------------
- Insert
---------------------------------------------------------------------}
--- | /O(min(n,W))/. Add a value to the set. When the value is already
--- an element of the set, it is replaced by the new one, ie. 'insert'
--- is left-biased.
-insert :: Int -> IntSet -> IntSet
-insert x t
- = case t of
- Bin p m l r
- | nomatch x p m -> join x (Tip x) p t
- | zero x m -> Bin p m (insert x l) r
- | otherwise -> Bin p m l (insert x r)
- Tip y
- | x==y -> Tip x
- | otherwise -> join x (Tip x) y t
- Nil -> Tip x
-
--- right-biased insertion, used by 'union'
-insertR :: Int -> IntSet -> IntSet
-insertR x t
- = case t of
- Bin p m l r
- | nomatch x p m -> join x (Tip x) p t
- | zero x m -> Bin p m (insert x l) r
- | otherwise -> Bin p m l (insert x r)
- Tip y
- | x==y -> t
- | otherwise -> join x (Tip x) y t
- Nil -> Tip x
-
--- | /O(min(n,W))/. Delete a value in the set. Returns the
--- original set when the value was not present.
-delete :: Int -> IntSet -> IntSet
-delete x t
- = case t of
- Bin p m l r
- | nomatch x p m -> t
- | zero x m -> bin p m (delete x l) r
- | otherwise -> bin p m l (delete x r)
- Tip y
- | x==y -> Nil
- | otherwise -> t
- Nil -> Nil
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
--- | The union of a list of sets.
-unions :: [IntSet] -> IntSet
-unions xs
- = foldlStrict union empty xs
-
-
--- | /O(n+m)/. The union of two sets.
-union :: IntSet -> IntSet -> IntSet
-union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = union1
- | shorter m2 m1 = union2
- | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)
- | otherwise = join p1 t1 p2 t2
- where
- union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
- | zero p2 m1 = Bin p1 m1 (union l1 t2) r1
- | otherwise = Bin p1 m1 l1 (union r1 t2)
-
- union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
- | zero p1 m2 = Bin p2 m2 (union t1 l2) r2
- | otherwise = Bin p2 m2 l2 (union t1 r2)
-
-union (Tip x) t = insert x t
-union t (Tip x) = insertR x t -- right bias
-union Nil t = t
-union t Nil = t
-
-
-{--------------------------------------------------------------------
- Difference
---------------------------------------------------------------------}
--- | /O(n+m)/. Difference between two sets.
-difference :: IntSet -> IntSet -> IntSet
-difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = difference1
- | shorter m2 m1 = difference2
- | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)
- | otherwise = t1
- where
- difference1 | nomatch p2 p1 m1 = t1
- | zero p2 m1 = bin p1 m1 (difference l1 t2) r1
- | otherwise = bin p1 m1 l1 (difference r1 t2)
-
- difference2 | nomatch p1 p2 m2 = t1
- | zero p1 m2 = difference t1 l2
- | otherwise = difference t1 r2
-
-difference t1@(Tip x) t2
- | member x t2 = Nil
- | otherwise = t1
-
-difference Nil t = Nil
-difference t (Tip x) = delete x t
-difference t Nil = t
-
-
-
-{--------------------------------------------------------------------
- Intersection
---------------------------------------------------------------------}
--- | /O(n+m)/. The intersection of two sets.
-intersection :: IntSet -> IntSet -> IntSet
-intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = intersection1
- | shorter m2 m1 = intersection2
- | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
- | otherwise = Nil
- where
- intersection1 | nomatch p2 p1 m1 = Nil
- | zero p2 m1 = intersection l1 t2
- | otherwise = intersection r1 t2
-
- intersection2 | nomatch p1 p2 m2 = Nil
- | zero p1 m2 = intersection t1 l2
- | otherwise = intersection t1 r2
-
-intersection t1@(Tip x) t2
- | member x t2 = t1
- | otherwise = Nil
-intersection t (Tip x)
- = case lookup x t of
- Just y -> Tip y
- Nothing -> Nil
-intersection Nil t = Nil
-intersection t Nil = Nil
-
-
-
-{--------------------------------------------------------------------
- Subset
---------------------------------------------------------------------}
--- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
-isProperSubsetOf :: IntSet -> IntSet -> Bool
-isProperSubsetOf t1 t2
- = case subsetCmp t1 t2 of
- LT -> True
- ge -> False
-
-subsetCmp t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = GT
- | shorter m2 m1 = subsetCmpLt
- | p1 == p2 = subsetCmpEq
- | otherwise = GT -- disjoint
- where
- subsetCmpLt | nomatch p1 p2 m2 = GT
- | zero p1 m2 = subsetCmp t1 l2
- | otherwise = subsetCmp t1 r2
- subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of
- (GT,_ ) -> GT
- (_ ,GT) -> GT
- (EQ,EQ) -> EQ
- other -> LT
-
-subsetCmp (Bin p m l r) t = GT
-subsetCmp (Tip x) (Tip y)
- | x==y = EQ
- | otherwise = GT -- disjoint
-subsetCmp (Tip x) t
- | member x t = LT
- | otherwise = GT -- disjoint
-subsetCmp Nil Nil = EQ
-subsetCmp Nil t = LT
-
--- | /O(n+m)/. Is this a subset?
--- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.
-
-isSubsetOf :: IntSet -> IntSet -> Bool
-isSubsetOf t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = False
- | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2
- else isSubsetOf t1 r2)
- | otherwise = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2
-isSubsetOf (Bin p m l r) t = False
-isSubsetOf (Tip x) t = member x t
-isSubsetOf Nil t = True
-
-
-{--------------------------------------------------------------------
- Filter
---------------------------------------------------------------------}
--- | /O(n)/. Filter all elements that satisfy some predicate.
-filter :: (Int -> Bool) -> IntSet -> IntSet
-filter pred t
- = case t of
- Bin p m l r
- -> bin p m (filter pred l) (filter pred r)
- Tip x
- | pred x -> t
- | otherwise -> Nil
- Nil -> Nil
-
--- | /O(n)/. partition the set according to some predicate.
-partition :: (Int -> Bool) -> IntSet -> (IntSet,IntSet)
-partition pred t
- = case t of
- Bin p m l r
- -> let (l1,l2) = partition pred l
- (r1,r2) = partition pred r
- in (bin p m l1 r1, bin p m l2 r2)
- Tip x
- | pred x -> (t,Nil)
- | otherwise -> (Nil,t)
- Nil -> (Nil,Nil)
-
-
--- | /O(min(n,W))/. The expression (@'split' x set@) is a pair @(set1,set2)@
--- where all elements in @set1@ are lower than @x@ and all elements in
--- @set2@ larger than @x@.
---
--- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [3,4])
-split :: Int -> IntSet -> (IntSet,IntSet)
-split x t
- = case t of
- Bin p m l r
- | m < 0 -> if x >= 0 then let (lt,gt) = split' x l in (union r lt, gt)
- else let (lt,gt) = split' x r in (lt, union gt l)
- -- handle negative numbers.
- | otherwise -> split' x t
- Tip y
- | x>y -> (t,Nil)
- | x<y -> (Nil,t)
- | otherwise -> (Nil,Nil)
- Nil -> (Nil, Nil)
-
-split' :: Int -> IntSet -> (IntSet,IntSet)
-split' x t
- = case t of
- Bin p m l r
- | match x p m -> if zero x m then let (lt,gt) = split' x l in (lt,union gt r)
- else let (lt,gt) = split' x r in (union l lt,gt)
- | otherwise -> if x < p then (Nil, t)
- else (t, Nil)
- Tip y
- | x>y -> (t,Nil)
- | x<y -> (Nil,t)
- | otherwise -> (Nil,Nil)
- Nil -> (Nil,Nil)
-
--- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot
--- element was found in the original set.
-splitMember :: Int -> IntSet -> (IntSet,Bool,IntSet)
-splitMember x t
- = case t of
- Bin p m l r
- | m < 0 -> if x >= 0 then let (lt,found,gt) = splitMember' x l in (union r lt, found, gt)
- else let (lt,found,gt) = splitMember' x r in (lt, found, union gt l)
- -- handle negative numbers.
- | otherwise -> splitMember' x t
- Tip y
- | x>y -> (t,False,Nil)
- | x<y -> (Nil,False,t)
- | otherwise -> (Nil,True,Nil)
- Nil -> (Nil,False,Nil)
-
-splitMember' :: Int -> IntSet -> (IntSet,Bool,IntSet)
-splitMember' x t
- = case t of
- Bin p m l r
- | match x p m -> if zero x m then let (lt,found,gt) = splitMember x l in (lt,found,union gt r)
- else let (lt,found,gt) = splitMember x r in (union l lt,found,gt)
- | otherwise -> if x < p then (Nil, False, t)
- else (t, False, Nil)
- Tip y
- | x>y -> (t,False,Nil)
- | x<y -> (Nil,False,t)
- | otherwise -> (Nil,True,Nil)
- Nil -> (Nil,False,Nil)
-
-{----------------------------------------------------------------------
- Min/Max
-----------------------------------------------------------------------}
-
--- | /O(min(n,W))/. Retrieves the maximal key of the set, and the set stripped from that element
--- @fail@s (in the monad) when passed an empty set.
-maxView :: (Monad m) => IntSet -> m (Int, IntSet)
-maxView t
- = case t of
- Bin p m l r | m < 0 -> let (result,t') = maxViewUnsigned l in return (result, bin p m t' r)
- Bin p m l r -> let (result,t') = maxViewUnsigned r in return (result, bin p m l t')
- Tip y -> return (y,Nil)
- Nil -> fail "maxView: empty set has no maximal element"
-
-maxViewUnsigned :: IntSet -> (Int, IntSet)
-maxViewUnsigned t
- = case t of
- Bin p m l r -> let (result,t') = maxViewUnsigned r in (result, bin p m l t')
- Tip y -> (y, Nil)
-
--- | /O(min(n,W))/. Retrieves the minimal key of the set, and the set stripped from that element
--- @fail@s (in the monad) when passed an empty set.
-minView :: (Monad m) => IntSet -> m (Int, IntSet)
-minView t
- = case t of
- Bin p m l r | m < 0 -> let (result,t') = minViewUnsigned r in return (result, bin p m l t')
- Bin p m l r -> let (result,t') = minViewUnsigned l in return (result, bin p m t' r)
- Tip y -> return (y, Nil)
- Nil -> fail "minView: empty set has no minimal element"
-
-minViewUnsigned :: IntSet -> (Int, IntSet)
-minViewUnsigned t
- = case t of
- Bin p m l r -> let (result,t') = minViewUnsigned l in (result, bin p m t' r)
- Tip y -> (y, Nil)
-
-
--- Duplicate the Identity monad here because base < mtl.
-newtype Identity a = Identity { runIdentity :: a }
-instance Monad Identity where
- return a = Identity a
- m >>= k = k (runIdentity m)
-
-
--- | /O(min(n,W))/. Delete and find the minimal element.
---
--- > deleteFindMin set = (findMin set, deleteMin set)
-deleteFindMin :: IntSet -> (Int, IntSet)
-deleteFindMin = runIdentity . minView
-
--- | /O(min(n,W))/. Delete and find the maximal element.
---
--- > deleteFindMax set = (findMax set, deleteMax set)
-deleteFindMax :: IntSet -> (Int, IntSet)
-deleteFindMax = runIdentity . maxView
-
--- | /O(min(n,W))/. The minimal element of a set.
-findMin :: IntSet -> Int
-findMin = fst . runIdentity . minView
-
--- | /O(min(n,W))/. The maximal element of a set.
-findMax :: IntSet -> Int
-findMax = fst . runIdentity . maxView
-
--- | /O(min(n,W))/. Delete the minimal element.
-deleteMin :: IntSet -> IntSet
-deleteMin = snd . runIdentity . minView
-
--- | /O(min(n,W))/. Delete the maximal element.
-deleteMax :: IntSet -> IntSet
-deleteMax = snd . runIdentity . maxView
-
-
-
-{----------------------------------------------------------------------
- Map
-----------------------------------------------------------------------}
-
--- | /O(n*min(n,W))/.
--- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.
---
--- It's worth noting that the size of the result may be smaller if,
--- for some @(x,y)@, @x \/= y && f x == f y@
-
-map :: (Int->Int) -> IntSet -> IntSet
-map f = fromList . List.map f . toList
-
-{--------------------------------------------------------------------
- Fold
---------------------------------------------------------------------}
--- | /O(n)/. Fold over the elements of a set in an unspecified order.
---
--- > sum set == fold (+) 0 set
--- > elems set == fold (:) [] set
-fold :: (Int -> b -> b) -> b -> IntSet -> b
-fold f z t
- = case t of
- Bin 0 m l r | m < 0 -> foldr f (foldr f z l) r
- -- put negative numbers before.
- Bin p m l r -> foldr f z t
- Tip x -> f x z
- Nil -> z
-
-foldr :: (Int -> b -> b) -> b -> IntSet -> b
-foldr f z t
- = case t of
- Bin p m l r -> foldr f (foldr f z r) l
- Tip x -> f x z
- Nil -> z
-
-{--------------------------------------------------------------------
- List variations
---------------------------------------------------------------------}
--- | /O(n)/. The elements of a set. (For sets, this is equivalent to toList)
-elems :: IntSet -> [Int]
-elems s
- = toList s
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
--- | /O(n)/. Convert the set to a list of elements.
-toList :: IntSet -> [Int]
-toList t
- = fold (:) [] t
-
--- | /O(n)/. Convert the set to an ascending list of elements.
-toAscList :: IntSet -> [Int]
-toAscList t = toList t
-
--- | /O(n*min(n,W))/. Create a set from a list of integers.
-fromList :: [Int] -> IntSet
-fromList xs
- = foldlStrict ins empty xs
- where
- ins t x = insert x t
-
--- | /O(n*min(n,W))/. Build a set from an ascending list of elements.
-fromAscList :: [Int] -> IntSet
-fromAscList xs
- = fromList xs
-
--- | /O(n*min(n,W))/. Build a set from an ascending list of distinct elements.
-fromDistinctAscList :: [Int] -> IntSet
-fromDistinctAscList xs
- = fromList xs
-
-
-{--------------------------------------------------------------------
- Eq
---------------------------------------------------------------------}
-instance Eq IntSet where
- t1 == t2 = equal t1 t2
- t1 /= t2 = nequal t1 t2
-
-equal :: IntSet -> IntSet -> Bool
-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
- = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
-equal (Tip x) (Tip y)
- = (x==y)
-equal Nil Nil = True
-equal t1 t2 = False
-
-nequal :: IntSet -> IntSet -> Bool
-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
- = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
-nequal (Tip x) (Tip y)
- = (x/=y)
-nequal Nil Nil = False
-nequal t1 t2 = True
-
-{--------------------------------------------------------------------
- Ord
---------------------------------------------------------------------}
-
-instance Ord IntSet where
- compare s1 s2 = compare (toAscList s1) (toAscList s2)
- -- tentative implementation. See if more efficient exists.
-
-{--------------------------------------------------------------------
- Show
---------------------------------------------------------------------}
-instance Show IntSet where
- showsPrec p xs = showParen (p > 10) $
- showString "fromList " . shows (toList xs)
-
-showSet :: [Int] -> ShowS
-showSet []
- = showString "{}"
-showSet (x:xs)
- = showChar '{' . shows x . showTail xs
- where
- showTail [] = showChar '}'
- showTail (x:xs) = showChar ',' . shows x . showTail xs
-
-{--------------------------------------------------------------------
- Read
---------------------------------------------------------------------}
-instance Read IntSet where
-#ifdef __GLASGOW_HASKELL__
- readPrec = parens $ prec 10 $ do
- Ident "fromList" <- lexP
- xs <- readPrec
- return (fromList xs)
-
- readListPrec = readListPrecDefault
-#else
- readsPrec p = readParen (p > 10) $ \ r -> do
- ("fromList",s) <- lex r
- (xs,t) <- reads s
- return (fromList xs,t)
-#endif
-
-{--------------------------------------------------------------------
- Typeable
---------------------------------------------------------------------}
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE0(IntSet,intSetTc,"IntSet")
-
-{--------------------------------------------------------------------
- Debugging
---------------------------------------------------------------------}
--- | /O(n)/. Show the tree that implements the set. The tree is shown
--- in a compressed, hanging format.
-showTree :: IntSet -> String
-showTree s
- = showTreeWith True False s
-
-
-{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows
- the tree that implements the set. If @hang@ is
- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
- @wide@ is 'True', an extra wide version is shown.
--}
-showTreeWith :: Bool -> Bool -> IntSet -> String
-showTreeWith hang wide t
- | hang = (showsTreeHang wide [] t) ""
- | otherwise = (showsTree wide [] [] t) ""
-
-showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS
-showsTree wide lbars rbars t
- = case t of
- Bin p m l r
- -> showsTree wide (withBar rbars) (withEmpty rbars) r .
- showWide wide rbars .
- showsBars lbars . showString (showBin p m) . showString "\n" .
- showWide wide lbars .
- showsTree wide (withEmpty lbars) (withBar lbars) l
- Tip x
- -> showsBars lbars . showString " " . shows x . showString "\n"
- Nil -> showsBars lbars . showString "|\n"
-
-showsTreeHang :: Bool -> [String] -> IntSet -> ShowS
-showsTreeHang wide bars t
- = case t of
- Bin p m l r
- -> showsBars bars . showString (showBin p m) . showString "\n" .
- showWide wide bars .
- showsTreeHang wide (withBar bars) l .
- showWide wide bars .
- showsTreeHang wide (withEmpty bars) r
- Tip x
- -> showsBars bars . showString " " . shows x . showString "\n"
- Nil -> showsBars bars . showString "|\n"
-
-showBin p m
- = "*" -- ++ show (p,m)
-
-showWide wide bars
- | wide = showString (concat (reverse bars)) . showString "|\n"
- | otherwise = id
-
-showsBars :: [String] -> ShowS
-showsBars bars
- = case bars of
- [] -> id
- _ -> showString (concat (reverse (tail bars))) . showString node
-
-node = "+--"
-withBar bars = "| ":bars
-withEmpty bars = " ":bars
-
-
-{--------------------------------------------------------------------
- Helpers
---------------------------------------------------------------------}
-{--------------------------------------------------------------------
- Join
---------------------------------------------------------------------}
-join :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet
-join p1 t1 p2 t2
- | zero p1 m = Bin p m t1 t2
- | otherwise = Bin p m t2 t1
- where
- m = branchMask p1 p2
- p = mask p1 m
-
-{--------------------------------------------------------------------
- @bin@ assures that we never have empty trees within a tree.
---------------------------------------------------------------------}
-bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet
-bin p m l Nil = l
-bin p m Nil r = r
-bin p m l r = Bin p m l r
-
-
-{--------------------------------------------------------------------
- Endian independent bit twiddling
---------------------------------------------------------------------}
-zero :: Int -> Mask -> Bool
-zero i m
- = (natFromInt i) .&. (natFromInt m) == 0
-
-nomatch,match :: Int -> Prefix -> Mask -> Bool
-nomatch i p m
- = (mask i m) /= p
-
-match i p m
- = (mask i m) == p
-
-mask :: Int -> Mask -> Prefix
-mask i m
- = maskW (natFromInt i) (natFromInt m)
-
-zeroN :: Nat -> Nat -> Bool
-zeroN i m = (i .&. m) == 0
-
-{--------------------------------------------------------------------
- Big endian operations
---------------------------------------------------------------------}
-maskW :: Nat -> Nat -> Prefix
-maskW i m
- = intFromNat (i .&. (complement (m-1) `xor` m))
-
-shorter :: Mask -> Mask -> Bool
-shorter m1 m2
- = (natFromInt m1) > (natFromInt m2)
-
-branchMask :: Prefix -> Prefix -> Mask
-branchMask p1 p2
- = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
-
-{----------------------------------------------------------------------
- Finding the highest bit (mask) in a word [x] can be done efficiently in
- three ways:
- * convert to a floating point value and the mantissa tells us the
- [log2(x)] that corresponds with the highest bit position. The mantissa
- is retrieved either via the standard C function [frexp] or by some bit
- twiddling on IEEE compatible numbers (float). Note that one needs to
- use at least [double] precision for an accurate mantissa of 32 bit
- numbers.
- * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
- * use processor specific assembler instruction (asm).
-
- The most portable way would be [bit], but is it efficient enough?
- I have measured the cycle counts of the different methods on an AMD
- Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
-
- highestBitMask: method cycles
- --------------
- frexp 200
- float 33
- bit 11
- asm 12
-
- highestBit: method cycles
- --------------
- frexp 195
- float 33
- bit 11
- asm 11
-
- Wow, the bit twiddling is on today's RISC like machines even faster
- than a single CISC instruction (BSR)!
-----------------------------------------------------------------------}
-
-{----------------------------------------------------------------------
- [highestBitMask] returns a word where only the highest bit is set.
- It is found by first setting all bits in lower positions than the
- highest bit and than taking an exclusive or with the original value.
- Allthough the function may look expensive, GHC compiles this into
- excellent C code that subsequently compiled into highly efficient
- machine code. The algorithm is derived from Jorg Arndt's FXT library.
-----------------------------------------------------------------------}
-highestBitMask :: Nat -> Nat
-highestBitMask x
- = case (x .|. shiftRL x 1) of
- x -> case (x .|. shiftRL x 2) of
- x -> case (x .|. shiftRL x 4) of
- x -> case (x .|. shiftRL x 8) of
- x -> case (x .|. shiftRL x 16) of
- x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms
- x -> (x `xor` (shiftRL x 1))
-
-
-{--------------------------------------------------------------------
- Utilities
---------------------------------------------------------------------}
-foldlStrict f z xs
- = case xs of
- [] -> z
- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
-
-
-{-
-{--------------------------------------------------------------------
- Testing
---------------------------------------------------------------------}
-testTree :: [Int] -> IntSet
-testTree xs = fromList xs
-test1 = testTree [1..20]
-test2 = testTree [30,29..10]
-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
-
-{--------------------------------------------------------------------
- QuickCheck
---------------------------------------------------------------------}
-qcheck prop
- = check config prop
- where
- config = Config
- { configMaxTest = 500
- , configMaxFail = 5000
- , configSize = \n -> (div n 2 + 3)
- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
- }
-
-
-{--------------------------------------------------------------------
- Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-instance Arbitrary IntSet where
- arbitrary = do{ xs <- arbitrary
- ; return (fromList xs)
- }
-
-
-{--------------------------------------------------------------------
- Single, Insert, Delete
---------------------------------------------------------------------}
-prop_Single :: Int -> Bool
-prop_Single x
- = (insert x empty == singleton x)
-
-prop_InsertDelete :: Int -> IntSet -> Property
-prop_InsertDelete k t
- = not (member k t) ==> delete k (insert k t) == t
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
-prop_UnionInsert :: Int -> IntSet -> Bool
-prop_UnionInsert x t
- = union t (singleton x) == insert x t
-
-prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool
-prop_UnionAssoc t1 t2 t3
- = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_UnionComm :: IntSet -> IntSet -> Bool
-prop_UnionComm t1 t2
- = (union t1 t2 == union t2 t1)
-
-prop_Diff :: [Int] -> [Int] -> Bool
-prop_Diff xs ys
- = toAscList (difference (fromList xs) (fromList ys))
- == List.sort ((List.\\) (nub xs) (nub ys))
-
-prop_Int :: [Int] -> [Int] -> Bool
-prop_Int xs ys
- = toAscList (intersection (fromList xs) (fromList ys))
- == List.sort (nub ((List.intersect) (xs) (ys)))
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [0..n::Int]
- in fromAscList xs == fromList xs
-
-prop_List :: [Int] -> Bool
-prop_List xs
- = (sort (nub xs) == toAscList (fromList xs))
--}
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Ix
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : stable
--- Portability : portable
---
--- The 'Ix' class is used to map a contiguous subrange of values in
--- type onto integers. It is used primarily for array indexing
--- (see "Data.Array", "Data.Array.IArray" and "Data.Array.MArray").
---
------------------------------------------------------------------------------
-module Data.Ix
- (
- -- * The 'Ix' class
- Ix
- ( range -- :: (Ix a) => (a,a) -> [a]
- , index -- :: (Ix a) => (a,a) -> a -> Int
- , inRange -- :: (Ix a) => (a,a) -> a -> Bool
- , rangeSize -- :: (Ix a) => (a,a) -> Int
- )
- -- Ix instances:
- --
- -- Ix Char
- -- Ix Int
- -- Ix Integer
- -- Ix Bool
- -- Ix Ordering
- -- Ix ()
- -- (Ix a, Ix b) => Ix (a, b)
- -- ...
-
- -- Implementation checked wrt. Haskell 98 lib report, 1/99.
-
- -- * Deriving Instances of 'Ix'
- -- | Derived instance declarations for the class 'Ix' are only possible
- -- for enumerations (i.e. datatypes having only nullary constructors)
- -- and single-constructor datatypes, including arbitrarily large tuples,
- -- whose constituent types are instances of 'Ix'.
- --
- -- * For an enumeration, the nullary constructors are assumed to be
- -- numbered left-to-right with the indices being 0 to n-1 inclusive. This
- -- is the same numbering defined by the 'Enum' class. For example, given
- -- the datatype:
- --
- -- > data Colour = Red | Orange | Yellow | Green | Blue | Indigo | Violet
- --
- -- we would have:
- --
- -- > range (Yellow,Blue) == [Yellow,Green,Blue]
- -- > index (Yellow,Blue) Green == 1
- -- > inRange (Yellow,Blue) Red == False
- --
- -- * For single-constructor datatypes, the derived instance declarations
- -- are as shown for tuples in Figure 1
- -- <http://www.haskell.org/onlinelibrary/ix.html#prelude-index>.
-
- ) where
-
-import Prelude
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Arr
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude( Ix(..) )
-#endif
-
-#ifdef __NHC__
-import Ix (Ix(..))
-#endif
-
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.List
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : stable
--- Portability : portable
---
--- Operations on lists.
---
------------------------------------------------------------------------------
-
-module Data.List
- (
-#ifdef __NHC__
- [] (..)
- ,
-#endif
-
- -- * Basic functions
-
- (++) -- :: [a] -> [a] -> [a]
- , head -- :: [a] -> a
- , last -- :: [a] -> a
- , tail -- :: [a] -> [a]
- , init -- :: [a] -> [a]
- , null -- :: [a] -> Bool
- , length -- :: [a] -> Int
-
- -- * List transformations
- , map -- :: (a -> b) -> [a] -> [b]
- , reverse -- :: [a] -> [a]
-
- , intersperse -- :: a -> [a] -> [a]
- , intercalate -- :: [a] -> [[a]] -> [a]
- , transpose -- :: [[a]] -> [[a]]
-
- -- * Reducing lists (folds)
-
- , foldl -- :: (a -> b -> a) -> a -> [b] -> a
- , foldl' -- :: (a -> b -> a) -> a -> [b] -> a
- , foldl1 -- :: (a -> a -> a) -> [a] -> a
- , foldl1' -- :: (a -> a -> a) -> [a] -> a
- , foldr -- :: (a -> b -> b) -> b -> [a] -> b
- , foldr1 -- :: (a -> a -> a) -> [a] -> a
-
- -- ** Special folds
-
- , concat -- :: [[a]] -> [a]
- , concatMap -- :: (a -> [b]) -> [a] -> [b]
- , and -- :: [Bool] -> Bool
- , or -- :: [Bool] -> Bool
- , any -- :: (a -> Bool) -> [a] -> Bool
- , all -- :: (a -> Bool) -> [a] -> Bool
- , sum -- :: (Num a) => [a] -> a
- , product -- :: (Num a) => [a] -> a
- , maximum -- :: (Ord a) => [a] -> a
- , minimum -- :: (Ord a) => [a] -> a
-
- -- * Building lists
-
- -- ** Scans
- , scanl -- :: (a -> b -> a) -> a -> [b] -> [a]
- , scanl1 -- :: (a -> a -> a) -> [a] -> [a]
- , scanr -- :: (a -> b -> b) -> b -> [a] -> [b]
- , scanr1 -- :: (a -> a -> a) -> [a] -> [a]
-
- -- ** Accumulating maps
- , mapAccumL -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
- , mapAccumR -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
-
- -- ** Infinite lists
- , iterate -- :: (a -> a) -> a -> [a]
- , repeat -- :: a -> [a]
- , replicate -- :: Int -> a -> [a]
- , cycle -- :: [a] -> [a]
-
- -- ** Unfolding
- , unfoldr -- :: (b -> Maybe (a, b)) -> b -> [a]
-
- -- * Sublists
-
- -- ** Extracting sublists
- , take -- :: Int -> [a] -> [a]
- , drop -- :: Int -> [a] -> [a]
- , splitAt -- :: Int -> [a] -> ([a], [a])
-
- , takeWhile -- :: (a -> Bool) -> [a] -> [a]
- , dropWhile -- :: (a -> Bool) -> [a] -> [a]
- , span -- :: (a -> Bool) -> [a] -> ([a], [a])
- , break -- :: (a -> Bool) -> [a] -> ([a], [a])
-
- , group -- :: Eq a => [a] -> [[a]]
-
- , inits -- :: [a] -> [[a]]
- , tails -- :: [a] -> [[a]]
-
- -- ** Predicates
- , isPrefixOf -- :: (Eq a) => [a] -> [a] -> Bool
- , isSuffixOf -- :: (Eq a) => [a] -> [a] -> Bool
- , isInfixOf -- :: (Eq a) => [a] -> [a] -> Bool
-
- -- * Searching lists
-
- -- ** Searching by equality
- , elem -- :: a -> [a] -> Bool
- , notElem -- :: a -> [a] -> Bool
- , lookup -- :: (Eq a) => a -> [(a,b)] -> Maybe b
-
- -- ** Searching with a predicate
- , find -- :: (a -> Bool) -> [a] -> Maybe a
- , filter -- :: (a -> Bool) -> [a] -> [a]
- , partition -- :: (a -> Bool) -> [a] -> ([a], [a])
-
- -- * Indexing lists
- -- | These functions treat a list @xs@ as a indexed collection,
- -- with indices ranging from 0 to @'length' xs - 1@.
-
- , (!!) -- :: [a] -> Int -> a
-
- , elemIndex -- :: (Eq a) => a -> [a] -> Maybe Int
- , elemIndices -- :: (Eq a) => a -> [a] -> [Int]
-
- , findIndex -- :: (a -> Bool) -> [a] -> Maybe Int
- , findIndices -- :: (a -> Bool) -> [a] -> [Int]
-
- -- * Zipping and unzipping lists
-
- , zip -- :: [a] -> [b] -> [(a,b)]
- , zip3
- , zip4, zip5, zip6, zip7
-
- , zipWith -- :: (a -> b -> c) -> [a] -> [b] -> [c]
- , zipWith3
- , zipWith4, zipWith5, zipWith6, zipWith7
-
- , unzip -- :: [(a,b)] -> ([a],[b])
- , unzip3
- , unzip4, unzip5, unzip6, unzip7
-
- -- * Special lists
-
- -- ** Functions on strings
- , lines -- :: String -> [String]
- , words -- :: String -> [String]
- , unlines -- :: [String] -> String
- , unwords -- :: [String] -> String
-
- -- ** \"Set\" operations
-
- , nub -- :: (Eq a) => [a] -> [a]
-
- , delete -- :: (Eq a) => a -> [a] -> [a]
- , (\\) -- :: (Eq a) => [a] -> [a] -> [a]
-
- , union -- :: (Eq a) => [a] -> [a] -> [a]
- , intersect -- :: (Eq a) => [a] -> [a] -> [a]
-
- -- ** Ordered lists
- , sort -- :: (Ord a) => [a] -> [a]
- , insert -- :: (Ord a) => a -> [a] -> [a]
-
- -- * Generalized functions
-
- -- ** The \"@By@\" operations
- -- | By convention, overloaded functions have a non-overloaded
- -- counterpart whose name is suffixed with \`@By@\'.
- --
- -- It is often convenient to use these functions together with
- -- 'Data.Function.on', for instance @'sortBy' ('compare'
- -- \`on\` 'fst')@.
-
- -- *** User-supplied equality (replacing an @Eq@ context)
- -- | The predicate is assumed to define an equivalence.
- , nubBy -- :: (a -> a -> Bool) -> [a] -> [a]
- , deleteBy -- :: (a -> a -> Bool) -> a -> [a] -> [a]
- , deleteFirstsBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
- , unionBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
- , intersectBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
- , groupBy -- :: (a -> a -> Bool) -> [a] -> [[a]]
-
- -- *** User-supplied comparison (replacing an @Ord@ context)
- -- | The function is assumed to define a total ordering.
- , sortBy -- :: (a -> a -> Ordering) -> [a] -> [a]
- , insertBy -- :: (a -> a -> Ordering) -> a -> [a] -> [a]
- , maximumBy -- :: (a -> a -> Ordering) -> [a] -> a
- , minimumBy -- :: (a -> a -> Ordering) -> [a] -> a
-
- -- ** The \"@generic@\" operations
- -- | The prefix \`@generic@\' indicates an overloaded function that
- -- is a generalized version of a "Prelude" function.
-
- , genericLength -- :: (Integral a) => [b] -> a
- , genericTake -- :: (Integral a) => a -> [b] -> [b]
- , genericDrop -- :: (Integral a) => a -> [b] -> [b]
- , genericSplitAt -- :: (Integral a) => a -> [b] -> ([b], [b])
- , genericIndex -- :: (Integral a) => [b] -> a -> b
- , genericReplicate -- :: (Integral a) => a -> b -> [b]
-
- ) where
-
-#ifdef __NHC__
-import Prelude hiding (Maybe(..))
-#endif
-
-import Data.Maybe
-import Data.Char ( isSpace )
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Num
-import GHC.Real
-import GHC.List
-import GHC.Base
-#endif
-
-infix 5 \\ -- comment to fool cpp
-
--- -----------------------------------------------------------------------------
--- List functions
-
--- | The 'elemIndex' function returns the index of the first element
--- in the given list which is equal (by '==') to the query element,
--- or 'Nothing' if there is no such element.
-elemIndex :: Eq a => a -> [a] -> Maybe Int
-elemIndex x = findIndex (x==)
-
--- | The 'elemIndices' function extends 'elemIndex', by returning the
--- indices of all elements equal to the query element, in ascending order.
-elemIndices :: Eq a => a -> [a] -> [Int]
-elemIndices x = findIndices (x==)
-
--- | The 'find' function takes a predicate and a list and returns the
--- first element in the list matching the predicate, or 'Nothing' if
--- there is no such element.
-find :: (a -> Bool) -> [a] -> Maybe a
-find p = listToMaybe . filter p
-
--- | The 'findIndex' function takes a predicate and a list and returns
--- the index of the first element in the list satisfying the predicate,
--- or 'Nothing' if there is no such element.
-findIndex :: (a -> Bool) -> [a] -> Maybe Int
-findIndex p = listToMaybe . findIndices p
-
--- | The 'findIndices' function extends 'findIndex', by returning the
--- indices of all elements satisfying the predicate, in ascending order.
-findIndices :: (a -> Bool) -> [a] -> [Int]
-
-#if defined(USE_REPORT_PRELUDE) || !defined(__GLASGOW_HASKELL__)
-findIndices p xs = [ i | (x,i) <- zip xs [0..], p x]
-#else
--- Efficient definition
-findIndices p ls = loop 0# ls
- where
- loop _ [] = []
- loop n (x:xs) | p x = I# n : loop (n +# 1#) xs
- | otherwise = loop (n +# 1#) xs
-#endif /* USE_REPORT_PRELUDE */
-
--- | The 'isPrefixOf' function takes two lists and returns 'True'
--- iff the first list is a prefix of the second.
-isPrefixOf :: (Eq a) => [a] -> [a] -> Bool
-isPrefixOf [] _ = True
-isPrefixOf _ [] = False
-isPrefixOf (x:xs) (y:ys)= x == y && isPrefixOf xs ys
-
--- | The 'isSuffixOf' function takes two lists and returns 'True'
--- iff the first list is a suffix of the second.
--- Both lists must be finite.
-isSuffixOf :: (Eq a) => [a] -> [a] -> Bool
-isSuffixOf x y = reverse x `isPrefixOf` reverse y
-
--- | The 'isInfixOf' function takes two lists and returns 'True'
--- iff the first list is contained, wholly and intact,
--- anywhere within the second.
---
--- Example:
---
--- >isInfixOf "Haskell" "I really like Haskell." -> True
--- >isInfixOf "Ial" "I really like Haskell." -> False
-isInfixOf :: (Eq a) => [a] -> [a] -> Bool
-isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
-
--- | The 'nub' function removes duplicate elements from a list.
--- In particular, it keeps only the first occurrence of each element.
--- (The name 'nub' means \`essence\'.)
--- It is a special case of 'nubBy', which allows the programmer to supply
--- their own equality test.
-nub :: (Eq a) => [a] -> [a]
-#ifdef USE_REPORT_PRELUDE
-nub = nubBy (==)
-#else
--- stolen from HBC
-nub l = nub' l [] -- '
- where
- nub' [] _ = [] -- '
- nub' (x:xs) ls -- '
- | x `elem` ls = nub' xs ls -- '
- | otherwise = x : nub' xs (x:ls) -- '
-#endif
-
--- | The 'nubBy' function behaves just like 'nub', except it uses a
--- user-supplied equality predicate instead of the overloaded '=='
--- function.
-nubBy :: (a -> a -> Bool) -> [a] -> [a]
-#ifdef USE_REPORT_PRELUDE
-nubBy eq [] = []
-nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs)
-#else
-nubBy eq l = nubBy' l []
- where
- nubBy' [] _ = []
- nubBy' (y:ys) xs
- | elem_by eq y xs = nubBy' ys xs
- | otherwise = y : nubBy' ys (y:xs)
-
--- Not exported:
--- Note that we keep the call to `eq` with arguments in the
--- same order as in the reference implementation
--- 'xs' is the list of things we've seen so far,
--- 'y' is the potential new element
-elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool
-elem_by _ _ [] = False
-elem_by eq y (x:xs) = x `eq` y || elem_by eq y xs
-#endif
-
-
--- | 'delete' @x@ removes the first occurrence of @x@ from its list argument.
--- For example,
---
--- > delete 'a' "banana" == "bnana"
---
--- It is a special case of 'deleteBy', which allows the programmer to
--- supply their own equality test.
-
-delete :: (Eq a) => a -> [a] -> [a]
-delete = deleteBy (==)
-
--- | The 'deleteBy' function behaves like 'delete', but takes a
--- user-supplied equality predicate.
-deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]
-deleteBy _ _ [] = []
-deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys
-
--- | The '\\' function is list difference ((non-associative).
--- In the result of @xs@ '\\' @ys@, the first occurrence of each element of
--- @ys@ in turn (if any) has been removed from @xs@. Thus
---
--- > (xs ++ ys) \\ xs == ys.
---
--- It is a special case of 'deleteFirstsBy', which allows the programmer
--- to supply their own equality test.
-
-(\\) :: (Eq a) => [a] -> [a] -> [a]
-(\\) = foldl (flip delete)
-
--- | The 'union' function returns the list union of the two lists.
--- For example,
---
--- > "dog" `union` "cow" == "dogcw"
---
--- Duplicates, and elements of the first list, are removed from the
--- the second list, but if the first list contains duplicates, so will
--- the result.
--- It is a special case of 'unionBy', which allows the programmer to supply
--- their own equality test.
-
-union :: (Eq a) => [a] -> [a] -> [a]
-union = unionBy (==)
-
--- | The 'unionBy' function is the non-overloaded version of 'union'.
-unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
-unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs
-
--- | The 'intersect' function takes the list intersection of two lists.
--- For example,
---
--- > [1,2,3,4] `intersect` [2,4,6,8] == [2,4]
---
--- If the first list contains duplicates, so will the result.
--- It is a special case of 'intersectBy', which allows the programmer to
--- supply their own equality test.
-
-intersect :: (Eq a) => [a] -> [a] -> [a]
-intersect = intersectBy (==)
-
--- | The 'intersectBy' function is the non-overloaded version of 'intersect'.
-intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
-intersectBy eq xs ys = [x | x <- xs, any (eq x) ys]
-
--- | The 'intersperse' function takes an element and a list and
--- \`intersperses\' that element between the elements of the list.
--- For example,
---
--- > intersperse ',' "abcde" == "a,b,c,d,e"
-
-intersperse :: a -> [a] -> [a]
-intersperse _ [] = []
-intersperse _ [x] = [x]
-intersperse sep (x:xs) = x : sep : intersperse sep xs
-
--- | 'intercalate' @xs xss@ is equivalent to @('concat' ('intersperse' xs xss))@.
--- It inserts the list @xs@ in between the lists in @xss@ and concatenates the
--- result.
-intercalate :: [a] -> [[a]] -> [a]
-intercalate xs xss = concat (intersperse xs xss)
-
--- | The 'transpose' function transposes the rows and columns of its argument.
--- For example,
---
--- > transpose [[1,2,3],[4,5,6]] == [[1,4],[2,5],[3,6]]
-
-transpose :: [[a]] -> [[a]]
-transpose [] = []
-transpose ([] : xss) = transpose xss
-transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : transpose (xs : [ t | (h:t) <- xss])
-
-
--- | The 'partition' function takes a predicate a list and returns
--- the pair of lists of elements which do and do not satisfy the
--- predicate, respectively; i.e.,
---
--- > partition p xs == (filter p xs, filter (not . p) xs)
-
-partition :: (a -> Bool) -> [a] -> ([a],[a])
-{-# INLINE partition #-}
-partition p xs = foldr (select p) ([],[]) xs
-
-select p x ~(ts,fs) | p x = (x:ts,fs)
- | otherwise = (ts, x:fs)
-
--- | The 'mapAccumL' function behaves like a combination of 'map' and
--- 'foldl'; it applies a function to each element of a list, passing
--- an accumulating parameter from left to right, and returning a final
--- value of this accumulator together with the new list.
-mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
- -- and accumulator, returning new
- -- accumulator and elt of result list
- -> acc -- Initial accumulator
- -> [x] -- Input list
- -> (acc, [y]) -- Final accumulator and result list
-mapAccumL _ s [] = (s, [])
-mapAccumL f s (x:xs) = (s'',y:ys)
- where (s', y ) = f s x
- (s'',ys) = mapAccumL f s' xs
-
--- | The 'mapAccumR' function behaves like a combination of 'map' and
--- 'foldr'; it applies a function to each element of a list, passing
--- an accumulating parameter from right to left, and returning a final
--- value of this accumulator together with the new list.
-mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
- -- and accumulator, returning new
- -- accumulator and elt of result list
- -> acc -- Initial accumulator
- -> [x] -- Input list
- -> (acc, [y]) -- Final accumulator and result list
-mapAccumR _ s [] = (s, [])
-mapAccumR f s (x:xs) = (s'', y:ys)
- where (s'',y ) = f s' x
- (s', ys) = mapAccumR f s xs
-
--- | The 'insert' function takes an element and a list and inserts the
--- element into the list at the last position where it is still less
--- than or equal to the next element. In particular, if the list
--- is sorted before the call, the result will also be sorted.
--- It is a special case of 'insertBy', which allows the programmer to
--- supply their own comparison function.
-insert :: Ord a => a -> [a] -> [a]
-insert e ls = insertBy (compare) e ls
-
--- | The non-overloaded version of 'insert'.
-insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]
-insertBy _ x [] = [x]
-insertBy cmp x ys@(y:ys')
- = case cmp x y of
- GT -> y : insertBy cmp x ys'
- _ -> x : ys
-
-#ifdef __GLASGOW_HASKELL__
-
--- | 'maximum' returns the maximum value from a list,
--- which must be non-empty, finite, and of an ordered type.
--- It is a special case of 'Data.List.maximumBy', which allows the
--- programmer to supply their own comparison function.
-maximum :: (Ord a) => [a] -> a
-maximum [] = errorEmptyList "maximum"
-maximum xs = foldl1 max xs
-
-{-# RULES
- "maximumInt" maximum = (strictMaximum :: [Int] -> Int);
- "maximumInteger" maximum = (strictMaximum :: [Integer] -> Integer)
- #-}
-
--- We can't make the overloaded version of maximum strict without
--- changing its semantics (max might not be strict), but we can for
--- the version specialised to 'Int'.
-strictMaximum :: (Ord a) => [a] -> a
-strictMaximum [] = errorEmptyList "maximum"
-strictMaximum xs = foldl1' max xs
-
--- | 'minimum' returns the minimum value from a list,
--- which must be non-empty, finite, and of an ordered type.
--- It is a special case of 'Data.List.minimumBy', which allows the
--- programmer to supply their own comparison function.
-minimum :: (Ord a) => [a] -> a
-minimum [] = errorEmptyList "minimum"
-minimum xs = foldl1 min xs
-
-{-# RULES
- "minimumInt" minimum = (strictMinimum :: [Int] -> Int);
- "minimumInteger" minimum = (strictMinimum :: [Integer] -> Integer)
- #-}
-
-strictMinimum :: (Ord a) => [a] -> a
-strictMinimum [] = errorEmptyList "minimum"
-strictMinimum xs = foldl1' min xs
-
-#endif /* __GLASGOW_HASKELL__ */
-
--- | The 'maximumBy' function takes a comparison function and a list
--- and returns the greatest element of the list by the comparison function.
--- The list must be finite and non-empty.
-maximumBy :: (a -> a -> Ordering) -> [a] -> a
-maximumBy _ [] = error "List.maximumBy: empty list"
-maximumBy cmp xs = foldl1 max xs
- where
- max x y = case cmp x y of
- GT -> x
- _ -> y
-
--- | The 'minimumBy' function takes a comparison function and a list
--- and returns the least element of the list by the comparison function.
--- The list must be finite and non-empty.
-minimumBy :: (a -> a -> Ordering) -> [a] -> a
-minimumBy _ [] = error "List.minimumBy: empty list"
-minimumBy cmp xs = foldl1 min xs
- where
- min x y = case cmp x y of
- GT -> y
- _ -> x
-
--- | The 'genericLength' function is an overloaded version of 'length'. In
--- particular, instead of returning an 'Int', it returns any type which is
--- an instance of 'Num'. It is, however, less efficient than 'length'.
-genericLength :: (Num i) => [b] -> i
-genericLength [] = 0
-genericLength (_:l) = 1 + genericLength l
-
--- | The 'genericTake' function is an overloaded version of 'take', which
--- accepts any 'Integral' value as the number of elements to take.
-genericTake :: (Integral i) => i -> [a] -> [a]
-genericTake 0 _ = []
-genericTake _ [] = []
-genericTake n (x:xs) | n > 0 = x : genericTake (n-1) xs
-genericTake _ _ = error "List.genericTake: negative argument"
-
--- | The 'genericDrop' function is an overloaded version of 'drop', which
--- accepts any 'Integral' value as the number of elements to drop.
-genericDrop :: (Integral i) => i -> [a] -> [a]
-genericDrop 0 xs = xs
-genericDrop _ [] = []
-genericDrop n (_:xs) | n > 0 = genericDrop (n-1) xs
-genericDrop _ _ = error "List.genericDrop: negative argument"
-
--- | The 'genericSplitAt' function is an overloaded version of 'splitAt', which
--- accepts any 'Integral' value as the position at which to split.
-genericSplitAt :: (Integral i) => i -> [b] -> ([b],[b])
-genericSplitAt 0 xs = ([],xs)
-genericSplitAt _ [] = ([],[])
-genericSplitAt n (x:xs) | n > 0 = (x:xs',xs'') where
- (xs',xs'') = genericSplitAt (n-1) xs
-genericSplitAt _ _ = error "List.genericSplitAt: negative argument"
-
--- | The 'genericIndex' function is an overloaded version of '!!', which
--- accepts any 'Integral' value as the index.
-genericIndex :: (Integral a) => [b] -> a -> b
-genericIndex (x:_) 0 = x
-genericIndex (_:xs) n
- | n > 0 = genericIndex xs (n-1)
- | otherwise = error "List.genericIndex: negative argument."
-genericIndex _ _ = error "List.genericIndex: index too large."
-
--- | The 'genericReplicate' function is an overloaded version of 'replicate',
--- which accepts any 'Integral' value as the number of repetitions to make.
-genericReplicate :: (Integral i) => i -> a -> [a]
-genericReplicate n x = genericTake n (repeat x)
-
--- | The 'zip4' function takes four lists and returns a list of
--- quadruples, analogous to 'zip'.
-zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
-zip4 = zipWith4 (,,,)
-
--- | The 'zip5' function takes five lists and returns a list of
--- five-tuples, analogous to 'zip'.
-zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
-zip5 = zipWith5 (,,,,)
-
--- | The 'zip6' function takes six lists and returns a list of six-tuples,
--- analogous to 'zip'.
-zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
- [(a,b,c,d,e,f)]
-zip6 = zipWith6 (,,,,,)
-
--- | The 'zip7' function takes seven lists and returns a list of
--- seven-tuples, analogous to 'zip'.
-zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
- [g] -> [(a,b,c,d,e,f,g)]
-zip7 = zipWith7 (,,,,,,)
-
--- | The 'zipWith4' function takes a function which combines four
--- elements, as well as four lists and returns a list of their point-wise
--- combination, analogous to 'zipWith'.
-zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
-zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
- = z a b c d : zipWith4 z as bs cs ds
-zipWith4 _ _ _ _ _ = []
-
--- | The 'zipWith5' function takes a function which combines five
--- elements, as well as five lists and returns a list of their point-wise
--- combination, analogous to 'zipWith'.
-zipWith5 :: (a->b->c->d->e->f) ->
- [a]->[b]->[c]->[d]->[e]->[f]
-zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
- = z a b c d e : zipWith5 z as bs cs ds es
-zipWith5 _ _ _ _ _ _ = []
-
--- | The 'zipWith6' function takes a function which combines six
--- elements, as well as six lists and returns a list of their point-wise
--- combination, analogous to 'zipWith'.
-zipWith6 :: (a->b->c->d->e->f->g) ->
- [a]->[b]->[c]->[d]->[e]->[f]->[g]
-zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
- = z a b c d e f : zipWith6 z as bs cs ds es fs
-zipWith6 _ _ _ _ _ _ _ = []
-
--- | The 'zipWith7' function takes a function which combines seven
--- elements, as well as seven lists and returns a list of their point-wise
--- combination, analogous to 'zipWith'.
-zipWith7 :: (a->b->c->d->e->f->g->h) ->
- [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
-zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
- = z a b c d e f g : zipWith7 z as bs cs ds es fs gs
-zipWith7 _ _ _ _ _ _ _ _ = []
-
--- | The 'unzip4' function takes a list of quadruples and returns four
--- lists, analogous to 'unzip'.
-unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d])
-unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->
- (a:as,b:bs,c:cs,d:ds))
- ([],[],[],[])
-
--- | The 'unzip5' function takes a list of five-tuples and returns five
--- lists, analogous to 'unzip'.
-unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])
-unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->
- (a:as,b:bs,c:cs,d:ds,e:es))
- ([],[],[],[],[])
-
--- | The 'unzip6' function takes a list of six-tuples and returns six
--- lists, analogous to 'unzip'.
-unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])
-unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->
- (a:as,b:bs,c:cs,d:ds,e:es,f:fs))
- ([],[],[],[],[],[])
-
--- | The 'unzip7' function takes a list of seven-tuples and returns
--- seven lists, analogous to 'unzip'.
-unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])
-unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->
- (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))
- ([],[],[],[],[],[],[])
-
-
--- | The 'deleteFirstsBy' function takes a predicate and two lists and
--- returns the first list with the first occurrence of each element of
--- the second list removed.
-deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
-deleteFirstsBy eq = foldl (flip (deleteBy eq))
-
--- | The 'group' function takes a list and returns a list of lists such
--- that the concatenation of the result is equal to the argument. Moreover,
--- each sublist in the result contains only equal elements. For example,
---
--- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"]
---
--- It is a special case of 'groupBy', which allows the programmer to supply
--- their own equality test.
-group :: Eq a => [a] -> [[a]]
-group = groupBy (==)
-
--- | The 'groupBy' function is the non-overloaded version of 'group'.
-groupBy :: (a -> a -> Bool) -> [a] -> [[a]]
-groupBy _ [] = []
-groupBy eq (x:xs) = (x:ys) : groupBy eq zs
- where (ys,zs) = span (eq x) xs
-
--- | The 'inits' function returns all initial segments of the argument,
--- shortest first. For example,
---
--- > inits "abc" == ["","a","ab","abc"]
---
-inits :: [a] -> [[a]]
-inits [] = [[]]
-inits (x:xs) = [[]] ++ map (x:) (inits xs)
-
--- | The 'tails' function returns all final segments of the argument,
--- longest first. For example,
---
--- > tails "abc" == ["abc", "bc", "c",""]
---
-tails :: [a] -> [[a]]
-tails [] = [[]]
-tails xxs@(_:xs) = xxs : tails xs
-
-
-------------------------------------------------------------------------------
--- Quick Sort algorithm taken from HBC's QSort library.
-
--- | The 'sort' function implements a stable sorting algorithm.
--- It is a special case of 'sortBy', which allows the programmer to supply
--- their own comparison function.
-sort :: (Ord a) => [a] -> [a]
-
--- | The 'sortBy' function is the non-overloaded version of 'sort'.
-sortBy :: (a -> a -> Ordering) -> [a] -> [a]
-
-#ifdef USE_REPORT_PRELUDE
-sort = sortBy compare
-sortBy cmp = foldr (insertBy cmp) []
-#else
-
-sortBy cmp l = mergesort cmp l
-sort l = mergesort compare l
-
-{-
-Quicksort replaced by mergesort, 14/5/2002.
-
-From: Ian Lynagh <igloo@earth.li>
-
-I am curious as to why the List.sort implementation in GHC is a
-quicksort algorithm rather than an algorithm that guarantees n log n
-time in the worst case? I have attached a mergesort implementation along
-with a few scripts to time it's performance, the results of which are
-shown below (* means it didn't finish successfully - in all cases this
-was due to a stack overflow).
-
-If I heap profile the random_list case with only 10000 then I see
-random_list peaks at using about 2.5M of memory, whereas in the same
-program using List.sort it uses only 100k.
-
-Input style Input length Sort data Sort alg User time
-stdin 10000 random_list sort 2.82
-stdin 10000 random_list mergesort 2.96
-stdin 10000 sorted sort 31.37
-stdin 10000 sorted mergesort 1.90
-stdin 10000 revsorted sort 31.21
-stdin 10000 revsorted mergesort 1.88
-stdin 100000 random_list sort *
-stdin 100000 random_list mergesort *
-stdin 100000 sorted sort *
-stdin 100000 sorted mergesort *
-stdin 100000 revsorted sort *
-stdin 100000 revsorted mergesort *
-func 10000 random_list sort 0.31
-func 10000 random_list mergesort 0.91
-func 10000 sorted sort 19.09
-func 10000 sorted mergesort 0.15
-func 10000 revsorted sort 19.17
-func 10000 revsorted mergesort 0.16
-func 100000 random_list sort 3.85
-func 100000 random_list mergesort *
-func 100000 sorted sort 5831.47
-func 100000 sorted mergesort 2.23
-func 100000 revsorted sort 5872.34
-func 100000 revsorted mergesort 2.24
--}
-
-mergesort :: (a -> a -> Ordering) -> [a] -> [a]
-mergesort cmp = mergesort' cmp . map wrap
-
-mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a]
-mergesort' cmp [] = []
-mergesort' cmp [xs] = xs
-mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss)
-
-merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]]
-merge_pairs cmp [] = []
-merge_pairs cmp [xs] = [xs]
-merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss
-
-merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
-merge cmp xs [] = xs
-merge cmp [] ys = ys
-merge cmp (x:xs) (y:ys)
- = case x `cmp` y of
- GT -> y : merge cmp (x:xs) ys
- _ -> x : merge cmp xs (y:ys)
-
-wrap :: a -> [a]
-wrap x = [x]
-
-{-
-OLD: qsort version
-
--- qsort is stable and does not concatenate.
-qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
-qsort _ [] r = r
-qsort _ [x] r = x:r
-qsort cmp (x:xs) r = qpart cmp x xs [] [] r
-
--- qpart partitions and sorts the sublists
-qpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]
-qpart cmp x [] rlt rge r =
- -- rlt and rge are in reverse order and must be sorted with an
- -- anti-stable sorting
- rqsort cmp rlt (x:rqsort cmp rge r)
-qpart cmp x (y:ys) rlt rge r =
- case cmp x y of
- GT -> qpart cmp x ys (y:rlt) rge r
- _ -> qpart cmp x ys rlt (y:rge) r
-
--- rqsort is as qsort but anti-stable, i.e. reverses equal elements
-rqsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
-rqsort _ [] r = r
-rqsort _ [x] r = x:r
-rqsort cmp (x:xs) r = rqpart cmp x xs [] [] r
-
-rqpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]
-rqpart cmp x [] rle rgt r =
- qsort cmp rle (x:qsort cmp rgt r)
-rqpart cmp x (y:ys) rle rgt r =
- case cmp y x of
- GT -> rqpart cmp x ys rle (y:rgt) r
- _ -> rqpart cmp x ys (y:rle) rgt r
--}
-
-#endif /* USE_REPORT_PRELUDE */
-
--- | The 'unfoldr' function is a \`dual\' to 'foldr': while 'foldr'
--- reduces a list to a summary value, 'unfoldr' builds a list from
--- a seed value. The function takes the element and returns 'Nothing'
--- if it is done producing the list or returns 'Just' @(a,b)@, in which
--- case, @a@ is a prepended to the list and @b@ is used as the next
--- element in a recursive call. For example,
---
--- > iterate f == unfoldr (\x -> Just (x, f x))
---
--- In some cases, 'unfoldr' can undo a 'foldr' operation:
---
--- > unfoldr f' (foldr f z xs) == xs
---
--- if the following holds:
---
--- > f' (f x y) = Just (x,y)
--- > f' z = Nothing
---
--- A simple use of unfoldr:
---
--- > unfoldr (\b -> if b == 0 then Nothing else Just (b, b-1)) 10
--- > [10,9,8,7,6,5,4,3,2,1]
---
-unfoldr :: (b -> Maybe (a, b)) -> b -> [a]
-unfoldr f b =
- case f b of
- Just (a,new_b) -> a : unfoldr f new_b
- Nothing -> []
-
--- -----------------------------------------------------------------------------
-
--- | A strict version of 'foldl'.
-foldl' :: (a -> b -> a) -> a -> [b] -> a
-foldl' f a [] = a
-foldl' f a (x:xs) = let a' = f a x in a' `seq` foldl' f a' xs
-
-#ifdef __GLASGOW_HASKELL__
--- | 'foldl1' is a variant of 'foldl' that has no starting value argument,
--- and thus must be applied to non-empty lists.
-foldl1 :: (a -> a -> a) -> [a] -> a
-foldl1 f (x:xs) = foldl f x xs
-foldl1 _ [] = errorEmptyList "foldl1"
-#endif /* __GLASGOW_HASKELL__ */
-
--- | A strict version of 'foldl1'
-foldl1' :: (a -> a -> a) -> [a] -> a
-foldl1' f (x:xs) = foldl' f x xs
-foldl1' _ [] = errorEmptyList "foldl1'"
-
-#ifdef __GLASGOW_HASKELL__
--- -----------------------------------------------------------------------------
--- List sum and product
-
-{-# SPECIALISE sum :: [Int] -> Int #-}
-{-# SPECIALISE sum :: [Integer] -> Integer #-}
-{-# SPECIALISE product :: [Int] -> Int #-}
-{-# SPECIALISE product :: [Integer] -> Integer #-}
--- | The 'sum' function computes the sum of a finite list of numbers.
-sum :: (Num a) => [a] -> a
--- | The 'product' function computes the product of a finite list of numbers.
-product :: (Num a) => [a] -> a
-#ifdef USE_REPORT_PRELUDE
-sum = foldl (+) 0
-product = foldl (*) 1
-#else
-sum l = sum' l 0
- where
- sum' [] a = a
- sum' (x:xs) a = sum' xs (a+x)
-product l = prod l 1
- where
- prod [] a = a
- prod (x:xs) a = prod xs (a*x)
-#endif
-
--- -----------------------------------------------------------------------------
--- Functions on strings
-
--- | 'lines' breaks a string up into a list of strings at newline
--- characters. The resulting strings do not contain newlines.
-lines :: String -> [String]
-lines "" = []
-lines s = let (l, s') = break (== '\n') s
- in l : case s' of
- [] -> []
- (_:s'') -> lines s''
-
--- | 'unlines' is an inverse operation to 'lines'.
--- It joins lines, after appending a terminating newline to each.
-unlines :: [String] -> String
-#ifdef USE_REPORT_PRELUDE
-unlines = concatMap (++ "\n")
-#else
--- HBC version (stolen)
--- here's a more efficient version
-unlines [] = []
-unlines (l:ls) = l ++ '\n' : unlines ls
-#endif
-
--- | 'words' breaks a string up into a list of words, which were delimited
--- by white space.
-words :: String -> [String]
-words s = case dropWhile {-partain:Char.-}isSpace s of
- "" -> []
- s' -> w : words s''
- where (w, s'') =
- break {-partain:Char.-}isSpace s'
-
--- | 'unwords' is an inverse operation to 'words'.
--- It joins words with separating spaces.
-unwords :: [String] -> String
-#ifdef USE_REPORT_PRELUDE
-unwords [] = ""
-unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
-#else
--- HBC version (stolen)
--- here's a more efficient version
-unwords [] = ""
-unwords [w] = w
-unwords (w:ws) = w ++ ' ' : unwords ws
-#endif
-
-#else /* !__GLASGOW_HASKELL__ */
-
-errorEmptyList :: String -> a
-errorEmptyList fun =
- error ("Prelude." ++ fun ++ ": empty list")
-
-#endif /* !__GLASGOW_HASKELL__ */
+++ /dev/null
-{-# OPTIONS_GHC -fno-bang-patterns #-}
-
------------------------------------------------------------------------------
--- |
--- Module : Data.Map
--- Copyright : (c) Daan Leijen 2002
--- License : BSD-style
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- An efficient implementation of maps from keys to values (dictionaries).
---
--- Since many function names (but not the type name) clash with
--- "Prelude" names, this module is usually imported @qualified@, e.g.
---
--- > import Data.Map (Map)
--- > import qualified Data.Map as Map
---
--- The implementation of 'Map' is based on /size balanced/ binary trees (or
--- trees of /bounded balance/) as described by:
---
--- * Stephen Adams, \"/Efficient sets: a balancing act/\",
--- Journal of Functional Programming 3(4):553-562, October 1993,
--- <http://www.swiss.ai.mit.edu/~adams/BB>.
---
--- * J. Nievergelt and E.M. Reingold,
--- \"/Binary search trees of bounded balance/\",
--- SIAM journal of computing 2(1), March 1973.
---
--- Note that the implementation is /left-biased/ -- the elements of a
--- first argument are always preferred to the second, for example in
--- 'union' or 'insert'.
------------------------------------------------------------------------------
-
-module Data.Map (
- -- * Map type
- Map -- instance Eq,Show,Read
-
- -- * Operators
- , (!), (\\)
-
-
- -- * Query
- , null
- , size
- , member
- , notMember
- , lookup
- , findWithDefault
-
- -- * Construction
- , empty
- , singleton
-
- -- ** Insertion
- , insert
- , insertWith, insertWithKey, insertLookupWithKey
- , insertWith', insertWithKey'
-
- -- ** Delete\/Update
- , delete
- , adjust
- , adjustWithKey
- , update
- , updateWithKey
- , updateLookupWithKey
- , alter
-
- -- * Combine
-
- -- ** Union
- , union
- , unionWith
- , unionWithKey
- , unions
- , unionsWith
-
- -- ** Difference
- , difference
- , differenceWith
- , differenceWithKey
-
- -- ** Intersection
- , intersection
- , intersectionWith
- , intersectionWithKey
-
- -- * Traversal
- -- ** Map
- , map
- , mapWithKey
- , mapAccum
- , mapAccumWithKey
- , mapKeys
- , mapKeysWith
- , mapKeysMonotonic
-
- -- ** Fold
- , fold
- , foldWithKey
-
- -- * Conversion
- , elems
- , keys
- , keysSet
- , assocs
-
- -- ** Lists
- , toList
- , fromList
- , fromListWith
- , fromListWithKey
-
- -- ** Ordered lists
- , toAscList
- , fromAscList
- , fromAscListWith
- , fromAscListWithKey
- , fromDistinctAscList
-
- -- * Filter
- , filter
- , filterWithKey
- , partition
- , partitionWithKey
-
- , mapMaybe
- , mapMaybeWithKey
- , mapEither
- , mapEitherWithKey
-
- , split
- , splitLookup
-
- -- * Submap
- , isSubmapOf, isSubmapOfBy
- , isProperSubmapOf, isProperSubmapOfBy
-
- -- * Indexed
- , lookupIndex
- , findIndex
- , elemAt
- , updateAt
- , deleteAt
-
- -- * Min\/Max
- , findMin
- , findMax
- , deleteMin
- , deleteMax
- , deleteFindMin
- , deleteFindMax
- , updateMin
- , updateMax
- , updateMinWithKey
- , updateMaxWithKey
- , minView
- , maxView
- , minViewWithKey
- , maxViewWithKey
-
- -- * Debugging
- , showTree
- , showTreeWith
- , valid
- ) where
-
-import Prelude hiding (lookup,map,filter,foldr,foldl,null)
-import qualified Data.Set as Set
-import qualified Data.List as List
-import Data.Monoid (Monoid(..))
-import Data.Typeable
-import Control.Applicative (Applicative(..), (<$>))
-import Data.Traversable (Traversable(traverse))
-import Data.Foldable (Foldable(foldMap))
-
-{-
--- for quick check
-import qualified Prelude
-import qualified List
-import Debug.QuickCheck
-import List(nub,sort)
--}
-
-#if __GLASGOW_HASKELL__
-import Text.Read
-import Data.Generics.Basics
-import Data.Generics.Instances
-#endif
-
-{--------------------------------------------------------------------
- Operators
---------------------------------------------------------------------}
-infixl 9 !,\\ --
-
--- | /O(log n)/. Find the value at a key.
--- Calls 'error' when the element can not be found.
-(!) :: Ord k => Map k a -> k -> a
-m ! k = find k m
-
--- | /O(n+m)/. See 'difference'.
-(\\) :: Ord k => Map k a -> Map k b -> Map k a
-m1 \\ m2 = difference m1 m2
-
-{--------------------------------------------------------------------
- Size balanced trees.
---------------------------------------------------------------------}
--- | A Map from keys @k@ to values @a@.
-data Map k a = Tip
- | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
-
-type Size = Int
-
-instance (Ord k) => Monoid (Map k v) where
- mempty = empty
- mappend = union
- mconcat = unions
-
-#if __GLASGOW_HASKELL__
-
-{--------------------------------------------------------------------
- A Data instance
---------------------------------------------------------------------}
-
--- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
-
-instance (Data k, Data a, Ord k) => Data (Map k a) where
- gfoldl f z map = z fromList `f` (toList map)
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.Map.Map"
- dataCast2 f = gcast2 f
-
-#endif
-
-{--------------------------------------------------------------------
- Query
---------------------------------------------------------------------}
--- | /O(1)/. Is the map empty?
-null :: Map k a -> Bool
-null t
- = case t of
- Tip -> True
- Bin sz k x l r -> False
-
--- | /O(1)/. The number of elements in the map.
-size :: Map k a -> Int
-size t
- = case t of
- Tip -> 0
- Bin sz k x l r -> sz
-
-
--- | /O(log n)/. Lookup the value at a key in the map.
---
--- The function will
--- @return@ the result in the monad or @fail@ in it the key isn't in the
--- map. Often, the monad to use is 'Maybe', so you get either
--- @('Just' result)@ or @'Nothing'@.
-lookup :: (Monad m,Ord k) => k -> Map k a -> m a
-lookup k t = case lookup' k t of
- Just x -> return x
- Nothing -> fail "Data.Map.lookup: Key not found"
-lookup' :: Ord k => k -> Map k a -> Maybe a
-lookup' k t
- = case t of
- Tip -> Nothing
- Bin sz kx x l r
- -> case compare k kx of
- LT -> lookup' k l
- GT -> lookup' k r
- EQ -> Just x
-
-lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)
-lookupAssoc k t
- = case t of
- Tip -> Nothing
- Bin sz kx x l r
- -> case compare k kx of
- LT -> lookupAssoc k l
- GT -> lookupAssoc k r
- EQ -> Just (kx,x)
-
--- | /O(log n)/. Is the key a member of the map?
-member :: Ord k => k -> Map k a -> Bool
-member k m
- = case lookup k m of
- Nothing -> False
- Just x -> True
-
--- | /O(log n)/. Is the key not a member of the map?
-notMember :: Ord k => k -> Map k a -> Bool
-notMember k m = not $ member k m
-
--- | /O(log n)/. Find the value at a key.
--- Calls 'error' when the element can not be found.
-find :: Ord k => k -> Map k a -> a
-find k m
- = case lookup k m of
- Nothing -> error "Map.find: element not in the map"
- Just x -> x
-
--- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
--- the value at key @k@ or returns @def@ when the key is not in the map.
-findWithDefault :: Ord k => a -> k -> Map k a -> a
-findWithDefault def k m
- = case lookup k m of
- Nothing -> def
- Just x -> x
-
-
-
-{--------------------------------------------------------------------
- Construction
---------------------------------------------------------------------}
--- | /O(1)/. The empty map.
-empty :: Map k a
-empty
- = Tip
-
--- | /O(1)/. A map with a single element.
-singleton :: k -> a -> Map k a
-singleton k x
- = Bin 1 k x Tip Tip
-
-{--------------------------------------------------------------------
- Insertion
---------------------------------------------------------------------}
--- | /O(log n)/. Insert a new key and value in the map.
--- If the key is already present in the map, the associated value is
--- replaced with the supplied value, i.e. 'insert' is equivalent to
--- @'insertWith' 'const'@.
-insert :: Ord k => k -> a -> Map k a -> Map k a
-insert kx x t
- = case t of
- Tip -> singleton kx x
- Bin sz ky y l r
- -> case compare kx ky of
- LT -> balance ky y (insert kx x l) r
- GT -> balance ky y l (insert kx x r)
- EQ -> Bin sz kx x l r
-
--- | /O(log n)/. Insert with a combining function.
--- @'insertWith' f key value mp@
--- will insert the pair (key, value) into @mp@ if key does
--- not exist in the map. If the key does exist, the function will
--- insert the pair @(key, f new_value old_value)@.
-insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWith f k x m
- = insertWithKey (\k x y -> f x y) k x m
-
--- | Same as 'insertWith', but the combining function is applied strictly.
-insertWith' :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWith' f k x m
- = insertWithKey' (\k x y -> f x y) k x m
-
-
--- | /O(log n)/. Insert with a combining function.
--- @'insertWithKey' f key value mp@
--- will insert the pair (key, value) into @mp@ if key does
--- not exist in the map. If the key does exist, the function will
--- insert the pair @(key,f key new_value old_value)@.
--- Note that the key passed to f is the same key passed to 'insertWithKey'.
-insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWithKey f kx x t
- = case t of
- Tip -> singleton kx x
- Bin sy ky y l r
- -> case compare kx ky of
- LT -> balance ky y (insertWithKey f kx x l) r
- GT -> balance ky y l (insertWithKey f kx x r)
- EQ -> Bin sy kx (f kx x y) l r
-
--- | Same as 'insertWithKey', but the combining function is applied strictly.
-insertWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWithKey' f kx x t
- = case t of
- Tip -> singleton kx x
- Bin sy ky y l r
- -> case compare kx ky of
- LT -> balance ky y (insertWithKey' f kx x l) r
- GT -> balance ky y l (insertWithKey' f kx x r)
- EQ -> let x' = f kx x y in seq x' (Bin sy kx x' l r)
-
-
--- | /O(log n)/. The expression (@'insertLookupWithKey' f k x map@)
--- is a pair where the first element is equal to (@'lookup' k map@)
--- and the second element equal to (@'insertWithKey' f k x map@).
-insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
-insertLookupWithKey f kx x t
- = case t of
- Tip -> (Nothing, singleton kx x)
- Bin sy ky y l r
- -> case compare kx ky of
- LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
- GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
- EQ -> (Just y, Bin sy kx (f kx x y) l r)
-
-{--------------------------------------------------------------------
- Deletion
- [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
---------------------------------------------------------------------}
--- | /O(log n)/. Delete a key and its value from the map. When the key is not
--- a member of the map, the original map is returned.
-delete :: Ord k => k -> Map k a -> Map k a
-delete k t
- = case t of
- Tip -> Tip
- Bin sx kx x l r
- -> case compare k kx of
- LT -> balance kx x (delete k l) r
- GT -> balance kx x l (delete k r)
- EQ -> glue l r
-
--- | /O(log n)/. Adjust a value at a specific key. When the key is not
--- a member of the map, the original map is returned.
-adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
-adjust f k m
- = adjustWithKey (\k x -> f x) k m
-
--- | /O(log n)/. Adjust a value at a specific key. When the key is not
--- a member of the map, the original map is returned.
-adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
-adjustWithKey f k m
- = updateWithKey (\k x -> Just (f k x)) k m
-
--- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
-update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
-update f k m
- = updateWithKey (\k x -> f x) k m
-
--- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
--- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
--- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
--- to the new value @y@.
-updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
-updateWithKey f k t
- = case t of
- Tip -> Tip
- Bin sx kx x l r
- -> case compare k kx of
- LT -> balance kx x (updateWithKey f k l) r
- GT -> balance kx x l (updateWithKey f k r)
- EQ -> case f kx x of
- Just x' -> Bin sx kx x' l r
- Nothing -> glue l r
-
--- | /O(log n)/. Lookup and update.
-updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
-updateLookupWithKey f k t
- = case t of
- Tip -> (Nothing,Tip)
- Bin sx kx x l r
- -> case compare k kx of
- LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
- GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r')
- EQ -> case f kx x of
- Just x' -> (Just x',Bin sx kx x' l r)
- Nothing -> (Just x,glue l r)
-
--- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
--- 'alter' can be used to insert, delete, or update a value in a 'Map'.
--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@
-alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
-alter f k t
- = case t of
- Tip -> case f Nothing of
- Nothing -> Tip
- Just x -> singleton k x
- Bin sx kx x l r
- -> case compare k kx of
- LT -> balance kx x (alter f k l) r
- GT -> balance kx x l (alter f k r)
- EQ -> case f (Just x) of
- Just x' -> Bin sx kx x' l r
- Nothing -> glue l r
-
-{--------------------------------------------------------------------
- Indexing
---------------------------------------------------------------------}
--- | /O(log n)/. Return the /index/ of a key. The index is a number from
--- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
--- the key is not a 'member' of the map.
-findIndex :: Ord k => k -> Map k a -> Int
-findIndex k t
- = case lookupIndex k t of
- Nothing -> error "Map.findIndex: element is not in the map"
- Just idx -> idx
-
--- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
--- /0/ up to, but not including, the 'size' of the map.
-lookupIndex :: (Monad m,Ord k) => k -> Map k a -> m Int
-lookupIndex k t = case lookup 0 t of
- Nothing -> fail "Data.Map.lookupIndex: Key not found."
- Just x -> return x
- where
- lookup idx Tip = Nothing
- lookup idx (Bin _ kx x l r)
- = case compare k kx of
- LT -> lookup idx l
- GT -> lookup (idx + size l + 1) r
- EQ -> Just (idx + size l)
-
--- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
--- invalid index is used.
-elemAt :: Int -> Map k a -> (k,a)
-elemAt i Tip = error "Map.elemAt: index out of range"
-elemAt i (Bin _ kx x l r)
- = case compare i sizeL of
- LT -> elemAt i l
- GT -> elemAt (i-sizeL-1) r
- EQ -> (kx,x)
- where
- sizeL = size l
-
--- | /O(log n)/. Update the element at /index/. Calls 'error' when an
--- invalid index is used.
-updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
-updateAt f i Tip = error "Map.updateAt: index out of range"
-updateAt f i (Bin sx kx x l r)
- = case compare i sizeL of
- LT -> updateAt f i l
- GT -> updateAt f (i-sizeL-1) r
- EQ -> case f kx x of
- Just x' -> Bin sx kx x' l r
- Nothing -> glue l r
- where
- sizeL = size l
-
--- | /O(log n)/. Delete the element at /index/.
--- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).
-deleteAt :: Int -> Map k a -> Map k a
-deleteAt i map
- = updateAt (\k x -> Nothing) i map
-
-
-{--------------------------------------------------------------------
- Minimal, Maximal
---------------------------------------------------------------------}
--- | /O(log n)/. The minimal key of the map.
-findMin :: Map k a -> (k,a)
-findMin (Bin _ kx x Tip r) = (kx,x)
-findMin (Bin _ kx x l r) = findMin l
-findMin Tip = error "Map.findMin: empty map has no minimal element"
-
--- | /O(log n)/. The maximal key of the map.
-findMax :: Map k a -> (k,a)
-findMax (Bin _ kx x l Tip) = (kx,x)
-findMax (Bin _ kx x l r) = findMax r
-findMax Tip = error "Map.findMax: empty map has no maximal element"
-
--- | /O(log n)/. Delete the minimal key.
-deleteMin :: Map k a -> Map k a
-deleteMin (Bin _ kx x Tip r) = r
-deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
-deleteMin Tip = Tip
-
--- | /O(log n)/. Delete the maximal key.
-deleteMax :: Map k a -> Map k a
-deleteMax (Bin _ kx x l Tip) = l
-deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
-deleteMax Tip = Tip
-
--- | /O(log n)/. Update the value at the minimal key.
-updateMin :: (a -> Maybe a) -> Map k a -> Map k a
-updateMin f m
- = updateMinWithKey (\k x -> f x) m
-
--- | /O(log n)/. Update the value at the maximal key.
-updateMax :: (a -> Maybe a) -> Map k a -> Map k a
-updateMax f m
- = updateMaxWithKey (\k x -> f x) m
-
-
--- | /O(log n)/. Update the value at the minimal key.
-updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
-updateMinWithKey f t
- = case t of
- Bin sx kx x Tip r -> case f kx x of
- Nothing -> r
- Just x' -> Bin sx kx x' Tip r
- Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
- Tip -> Tip
-
--- | /O(log n)/. Update the value at the maximal key.
-updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
-updateMaxWithKey f t
- = case t of
- Bin sx kx x l Tip -> case f kx x of
- Nothing -> l
- Just x' -> Bin sx kx x' l Tip
- Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
- Tip -> Tip
-
--- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and the map stripped from that element
--- @fail@s (in the monad) when passed an empty map.
-minViewWithKey :: Monad m => Map k a -> m ((k,a), Map k a)
-minViewWithKey Tip = fail "Map.minView: empty map"
-minViewWithKey x = return (deleteFindMin x)
-
--- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and the map stripped from that element
--- @fail@s (in the monad) when passed an empty map.
-maxViewWithKey :: Monad m => Map k a -> m ((k,a), Map k a)
-maxViewWithKey Tip = fail "Map.maxView: empty map"
-maxViewWithKey x = return (deleteFindMax x)
-
--- | /O(log n)/. Retrieves the minimal key\'s value of the map, and the map stripped from that element
--- @fail@s (in the monad) when passed an empty map.
-minView :: Monad m => Map k a -> m (a, Map k a)
-minView Tip = fail "Map.minView: empty map"
-minView x = return (first snd $ deleteFindMin x)
-
--- | /O(log n)/. Retrieves the maximal key\'s value of the map, and the map stripped from that element
--- @fail@s (in the monad) when passed an empty map.
-maxView :: Monad m => Map k a -> m (a, Map k a)
-maxView Tip = fail "Map.maxView: empty map"
-maxView x = return (first snd $ deleteFindMax x)
-
--- Update the 1st component of a tuple (special case of Control.Arrow.first)
-first :: (a -> b) -> (a,c) -> (b,c)
-first f (x,y) = (f x, y)
-
-{--------------------------------------------------------------------
- Union.
---------------------------------------------------------------------}
--- | The union of a list of maps:
--- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
-unions :: Ord k => [Map k a] -> Map k a
-unions ts
- = foldlStrict union empty ts
-
--- | The union of a list of maps, with a combining operation:
--- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
-unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
-unionsWith f ts
- = foldlStrict (unionWith f) empty ts
-
--- | /O(n+m)/.
--- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
--- It prefers @t1@ when duplicate keys are encountered,
--- i.e. (@'union' == 'unionWith' 'const'@).
--- The implementation uses the efficient /hedge-union/ algorithm.
--- Hedge-union is more efficient on (bigset `union` smallset)
-union :: Ord k => Map k a -> Map k a -> Map k a
-union Tip t2 = t2
-union t1 Tip = t1
-union t1 t2 = hedgeUnionL (const LT) (const GT) t1 t2
-
--- left-biased hedge union
-hedgeUnionL cmplo cmphi t1 Tip
- = t1
-hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
- = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
- (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
- where
- cmpkx k = compare kx k
-
--- right-biased hedge union
-hedgeUnionR cmplo cmphi t1 Tip
- = t1
-hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
- = join kx newx (hedgeUnionR cmplo cmpkx l lt)
- (hedgeUnionR cmpkx cmphi r gt)
- where
- cmpkx k = compare kx k
- lt = trim cmplo cmpkx t2
- (found,gt) = trimLookupLo kx cmphi t2
- newx = case found of
- Nothing -> x
- Just (_,y) -> y
-
-{--------------------------------------------------------------------
- Union with a combining function
---------------------------------------------------------------------}
--- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
-unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
-unionWith f m1 m2
- = unionWithKey (\k x y -> f x y) m1 m2
-
--- | /O(n+m)/.
--- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
--- Hedge-union is more efficient on (bigset `union` smallset).
-unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
-unionWithKey f Tip t2 = t2
-unionWithKey f t1 Tip = t1
-unionWithKey f t1 t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
-
-hedgeUnionWithKey f cmplo cmphi t1 Tip
- = t1
-hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
- = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
- (hedgeUnionWithKey f cmpkx cmphi r gt)
- where
- cmpkx k = compare kx k
- lt = trim cmplo cmpkx t2
- (found,gt) = trimLookupLo kx cmphi t2
- newx = case found of
- Nothing -> x
- Just (_,y) -> f kx x y
-
-{--------------------------------------------------------------------
- Difference
---------------------------------------------------------------------}
--- | /O(n+m)/. Difference of two maps.
--- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
-difference :: Ord k => Map k a -> Map k b -> Map k a
-difference Tip t2 = Tip
-difference t1 Tip = t1
-difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
-
-hedgeDiff cmplo cmphi Tip t
- = Tip
-hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeDiff cmplo cmphi t (Bin _ kx x l r)
- = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
- (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
- where
- cmpkx k = compare kx k
-
--- | /O(n+m)/. Difference with a combining function.
--- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
-differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
-differenceWith f m1 m2
- = differenceWithKey (\k x y -> f x y) m1 m2
-
--- | /O(n+m)/. Difference with a combining function. When two equal keys are
--- encountered, the combining function is applied to the key and both values.
--- If it returns 'Nothing', the element is discarded (proper set difference). If
--- it returns (@'Just' y@), the element is updated with a new value @y@.
--- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
-differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
-differenceWithKey f Tip t2 = Tip
-differenceWithKey f t1 Tip = t1
-differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
-
-hedgeDiffWithKey f cmplo cmphi Tip t
- = Tip
-hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
- = case found of
- Nothing -> merge tl tr
- Just (ky,y) ->
- case f ky y x of
- Nothing -> merge tl tr
- Just z -> join ky z tl tr
- where
- cmpkx k = compare kx k
- lt = trim cmplo cmpkx t
- (found,gt) = trimLookupLo kx cmphi t
- tl = hedgeDiffWithKey f cmplo cmpkx lt l
- tr = hedgeDiffWithKey f cmpkx cmphi gt r
-
-
-
-{--------------------------------------------------------------------
- Intersection
---------------------------------------------------------------------}
--- | /O(n+m)/. Intersection of two maps. The values in the first
--- map are returned, i.e. (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
-intersection :: Ord k => Map k a -> Map k b -> Map k a
-intersection m1 m2
- = intersectionWithKey (\k x y -> x) m1 m2
-
--- | /O(n+m)/. Intersection with a combining function.
-intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
-intersectionWith f m1 m2
- = intersectionWithKey (\k x y -> f x y) m1 m2
-
--- | /O(n+m)/. Intersection with a combining function.
--- Intersection is more efficient on (bigset `intersection` smallset)
---intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
---intersectionWithKey f Tip t = Tip
---intersectionWithKey f t Tip = Tip
---intersectionWithKey f t1 t2 = intersectWithKey f t1 t2
---
---intersectWithKey f Tip t = Tip
---intersectWithKey f t Tip = Tip
---intersectWithKey f t (Bin _ kx x l r)
--- = case found of
--- Nothing -> merge tl tr
--- Just y -> join kx (f kx y x) tl tr
--- where
--- (lt,found,gt) = splitLookup kx t
--- tl = intersectWithKey f lt l
--- tr = intersectWithKey f gt r
-
-
-intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
-intersectionWithKey f Tip t = Tip
-intersectionWithKey f t Tip = Tip
-intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =
- if s1 >= s2 then
- let (lt,found,gt) = splitLookupWithKey k2 t1
- tl = intersectionWithKey f lt l2
- tr = intersectionWithKey f gt r2
- in case found of
- Just (k,x) -> join k (f k x x2) tl tr
- Nothing -> merge tl tr
- else let (lt,found,gt) = splitLookup k1 t2
- tl = intersectionWithKey f l1 lt
- tr = intersectionWithKey f r1 gt
- in case found of
- Just x -> join k1 (f k1 x1 x) tl tr
- Nothing -> merge tl tr
-
-
-
-{--------------------------------------------------------------------
- Submap
---------------------------------------------------------------------}
--- | /O(n+m)/.
--- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
-isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
-isSubmapOf m1 m2
- = isSubmapOfBy (==) m1 m2
-
-{- | /O(n+m)/.
- The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
- applied to their respective values. For example, the following
- expressions are all 'True':
-
- > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
-
- But the following are all 'False':
-
- > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
--}
-isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
-isSubmapOfBy f t1 t2
- = (size t1 <= size t2) && (submap' f t1 t2)
-
-submap' f Tip t = True
-submap' f t Tip = False
-submap' f (Bin _ kx x l r) t
- = case found of
- Nothing -> False
- Just y -> f x y && submap' f l lt && submap' f r gt
- where
- (lt,found,gt) = splitLookup kx t
-
--- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
--- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
-isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
-isProperSubmapOf m1 m2
- = isProperSubmapOfBy (==) m1 m2
-
-{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
- @m1@ and @m2@ are not equal,
- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
- applied to their respective values. For example, the following
- expressions are all 'True':
-
- > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
- > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
-
- But the following are all 'False':
-
- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
- > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
--}
-isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
-isProperSubmapOfBy f t1 t2
- = (size t1 < size t2) && (submap' f t1 t2)
-
-{--------------------------------------------------------------------
- Filter and partition
---------------------------------------------------------------------}
--- | /O(n)/. Filter all values that satisfy the predicate.
-filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
-filter p m
- = filterWithKey (\k x -> p x) m
-
--- | /O(n)/. Filter all keys\/values that satisfy the predicate.
-filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
-filterWithKey p Tip = Tip
-filterWithKey p (Bin _ kx x l r)
- | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
- | otherwise = merge (filterWithKey p l) (filterWithKey p r)
-
-
--- | /O(n)/. partition the map according to a predicate. The first
--- map contains all elements that satisfy the predicate, the second all
--- elements that fail the predicate. See also 'split'.
-partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
-partition p m
- = partitionWithKey (\k x -> p x) m
-
--- | /O(n)/. partition the map according to a predicate. The first
--- map contains all elements that satisfy the predicate, the second all
--- elements that fail the predicate. See also 'split'.
-partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
-partitionWithKey p Tip = (Tip,Tip)
-partitionWithKey p (Bin _ kx x l r)
- | p kx x = (join kx x l1 r1,merge l2 r2)
- | otherwise = (merge l1 r1,join kx x l2 r2)
- where
- (l1,l2) = partitionWithKey p l
- (r1,r2) = partitionWithKey p r
-
--- | /O(n)/. Map values and collect the 'Just' results.
-mapMaybe :: Ord k => (a -> Maybe b) -> Map k a -> Map k b
-mapMaybe f m
- = mapMaybeWithKey (\k x -> f x) m
-
--- | /O(n)/. Map keys\/values and collect the 'Just' results.
-mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> Map k a -> Map k b
-mapMaybeWithKey f Tip = Tip
-mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of
- Just y -> join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)
- Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r)
-
--- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
-mapEither :: Ord k => (a -> Either b c) -> Map k a -> (Map k b, Map k c)
-mapEither f m
- = mapEitherWithKey (\k x -> f x) m
-
--- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
-mapEitherWithKey :: Ord k =>
- (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)
-mapEitherWithKey f Tip = (Tip, Tip)
-mapEitherWithKey f (Bin _ kx x l r) = case f kx x of
- Left y -> (join kx y l1 r1, merge l2 r2)
- Right z -> (merge l1 r1, join kx z l2 r2)
- where
- (l1,l2) = mapEitherWithKey f l
- (r1,r2) = mapEitherWithKey f r
-
-{--------------------------------------------------------------------
- Mapping
---------------------------------------------------------------------}
--- | /O(n)/. Map a function over all values in the map.
-map :: (a -> b) -> Map k a -> Map k b
-map f m
- = mapWithKey (\k x -> f x) m
-
--- | /O(n)/. Map a function over all values in the map.
-mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
-mapWithKey f Tip = Tip
-mapWithKey f (Bin sx kx x l r)
- = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
-
--- | /O(n)/. The function 'mapAccum' threads an accumulating
--- argument through the map in ascending order of keys.
-mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccum f a m
- = mapAccumWithKey (\a k x -> f a x) a m
-
--- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
--- argument through the map in ascending order of keys.
-mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccumWithKey f a t
- = mapAccumL f a t
-
--- | /O(n)/. The function 'mapAccumL' threads an accumulating
--- argument throught the map in ascending order of keys.
-mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccumL f a t
- = case t of
- Tip -> (a,Tip)
- Bin sx kx x l r
- -> let (a1,l') = mapAccumL f a l
- (a2,x') = f a1 kx x
- (a3,r') = mapAccumL f a2 r
- in (a3,Bin sx kx x' l' r')
-
--- | /O(n)/. The function 'mapAccumR' threads an accumulating
--- argument throught the map in descending order of keys.
-mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccumR f a t
- = case t of
- Tip -> (a,Tip)
- Bin sx kx x l r
- -> let (a1,r') = mapAccumR f a r
- (a2,x') = f a1 kx x
- (a3,l') = mapAccumR f a2 l
- in (a3,Bin sx kx x' l' r')
-
--- | /O(n*log n)/.
--- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
---
--- The size of the result may be smaller if @f@ maps two or more distinct
--- keys to the same new key. In this case the value at the smallest of
--- these keys is retained.
-
-mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
-mapKeys = mapKeysWith (\x y->x)
-
--- | /O(n*log n)/.
--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
---
--- The size of the result may be smaller if @f@ maps two or more distinct
--- keys to the same new key. In this case the associated values will be
--- combined using @c@.
-
-mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
-mapKeysWith c f = fromListWith c . List.map fFirst . toList
- where fFirst (x,y) = (f x, y)
-
-
--- | /O(n)/.
--- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
--- is strictly monotonic.
--- /The precondition is not checked./
--- Semi-formally, we have:
---
--- > and [x < y ==> f x < f y | x <- ls, y <- ls]
--- > ==> mapKeysMonotonic f s == mapKeys f s
--- > where ls = keys s
-
-mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
-mapKeysMonotonic f Tip = Tip
-mapKeysMonotonic f (Bin sz k x l r) =
- Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
-
-{--------------------------------------------------------------------
- Folds
---------------------------------------------------------------------}
-
--- | /O(n)/. Fold the values in the map, such that
--- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
--- For example,
---
--- > elems map = fold (:) [] map
---
-fold :: (a -> b -> b) -> b -> Map k a -> b
-fold f z m
- = foldWithKey (\k x z -> f x z) z m
-
--- | /O(n)/. Fold the keys and values in the map, such that
--- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
--- For example,
---
--- > keys map = foldWithKey (\k x ks -> k:ks) [] map
---
-foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
-foldWithKey f z t
- = foldr f z t
-
--- | /O(n)/. In-order fold.
-foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
-foldi f z Tip = z
-foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)
-
--- | /O(n)/. Post-order fold.
-foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
-foldr f z Tip = z
-foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
-
--- | /O(n)/. Pre-order fold.
-foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
-foldl f z Tip = z
-foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
-
-{--------------------------------------------------------------------
- List variations
---------------------------------------------------------------------}
--- | /O(n)/.
--- Return all elements of the map in the ascending order of their keys.
-elems :: Map k a -> [a]
-elems m
- = [x | (k,x) <- assocs m]
-
--- | /O(n)/. Return all keys of the map in ascending order.
-keys :: Map k a -> [k]
-keys m
- = [k | (k,x) <- assocs m]
-
--- | /O(n)/. The set of all keys of the map.
-keysSet :: Map k a -> Set.Set k
-keysSet m = Set.fromDistinctAscList (keys m)
-
--- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
-assocs :: Map k a -> [(k,a)]
-assocs m
- = toList m
-
-{--------------------------------------------------------------------
- Lists
- use [foldlStrict] to reduce demand on the control-stack
---------------------------------------------------------------------}
--- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
-fromList :: Ord k => [(k,a)] -> Map k a
-fromList xs
- = foldlStrict ins empty xs
- where
- ins t (k,x) = insert k x t
-
--- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
-fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
-fromListWith f xs
- = fromListWithKey (\k x y -> f x y) xs
-
--- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
-fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
-fromListWithKey f xs
- = foldlStrict ins empty xs
- where
- ins t (k,x) = insertWithKey f k x t
-
--- | /O(n)/. Convert to a list of key\/value pairs.
-toList :: Map k a -> [(k,a)]
-toList t = toAscList t
-
--- | /O(n)/. Convert to an ascending list.
-toAscList :: Map k a -> [(k,a)]
-toAscList t = foldr (\k x xs -> (k,x):xs) [] t
-
--- | /O(n)/.
-toDescList :: Map k a -> [(k,a)]
-toDescList t = foldl (\xs k x -> (k,x):xs) [] t
-
-
-{--------------------------------------------------------------------
- Building trees from ascending/descending lists can be done in linear time.
-
- Note that if [xs] is ascending that:
- fromAscList xs == fromList xs
- fromAscListWith f xs == fromListWith f xs
---------------------------------------------------------------------}
--- | /O(n)/. Build a map from an ascending list in linear time.
--- /The precondition (input list is ascending) is not checked./
-fromAscList :: Eq k => [(k,a)] -> Map k a
-fromAscList xs
- = fromAscListWithKey (\k x y -> x) xs
-
--- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
--- /The precondition (input list is ascending) is not checked./
-fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
-fromAscListWith f xs
- = fromAscListWithKey (\k x y -> f x y) xs
-
--- | /O(n)/. Build a map from an ascending list in linear time with a
--- combining function for equal keys.
--- /The precondition (input list is ascending) is not checked./
-fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
-fromAscListWithKey f xs
- = fromDistinctAscList (combineEq f xs)
- where
- -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
- combineEq f xs
- = case xs of
- [] -> []
- [x] -> [x]
- (x:xx) -> combineEq' x xx
-
- combineEq' z [] = [z]
- combineEq' z@(kz,zz) (x@(kx,xx):xs)
- | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs
- | otherwise = z:combineEq' x xs
-
-
--- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
--- /The precondition is not checked./
-fromDistinctAscList :: [(k,a)] -> Map k a
-fromDistinctAscList xs
- = build const (length xs) xs
- where
- -- 1) use continutations so that we use heap space instead of stack space.
- -- 2) special case for n==5 to build bushier trees.
- build c 0 xs = c Tip xs
- build c 5 xs = case xs of
- ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
- -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
- build c n xs = seq nr $ build (buildR nr c) nl xs
- where
- nl = n `div` 2
- nr = n - nl - 1
-
- buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
- buildB l k x c r zs = c (bin k x l r) zs
-
-
-
-{--------------------------------------------------------------------
- Utility functions that return sub-ranges of the original
- tree. Some functions take a comparison function as argument to
- allow comparisons against infinite values. A function [cmplo k]
- should be read as [compare lo k].
-
- [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
- and [cmphi k == GT] for the key [k] of the root.
- [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
- [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
-
- [split k t] Returns two trees [l] and [r] where all keys
- in [l] are <[k] and all keys in [r] are >[k].
- [splitLookup k t] Just like [split] but also returns whether [k]
- was found in the tree.
---------------------------------------------------------------------}
-
-{--------------------------------------------------------------------
- [trim lo hi t] trims away all subtrees that surely contain no
- values between the range [lo] to [hi]. The returned tree is either
- empty or the key of the root is between @lo@ and @hi@.
---------------------------------------------------------------------}
-trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
-trim cmplo cmphi Tip = Tip
-trim cmplo cmphi t@(Bin sx kx x l r)
- = case cmplo kx of
- LT -> case cmphi kx of
- GT -> t
- le -> trim cmplo cmphi l
- ge -> trim cmplo cmphi r
-
-trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe (k,a), Map k a)
-trimLookupLo lo cmphi Tip = (Nothing,Tip)
-trimLookupLo lo cmphi t@(Bin sx kx x l r)
- = case compare lo kx of
- LT -> case cmphi kx of
- GT -> (lookupAssoc lo t, t)
- le -> trimLookupLo lo cmphi l
- GT -> trimLookupLo lo cmphi r
- EQ -> (Just (kx,x),trim (compare lo) cmphi r)
-
-
-{--------------------------------------------------------------------
- [filterGt k t] filter all keys >[k] from tree [t]
- [filterLt k t] filter all keys <[k] from tree [t]
---------------------------------------------------------------------}
-filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
-filterGt cmp Tip = Tip
-filterGt cmp (Bin sx kx x l r)
- = case cmp kx of
- LT -> join kx x (filterGt cmp l) r
- GT -> filterGt cmp r
- EQ -> r
-
-filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
-filterLt cmp Tip = Tip
-filterLt cmp (Bin sx kx x l r)
- = case cmp kx of
- LT -> filterLt cmp l
- GT -> join kx x l (filterLt cmp r)
- EQ -> l
-
-{--------------------------------------------------------------------
- Split
---------------------------------------------------------------------}
--- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
--- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
-split :: Ord k => k -> Map k a -> (Map k a,Map k a)
-split k Tip = (Tip,Tip)
-split k (Bin sx kx x l r)
- = case compare k kx of
- LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
- GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
- EQ -> (l,r)
-
--- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
--- like 'split' but also returns @'lookup' k map@.
-splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
-splitLookup k Tip = (Tip,Nothing,Tip)
-splitLookup k (Bin sx kx x l r)
- = case compare k kx of
- LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)
- GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)
- EQ -> (l,Just x,r)
-
--- | /O(log n)/.
-splitLookupWithKey :: Ord k => k -> Map k a -> (Map k a,Maybe (k,a),Map k a)
-splitLookupWithKey k Tip = (Tip,Nothing,Tip)
-splitLookupWithKey k (Bin sx kx x l r)
- = case compare k kx of
- LT -> let (lt,z,gt) = splitLookupWithKey k l in (lt,z,join kx x gt r)
- GT -> let (lt,z,gt) = splitLookupWithKey k r in (join kx x l lt,z,gt)
- EQ -> (l,Just (kx, x),r)
-
--- | /O(log n)/. Performs a 'split' but also returns whether the pivot
--- element was found in the original set.
-splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)
-splitMember x t = let (l,m,r) = splitLookup x t in
- (l,maybe False (const True) m,r)
-
-
-{--------------------------------------------------------------------
- Utility functions that maintain the balance properties of the tree.
- All constructors assume that all values in [l] < [k] and all values
- in [r] > [k], and that [l] and [r] are valid trees.
-
- In order of sophistication:
- [Bin sz k x l r] The type constructor.
- [bin k x l r] Maintains the correct size, assumes that both [l]
- and [r] are balanced with respect to each other.
- [balance k x l r] Restores the balance and size.
- Assumes that the original tree was balanced and
- that [l] or [r] has changed by at most one element.
- [join k x l r] Restores balance and size.
-
- Furthermore, we can construct a new tree from two trees. Both operations
- assume that all values in [l] < all values in [r] and that [l] and [r]
- are valid:
- [glue l r] Glues [l] and [r] together. Assumes that [l] and
- [r] are already balanced with respect to each other.
- [merge l r] Merges two trees and restores balance.
-
- Note: in contrast to Adam's paper, we use (<=) comparisons instead
- of (<) comparisons in [join], [merge] and [balance].
- Quickcheck (on [difference]) showed that this was necessary in order
- to maintain the invariants. It is quite unsatisfactory that I haven't
- been able to find out why this is actually the case! Fortunately, it
- doesn't hurt to be a bit more conservative.
---------------------------------------------------------------------}
-
-{--------------------------------------------------------------------
- Join
---------------------------------------------------------------------}
-join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
-join kx x Tip r = insertMin kx x r
-join kx x l Tip = insertMax kx x l
-join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
- | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
- | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
- | otherwise = bin kx x l r
-
-
--- insertMin and insertMax don't perform potentially expensive comparisons.
-insertMax,insertMin :: k -> a -> Map k a -> Map k a
-insertMax kx x t
- = case t of
- Tip -> singleton kx x
- Bin sz ky y l r
- -> balance ky y l (insertMax kx x r)
-
-insertMin kx x t
- = case t of
- Tip -> singleton kx x
- Bin sz ky y l r
- -> balance ky y (insertMin kx x l) r
-
-{--------------------------------------------------------------------
- [merge l r]: merges two trees.
---------------------------------------------------------------------}
-merge :: Map k a -> Map k a -> Map k a
-merge Tip r = r
-merge l Tip = l
-merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
- | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
- | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
- | otherwise = glue l r
-
-{--------------------------------------------------------------------
- [glue l r]: glues two trees together.
- Assumes that [l] and [r] are already balanced with respect to each other.
---------------------------------------------------------------------}
-glue :: Map k a -> Map k a -> Map k a
-glue Tip r = r
-glue l Tip = l
-glue l r
- | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
- | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
-
-
--- | /O(log n)/. Delete and find the minimal element.
-deleteFindMin :: Map k a -> ((k,a),Map k a)
-deleteFindMin t
- = case t of
- Bin _ k x Tip r -> ((k,x),r)
- Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
- Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
-
--- | /O(log n)/. Delete and find the maximal element.
-deleteFindMax :: Map k a -> ((k,a),Map k a)
-deleteFindMax t
- = case t of
- Bin _ k x l Tip -> ((k,x),l)
- Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
- Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
-
-
-{--------------------------------------------------------------------
- [balance l x r] balances two trees with value x.
- The sizes of the trees should balance after decreasing the
- size of one of them. (a rotation).
-
- [delta] is the maximal relative difference between the sizes of
- two trees, it corresponds with the [w] in Adams' paper.
- [ratio] is the ratio between an outer and inner sibling of the
- heavier subtree in an unbalanced setting. It determines
- whether a double or single rotation should be performed
- to restore balance. It is correspondes with the inverse
- of $\alpha$ in Adam's article.
-
- Note that:
- - [delta] should be larger than 4.646 with a [ratio] of 2.
- - [delta] should be larger than 3.745 with a [ratio] of 1.534.
-
- - A lower [delta] leads to a more 'perfectly' balanced tree.
- - A higher [delta] performs less rebalancing.
-
- - Balancing is automatic for random data and a balancing
- scheme is only necessary to avoid pathological worst cases.
- Almost any choice will do, and in practice, a rather large
- [delta] may perform better than smaller one.
-
- Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
- to decide whether a single or double rotation is needed. Allthough
- he actually proves that this ratio is needed to maintain the
- invariants, his implementation uses an invalid ratio of [1].
---------------------------------------------------------------------}
-delta,ratio :: Int
-delta = 5
-ratio = 2
-
-balance :: k -> a -> Map k a -> Map k a -> Map k a
-balance k x l r
- | sizeL + sizeR <= 1 = Bin sizeX k x l r
- | sizeR >= delta*sizeL = rotateL k x l r
- | sizeL >= delta*sizeR = rotateR k x l r
- | otherwise = Bin sizeX k x l r
- where
- sizeL = size l
- sizeR = size r
- sizeX = sizeL + sizeR + 1
-
--- rotate
-rotateL k x l r@(Bin _ _ _ ly ry)
- | size ly < ratio*size ry = singleL k x l r
- | otherwise = doubleL k x l r
-
-rotateR k x l@(Bin _ _ _ ly ry) r
- | size ry < ratio*size ly = singleR k x l r
- | otherwise = doubleR k x l r
-
--- basic rotations
-singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
-singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
-
-doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)
-doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)
-
-
-{--------------------------------------------------------------------
- The bin constructor maintains the size of the tree
---------------------------------------------------------------------}
-bin :: k -> a -> Map k a -> Map k a -> Map k a
-bin k x l r
- = Bin (size l + size r + 1) k x l r
-
-
-{--------------------------------------------------------------------
- Eq converts the tree to a list. In a lazy setting, this
- actually seems one of the faster methods to compare two trees
- and it is certainly the simplest :-)
---------------------------------------------------------------------}
-instance (Eq k,Eq a) => Eq (Map k a) where
- t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
-
-{--------------------------------------------------------------------
- Ord
---------------------------------------------------------------------}
-
-instance (Ord k, Ord v) => Ord (Map k v) where
- compare m1 m2 = compare (toAscList m1) (toAscList m2)
-
-{--------------------------------------------------------------------
- Functor
---------------------------------------------------------------------}
-instance Functor (Map k) where
- fmap f m = map f m
-
-instance Traversable (Map k) where
- traverse f Tip = pure Tip
- traverse f (Bin s k v l r)
- = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r
-
-instance Foldable (Map k) where
- foldMap _f Tip = mempty
- foldMap f (Bin _s _k v l r)
- = foldMap f l `mappend` f v `mappend` foldMap f r
-
-{--------------------------------------------------------------------
- Read
---------------------------------------------------------------------}
-instance (Ord k, Read k, Read e) => Read (Map k e) where
-#ifdef __GLASGOW_HASKELL__
- readPrec = parens $ prec 10 $ do
- Ident "fromList" <- lexP
- xs <- readPrec
- return (fromList xs)
-
- readListPrec = readListPrecDefault
-#else
- readsPrec p = readParen (p > 10) $ \ r -> do
- ("fromList",s) <- lex r
- (xs,t) <- reads s
- return (fromList xs,t)
-#endif
-
--- parses a pair of things with the syntax a:=b
-readPair :: (Read a, Read b) => ReadS (a,b)
-readPair s = do (a, ct1) <- reads s
- (":=", ct2) <- lex ct1
- (b, ct3) <- reads ct2
- return ((a,b), ct3)
-
-{--------------------------------------------------------------------
- Show
---------------------------------------------------------------------}
-instance (Show k, Show a) => Show (Map k a) where
- showsPrec d m = showParen (d > 10) $
- showString "fromList " . shows (toList m)
-
-showMap :: (Show k,Show a) => [(k,a)] -> ShowS
-showMap []
- = showString "{}"
-showMap (x:xs)
- = showChar '{' . showElem x . showTail xs
- where
- showTail [] = showChar '}'
- showTail (x:xs) = showString ", " . showElem x . showTail xs
-
- showElem (k,x) = shows k . showString " := " . shows x
-
-
--- | /O(n)/. Show the tree that implements the map. The tree is shown
--- in a compressed, hanging format.
-showTree :: (Show k,Show a) => Map k a -> String
-showTree m
- = showTreeWith showElem True False m
- where
- showElem k x = show k ++ ":=" ++ show x
-
-
-{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
- the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
- @wide@ is 'True', an extra wide version is shown.
-
-> Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
-> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
-> (4,())
-> +--(2,())
-> | +--(1,())
-> | +--(3,())
-> +--(5,())
->
-> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
-> (4,())
-> |
-> +--(2,())
-> | |
-> | +--(1,())
-> | |
-> | +--(3,())
-> |
-> +--(5,())
->
-> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
-> +--(5,())
-> |
-> (4,())
-> |
-> | +--(3,())
-> | |
-> +--(2,())
-> |
-> +--(1,())
-
--}
-showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
-showTreeWith showelem hang wide t
- | hang = (showsTreeHang showelem wide [] t) ""
- | otherwise = (showsTree showelem wide [] [] t) ""
-
-showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
-showsTree showelem wide lbars rbars t
- = case t of
- Tip -> showsBars lbars . showString "|\n"
- Bin sz kx x Tip Tip
- -> showsBars lbars . showString (showelem kx x) . showString "\n"
- Bin sz kx x l r
- -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
- showWide wide rbars .
- showsBars lbars . showString (showelem kx x) . showString "\n" .
- showWide wide lbars .
- showsTree showelem wide (withEmpty lbars) (withBar lbars) l
-
-showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
-showsTreeHang showelem wide bars t
- = case t of
- Tip -> showsBars bars . showString "|\n"
- Bin sz kx x Tip Tip
- -> showsBars bars . showString (showelem kx x) . showString "\n"
- Bin sz kx x l r
- -> showsBars bars . showString (showelem kx x) . showString "\n" .
- showWide wide bars .
- showsTreeHang showelem wide (withBar bars) l .
- showWide wide bars .
- showsTreeHang showelem wide (withEmpty bars) r
-
-
-showWide wide bars
- | wide = showString (concat (reverse bars)) . showString "|\n"
- | otherwise = id
-
-showsBars :: [String] -> ShowS
-showsBars bars
- = case bars of
- [] -> id
- _ -> showString (concat (reverse (tail bars))) . showString node
-
-node = "+--"
-withBar bars = "| ":bars
-withEmpty bars = " ":bars
-
-{--------------------------------------------------------------------
- Typeable
---------------------------------------------------------------------}
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE2(Map,mapTc,"Map")
-
-{--------------------------------------------------------------------
- Assertions
---------------------------------------------------------------------}
--- | /O(n)/. Test if the internal map structure is valid.
-valid :: Ord k => Map k a -> Bool
-valid t
- = balanced t && ordered t && validsize t
-
-ordered t
- = bounded (const True) (const True) t
- where
- bounded lo hi t
- = case t of
- Tip -> True
- Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
-
--- | Exported only for "Debug.QuickCheck"
-balanced :: Map k a -> Bool
-balanced t
- = case t of
- Tip -> True
- Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
- balanced l && balanced r
-
-
-validsize t
- = (realsize t == Just (size t))
- where
- realsize t
- = case t of
- Tip -> Just 0
- Bin sz kx x l r -> case (realsize l,realsize r) of
- (Just n,Just m) | n+m+1 == sz -> Just sz
- other -> Nothing
-
-{--------------------------------------------------------------------
- Utilities
---------------------------------------------------------------------}
-foldlStrict f z xs
- = case xs of
- [] -> z
- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
-
-
-{-
-{--------------------------------------------------------------------
- Testing
---------------------------------------------------------------------}
-testTree xs = fromList [(x,"*") | x <- xs]
-test1 = testTree [1..20]
-test2 = testTree [30,29..10]
-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
-
-{--------------------------------------------------------------------
- QuickCheck
---------------------------------------------------------------------}
-qcheck prop
- = check config prop
- where
- config = Config
- { configMaxTest = 500
- , configMaxFail = 5000
- , configSize = \n -> (div n 2 + 3)
- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
- }
-
-
-{--------------------------------------------------------------------
- Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
- arbitrary = sized (arbtree 0 maxkey)
- where maxkey = 10000
-
-arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
-arbtree lo hi n
- | n <= 0 = return Tip
- | lo >= hi = return Tip
- | otherwise = do{ x <- arbitrary
- ; i <- choose (lo,hi)
- ; m <- choose (1,30)
- ; let (ml,mr) | m==(1::Int)= (1,2)
- | m==2 = (2,1)
- | m==3 = (1,1)
- | otherwise = (2,2)
- ; l <- arbtree lo (i-1) (n `div` ml)
- ; r <- arbtree (i+1) hi (n `div` mr)
- ; return (bin (toEnum i) x l r)
- }
-
-
-{--------------------------------------------------------------------
- Valid tree's
---------------------------------------------------------------------}
-forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
-forValid f
- = forAll arbitrary $ \t ->
--- classify (balanced t) "balanced" $
- classify (size t == 0) "empty" $
- classify (size t > 0 && size t <= 10) "small" $
- classify (size t > 10 && size t <= 64) "medium" $
- classify (size t > 64) "large" $
- balanced t ==> f t
-
-forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
-forValidIntTree f
- = forValid f
-
-forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
-forValidUnitTree f
- = forValid f
-
-
-prop_Valid
- = forValidUnitTree $ \t -> valid t
-
-{--------------------------------------------------------------------
- Single, Insert, Delete
---------------------------------------------------------------------}
-prop_Single :: Int -> Int -> Bool
-prop_Single k x
- = (insert k x empty == singleton k x)
-
-prop_InsertValid :: Int -> Property
-prop_InsertValid k
- = forValidUnitTree $ \t -> valid (insert k () t)
-
-prop_InsertDelete :: Int -> Map Int () -> Property
-prop_InsertDelete k t
- = (lookup k t == Nothing) ==> delete k (insert k () t) == t
-
-prop_DeleteValid :: Int -> Property
-prop_DeleteValid k
- = forValidUnitTree $ \t ->
- valid (delete k (insert k () t))
-
-{--------------------------------------------------------------------
- Balance
---------------------------------------------------------------------}
-prop_Join :: Int -> Property
-prop_Join k
- = forValidUnitTree $ \t ->
- let (l,r) = split k t
- in valid (join k () l r)
-
-prop_Merge :: Int -> Property
-prop_Merge k
- = forValidUnitTree $ \t ->
- let (l,r) = split k t
- in valid (merge l r)
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
-prop_UnionValid :: Property
-prop_UnionValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (union t1 t2)
-
-prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
-prop_UnionInsert k x t
- = union (singleton k x) t == insert k x t
-
-prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
-prop_UnionAssoc t1 t2 t3
- = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
-prop_UnionComm t1 t2
- = (union t1 t2 == unionWith (\x y -> y) t2 t1)
-
-prop_UnionWithValid
- = forValidIntTree $ \t1 ->
- forValidIntTree $ \t2 ->
- valid (unionWithKey (\k x y -> x+y) t1 t2)
-
-prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_UnionWith xs ys
- = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
- == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
-
-prop_DiffValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (difference t1 t2)
-
-prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_Diff xs ys
- = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
- == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
-
-prop_IntValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (intersection t1 t2)
-
-prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_Int xs ys
- = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
- == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [(x,()) | x <- [0..n::Int]]
- in fromAscList xs == fromList xs
-
-prop_List :: [Int] -> Bool
-prop_List xs
- = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])
--}
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Maybe
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : stable
--- Portability : portable
---
--- The Maybe type, and associated operations.
---
------------------------------------------------------------------------------
-
-module Data.Maybe
- (
- Maybe(Nothing,Just)-- instance of: Eq, Ord, Show, Read,
- -- Functor, Monad, MonadPlus
-
- , maybe -- :: b -> (a -> b) -> Maybe a -> b
-
- , isJust -- :: Maybe a -> Bool
- , isNothing -- :: Maybe a -> Bool
- , fromJust -- :: Maybe a -> a
- , fromMaybe -- :: a -> Maybe a -> a
- , listToMaybe -- :: [a] -> Maybe a
- , maybeToList -- :: Maybe a -> [a]
- , catMaybes -- :: [Maybe a] -> [a]
- , mapMaybe -- :: (a -> Maybe b) -> [a] -> [b]
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import {-# SOURCE #-} GHC.Err ( error )
-import GHC.Base
-#endif
-
-#ifdef __NHC__
-import Prelude
-import Prelude (Maybe(..), maybe)
-import Maybe
- ( isJust
- , isNothing
- , fromJust
- , fromMaybe
- , listToMaybe
- , maybeToList
- , catMaybes
- , mapMaybe
- )
-#else
-
-#ifndef __HUGS__
--- ---------------------------------------------------------------------------
--- The Maybe type, and instances
-
--- | The 'Maybe' type encapsulates an optional value. A value of type
--- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@),
--- or it is empty (represented as 'Nothing'). Using 'Maybe' is a good way to
--- deal with errors or exceptional cases without resorting to drastic
--- measures such as 'error'.
---
--- The 'Maybe' type is also a monad. It is a simple kind of error
--- monad, where all errors are represented by 'Nothing'. A richer
--- error monad can be built using the 'Data.Either.Either' type.
-
-data Maybe a = Nothing | Just a
- deriving (Eq, Ord)
-
-instance Functor Maybe where
- fmap _ Nothing = Nothing
- fmap f (Just a) = Just (f a)
-
-instance Monad Maybe where
- (Just x) >>= k = k x
- Nothing >>= _ = Nothing
-
- (Just _) >> k = k
- Nothing >> _ = Nothing
-
- return = Just
- fail _ = Nothing
-
--- ---------------------------------------------------------------------------
--- Functions over Maybe
-
--- | The 'maybe' function takes a default value, a function, and a 'Maybe'
--- value. If the 'Maybe' value is 'Nothing', the function returns the
--- default value. Otherwise, it applies the function to the value inside
--- the 'Just' and returns the result.
-maybe :: b -> (a -> b) -> Maybe a -> b
-maybe n _ Nothing = n
-maybe _ f (Just x) = f x
-#endif /* __HUGS__ */
-
--- | The 'isJust' function returns 'True' iff its argument is of the
--- form @Just _@.
-isJust :: Maybe a -> Bool
-isJust Nothing = False
-isJust _ = True
-
--- | The 'isNothing' function returns 'True' iff its argument is 'Nothing'.
-isNothing :: Maybe a -> Bool
-isNothing Nothing = True
-isNothing _ = False
-
--- | The 'fromJust' function extracts the element out of a 'Just' and
--- throws an error if its argument is 'Nothing'.
-fromJust :: Maybe a -> a
-fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck
-fromJust (Just x) = x
-
--- | The 'fromMaybe' function takes a default value and and 'Maybe'
--- value. If the 'Maybe' is 'Nothing', it returns the default values;
--- otherwise, it returns the value contained in the 'Maybe'.
-fromMaybe :: a -> Maybe a -> a
-fromMaybe d x = case x of {Nothing -> d;Just v -> v}
-
--- | The 'maybeToList' function returns an empty list when given
--- 'Nothing' or a singleton list when not given 'Nothing'.
-maybeToList :: Maybe a -> [a]
-maybeToList Nothing = []
-maybeToList (Just x) = [x]
-
--- | The 'listToMaybe' function returns 'Nothing' on an empty list
--- or @'Just' a@ where @a@ is the first element of the list.
-listToMaybe :: [a] -> Maybe a
-listToMaybe [] = Nothing
-listToMaybe (a:_) = Just a
-
--- | The 'catMaybes' function takes a list of 'Maybe's and returns
--- a list of all the 'Just' values.
-catMaybes :: [Maybe a] -> [a]
-catMaybes ls = [x | Just x <- ls]
-
--- | The 'mapMaybe' function is a version of 'map' which can throw
--- out elements. In particular, the functional argument returns
--- something of type @'Maybe' b@. If this is 'Nothing', no element
--- is added on to the result list. If it just @'Just' b@, then @b@ is
--- included in the result list.
-mapMaybe :: (a -> Maybe b) -> [a] -> [b]
-mapMaybe _ [] = []
-mapMaybe f (x:xs) =
- let rs = mapMaybe f xs in
- case f x of
- Nothing -> rs
- Just r -> r:rs
-
-#endif /* else not __NHC__ */
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Monoid
--- Copyright : (c) Andy Gill 2001,
--- (c) Oregon Graduate Institute of Science and Technology, 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- The Monoid class with various general-purpose instances.
---
--- Inspired by the paper
--- /Functional Programming with Overloading and
--- Higher-Order Polymorphism/,
--- Mark P Jones (<http://www.cse.ogi.edu/~mpj/>)
--- Advanced School of Functional Programming, 1995.
------------------------------------------------------------------------------
-
-module Data.Monoid (
- -- * Monoid typeclass
- Monoid(..),
- Dual(..),
- Endo(..),
- -- * Bool wrappers
- All(..),
- Any(..),
- -- * Num wrappers
- Sum(..),
- Product(..),
- -- * Maybe wrappers
- -- $MaybeExamples
- First(..),
- Last(..)
- ) where
-
-import Prelude
-
-{-
--- just for testing
-import Data.Maybe
-import Test.QuickCheck
--- -}
-
--- ---------------------------------------------------------------------------
--- | The monoid class.
--- A minimal complete definition must supply 'mempty' and 'mappend',
--- and these should satisfy the monoid laws.
-
-class Monoid a where
- mempty :: a
- -- ^ Identity of 'mappend'
- mappend :: a -> a -> a
- -- ^ An associative operation
- mconcat :: [a] -> a
-
- -- ^ Fold a list using the monoid.
- -- For most types, the default definition for 'mconcat' will be
- -- used, but the function is included in the class definition so
- -- that an optimized version can be provided for specific types.
-
- mconcat = foldr mappend mempty
-
--- Monoid instances.
-
-instance Monoid [a] where
- mempty = []
- mappend = (++)
-
-instance Monoid b => Monoid (a -> b) where
- mempty _ = mempty
- mappend f g x = f x `mappend` g x
-
-instance Monoid () where
- -- Should it be strict?
- mempty = ()
- _ `mappend` _ = ()
- mconcat _ = ()
-
-instance (Monoid a, Monoid b) => Monoid (a,b) where
- mempty = (mempty, mempty)
- (a1,b1) `mappend` (a2,b2) =
- (a1 `mappend` a2, b1 `mappend` b2)
-
-instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where
- mempty = (mempty, mempty, mempty)
- (a1,b1,c1) `mappend` (a2,b2,c2) =
- (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2)
-
-instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where
- mempty = (mempty, mempty, mempty, mempty)
- (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) =
- (a1 `mappend` a2, b1 `mappend` b2,
- c1 `mappend` c2, d1 `mappend` d2)
-
-instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>
- Monoid (a,b,c,d,e) where
- mempty = (mempty, mempty, mempty, mempty, mempty)
- (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) =
- (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2,
- d1 `mappend` d2, e1 `mappend` e2)
-
--- lexicographical ordering
-instance Monoid Ordering where
- mempty = EQ
- LT `mappend` _ = LT
- EQ `mappend` y = y
- GT `mappend` _ = GT
-
--- | The dual of a monoid, obtained by swapping the arguments of 'mappend'.
-newtype Dual a = Dual { getDual :: a }
- deriving (Eq, Ord, Read, Show, Bounded)
-
-instance Monoid a => Monoid (Dual a) where
- mempty = Dual mempty
- Dual x `mappend` Dual y = Dual (y `mappend` x)
-
--- | The monoid of endomorphisms under composition.
-newtype Endo a = Endo { appEndo :: a -> a }
-
-instance Monoid (Endo a) where
- mempty = Endo id
- Endo f `mappend` Endo g = Endo (f . g)
-
--- | Boolean monoid under conjunction.
-newtype All = All { getAll :: Bool }
- deriving (Eq, Ord, Read, Show, Bounded)
-
-instance Monoid All where
- mempty = All True
- All x `mappend` All y = All (x && y)
-
--- | Boolean monoid under disjunction.
-newtype Any = Any { getAny :: Bool }
- deriving (Eq, Ord, Read, Show, Bounded)
-
-instance Monoid Any where
- mempty = Any False
- Any x `mappend` Any y = Any (x || y)
-
--- | Monoid under addition.
-newtype Sum a = Sum { getSum :: a }
- deriving (Eq, Ord, Read, Show, Bounded)
-
-instance Num a => Monoid (Sum a) where
- mempty = Sum 0
- Sum x `mappend` Sum y = Sum (x + y)
-
--- | Monoid under multiplication.
-newtype Product a = Product { getProduct :: a }
- deriving (Eq, Ord, Read, Show, Bounded)
-
-instance Num a => Monoid (Product a) where
- mempty = Product 1
- Product x `mappend` Product y = Product (x * y)
-
--- $MaybeExamples
--- To implement @find@ or @findLast@ on any 'Foldable':
---
--- @
--- findLast :: Foldable t => (a -> Bool) -> t a -> Maybe a
--- findLast pred = getLast . foldMap (\x -> if pred x
--- then Last (Just x)
--- else Last Nothing)
--- @
---
--- Much of "Data.Map"'s interface can be implemented with
--- 'Data.Map.alter'. Some of the rest can be implemented with a new
--- @alterA@ function and either 'First' or 'Last':
---
--- > alterA :: (Applicative f, Ord k) =>
--- > (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
--- >
--- > instance Monoid a => Applicative ((,) a) -- from Control.Applicative
---
--- @
--- insertLookupWithKey :: Ord k => (k -> v -> v -> v) -> k -> v
--- -> Map k v -> (Maybe v, Map k v)
--- insertLookupWithKey combine key value =
--- Arrow.first getFirst . alterA doChange key
--- where
--- doChange Nothing = (First Nothing, Just value)
--- doChange (Just oldValue) =
--- (First (Just oldValue),
--- Just (combine key value oldValue))
--- @
-
--- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to
--- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be
--- turned into a monoid simply by adjoining an element @e@ not in @S@
--- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since
--- there is no \"Semigroup\" typeclass providing just 'mappend', we
--- use 'Monoid' instead.
-instance Monoid a => Monoid (Maybe a) where
- mempty = Nothing
- Nothing `mappend` m = m
- m `mappend` Nothing = m
- Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)
-
-
--- | Maybe monoid returning the leftmost non-Nothing value.
-newtype First a = First { getFirst :: Maybe a }
-#ifndef __HADDOCK__
- deriving (Eq, Ord, Read, Show)
-#else /* __HADDOCK__ */
-instance Eq a => Eq (First a)
-instance Ord a => Ord (First a)
-instance Read a => Read (First a)
-instance Show a => Show (First a)
-#endif
-
-instance Monoid (First a) where
- mempty = First Nothing
- r@(First (Just _)) `mappend` _ = r
- First Nothing `mappend` r = r
-
--- | Maybe monoid returning the rightmost non-Nothing value.
-newtype Last a = Last { getLast :: Maybe a }
-#ifndef __HADDOCK__
- deriving (Eq, Ord, Read, Show)
-#else /* __HADDOCK__ */
-instance Eq a => Eq (Last a)
-instance Ord a => Ord (Last a)
-instance Read a => Read (Last a)
-instance Show a => Show (Last a)
-#endif
-
-instance Monoid (Last a) where
- mempty = Last Nothing
- _ `mappend` r@(Last (Just _)) = r
- r `mappend` Last Nothing = r
-
-{-
-{--------------------------------------------------------------------
- Testing
---------------------------------------------------------------------}
-instance Arbitrary a => Arbitrary (Maybe a) where
- arbitrary = oneof [return Nothing, Just `fmap` arbitrary]
-
-prop_mconcatMaybe :: [Maybe [Int]] -> Bool
-prop_mconcatMaybe x =
- fromMaybe [] (mconcat x) == mconcat (catMaybes x)
-
-prop_mconcatFirst :: [Maybe Int] -> Bool
-prop_mconcatFirst x =
- getFirst (mconcat (map First x)) == listToMaybe (catMaybes x)
-prop_mconcatLast :: [Maybe Int] -> Bool
-prop_mconcatLast x =
- getLast (mconcat (map Last x)) == listLastToMaybe (catMaybes x)
- where listLastToMaybe [] = Nothing
- listLastToMaybe lst = Just (last lst)
--- -}
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Ord
--- Copyright : (c) The University of Glasgow 2005
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : stable
--- Portability : portable
---
--- Orderings
---
------------------------------------------------------------------------------
-
-module Data.Ord (
- Ord(..),
- Ordering(..),
- comparing,
- ) where
-
-#if __GLASGOW_HASKELL__
-import GHC.Base
-#endif
-
--- |
--- > comparing p x y = compare (p x) (p y)
---
--- Useful combinator for use in conjunction with the @xxxBy@ family
--- of functions from "Data.List", for example:
---
--- > ... sortBy (comparing fst) ...
-comparing :: (Ord a) => (b -> a) -> b -> b -> Ordering
-comparing p x y = compare (p x) (p y)
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.PackedString
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- This API is deprecated. You might be able to use "Data.ByteString"
--- or "Data.ByteString.Char8", provided you don't need full Unicode support.
--- The long term aim is to provide a Unicode layer on "Data.ByteString",
--- and then to provide a replacement for this "Data.PackedString" API based on
--- that.
---
------------------------------------------------------------------------------
-
--- Original GHC implementation by Bryan O\'Sullivan,
--- rewritten to use UArray by Simon Marlow.
-
-module Data.PackedString
- {-# DEPRECATED "use Data.ByteString, Data.ByteString.Char8, or plain String." #-}
- (
- -- * The @PackedString@ type
- PackedString, -- abstract, instances: Eq, Ord, Show, Typeable
-
- -- * Converting to and from @PackedString@s
- packString, -- :: String -> PackedString
- unpackPS, -- :: PackedString -> String
-
-#ifndef __NHC__
- -- * I\/O with @PackedString@s
- hPutPS, -- :: Handle -> PackedString -> IO ()
- hGetPS, -- :: Handle -> Int -> IO PackedString
-#endif
-
- -- * List-like manipulation functions
- nilPS, -- :: PackedString
- consPS, -- :: Char -> PackedString -> PackedString
- headPS, -- :: PackedString -> Char
- tailPS, -- :: PackedString -> PackedString
- nullPS, -- :: PackedString -> Bool
- appendPS, -- :: PackedString -> PackedString -> PackedString
- lengthPS, -- :: PackedString -> Int
- indexPS, -- :: PackedString -> Int -> Char
- mapPS, -- :: (Char -> Char) -> PackedString -> PackedString
- filterPS, -- :: (Char -> Bool) -> PackedString -> PackedString
- reversePS, -- :: PackedString -> PackedString
- concatPS, -- :: [PackedString] -> PackedString
- elemPS, -- :: Char -> PackedString -> Bool
- substrPS, -- :: PackedString -> Int -> Int -> PackedString
- takePS, -- :: Int -> PackedString -> PackedString
- dropPS, -- :: Int -> PackedString -> PackedString
- splitAtPS, -- :: Int -> PackedString -> (PackedString, PackedString)
-
- foldlPS, -- :: (a -> Char -> a) -> a -> PackedString -> a
- foldrPS, -- :: (Char -> a -> a) -> a -> PackedString -> a
- takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
- dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
- spanPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
- breakPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
- linesPS, -- :: PackedString -> [PackedString]
- unlinesPS, -- :: [PackedString] -> PackedString
- wordsPS, -- :: PackedString -> [PackedString]
- unwordsPS, -- :: [PackedString] -> PackedString
- splitPS, -- :: Char -> PackedString -> [PackedString]
- splitWithPS, -- :: (Char -> Bool) -> PackedString -> [PackedString]
-
- joinPS, -- :: PackedString -> [PackedString] -> PackedString
-
- ) where
-
-import Prelude
-
-#ifndef __NHC__
-
-import Data.Array.Unboxed
-import Data.Array.IO
-import Data.Typeable
-import Data.Char
-
-import System.IO
-
--- -----------------------------------------------------------------------------
--- PackedString type declaration
-
--- | A space-efficient representation of a 'String', which supports various
--- efficient operations. A 'PackedString' contains full Unicode 'Char's.
-newtype PackedString = PS (UArray Int Char)
-
--- ToDo: we could support "slices", i.e. include offset and length fields into
--- the string, so that operations like take/drop could be O(1). Perhaps making
--- a slice should be conditional on the ratio of the slice/string size to
--- limit memory leaks.
-
-instance Eq PackedString where
- (PS x) == (PS y) = x == y
-
-instance Ord PackedString where
- compare (PS x) (PS y) = compare x y
-
---instance Read PackedString: ToDo
-
-instance Show PackedString where
- showsPrec p ps r = showsPrec p (unpackPS ps) r
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE0(PackedString,packedStringTc,"PackedString")
-
--- -----------------------------------------------------------------------------
--- Constructor functions
-
--- | The 'nilPS' value is the empty string.
-nilPS :: PackedString
-nilPS = PS (array (0,-1) [])
-
--- | The 'consPS' function prepends the given character to the
--- given string.
-consPS :: Char -> PackedString -> PackedString
-consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better
-
--- | Convert a 'String' into a 'PackedString'
-packString :: String -> PackedString
-packString str = packNChars (length str) str
-
--- | The 'packNChars' function creates a 'PackedString' out of the
--- first @len@ elements of the given 'String'.
-packNChars :: Int -> [Char] -> PackedString
-packNChars len str = PS (listArray (0,len-1) str)
-
--- -----------------------------------------------------------------------------
--- Destructor functions (taking PackedStrings apart)
-
--- | Convert a 'PackedString' into a 'String'
-unpackPS :: PackedString -> String
-unpackPS (PS ps) = elems ps
-
--- -----------------------------------------------------------------------------
--- List-mimicking functions for PackedStrings
-
--- | The 'lengthPS' function returns the length of the input list. Analogous to 'length'.
-lengthPS :: PackedString -> Int
-lengthPS (PS ps) = rangeSize (bounds ps)
-
--- | The 'indexPS' function returns the character in the string at the given position.
-indexPS :: PackedString -> Int -> Char
-indexPS (PS ps) i = ps ! i
-
--- | The 'headPS' function returns the first element of a 'PackedString' or throws an
--- error if the string is empty.
-headPS :: PackedString -> Char
-headPS ps
- | nullPS ps = error "Data.PackedString.headPS: head []"
- | otherwise = indexPS ps 0
-
--- | The 'tailPS' function returns the tail of a 'PackedString' or throws an error
--- if the string is empty.
-tailPS :: PackedString -> PackedString
-tailPS ps
- | len <= 0 = error "Data.PackedString.tailPS: tail []"
- | len == 1 = nilPS
- | otherwise = substrPS ps 1 (len - 1)
- where
- len = lengthPS ps
-
--- | The 'nullPS' function returns True iff the argument is null.
-nullPS :: PackedString -> Bool
-nullPS (PS ps) = rangeSize (bounds ps) == 0
-
--- | The 'appendPS' function appends the second string onto the first.
-appendPS :: PackedString -> PackedString -> PackedString
-appendPS xs ys
- | nullPS xs = ys
- | nullPS ys = xs
- | otherwise = concatPS [xs,ys]
-
--- | The 'mapPS' function applies a function to each character in the string.
-mapPS :: (Char -> Char) -> PackedString -> PackedString
-mapPS f (PS ps) = PS (amap f ps)
-
--- | The 'filterPS' function filters out the appropriate substring.
-filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
-filterPS pred ps = packString (filter pred (unpackPS ps))
-
--- | The 'foldlPS' function behaves like 'foldl' on 'PackedString's.
-foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
-foldlPS f b ps = foldl f b (unpackPS ps)
-
--- | The 'foldrPS' function behaves like 'foldr' on 'PackedString's.
-foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
-foldrPS f v ps = foldr f v (unpackPS ps)
-
--- | The 'takePS' function takes the first @n@ characters of a 'PackedString'.
-takePS :: Int -> PackedString -> PackedString
-takePS n ps = substrPS ps 0 (n-1)
-
--- | The 'dropPS' function drops the first @n@ characters of a 'PackedString'.
-dropPS :: Int -> PackedString -> PackedString
-dropPS n ps = substrPS ps n (lengthPS ps - 1)
-
--- | The 'splitWithPS' function splits a 'PackedString' at a given index.
-splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
-splitAtPS n ps = (takePS n ps, dropPS n ps)
-
--- | The 'takeWhilePS' function is analogous to the 'takeWhile' function.
-takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
-takeWhilePS pred ps = packString (takeWhile pred (unpackPS ps))
-
--- | The 'dropWhilePS' function is analogous to the 'dropWhile' function.
-dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
-dropWhilePS pred ps = packString (dropWhile pred (unpackPS ps))
-
--- | The 'elemPS' function returns True iff the given element is in the string.
-elemPS :: Char -> PackedString -> Bool
-elemPS c ps = c `elem` unpackPS ps
-
--- | The 'spanPS' function returns a pair containing the result of
--- running both 'takeWhilePS' and 'dropWhilePS'.
-spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
-spanPS p ps = (takeWhilePS p ps, dropWhilePS p ps)
-
--- | The 'breakPS' function breaks a string at the first position which
--- satisfies the predicate.
-breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
-breakPS p ps = spanPS (not . p) ps
-
--- | The 'linesPS' function splits the input on line-breaks.
-linesPS :: PackedString -> [PackedString]
-linesPS ps = splitPS '\n' ps
-
--- | The 'unlinesPS' function concatenates the input list after
--- interspersing newlines.
-unlinesPS :: [PackedString] -> PackedString
-unlinesPS = joinPS (packString "\n")
-
--- | The 'wordsPS' function is analogous to the 'words' function.
-wordsPS :: PackedString -> [PackedString]
-wordsPS ps = filter (not.nullPS) (splitWithPS isSpace ps)
-
--- | The 'unwordsPS' function is analogous to the 'unwords' function.
-unwordsPS :: [PackedString] -> PackedString
-unwordsPS = joinPS (packString " ")
-
--- | The 'reversePS' function reverses the string.
-reversePS :: PackedString -> PackedString
-reversePS ps = packString (reverse (unpackPS ps))
-
--- | The 'concatPS' function concatenates a list of 'PackedString's.
-concatPS :: [PackedString] -> PackedString
-concatPS pss = packString (concat (map unpackPS pss))
-
-------------------------------------------------------------
-
--- | The 'joinPS' function takes a 'PackedString' and a list of 'PackedString's
--- and concatenates the list after interspersing the first argument between
--- each element of the list.
-joinPS :: PackedString -> [PackedString] -> PackedString
-joinPS filler pss = concatPS (splice pss)
- where
- splice [] = []
- splice [x] = [x]
- splice (x:y:xs) = x:filler:splice (y:xs)
-
--- ToDo: the obvious generalisation
-{-
- Some properties that hold:
-
- * splitPS x ls = ls'
- where False = any (map (x `elemPS`) ls')
-
- * joinPS (packString [x]) (splitPS x ls) = ls
--}
-
--- | The 'splitPS' function splits the input string on each occurrence of the given 'Char'.
-splitPS :: Char -> PackedString -> [PackedString]
-splitPS c = splitWithPS (== c)
-
--- | The 'splitWithPS' function takes a character predicate and splits the input string
--- at each character which satisfies the predicate.
-splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]
-splitWithPS pred (PS ps) =
- splitify 0
- where
- len = lengthPS (PS ps)
-
- splitify n
- | n >= len = []
- | otherwise =
- let
- break_pt = first_pos_that_satisfies pred ps len n
- in
- if break_pt == n then -- immediate match, empty substring
- nilPS
- : splitify (break_pt + 1)
- else
- substrPS (PS ps) n (break_pt - 1) -- leave out the matching character
- : splitify (break_pt + 1)
-
-first_pos_that_satisfies pred ps len n =
- case [ m | m <- [n..len-1], pred (ps ! m) ] of
- [] -> len
- (m:_) -> m
-
--- -----------------------------------------------------------------------------
--- Local utility functions
-
--- The definition of @_substrPS@ is essentially:
--- @take (end - begin + 1) (drop begin str)@.
-
--- | The 'substrPS' function takes a 'PackedString' and two indices
--- and returns the substring of the input string between (and including)
--- these indices.
-substrPS :: PackedString -> Int -> Int -> PackedString
-substrPS (PS ps) begin end = packString [ ps ! i | i <- [begin..end] ]
-
--- -----------------------------------------------------------------------------
--- hPutPS
-
--- | Outputs a 'PackedString' to the specified 'Handle'.
---
--- NOTE: the representation of the 'PackedString' in the file is assumed to
--- be in the ISO-8859-1 encoding. In other words, only the least significant
--- byte is taken from each character in the 'PackedString'.
-hPutPS :: Handle -> PackedString -> IO ()
-hPutPS h (PS ps) = do
- let l = lengthPS (PS ps)
- arr <- newArray_ (0, l-1)
- sequence_ [ writeArray arr i (fromIntegral (ord (ps ! i))) | i <- [0..l-1] ]
- hPutArray h arr l
-
--- -----------------------------------------------------------------------------
--- hGetPS
-
--- | Read a 'PackedString' directly from the specified 'Handle'.
--- This is far more efficient than reading the characters into a 'String'
--- and then using 'packString'.
---
--- NOTE: as with 'hPutPS', the string representation in the file is
--- assumed to be ISO-8859-1.
-hGetPS :: Handle -> Int -> IO PackedString
-hGetPS h i = do
- arr <- newArray_ (0, i-1)
- l <- hGetArray h arr i
- chars <- mapM (\i -> readArray arr i >>= return.chr.fromIntegral) [0..l-1]
- return (packNChars l chars)
-
-#else /* __NHC__ */
-
---import Prelude hiding (append, break, concat, cons, drop, dropWhile,
--- filter, foldl, foldr, head, length, lines, map,
--- nil, null, reverse, span, splitAt, subst, tail,
--- take, takeWhile, unlines, unwords, words)
--- also hiding: Ix(..), Functor(..)
-import qualified NHC.PackedString
-import NHC.PackedString (PackedString,packString,unpackPS)
-import List (intersperse)
-
-
-nilPS :: PackedString
-consPS :: Char -> PackedString -> PackedString
-headPS :: PackedString -> Char
-tailPS :: PackedString -> PackedString
-nullPS :: PackedString -> Bool
-appendPS :: PackedString -> PackedString -> PackedString
-lengthPS :: PackedString -> Int
-indexPS :: PackedString -> Int -> Char
-mapPS :: (Char -> Char) -> PackedString -> PackedString
-filterPS :: (Char -> Bool) -> PackedString -> PackedString
-reversePS :: PackedString -> PackedString
-concatPS :: [PackedString] -> PackedString
-elemPS :: Char -> PackedString -> Bool
-substrPS :: PackedString -> Int -> Int -> PackedString
-takePS :: Int -> PackedString -> PackedString
-dropPS :: Int -> PackedString -> PackedString
-splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
-
-foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
-foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
-takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
-dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
-spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
-breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
-linesPS :: PackedString -> [PackedString]
-unlinesPS :: [PackedString] -> PackedString
-
-wordsPS :: PackedString -> [PackedString]
-unwordsPS :: [PackedString] -> PackedString
-splitPS :: Char -> PackedString -> [PackedString]
-splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]
-joinPS :: PackedString -> [PackedString] -> PackedString
-
-nilPS = NHC.PackedString.nil
-consPS = NHC.PackedString.cons
-headPS = NHC.PackedString.head
-tailPS = NHC.PackedString.tail
-nullPS = NHC.PackedString.null
-appendPS = NHC.PackedString.append
-lengthPS = NHC.PackedString.length
-indexPS p i = (unpackPS p) !! i
-mapPS = NHC.PackedString.map
-filterPS = NHC.PackedString.filter
-reversePS = NHC.PackedString.reverse
-concatPS = NHC.PackedString.concat
-elemPS c p = c `elem` unpackPS p
-substrPS = NHC.PackedString.substr
-takePS = NHC.PackedString.take
-dropPS = NHC.PackedString.drop
-splitAtPS = NHC.PackedString.splitAt
-
-foldlPS = NHC.PackedString.foldl
-foldrPS = NHC.PackedString.foldr
-takeWhilePS = NHC.PackedString.takeWhile
-dropWhilePS = NHC.PackedString.dropWhile
-spanPS = NHC.PackedString.span
-breakPS = NHC.PackedString.break
-linesPS = NHC.PackedString.lines
-unlinesPS = NHC.PackedString.unlines
-
-wordsPS = NHC.PackedString.words
-unwordsPS = NHC.PackedString.unwords
-splitPS c = splitWithPS (==c)
-splitWithPS p =
- map packString . split' p [] . unpackPS
- where
- split' :: (Char->Bool) -> String -> String -> [String]
- split' pred [] [] = []
- split' pred acc [] = [reverse acc]
- split' pred acc (x:xs) | pred x = reverse acc: split' pred [] xs
- | otherwise = split' pred (x:acc) xs
-
-joinPS sep = concatPS . intersperse sep
-
-#endif
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Ratio
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : stable
--- Portability : portable
---
--- Standard functions on rational numbers
---
------------------------------------------------------------------------------
-
-module Data.Ratio
- ( Ratio
- , Rational
- , (%) -- :: (Integral a) => a -> a -> Ratio a
- , numerator -- :: (Integral a) => Ratio a -> a
- , denominator -- :: (Integral a) => Ratio a -> a
- , approxRational -- :: (RealFrac a) => a -> a -> Rational
-
- -- Ratio instances:
- -- (Integral a) => Eq (Ratio a)
- -- (Integral a) => Ord (Ratio a)
- -- (Integral a) => Num (Ratio a)
- -- (Integral a) => Real (Ratio a)
- -- (Integral a) => Fractional (Ratio a)
- -- (Integral a) => RealFrac (Ratio a)
- -- (Integral a) => Enum (Ratio a)
- -- (Read a, Integral a) => Read (Ratio a)
- -- (Integral a) => Show (Ratio a)
-
- ) where
-
-import Prelude
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Real -- The basic defns for Ratio
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude(Ratio(..), (%), numerator, denominator)
-#endif
-
-#ifdef __NHC__
-import Ratio (Ratio(..), (%), numerator, denominator, approxRational)
-#else
-
--- -----------------------------------------------------------------------------
--- approxRational
-
--- | 'approxRational', applied to two real fractional numbers @x@ and @epsilon@,
--- returns the simplest rational number within @epsilon@ of @x@.
--- A rational number @y@ is said to be /simpler/ than another @y'@ if
---
--- * @'abs' ('numerator' y) <= 'abs' ('numerator' y')@, and
---
--- * @'denominator' y <= 'denominator' y'@.
---
--- Any real interval contains a unique simplest rational;
--- in particular, note that @0\/1@ is the simplest rational of all.
-
--- Implementation details: Here, for simplicity, we assume a closed rational
--- interval. If such an interval includes at least one whole number, then
--- the simplest rational is the absolutely least whole number. Otherwise,
--- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d
--- and abs r' < d', and the simplest rational is q%1 + the reciprocal of
--- the simplest rational between d'%r' and d%r.
-
-approxRational :: (RealFrac a) => a -> a -> Rational
-approxRational rat eps = simplest (rat-eps) (rat+eps)
- where simplest x y | y < x = simplest y x
- | x == y = xr
- | x > 0 = simplest' n d n' d'
- | y < 0 = - simplest' (-n') d' (-n) d
- | otherwise = 0 :% 1
- where xr = toRational x
- n = numerator xr
- d = denominator xr
- nd' = toRational y
- n' = numerator nd'
- d' = denominator nd'
-
- simplest' n d n' d' -- assumes 0 < n%d < n'%d'
- | r == 0 = q :% 1
- | q /= q' = (q+1) :% 1
- | otherwise = (q*n''+d'') :% n''
- where (q,r) = quotRem n d
- (q',r') = quotRem n' d'
- nd'' = simplest' d' r' d r
- n'' = numerator nd''
- d'' = denominator nd''
-#endif
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.STRef
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Control.Monad.ST)
---
--- Mutable references in the (strict) ST monad.
---
------------------------------------------------------------------------------
-
-module Data.STRef (
- -- * STRefs
- STRef, -- abstract, instance Eq
- newSTRef, -- :: a -> ST s (STRef s a)
- readSTRef, -- :: STRef s a -> ST s a
- writeSTRef, -- :: STRef s a -> a -> ST s ()
- modifySTRef -- :: STRef s a -> (a -> a) -> ST s ()
- ) where
-
-import Prelude
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.ST
-import GHC.STRef
-#endif
-
-#ifdef __HUGS__
-import Hugs.ST
-import Data.Typeable
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
-#endif
-
--- |Mutate the contents of an 'STRef'
-modifySTRef :: STRef s a -> (a -> a) -> ST s ()
-modifySTRef ref f = writeSTRef ref . f =<< readSTRef ref
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.STRef.Lazy
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Control.Monad.ST.Lazy)
---
--- Mutable references in the lazy ST monad.
---
------------------------------------------------------------------------------
-module Data.STRef.Lazy (
- -- * STRefs
- ST.STRef, -- abstract, instance Eq
- newSTRef, -- :: a -> ST s (STRef s a)
- readSTRef, -- :: STRef s a -> ST s a
- writeSTRef, -- :: STRef s a -> a -> ST s ()
- modifySTRef -- :: STRef s a -> (a -> a) -> ST s ()
- ) where
-
-import Control.Monad.ST.Lazy
-import qualified Data.STRef as ST
-
-newSTRef :: a -> ST s (ST.STRef s a)
-readSTRef :: ST.STRef s a -> ST s a
-writeSTRef :: ST.STRef s a -> a -> ST s ()
-modifySTRef :: ST.STRef s a -> (a -> a) -> ST s ()
-
-newSTRef = strictToLazyST . ST.newSTRef
-readSTRef = strictToLazyST . ST.readSTRef
-writeSTRef r a = strictToLazyST (ST.writeSTRef r a)
-modifySTRef r f = strictToLazyST (ST.modifySTRef r f)
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.STRef.Strict
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : non-portable (uses Control.Monad.ST.Strict)
---
--- Mutable references in the (strict) ST monad (re-export of "Data.STRef")
---
------------------------------------------------------------------------------
-
-module Data.STRef.Strict (
- module Data.STRef
- ) where
-
-import Prelude
-import Data.STRef
+++ /dev/null
-{-# OPTIONS -cpp -fglasgow-exts #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Sequence
--- Copyright : (c) Ross Paterson 2005
--- License : BSD-style
--- Maintainer : ross@soi.city.ac.uk
--- Stability : experimental
--- Portability : portable
---
--- General purpose finite sequences.
--- Apart from being finite and having strict operations, sequences
--- also differ from lists in supporting a wider variety of operations
--- efficiently.
---
--- An amortized running time is given for each operation, with /n/ referring
--- to the length of the sequence and /i/ being the integral index used by
--- some operations. These bounds hold even in a persistent (shared) setting.
---
--- The implementation uses 2-3 finger trees annotated with sizes,
--- as described in section 4.2 of
---
--- * Ralf Hinze and Ross Paterson,
--- \"Finger trees: a simple general-purpose data structure\",
--- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
--- <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>
---
--- /Note/: Many of these operations have the same names as similar
--- operations on lists in the "Prelude". The ambiguity may be resolved
--- using either qualification or the @hiding@ clause.
---
------------------------------------------------------------------------------
-
-module Data.Sequence (
- Seq,
- -- * Construction
- empty, -- :: Seq a
- singleton, -- :: a -> Seq a
- (<|), -- :: a -> Seq a -> Seq a
- (|>), -- :: Seq a -> a -> Seq a
- (><), -- :: Seq a -> Seq a -> Seq a
- fromList, -- :: [a] -> Seq a
- -- * Deconstruction
- -- | Additional functions for deconstructing sequences are available
- -- via the 'Foldable' instance of 'Seq'.
-
- -- ** Queries
- null, -- :: Seq a -> Bool
- length, -- :: Seq a -> Int
- -- ** Views
- ViewL(..),
- viewl, -- :: Seq a -> ViewL a
- ViewR(..),
- viewr, -- :: Seq a -> ViewR a
- -- ** Indexing
- index, -- :: Seq a -> Int -> a
- adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a
- update, -- :: Int -> a -> Seq a -> Seq a
- take, -- :: Int -> Seq a -> Seq a
- drop, -- :: Int -> Seq a -> Seq a
- splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)
- -- * Transformations
- reverse, -- :: Seq a -> Seq a
-#if TESTING
- valid,
-#endif
- ) where
-
-import Prelude hiding (
- null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
- reverse)
-import qualified Data.List (foldl')
-import Control.Applicative (Applicative(..), (<$>))
-import Control.Monad (MonadPlus(..))
-import Data.Monoid (Monoid(..))
-import Data.Foldable
-import Data.Traversable
-import Data.Typeable
-
-#ifdef __GLASGOW_HASKELL__
-import Text.Read (Lexeme(Ident), lexP, parens, prec,
- readPrec, readListPrec, readListPrecDefault)
-import Data.Generics.Basics (Data(..), Fixity(..),
- constrIndex, mkConstr, mkDataType)
-#endif
-
-#if TESTING
-import Control.Monad (liftM, liftM3, liftM4)
-import Test.QuickCheck
-#endif
-
-infixr 5 `consTree`
-infixl 5 `snocTree`
-
-infixr 5 ><
-infixr 5 <|, :<
-infixl 5 |>, :>
-
-class Sized a where
- size :: a -> Int
-
--- | General-purpose finite sequences.
-newtype Seq a = Seq (FingerTree (Elem a))
-
-instance Functor Seq where
- fmap f (Seq xs) = Seq (fmap (fmap f) xs)
-
-instance Foldable Seq where
- foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
- foldl f z (Seq xs) = foldl (foldl f) z xs
-
- foldr1 f (Seq xs) = getElem (foldr1 f' xs)
- where f' (Elem x) (Elem y) = Elem (f x y)
-
- foldl1 f (Seq xs) = getElem (foldl1 f' xs)
- where f' (Elem x) (Elem y) = Elem (f x y)
-
-instance Traversable Seq where
- traverse f (Seq xs) = Seq <$> traverse (traverse f) xs
-
-instance Monad Seq where
- return = singleton
- xs >>= f = foldl' add empty xs
- where add ys x = ys >< f x
-
-instance MonadPlus Seq where
- mzero = empty
- mplus = (><)
-
-instance Eq a => Eq (Seq a) where
- xs == ys = length xs == length ys && toList xs == toList ys
-
-instance Ord a => Ord (Seq a) where
- compare xs ys = compare (toList xs) (toList ys)
-
-#if TESTING
-instance Show a => Show (Seq a) where
- showsPrec p (Seq x) = showsPrec p x
-#else
-instance Show a => Show (Seq a) where
- showsPrec p xs = showParen (p > 10) $
- showString "fromList " . shows (toList xs)
-#endif
-
-instance Read a => Read (Seq a) where
-#ifdef __GLASGOW_HASKELL__
- readPrec = parens $ prec 10 $ do
- Ident "fromList" <- lexP
- xs <- readPrec
- return (fromList xs)
-
- readListPrec = readListPrecDefault
-#else
- readsPrec p = readParen (p > 10) $ \ r -> do
- ("fromList",s) <- lex r
- (xs,t) <- reads s
- return (fromList xs,t)
-#endif
-
-instance Monoid (Seq a) where
- mempty = empty
- mappend = (><)
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
-
-#if __GLASGOW_HASKELL__
-instance Data a => Data (Seq a) where
- gfoldl f z s = case viewl s of
- EmptyL -> z empty
- x :< xs -> z (<|) `f` x `f` xs
-
- gunfold k z c = case constrIndex c of
- 1 -> z empty
- 2 -> k (k (z (<|)))
- _ -> error "gunfold"
-
- toConstr xs
- | null xs = emptyConstr
- | otherwise = consConstr
-
- dataTypeOf _ = seqDataType
-
- dataCast1 f = gcast1 f
-
-emptyConstr = mkConstr seqDataType "empty" [] Prefix
-consConstr = mkConstr seqDataType "<|" [] Infix
-seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
-#endif
-
--- Finger trees
-
-data FingerTree a
- = Empty
- | Single a
- | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
-#if TESTING
- deriving Show
-#endif
-
-instance Sized a => Sized (FingerTree a) where
- {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
- {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
- size Empty = 0
- size (Single x) = size x
- size (Deep v _ _ _) = v
-
-instance Foldable FingerTree where
- foldr _ z Empty = z
- foldr f z (Single x) = x `f` z
- foldr f z (Deep _ pr m sf) =
- foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr
-
- foldl _ z Empty = z
- foldl f z (Single x) = z `f` x
- foldl f z (Deep _ pr m sf) =
- foldl f (foldl (foldl f) (foldl f z pr) m) sf
-
- foldr1 _ Empty = error "foldr1: empty sequence"
- foldr1 _ (Single x) = x
- foldr1 f (Deep _ pr m sf) =
- foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr
-
- foldl1 _ Empty = error "foldl1: empty sequence"
- foldl1 _ (Single x) = x
- foldl1 f (Deep _ pr m sf) =
- foldl f (foldl (foldl f) (foldl1 f pr) m) sf
-
-instance Functor FingerTree where
- fmap _ Empty = Empty
- fmap f (Single x) = Single (f x)
- fmap f (Deep v pr m sf) =
- Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
-
-instance Traversable FingerTree where
- traverse _ Empty = pure Empty
- traverse f (Single x) = Single <$> f x
- traverse f (Deep v pr m sf) =
- Deep v <$> traverse f pr <*> traverse (traverse f) m <*>
- traverse f sf
-
-{-# INLINE deep #-}
-{-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
-deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
-deep pr m sf = Deep (size pr + size m + size sf) pr m sf
-
--- Digits
-
-data Digit a
- = One a
- | Two a a
- | Three a a a
- | Four a a a a
-#if TESTING
- deriving Show
-#endif
-
-instance Foldable Digit where
- foldr f z (One a) = a `f` z
- foldr f z (Two a b) = a `f` (b `f` z)
- foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
- foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
-
- foldl f z (One a) = z `f` a
- foldl f z (Two a b) = (z `f` a) `f` b
- foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
- foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
-
- foldr1 f (One a) = a
- foldr1 f (Two a b) = a `f` b
- foldr1 f (Three a b c) = a `f` (b `f` c)
- foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
-
- foldl1 f (One a) = a
- foldl1 f (Two a b) = a `f` b
- foldl1 f (Three a b c) = (a `f` b) `f` c
- foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
-
-instance Functor Digit where
- fmap = fmapDefault
-
-instance Traversable Digit where
- traverse f (One a) = One <$> f a
- traverse f (Two a b) = Two <$> f a <*> f b
- traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
- traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
-
-instance Sized a => Sized (Digit a) where
- {-# SPECIALIZE instance Sized (Digit (Elem a)) #-}
- {-# SPECIALIZE instance Sized (Digit (Node a)) #-}
- size xs = foldl (\ i x -> i + size x) 0 xs
-
-{-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
-digitToTree :: Sized a => Digit a -> FingerTree a
-digitToTree (One a) = Single a
-digitToTree (Two a b) = deep (One a) Empty (One b)
-digitToTree (Three a b c) = deep (Two a b) Empty (One c)
-digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
-
--- Nodes
-
-data Node a
- = Node2 {-# UNPACK #-} !Int a a
- | Node3 {-# UNPACK #-} !Int a a a
-#if TESTING
- deriving Show
-#endif
-
-instance Foldable Node where
- foldr f z (Node2 _ a b) = a `f` (b `f` z)
- foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
-
- foldl f z (Node2 _ a b) = (z `f` a) `f` b
- foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
-
-instance Functor Node where
- fmap = fmapDefault
-
-instance Traversable Node where
- traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
- traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
-
-instance Sized (Node a) where
- size (Node2 v _ _) = v
- size (Node3 v _ _ _) = v
-
-{-# INLINE node2 #-}
-{-# SPECIALIZE node2 :: Elem a -> Elem a -> Node (Elem a) #-}
-{-# SPECIALIZE node2 :: Node a -> Node a -> Node (Node a) #-}
-node2 :: Sized a => a -> a -> Node a
-node2 a b = Node2 (size a + size b) a b
-
-{-# INLINE node3 #-}
-{-# SPECIALIZE node3 :: Elem a -> Elem a -> Elem a -> Node (Elem a) #-}
-{-# SPECIALIZE node3 :: Node a -> Node a -> Node a -> Node (Node a) #-}
-node3 :: Sized a => a -> a -> a -> Node a
-node3 a b c = Node3 (size a + size b + size c) a b c
-
-nodeToDigit :: Node a -> Digit a
-nodeToDigit (Node2 _ a b) = Two a b
-nodeToDigit (Node3 _ a b c) = Three a b c
-
--- Elements
-
-newtype Elem a = Elem { getElem :: a }
-
-instance Sized (Elem a) where
- size _ = 1
-
-instance Functor Elem where
- fmap f (Elem x) = Elem (f x)
-
-instance Foldable Elem where
- foldr f z (Elem x) = f x z
- foldl f z (Elem x) = f z x
-
-instance Traversable Elem where
- traverse f (Elem x) = Elem <$> f x
-
-#ifdef TESTING
-instance (Show a) => Show (Elem a) where
- showsPrec p (Elem x) = showsPrec p x
-#endif
-
-------------------------------------------------------------------------
--- Construction
-------------------------------------------------------------------------
-
--- | /O(1)/. The empty sequence.
-empty :: Seq a
-empty = Seq Empty
-
--- | /O(1)/. A singleton sequence.
-singleton :: a -> Seq a
-singleton x = Seq (Single (Elem x))
-
--- | /O(1)/. Add an element to the left end of a sequence.
--- Mnemonic: a triangle with the single element at the pointy end.
-(<|) :: a -> Seq a -> Seq a
-x <| Seq xs = Seq (Elem x `consTree` xs)
-
-{-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
-consTree :: Sized a => a -> FingerTree a -> FingerTree a
-consTree a Empty = Single a
-consTree a (Single b) = deep (One a) Empty (One b)
-consTree a (Deep s (Four b c d e) m sf) = m `seq`
- Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
-consTree a (Deep s (Three b c d) m sf) =
- Deep (size a + s) (Four a b c d) m sf
-consTree a (Deep s (Two b c) m sf) =
- Deep (size a + s) (Three a b c) m sf
-consTree a (Deep s (One b) m sf) =
- Deep (size a + s) (Two a b) m sf
-
--- | /O(1)/. Add an element to the right end of a sequence.
--- Mnemonic: a triangle with the single element at the pointy end.
-(|>) :: Seq a -> a -> Seq a
-Seq xs |> x = Seq (xs `snocTree` Elem x)
-
-{-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
-{-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
-snocTree :: Sized a => FingerTree a -> a -> FingerTree a
-snocTree Empty a = Single a
-snocTree (Single a) b = deep (One a) Empty (One b)
-snocTree (Deep s pr m (Four a b c d)) e = m `seq`
- Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
-snocTree (Deep s pr m (Three a b c)) d =
- Deep (s + size d) pr m (Four a b c d)
-snocTree (Deep s pr m (Two a b)) c =
- Deep (s + size c) pr m (Three a b c)
-snocTree (Deep s pr m (One a)) b =
- Deep (s + size b) pr m (Two a b)
-
--- | /O(log(min(n1,n2)))/. Concatenate two sequences.
-(><) :: Seq a -> Seq a -> Seq a
-Seq xs >< Seq ys = Seq (appendTree0 xs ys)
-
--- The appendTree/addDigits gunk below is machine generated
-
-appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)
-appendTree0 Empty xs =
- xs
-appendTree0 xs Empty =
- xs
-appendTree0 (Single x) xs =
- x `consTree` xs
-appendTree0 xs (Single x) =
- xs `snocTree` x
-appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
- Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2
-
-addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))
-addDigits0 m1 (One a) (One b) m2 =
- appendTree1 m1 (node2 a b) m2
-addDigits0 m1 (One a) (Two b c) m2 =
- appendTree1 m1 (node3 a b c) m2
-addDigits0 m1 (One a) (Three b c d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits0 m1 (One a) (Four b c d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits0 m1 (Two a b) (One c) m2 =
- appendTree1 m1 (node3 a b c) m2
-addDigits0 m1 (Two a b) (Two c d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits0 m1 (Two a b) (Three c d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits0 m1 (Two a b) (Four c d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits0 m1 (Three a b c) (One d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits0 m1 (Three a b c) (Two d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits0 m1 (Three a b c) (Three d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits0 m1 (Three a b c) (Four d e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits0 m1 (Four a b c d) (One e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits0 m1 (Four a b c d) (Two e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits0 m1 (Four a b c d) (Three e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-
-appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
-appendTree1 Empty a xs =
- a `consTree` xs
-appendTree1 xs a Empty =
- xs `snocTree` a
-appendTree1 (Single x) a xs =
- x `consTree` a `consTree` xs
-appendTree1 xs a (Single x) =
- xs `snocTree` a `snocTree` x
-appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
- Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
-
-addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
-addDigits1 m1 (One a) b (One c) m2 =
- appendTree1 m1 (node3 a b c) m2
-addDigits1 m1 (One a) b (Two c d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits1 m1 (One a) b (Three c d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits1 m1 (One a) b (Four c d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits1 m1 (Two a b) c (One d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits1 m1 (Two a b) c (Two d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits1 m1 (Two a b) c (Three d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits1 m1 (Two a b) c (Four d e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits1 m1 (Three a b c) d (One e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits1 m1 (Three a b c) d (Two e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits1 m1 (Three a b c) d (Three e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits1 m1 (Four a b c d) e (One f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits1 m1 (Four a b c d) e (Two f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-
-appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
-appendTree2 Empty a b xs =
- a `consTree` b `consTree` xs
-appendTree2 xs a b Empty =
- xs `snocTree` a `snocTree` b
-appendTree2 (Single x) a b xs =
- x `consTree` a `consTree` b `consTree` xs
-appendTree2 xs a b (Single x) =
- xs `snocTree` a `snocTree` b `snocTree` x
-appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
- Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
-
-addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
-addDigits2 m1 (One a) b c (One d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits2 m1 (One a) b c (Two d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits2 m1 (One a) b c (Three d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits2 m1 (One a) b c (Four d e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits2 m1 (Two a b) c d (One e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits2 m1 (Two a b) c d (Two e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits2 m1 (Two a b) c d (Three e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits2 m1 (Three a b c) d e (One f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits2 m1 (Three a b c) d e (Two f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits2 m1 (Four a b c d) e f (One g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-
-appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
-appendTree3 Empty a b c xs =
- a `consTree` b `consTree` c `consTree` xs
-appendTree3 xs a b c Empty =
- xs `snocTree` a `snocTree` b `snocTree` c
-appendTree3 (Single x) a b c xs =
- x `consTree` a `consTree` b `consTree` c `consTree` xs
-appendTree3 xs a b c (Single x) =
- xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
-appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
- Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
-
-addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
-addDigits3 m1 (One a) b c d (One e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits3 m1 (One a) b c d (Two e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits3 m1 (One a) b c d (Three e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits3 m1 (One a) b c d (Four e f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits3 m1 (Two a b) c d e (One f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits3 m1 (Two a b) c d e (Two f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits3 m1 (Three a b c) d e f (One g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits3 m1 (Four a b c d) e f g (One h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
-
-appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
-appendTree4 Empty a b c d xs =
- a `consTree` b `consTree` c `consTree` d `consTree` xs
-appendTree4 xs a b c d Empty =
- xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
-appendTree4 (Single x) a b c d xs =
- x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
-appendTree4 xs a b c d (Single x) =
- xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
-appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
- Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
-
-addDigits4 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
-addDigits4 m1 (One a) b c d e (One f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits4 m1 (One a) b c d e (Two f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits4 m1 (One a) b c d e (Three f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits4 m1 (Two a b) c d e f (One g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits4 m1 (Three a b c) d e f g (One h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
-addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
-addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
-
-------------------------------------------------------------------------
--- Deconstruction
-------------------------------------------------------------------------
-
--- | /O(1)/. Is this the empty sequence?
-null :: Seq a -> Bool
-null (Seq Empty) = True
-null _ = False
-
--- | /O(1)/. The number of elements in the sequence.
-length :: Seq a -> Int
-length (Seq xs) = size xs
-
--- Views
-
-data Maybe2 a b = Nothing2 | Just2 a b
-
--- | View of the left end of a sequence.
-data ViewL a
- = EmptyL -- ^ empty sequence
- | a :< Seq a -- ^ leftmost element and the rest of the sequence
-#ifndef __HADDOCK__
-# if __GLASGOW_HASKELL__
- deriving (Eq, Ord, Show, Read, Data)
-# else
- deriving (Eq, Ord, Show, Read)
-# endif
-#else
-instance Eq a => Eq (ViewL a)
-instance Ord a => Ord (ViewL a)
-instance Show a => Show (ViewL a)
-instance Read a => Read (ViewL a)
-instance Data a => Data (ViewL a)
-#endif
-
-INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
-
-instance Functor ViewL where
- fmap = fmapDefault
-
-instance Foldable ViewL where
- foldr f z EmptyL = z
- foldr f z (x :< xs) = f x (foldr f z xs)
-
- foldl f z EmptyL = z
- foldl f z (x :< xs) = foldl f (f z x) xs
-
- foldl1 f EmptyL = error "foldl1: empty view"
- foldl1 f (x :< xs) = foldl f x xs
-
-instance Traversable ViewL where
- traverse _ EmptyL = pure EmptyL
- traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs
-
--- | /O(1)/. Analyse the left end of a sequence.
-viewl :: Seq a -> ViewL a
-viewl (Seq xs) = case viewLTree xs of
- Nothing2 -> EmptyL
- Just2 (Elem x) xs' -> x :< Seq xs'
-
-{-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}
-{-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}
-viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)
-viewLTree Empty = Nothing2
-viewLTree (Single a) = Just2 a Empty
-viewLTree (Deep s (One a) m sf) = Just2 a (case viewLTree m of
- Nothing2 -> digitToTree sf
- Just2 b m' -> Deep (s - size a) (nodeToDigit b) m' sf)
-viewLTree (Deep s (Two a b) m sf) =
- Just2 a (Deep (s - size a) (One b) m sf)
-viewLTree (Deep s (Three a b c) m sf) =
- Just2 a (Deep (s - size a) (Two b c) m sf)
-viewLTree (Deep s (Four a b c d) m sf) =
- Just2 a (Deep (s - size a) (Three b c d) m sf)
-
--- | View of the right end of a sequence.
-data ViewR a
- = EmptyR -- ^ empty sequence
- | Seq a :> a -- ^ the sequence minus the rightmost element,
- -- and the rightmost element
-#ifndef __HADDOCK__
-# if __GLASGOW_HASKELL__
- deriving (Eq, Ord, Show, Read, Data)
-# else
- deriving (Eq, Ord, Show, Read)
-# endif
-#else
-instance Eq a => Eq (ViewR a)
-instance Ord a => Ord (ViewR a)
-instance Show a => Show (ViewR a)
-instance Read a => Read (ViewR a)
-instance Data a => Data (ViewR a)
-#endif
-
-INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
-
-instance Functor ViewR where
- fmap = fmapDefault
-
-instance Foldable ViewR where
- foldr f z EmptyR = z
- foldr f z (xs :> x) = foldr f (f x z) xs
-
- foldl f z EmptyR = z
- foldl f z (xs :> x) = f (foldl f z xs) x
-
- foldr1 f EmptyR = error "foldr1: empty view"
- foldr1 f (xs :> x) = foldr f x xs
-
-instance Traversable ViewR where
- traverse _ EmptyR = pure EmptyR
- traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x
-
--- | /O(1)/. Analyse the right end of a sequence.
-viewr :: Seq a -> ViewR a
-viewr (Seq xs) = case viewRTree xs of
- Nothing2 -> EmptyR
- Just2 xs' (Elem x) -> Seq xs' :> x
-
-{-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}
-{-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}
-viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a
-viewRTree Empty = Nothing2
-viewRTree (Single z) = Just2 Empty z
-viewRTree (Deep s pr m (One z)) = Just2 (case viewRTree m of
- Nothing2 -> digitToTree pr
- Just2 m' y -> Deep (s - size z) pr m' (nodeToDigit y)) z
-viewRTree (Deep s pr m (Two y z)) =
- Just2 (Deep (s - size z) pr m (One y)) z
-viewRTree (Deep s pr m (Three x y z)) =
- Just2 (Deep (s - size z) pr m (Two x y)) z
-viewRTree (Deep s pr m (Four w x y z)) =
- Just2 (Deep (s - size z) pr m (Three w x y)) z
-
--- Indexing
-
--- | /O(log(min(i,n-i)))/. The element at the specified position
-index :: Seq a -> Int -> a
-index (Seq xs) i
- | 0 <= i && i < size xs = case lookupTree i xs of
- Place _ (Elem x) -> x
- | otherwise = error "index out of bounds"
-
-data Place a = Place {-# UNPACK #-} !Int a
-#if TESTING
- deriving Show
-#endif
-
-{-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}
-{-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}
-lookupTree :: Sized a => Int -> FingerTree a -> Place a
-lookupTree _ Empty = error "lookupTree of empty tree"
-lookupTree i (Single x) = Place i x
-lookupTree i (Deep _ pr m sf)
- | i < spr = lookupDigit i pr
- | i < spm = case lookupTree (i - spr) m of
- Place i' xs -> lookupNode i' xs
- | otherwise = lookupDigit (i - spm) sf
- where spr = size pr
- spm = spr + size m
-
-{-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}
-{-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}
-lookupNode :: Sized a => Int -> Node a -> Place a
-lookupNode i (Node2 _ a b)
- | i < sa = Place i a
- | otherwise = Place (i - sa) b
- where sa = size a
-lookupNode i (Node3 _ a b c)
- | i < sa = Place i a
- | i < sab = Place (i - sa) b
- | otherwise = Place (i - sab) c
- where sa = size a
- sab = sa + size b
-
-{-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}
-{-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}
-lookupDigit :: Sized a => Int -> Digit a -> Place a
-lookupDigit i (One a) = Place i a
-lookupDigit i (Two a b)
- | i < sa = Place i a
- | otherwise = Place (i - sa) b
- where sa = size a
-lookupDigit i (Three a b c)
- | i < sa = Place i a
- | i < sab = Place (i - sa) b
- | otherwise = Place (i - sab) c
- where sa = size a
- sab = sa + size b
-lookupDigit i (Four a b c d)
- | i < sa = Place i a
- | i < sab = Place (i - sa) b
- | i < sabc = Place (i - sab) c
- | otherwise = Place (i - sabc) d
- where sa = size a
- sab = sa + size b
- sabc = sab + size c
-
--- | /O(log(min(i,n-i)))/. Replace the element at the specified position
-update :: Int -> a -> Seq a -> Seq a
-update i x = adjust (const x) i
-
--- | /O(log(min(i,n-i)))/. Update the element at the specified position
-adjust :: (a -> a) -> Int -> Seq a -> Seq a
-adjust f i (Seq xs)
- | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) i xs)
- | otherwise = Seq xs
-
-{-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
-adjustTree :: Sized a => (Int -> a -> a) ->
- Int -> FingerTree a -> FingerTree a
-adjustTree _ _ Empty = error "adjustTree of empty tree"
-adjustTree f i (Single x) = Single (f i x)
-adjustTree f i (Deep s pr m sf)
- | i < spr = Deep s (adjustDigit f i pr) m sf
- | i < spm = Deep s pr (adjustTree (adjustNode f) (i - spr) m) sf
- | otherwise = Deep s pr m (adjustDigit f (i - spm) sf)
- where spr = size pr
- spm = spr + size m
-
-{-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}
-{-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}
-adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a
-adjustNode f i (Node2 s a b)
- | i < sa = Node2 s (f i a) b
- | otherwise = Node2 s a (f (i - sa) b)
- where sa = size a
-adjustNode f i (Node3 s a b c)
- | i < sa = Node3 s (f i a) b c
- | i < sab = Node3 s a (f (i - sa) b) c
- | otherwise = Node3 s a b (f (i - sab) c)
- where sa = size a
- sab = sa + size b
-
-{-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}
-{-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}
-adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a
-adjustDigit f i (One a) = One (f i a)
-adjustDigit f i (Two a b)
- | i < sa = Two (f i a) b
- | otherwise = Two a (f (i - sa) b)
- where sa = size a
-adjustDigit f i (Three a b c)
- | i < sa = Three (f i a) b c
- | i < sab = Three a (f (i - sa) b) c
- | otherwise = Three a b (f (i - sab) c)
- where sa = size a
- sab = sa + size b
-adjustDigit f i (Four a b c d)
- | i < sa = Four (f i a) b c d
- | i < sab = Four a (f (i - sa) b) c d
- | i < sabc = Four a b (f (i - sab) c) d
- | otherwise = Four a b c (f (i- sabc) d)
- where sa = size a
- sab = sa + size b
- sabc = sab + size c
-
--- Splitting
-
--- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.
-take :: Int -> Seq a -> Seq a
-take i = fst . splitAt i
-
--- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.
-drop :: Int -> Seq a -> Seq a
-drop i = snd . splitAt i
-
--- | /O(log(min(i,n-i)))/. Split a sequence at a given position.
-splitAt :: Int -> Seq a -> (Seq a, Seq a)
-splitAt i (Seq xs) = (Seq l, Seq r)
- where (l, r) = split i xs
-
-split :: Int -> FingerTree (Elem a) ->
- (FingerTree (Elem a), FingerTree (Elem a))
-split i Empty = i `seq` (Empty, Empty)
-split i xs
- | size xs > i = (l, consTree x r)
- | otherwise = (xs, Empty)
- where Split l x r = splitTree i xs
-
-data Split t a = Split t a t
-#if TESTING
- deriving Show
-#endif
-
-{-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}
-{-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}
-splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a
-splitTree _ Empty = error "splitTree of empty tree"
-splitTree i (Single x) = i `seq` Split Empty x Empty
-splitTree i (Deep _ pr m sf)
- | i < spr = case splitDigit i pr of
- Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
- | i < spm = case splitTree im m of
- Split ml xs mr -> case splitNode (im - size ml) xs of
- Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
- | otherwise = case splitDigit (i - spm) sf of
- Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
- where spr = size pr
- spm = spr + size m
- im = i - spr
-
-{-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
-deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
-deepL Nothing m sf = case viewLTree m of
- Nothing2 -> digitToTree sf
- Just2 a m' -> deep (nodeToDigit a) m' sf
-deepL (Just pr) m sf = deep pr m sf
-
-{-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
-deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
-deepR pr m Nothing = case viewRTree m of
- Nothing2 -> digitToTree pr
- Just2 m' a -> deep pr m' (nodeToDigit a)
-deepR pr m (Just sf) = deep pr m sf
-
-{-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
-{-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
-splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a
-splitNode i (Node2 _ a b)
- | i < sa = Split Nothing a (Just (One b))
- | otherwise = Split (Just (One a)) b Nothing
- where sa = size a
-splitNode i (Node3 _ a b c)
- | i < sa = Split Nothing a (Just (Two b c))
- | i < sab = Split (Just (One a)) b (Just (One c))
- | otherwise = Split (Just (Two a b)) c Nothing
- where sa = size a
- sab = sa + size b
-
-{-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
-{-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
-splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a
-splitDigit i (One a) = i `seq` Split Nothing a Nothing
-splitDigit i (Two a b)
- | i < sa = Split Nothing a (Just (One b))
- | otherwise = Split (Just (One a)) b Nothing
- where sa = size a
-splitDigit i (Three a b c)
- | i < sa = Split Nothing a (Just (Two b c))
- | i < sab = Split (Just (One a)) b (Just (One c))
- | otherwise = Split (Just (Two a b)) c Nothing
- where sa = size a
- sab = sa + size b
-splitDigit i (Four a b c d)
- | i < sa = Split Nothing a (Just (Three b c d))
- | i < sab = Split (Just (One a)) b (Just (Two c d))
- | i < sabc = Split (Just (Two a b)) c (Just (One d))
- | otherwise = Split (Just (Three a b c)) d Nothing
- where sa = size a
- sab = sa + size b
- sabc = sab + size c
-
-------------------------------------------------------------------------
--- Lists
-------------------------------------------------------------------------
-
--- | /O(n)/. Create a sequence from a finite list of elements.
--- There is a function 'toList' in the opposite direction for all
--- instances of the 'Foldable' class, including 'Seq'.
-fromList :: [a] -> Seq a
-fromList = Data.List.foldl' (|>) empty
-
-------------------------------------------------------------------------
--- Reverse
-------------------------------------------------------------------------
-
--- | /O(n)/. The reverse of a sequence.
-reverse :: Seq a -> Seq a
-reverse (Seq xs) = Seq (reverseTree id xs)
-
-reverseTree :: (a -> a) -> FingerTree a -> FingerTree a
-reverseTree _ Empty = Empty
-reverseTree f (Single x) = Single (f x)
-reverseTree f (Deep s pr m sf) =
- Deep s (reverseDigit f sf)
- (reverseTree (reverseNode f) m)
- (reverseDigit f pr)
-
-reverseDigit :: (a -> a) -> Digit a -> Digit a
-reverseDigit f (One a) = One (f a)
-reverseDigit f (Two a b) = Two (f b) (f a)
-reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
-reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
-
-reverseNode :: (a -> a) -> Node a -> Node a
-reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
-reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
-
-#if TESTING
-
-------------------------------------------------------------------------
--- QuickCheck
-------------------------------------------------------------------------
-
-instance Arbitrary a => Arbitrary (Seq a) where
- arbitrary = liftM Seq arbitrary
- coarbitrary (Seq x) = coarbitrary x
-
-instance Arbitrary a => Arbitrary (Elem a) where
- arbitrary = liftM Elem arbitrary
- coarbitrary (Elem x) = coarbitrary x
-
-instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
- arbitrary = sized arb
- where arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a)
- arb 0 = return Empty
- arb 1 = liftM Single arbitrary
- arb n = liftM3 deep arbitrary (arb (n `div` 2)) arbitrary
-
- coarbitrary Empty = variant 0
- coarbitrary (Single x) = variant 1 . coarbitrary x
- coarbitrary (Deep _ pr m sf) =
- variant 2 . coarbitrary pr . coarbitrary m . coarbitrary sf
-
-instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
- arbitrary = oneof [
- liftM2 node2 arbitrary arbitrary,
- liftM3 node3 arbitrary arbitrary arbitrary]
-
- coarbitrary (Node2 _ a b) = variant 0 . coarbitrary a . coarbitrary b
- coarbitrary (Node3 _ a b c) =
- variant 1 . coarbitrary a . coarbitrary b . coarbitrary c
-
-instance Arbitrary a => Arbitrary (Digit a) where
- arbitrary = oneof [
- liftM One arbitrary,
- liftM2 Two arbitrary arbitrary,
- liftM3 Three arbitrary arbitrary arbitrary,
- liftM4 Four arbitrary arbitrary arbitrary arbitrary]
-
- coarbitrary (One a) = variant 0 . coarbitrary a
- coarbitrary (Two a b) = variant 1 . coarbitrary a . coarbitrary b
- coarbitrary (Three a b c) =
- variant 2 . coarbitrary a . coarbitrary b . coarbitrary c
- coarbitrary (Four a b c d) =
- variant 3 . coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d
-
-------------------------------------------------------------------------
--- Valid trees
-------------------------------------------------------------------------
-
-class Valid a where
- valid :: a -> Bool
-
-instance Valid (Elem a) where
- valid _ = True
-
-instance Valid (Seq a) where
- valid (Seq xs) = valid xs
-
-instance (Sized a, Valid a) => Valid (FingerTree a) where
- valid Empty = True
- valid (Single x) = valid x
- valid (Deep s pr m sf) =
- s == size pr + size m + size sf && valid pr && valid m && valid sf
-
-instance (Sized a, Valid a) => Valid (Node a) where
- valid (Node2 s a b) = s == size a + size b && valid a && valid b
- valid (Node3 s a b c) =
- s == size a + size b + size c && valid a && valid b && valid c
-
-instance Valid a => Valid (Digit a) where
- valid (One a) = valid a
- valid (Two a b) = valid a && valid b
- valid (Three a b c) = valid a && valid b && valid c
- valid (Four a b c d) = valid a && valid b && valid c && valid d
-
-#endif
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Set
--- Copyright : (c) Daan Leijen 2002
--- License : BSD-style
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- An efficient implementation of sets.
---
--- Since many function names (but not the type name) clash with
--- "Prelude" names, this module is usually imported @qualified@, e.g.
---
--- > import Data.Set (Set)
--- > import qualified Data.Set as Set
---
--- The implementation of 'Set' is based on /size balanced/ binary trees (or
--- trees of /bounded balance/) as described by:
---
--- * Stephen Adams, \"/Efficient sets: a balancing act/\",
--- Journal of Functional Programming 3(4):553-562, October 1993,
--- <http://www.swiss.ai.mit.edu/~adams/BB>.
---
--- * J. Nievergelt and E.M. Reingold,
--- \"/Binary search trees of bounded balance/\",
--- SIAM journal of computing 2(1), March 1973.
---
--- Note that the implementation is /left-biased/ -- the elements of a
--- first argument are always preferred to the second, for example in
--- 'union' or 'insert'. Of course, left-biasing can only be observed
--- when equality is an equivalence relation instead of structural
--- equality.
------------------------------------------------------------------------------
-
-module Data.Set (
- -- * Set type
- Set -- instance Eq,Ord,Show,Read,Data,Typeable
-
- -- * Operators
- , (\\)
-
- -- * Query
- , null
- , size
- , member
- , notMember
- , isSubsetOf
- , isProperSubsetOf
-
- -- * Construction
- , empty
- , singleton
- , insert
- , delete
-
- -- * Combine
- , union, unions
- , difference
- , intersection
-
- -- * Filter
- , filter
- , partition
- , split
- , splitMember
-
- -- * Map
- , map
- , mapMonotonic
-
- -- * Fold
- , fold
-
- -- * Min\/Max
- , findMin
- , findMax
- , deleteMin
- , deleteMax
- , deleteFindMin
- , deleteFindMax
- , maxView
- , minView
-
- -- * Conversion
-
- -- ** List
- , elems
- , toList
- , fromList
-
- -- ** Ordered list
- , toAscList
- , fromAscList
- , fromDistinctAscList
-
- -- * Debugging
- , showTree
- , showTreeWith
- , valid
- ) where
-
-import Prelude hiding (filter,foldr,null,map)
-import qualified Data.List as List
-import Data.Monoid (Monoid(..))
-import Data.Typeable
-import Data.Foldable (Foldable(foldMap))
-
-{-
--- just for testing
-import QuickCheck
-import List (nub,sort)
-import qualified List
--}
-
-#if __GLASGOW_HASKELL__
-import Text.Read
-import Data.Generics.Basics
-import Data.Generics.Instances
-#endif
-
-{--------------------------------------------------------------------
- Operators
---------------------------------------------------------------------}
-infixl 9 \\ --
-
--- | /O(n+m)/. See 'difference'.
-(\\) :: Ord a => Set a -> Set a -> Set a
-m1 \\ m2 = difference m1 m2
-
-{--------------------------------------------------------------------
- Sets are size balanced trees
---------------------------------------------------------------------}
--- | A set of values @a@.
-data Set a = Tip
- | Bin {-# UNPACK #-} !Size a !(Set a) !(Set a)
-
-type Size = Int
-
-instance Ord a => Monoid (Set a) where
- mempty = empty
- mappend = union
- mconcat = unions
-
-instance Foldable Set where
- foldMap f Tip = mempty
- foldMap f (Bin _s k l r) = foldMap f l `mappend` f k `mappend` foldMap f r
-
-#if __GLASGOW_HASKELL__
-
-{--------------------------------------------------------------------
- A Data instance
---------------------------------------------------------------------}
-
--- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
-
-instance (Data a, Ord a) => Data (Set a) where
- gfoldl f z set = z fromList `f` (toList set)
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.Set.Set"
- dataCast1 f = gcast1 f
-
-#endif
-
-{--------------------------------------------------------------------
- Query
---------------------------------------------------------------------}
--- | /O(1)/. Is this the empty set?
-null :: Set a -> Bool
-null t
- = case t of
- Tip -> True
- Bin sz x l r -> False
-
--- | /O(1)/. The number of elements in the set.
-size :: Set a -> Int
-size t
- = case t of
- Tip -> 0
- Bin sz x l r -> sz
-
--- | /O(log n)/. Is the element in the set?
-member :: Ord a => a -> Set a -> Bool
-member x t
- = case t of
- Tip -> False
- Bin sz y l r
- -> case compare x y of
- LT -> member x l
- GT -> member x r
- EQ -> True
-
--- | /O(log n)/. Is the element not in the set?
-notMember :: Ord a => a -> Set a -> Bool
-notMember x t = not $ member x t
-
-{--------------------------------------------------------------------
- Construction
---------------------------------------------------------------------}
--- | /O(1)/. The empty set.
-empty :: Set a
-empty
- = Tip
-
--- | /O(1)/. Create a singleton set.
-singleton :: a -> Set a
-singleton x
- = Bin 1 x Tip Tip
-
-{--------------------------------------------------------------------
- Insertion, Deletion
---------------------------------------------------------------------}
--- | /O(log n)/. Insert an element in a set.
--- If the set already contains an element equal to the given value,
--- it is replaced with the new value.
-insert :: Ord a => a -> Set a -> Set a
-insert x t
- = case t of
- Tip -> singleton x
- Bin sz y l r
- -> case compare x y of
- LT -> balance y (insert x l) r
- GT -> balance y l (insert x r)
- EQ -> Bin sz x l r
-
-
--- | /O(log n)/. Delete an element from a set.
-delete :: Ord a => a -> Set a -> Set a
-delete x t
- = case t of
- Tip -> Tip
- Bin sz y l r
- -> case compare x y of
- LT -> balance y (delete x l) r
- GT -> balance y l (delete x r)
- EQ -> glue l r
-
-{--------------------------------------------------------------------
- Subset
---------------------------------------------------------------------}
--- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
-isProperSubsetOf :: Ord a => Set a -> Set a -> Bool
-isProperSubsetOf s1 s2
- = (size s1 < size s2) && (isSubsetOf s1 s2)
-
-
--- | /O(n+m)/. Is this a subset?
--- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.
-isSubsetOf :: Ord a => Set a -> Set a -> Bool
-isSubsetOf t1 t2
- = (size t1 <= size t2) && (isSubsetOfX t1 t2)
-
-isSubsetOfX Tip t = True
-isSubsetOfX t Tip = False
-isSubsetOfX (Bin _ x l r) t
- = found && isSubsetOfX l lt && isSubsetOfX r gt
- where
- (lt,found,gt) = splitMember x t
-
-
-{--------------------------------------------------------------------
- Minimal, Maximal
---------------------------------------------------------------------}
--- | /O(log n)/. The minimal element of a set.
-findMin :: Set a -> a
-findMin (Bin _ x Tip r) = x
-findMin (Bin _ x l r) = findMin l
-findMin Tip = error "Set.findMin: empty set has no minimal element"
-
--- | /O(log n)/. The maximal element of a set.
-findMax :: Set a -> a
-findMax (Bin _ x l Tip) = x
-findMax (Bin _ x l r) = findMax r
-findMax Tip = error "Set.findMax: empty set has no maximal element"
-
--- | /O(log n)/. Delete the minimal element.
-deleteMin :: Set a -> Set a
-deleteMin (Bin _ x Tip r) = r
-deleteMin (Bin _ x l r) = balance x (deleteMin l) r
-deleteMin Tip = Tip
-
--- | /O(log n)/. Delete the maximal element.
-deleteMax :: Set a -> Set a
-deleteMax (Bin _ x l Tip) = l
-deleteMax (Bin _ x l r) = balance x l (deleteMax r)
-deleteMax Tip = Tip
-
-
-{--------------------------------------------------------------------
- Union.
---------------------------------------------------------------------}
--- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).
-unions :: Ord a => [Set a] -> Set a
-unions ts
- = foldlStrict union empty ts
-
-
--- | /O(n+m)/. The union of two sets, preferring the first set when
--- equal elements are encountered.
--- The implementation uses the efficient /hedge-union/ algorithm.
--- Hedge-union is more efficient on (bigset `union` smallset).
-union :: Ord a => Set a -> Set a -> Set a
-union Tip t2 = t2
-union t1 Tip = t1
-union t1 t2 = hedgeUnion (const LT) (const GT) t1 t2
-
-hedgeUnion cmplo cmphi t1 Tip
- = t1
-hedgeUnion cmplo cmphi Tip (Bin _ x l r)
- = join x (filterGt cmplo l) (filterLt cmphi r)
-hedgeUnion cmplo cmphi (Bin _ x l r) t2
- = join x (hedgeUnion cmplo cmpx l (trim cmplo cmpx t2))
- (hedgeUnion cmpx cmphi r (trim cmpx cmphi t2))
- where
- cmpx y = compare x y
-
-{--------------------------------------------------------------------
- Difference
---------------------------------------------------------------------}
--- | /O(n+m)/. Difference of two sets.
--- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
-difference :: Ord a => Set a -> Set a -> Set a
-difference Tip t2 = Tip
-difference t1 Tip = t1
-difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
-
-hedgeDiff cmplo cmphi Tip t
- = Tip
-hedgeDiff cmplo cmphi (Bin _ x l r) Tip
- = join x (filterGt cmplo l) (filterLt cmphi r)
-hedgeDiff cmplo cmphi t (Bin _ x l r)
- = merge (hedgeDiff cmplo cmpx (trim cmplo cmpx t) l)
- (hedgeDiff cmpx cmphi (trim cmpx cmphi t) r)
- where
- cmpx y = compare x y
-
-{--------------------------------------------------------------------
- Intersection
---------------------------------------------------------------------}
--- | /O(n+m)/. The intersection of two sets.
--- Elements of the result come from the first set, so for example
---
--- > import qualified Data.Set as S
--- > data AB = A | B deriving Show
--- > instance Ord AB where compare _ _ = EQ
--- > instance Eq AB where _ == _ = True
--- > main = print (S.singleton A `S.intersection` S.singleton B,
--- > S.singleton B `S.intersection` S.singleton A)
---
--- prints @(fromList [A],fromList [B])@.
-intersection :: Ord a => Set a -> Set a -> Set a
-intersection Tip t = Tip
-intersection t Tip = Tip
-intersection t1@(Bin s1 x1 l1 r1) t2@(Bin s2 x2 l2 r2) =
- if s1 >= s2 then
- let (lt,found,gt) = splitLookup x2 t1
- tl = intersection lt l2
- tr = intersection gt r2
- in case found of
- Just x -> join x tl tr
- Nothing -> merge tl tr
- else let (lt,found,gt) = splitMember x1 t2
- tl = intersection l1 lt
- tr = intersection r1 gt
- in if found then join x1 tl tr
- else merge tl tr
-
-{--------------------------------------------------------------------
- Filter and partition
---------------------------------------------------------------------}
--- | /O(n)/. Filter all elements that satisfy the predicate.
-filter :: Ord a => (a -> Bool) -> Set a -> Set a
-filter p Tip = Tip
-filter p (Bin _ x l r)
- | p x = join x (filter p l) (filter p r)
- | otherwise = merge (filter p l) (filter p r)
-
--- | /O(n)/. Partition the set into two sets, one with all elements that satisfy
--- the predicate and one with all elements that don't satisfy the predicate.
--- See also 'split'.
-partition :: Ord a => (a -> Bool) -> Set a -> (Set a,Set a)
-partition p Tip = (Tip,Tip)
-partition p (Bin _ x l r)
- | p x = (join x l1 r1,merge l2 r2)
- | otherwise = (merge l1 r1,join x l2 r2)
- where
- (l1,l2) = partition p l
- (r1,r2) = partition p r
-
-{----------------------------------------------------------------------
- Map
-----------------------------------------------------------------------}
-
--- | /O(n*log n)/.
--- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.
---
--- It's worth noting that the size of the result may be smaller if,
--- for some @(x,y)@, @x \/= y && f x == f y@
-
-map :: (Ord a, Ord b) => (a->b) -> Set a -> Set b
-map f = fromList . List.map f . toList
-
--- | /O(n)/. The
---
--- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is monotonic.
--- /The precondition is not checked./
--- Semi-formally, we have:
---
--- > and [x < y ==> f x < f y | x <- ls, y <- ls]
--- > ==> mapMonotonic f s == map f s
--- > where ls = toList s
-
-mapMonotonic :: (a->b) -> Set a -> Set b
-mapMonotonic f Tip = Tip
-mapMonotonic f (Bin sz x l r) =
- Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)
-
-
-{--------------------------------------------------------------------
- Fold
---------------------------------------------------------------------}
--- | /O(n)/. Fold over the elements of a set in an unspecified order.
-fold :: (a -> b -> b) -> b -> Set a -> b
-fold f z s
- = foldr f z s
-
--- | /O(n)/. Post-order fold.
-foldr :: (a -> b -> b) -> b -> Set a -> b
-foldr f z Tip = z
-foldr f z (Bin _ x l r) = foldr f (f x (foldr f z r)) l
-
-{--------------------------------------------------------------------
- List variations
---------------------------------------------------------------------}
--- | /O(n)/. The elements of a set.
-elems :: Set a -> [a]
-elems s
- = toList s
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
--- | /O(n)/. Convert the set to a list of elements.
-toList :: Set a -> [a]
-toList s
- = toAscList s
-
--- | /O(n)/. Convert the set to an ascending list of elements.
-toAscList :: Set a -> [a]
-toAscList t
- = foldr (:) [] t
-
-
--- | /O(n*log n)/. Create a set from a list of elements.
-fromList :: Ord a => [a] -> Set a
-fromList xs
- = foldlStrict ins empty xs
- where
- ins t x = insert x t
-
-{--------------------------------------------------------------------
- Building trees from ascending/descending lists can be done in linear time.
-
- Note that if [xs] is ascending that:
- fromAscList xs == fromList xs
---------------------------------------------------------------------}
--- | /O(n)/. Build a set from an ascending list in linear time.
--- /The precondition (input list is ascending) is not checked./
-fromAscList :: Eq a => [a] -> Set a
-fromAscList xs
- = fromDistinctAscList (combineEq xs)
- where
- -- [combineEq xs] combines equal elements with [const] in an ordered list [xs]
- combineEq xs
- = case xs of
- [] -> []
- [x] -> [x]
- (x:xx) -> combineEq' x xx
-
- combineEq' z [] = [z]
- combineEq' z (x:xs)
- | z==x = combineEq' z xs
- | otherwise = z:combineEq' x xs
-
-
--- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.
--- /The precondition (input list is strictly ascending) is not checked./
-fromDistinctAscList :: [a] -> Set a
-fromDistinctAscList xs
- = build const (length xs) xs
- where
- -- 1) use continutations so that we use heap space instead of stack space.
- -- 2) special case for n==5 to build bushier trees.
- build c 0 xs = c Tip xs
- build c 5 xs = case xs of
- (x1:x2:x3:x4:x5:xx)
- -> c (bin x4 (bin x2 (singleton x1) (singleton x3)) (singleton x5)) xx
- build c n xs = seq nr $ build (buildR nr c) nl xs
- where
- nl = n `div` 2
- nr = n - nl - 1
-
- buildR n c l (x:ys) = build (buildB l x c) n ys
- buildB l x c r zs = c (bin x l r) zs
-
-{--------------------------------------------------------------------
- Eq converts the set to a list. In a lazy setting, this
- actually seems one of the faster methods to compare two trees
- and it is certainly the simplest :-)
---------------------------------------------------------------------}
-instance Eq a => Eq (Set a) where
- t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
-
-{--------------------------------------------------------------------
- Ord
---------------------------------------------------------------------}
-
-instance Ord a => Ord (Set a) where
- compare s1 s2 = compare (toAscList s1) (toAscList s2)
-
-{--------------------------------------------------------------------
- Show
---------------------------------------------------------------------}
-instance Show a => Show (Set a) where
- showsPrec p xs = showParen (p > 10) $
- showString "fromList " . shows (toList xs)
-
-showSet :: (Show a) => [a] -> ShowS
-showSet []
- = showString "{}"
-showSet (x:xs)
- = showChar '{' . shows x . showTail xs
- where
- showTail [] = showChar '}'
- showTail (x:xs) = showChar ',' . shows x . showTail xs
-
-{--------------------------------------------------------------------
- Read
---------------------------------------------------------------------}
-instance (Read a, Ord a) => Read (Set a) where
-#ifdef __GLASGOW_HASKELL__
- readPrec = parens $ prec 10 $ do
- Ident "fromList" <- lexP
- xs <- readPrec
- return (fromList xs)
-
- readListPrec = readListPrecDefault
-#else
- readsPrec p = readParen (p > 10) $ \ r -> do
- ("fromList",s) <- lex r
- (xs,t) <- reads s
- return (fromList xs,t)
-#endif
-
-{--------------------------------------------------------------------
- Typeable/Data
---------------------------------------------------------------------}
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(Set,setTc,"Set")
-
-{--------------------------------------------------------------------
- Utility functions that return sub-ranges of the original
- tree. Some functions take a comparison function as argument to
- allow comparisons against infinite values. A function [cmplo x]
- should be read as [compare lo x].
-
- [trim cmplo cmphi t] A tree that is either empty or where [cmplo x == LT]
- and [cmphi x == GT] for the value [x] of the root.
- [filterGt cmp t] A tree where for all values [k]. [cmp k == LT]
- [filterLt cmp t] A tree where for all values [k]. [cmp k == GT]
-
- [split k t] Returns two trees [l] and [r] where all values
- in [l] are <[k] and all keys in [r] are >[k].
- [splitMember k t] Just like [split] but also returns whether [k]
- was found in the tree.
---------------------------------------------------------------------}
-
-{--------------------------------------------------------------------
- [trim lo hi t] trims away all subtrees that surely contain no
- values between the range [lo] to [hi]. The returned tree is either
- empty or the key of the root is between @lo@ and @hi@.
---------------------------------------------------------------------}
-trim :: (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a
-trim cmplo cmphi Tip = Tip
-trim cmplo cmphi t@(Bin sx x l r)
- = case cmplo x of
- LT -> case cmphi x of
- GT -> t
- le -> trim cmplo cmphi l
- ge -> trim cmplo cmphi r
-
-trimMemberLo :: Ord a => a -> (a -> Ordering) -> Set a -> (Bool, Set a)
-trimMemberLo lo cmphi Tip = (False,Tip)
-trimMemberLo lo cmphi t@(Bin sx x l r)
- = case compare lo x of
- LT -> case cmphi x of
- GT -> (member lo t, t)
- le -> trimMemberLo lo cmphi l
- GT -> trimMemberLo lo cmphi r
- EQ -> (True,trim (compare lo) cmphi r)
-
-
-{--------------------------------------------------------------------
- [filterGt x t] filter all values >[x] from tree [t]
- [filterLt x t] filter all values <[x] from tree [t]
---------------------------------------------------------------------}
-filterGt :: (a -> Ordering) -> Set a -> Set a
-filterGt cmp Tip = Tip
-filterGt cmp (Bin sx x l r)
- = case cmp x of
- LT -> join x (filterGt cmp l) r
- GT -> filterGt cmp r
- EQ -> r
-
-filterLt :: (a -> Ordering) -> Set a -> Set a
-filterLt cmp Tip = Tip
-filterLt cmp (Bin sx x l r)
- = case cmp x of
- LT -> filterLt cmp l
- GT -> join x l (filterLt cmp r)
- EQ -> l
-
-
-{--------------------------------------------------------------------
- Split
---------------------------------------------------------------------}
--- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@
--- where all elements in @set1@ are lower than @x@ and all elements in
--- @set2@ larger than @x@. @x@ is not found in neither @set1@ nor @set2@.
-split :: Ord a => a -> Set a -> (Set a,Set a)
-split x Tip = (Tip,Tip)
-split x (Bin sy y l r)
- = case compare x y of
- LT -> let (lt,gt) = split x l in (lt,join y gt r)
- GT -> let (lt,gt) = split x r in (join y l lt,gt)
- EQ -> (l,r)
-
--- | /O(log n)/. Performs a 'split' but also returns whether the pivot
--- element was found in the original set.
-splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a)
-splitMember x t = let (l,m,r) = splitLookup x t in
- (l,maybe False (const True) m,r)
-
--- | /O(log n)/. Performs a 'split' but also returns the pivot
--- element that was found in the original set.
-splitLookup :: Ord a => a -> Set a -> (Set a,Maybe a,Set a)
-splitLookup x Tip = (Tip,Nothing,Tip)
-splitLookup x (Bin sy y l r)
- = case compare x y of
- LT -> let (lt,found,gt) = splitLookup x l in (lt,found,join y gt r)
- GT -> let (lt,found,gt) = splitLookup x r in (join y l lt,found,gt)
- EQ -> (l,Just y,r)
-
-{--------------------------------------------------------------------
- Utility functions that maintain the balance properties of the tree.
- All constructors assume that all values in [l] < [x] and all values
- in [r] > [x], and that [l] and [r] are valid trees.
-
- In order of sophistication:
- [Bin sz x l r] The type constructor.
- [bin x l r] Maintains the correct size, assumes that both [l]
- and [r] are balanced with respect to each other.
- [balance x l r] Restores the balance and size.
- Assumes that the original tree was balanced and
- that [l] or [r] has changed by at most one element.
- [join x l r] Restores balance and size.
-
- Furthermore, we can construct a new tree from two trees. Both operations
- assume that all values in [l] < all values in [r] and that [l] and [r]
- are valid:
- [glue l r] Glues [l] and [r] together. Assumes that [l] and
- [r] are already balanced with respect to each other.
- [merge l r] Merges two trees and restores balance.
-
- Note: in contrast to Adam's paper, we use (<=) comparisons instead
- of (<) comparisons in [join], [merge] and [balance].
- Quickcheck (on [difference]) showed that this was necessary in order
- to maintain the invariants. It is quite unsatisfactory that I haven't
- been able to find out why this is actually the case! Fortunately, it
- doesn't hurt to be a bit more conservative.
---------------------------------------------------------------------}
-
-{--------------------------------------------------------------------
- Join
---------------------------------------------------------------------}
-join :: a -> Set a -> Set a -> Set a
-join x Tip r = insertMin x r
-join x l Tip = insertMax x l
-join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)
- | delta*sizeL <= sizeR = balance z (join x l lz) rz
- | delta*sizeR <= sizeL = balance y ly (join x ry r)
- | otherwise = bin x l r
-
-
--- insertMin and insertMax don't perform potentially expensive comparisons.
-insertMax,insertMin :: a -> Set a -> Set a
-insertMax x t
- = case t of
- Tip -> singleton x
- Bin sz y l r
- -> balance y l (insertMax x r)
-
-insertMin x t
- = case t of
- Tip -> singleton x
- Bin sz y l r
- -> balance y (insertMin x l) r
-
-{--------------------------------------------------------------------
- [merge l r]: merges two trees.
---------------------------------------------------------------------}
-merge :: Set a -> Set a -> Set a
-merge Tip r = r
-merge l Tip = l
-merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)
- | delta*sizeL <= sizeR = balance y (merge l ly) ry
- | delta*sizeR <= sizeL = balance x lx (merge rx r)
- | otherwise = glue l r
-
-{--------------------------------------------------------------------
- [glue l r]: glues two trees together.
- Assumes that [l] and [r] are already balanced with respect to each other.
---------------------------------------------------------------------}
-glue :: Set a -> Set a -> Set a
-glue Tip r = r
-glue l Tip = l
-glue l r
- | size l > size r = let (m,l') = deleteFindMax l in balance m l' r
- | otherwise = let (m,r') = deleteFindMin r in balance m l r'
-
-
--- | /O(log n)/. Delete and find the minimal element.
---
--- > deleteFindMin set = (findMin set, deleteMin set)
-
-deleteFindMin :: Set a -> (a,Set a)
-deleteFindMin t
- = case t of
- Bin _ x Tip r -> (x,r)
- Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balance x l' r)
- Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)
-
--- | /O(log n)/. Delete and find the maximal element.
---
--- > deleteFindMax set = (findMax set, deleteMax set)
-deleteFindMax :: Set a -> (a,Set a)
-deleteFindMax t
- = case t of
- Bin _ x l Tip -> (x,l)
- Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balance x l r')
- Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)
-
--- | /O(log n)/. Retrieves the minimal key of the set, and the set stripped from that element
--- @fail@s (in the monad) when passed an empty set.
-minView :: Monad m => Set a -> m (a, Set a)
-minView Tip = fail "Set.minView: empty set"
-minView x = return (deleteFindMin x)
-
--- | /O(log n)/. Retrieves the maximal key of the set, and the set stripped from that element
--- @fail@s (in the monad) when passed an empty set.
-maxView :: Monad m => Set a -> m (a, Set a)
-maxView Tip = fail "Set.maxView: empty set"
-maxView x = return (deleteFindMax x)
-
-
-{--------------------------------------------------------------------
- [balance x l r] balances two trees with value x.
- The sizes of the trees should balance after decreasing the
- size of one of them. (a rotation).
-
- [delta] is the maximal relative difference between the sizes of
- two trees, it corresponds with the [w] in Adams' paper,
- or equivalently, [1/delta] corresponds with the $\alpha$
- in Nievergelt's paper. Adams shows that [delta] should
- be larger than 3.745 in order to garantee that the
- rotations can always restore balance.
-
- [ratio] is the ratio between an outer and inner sibling of the
- heavier subtree in an unbalanced setting. It determines
- whether a double or single rotation should be performed
- to restore balance. It is correspondes with the inverse
- of $\alpha$ in Adam's article.
-
- Note that:
- - [delta] should be larger than 4.646 with a [ratio] of 2.
- - [delta] should be larger than 3.745 with a [ratio] of 1.534.
-
- - A lower [delta] leads to a more 'perfectly' balanced tree.
- - A higher [delta] performs less rebalancing.
-
- - Balancing is automatic for random data and a balancing
- scheme is only necessary to avoid pathological worst cases.
- Almost any choice will do in practice
-
- - Allthough it seems that a rather large [delta] may perform better
- than smaller one, measurements have shown that the smallest [delta]
- of 4 is actually the fastest on a wide range of operations. It
- especially improves performance on worst-case scenarios like
- a sequence of ordered insertions.
-
- Note: in contrast to Adams' paper, we use a ratio of (at least) 2
- to decide whether a single or double rotation is needed. Allthough
- he actually proves that this ratio is needed to maintain the
- invariants, his implementation uses a (invalid) ratio of 1.
- He is aware of the problem though since he has put a comment in his
- original source code that he doesn't care about generating a
- slightly inbalanced tree since it doesn't seem to matter in practice.
- However (since we use quickcheck :-) we will stick to strictly balanced
- trees.
---------------------------------------------------------------------}
-delta,ratio :: Int
-delta = 4
-ratio = 2
-
-balance :: a -> Set a -> Set a -> Set a
-balance x l r
- | sizeL + sizeR <= 1 = Bin sizeX x l r
- | sizeR >= delta*sizeL = rotateL x l r
- | sizeL >= delta*sizeR = rotateR x l r
- | otherwise = Bin sizeX x l r
- where
- sizeL = size l
- sizeR = size r
- sizeX = sizeL + sizeR + 1
-
--- rotate
-rotateL x l r@(Bin _ _ ly ry)
- | size ly < ratio*size ry = singleL x l r
- | otherwise = doubleL x l r
-
-rotateR x l@(Bin _ _ ly ry) r
- | size ry < ratio*size ly = singleR x l r
- | otherwise = doubleR x l r
-
--- basic rotations
-singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3
-singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3)
-
-doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
-doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)
-
-
-{--------------------------------------------------------------------
- The bin constructor maintains the size of the tree
---------------------------------------------------------------------}
-bin :: a -> Set a -> Set a -> Set a
-bin x l r
- = Bin (size l + size r + 1) x l r
-
-
-{--------------------------------------------------------------------
- Utilities
---------------------------------------------------------------------}
-foldlStrict f z xs
- = case xs of
- [] -> z
- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
-
-
-{--------------------------------------------------------------------
- Debugging
---------------------------------------------------------------------}
--- | /O(n)/. Show the tree that implements the set. The tree is shown
--- in a compressed, hanging format.
-showTree :: Show a => Set a -> String
-showTree s
- = showTreeWith True False s
-
-
-{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
- the tree that implements the set. If @hang@ is
- @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
- @wide@ is 'True', an extra wide version is shown.
-
-> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]
-> 4
-> +--2
-> | +--1
-> | +--3
-> +--5
->
-> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]
-> 4
-> |
-> +--2
-> | |
-> | +--1
-> | |
-> | +--3
-> |
-> +--5
->
-> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]
-> +--5
-> |
-> 4
-> |
-> | +--3
-> | |
-> +--2
-> |
-> +--1
-
--}
-showTreeWith :: Show a => Bool -> Bool -> Set a -> String
-showTreeWith hang wide t
- | hang = (showsTreeHang wide [] t) ""
- | otherwise = (showsTree wide [] [] t) ""
-
-showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS
-showsTree wide lbars rbars t
- = case t of
- Tip -> showsBars lbars . showString "|\n"
- Bin sz x Tip Tip
- -> showsBars lbars . shows x . showString "\n"
- Bin sz x l r
- -> showsTree wide (withBar rbars) (withEmpty rbars) r .
- showWide wide rbars .
- showsBars lbars . shows x . showString "\n" .
- showWide wide lbars .
- showsTree wide (withEmpty lbars) (withBar lbars) l
-
-showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS
-showsTreeHang wide bars t
- = case t of
- Tip -> showsBars bars . showString "|\n"
- Bin sz x Tip Tip
- -> showsBars bars . shows x . showString "\n"
- Bin sz x l r
- -> showsBars bars . shows x . showString "\n" .
- showWide wide bars .
- showsTreeHang wide (withBar bars) l .
- showWide wide bars .
- showsTreeHang wide (withEmpty bars) r
-
-
-showWide wide bars
- | wide = showString (concat (reverse bars)) . showString "|\n"
- | otherwise = id
-
-showsBars :: [String] -> ShowS
-showsBars bars
- = case bars of
- [] -> id
- _ -> showString (concat (reverse (tail bars))) . showString node
-
-node = "+--"
-withBar bars = "| ":bars
-withEmpty bars = " ":bars
-
-{--------------------------------------------------------------------
- Assertions
---------------------------------------------------------------------}
--- | /O(n)/. Test if the internal set structure is valid.
-valid :: Ord a => Set a -> Bool
-valid t
- = balanced t && ordered t && validsize t
-
-ordered t
- = bounded (const True) (const True) t
- where
- bounded lo hi t
- = case t of
- Tip -> True
- Bin sz x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r
-
-balanced :: Set a -> Bool
-balanced t
- = case t of
- Tip -> True
- Bin sz x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
- balanced l && balanced r
-
-
-validsize t
- = (realsize t == Just (size t))
- where
- realsize t
- = case t of
- Tip -> Just 0
- Bin sz x l r -> case (realsize l,realsize r) of
- (Just n,Just m) | n+m+1 == sz -> Just sz
- other -> Nothing
-
-{-
-{--------------------------------------------------------------------
- Testing
---------------------------------------------------------------------}
-testTree :: [Int] -> Set Int
-testTree xs = fromList xs
-test1 = testTree [1..20]
-test2 = testTree [30,29..10]
-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
-
-{--------------------------------------------------------------------
- QuickCheck
---------------------------------------------------------------------}
-qcheck prop
- = check config prop
- where
- config = Config
- { configMaxTest = 500
- , configMaxFail = 5000
- , configSize = \n -> (div n 2 + 3)
- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
- }
-
-
-{--------------------------------------------------------------------
- Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-instance (Enum a) => Arbitrary (Set a) where
- arbitrary = sized (arbtree 0 maxkey)
- where maxkey = 10000
-
-arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a)
-arbtree lo hi n
- | n <= 0 = return Tip
- | lo >= hi = return Tip
- | otherwise = do{ i <- choose (lo,hi)
- ; m <- choose (1,30)
- ; let (ml,mr) | m==(1::Int)= (1,2)
- | m==2 = (2,1)
- | m==3 = (1,1)
- | otherwise = (2,2)
- ; l <- arbtree lo (i-1) (n `div` ml)
- ; r <- arbtree (i+1) hi (n `div` mr)
- ; return (bin (toEnum i) l r)
- }
-
-
-{--------------------------------------------------------------------
- Valid tree's
---------------------------------------------------------------------}
-forValid :: (Enum a,Show a,Testable b) => (Set a -> b) -> Property
-forValid f
- = forAll arbitrary $ \t ->
--- classify (balanced t) "balanced" $
- classify (size t == 0) "empty" $
- classify (size t > 0 && size t <= 10) "small" $
- classify (size t > 10 && size t <= 64) "medium" $
- classify (size t > 64) "large" $
- balanced t ==> f t
-
-forValidIntTree :: Testable a => (Set Int -> a) -> Property
-forValidIntTree f
- = forValid f
-
-forValidUnitTree :: Testable a => (Set Int -> a) -> Property
-forValidUnitTree f
- = forValid f
-
-
-prop_Valid
- = forValidUnitTree $ \t -> valid t
-
-{--------------------------------------------------------------------
- Single, Insert, Delete
---------------------------------------------------------------------}
-prop_Single :: Int -> Bool
-prop_Single x
- = (insert x empty == singleton x)
-
-prop_InsertValid :: Int -> Property
-prop_InsertValid k
- = forValidUnitTree $ \t -> valid (insert k t)
-
-prop_InsertDelete :: Int -> Set Int -> Property
-prop_InsertDelete k t
- = not (member k t) ==> delete k (insert k t) == t
-
-prop_DeleteValid :: Int -> Property
-prop_DeleteValid k
- = forValidUnitTree $ \t ->
- valid (delete k (insert k t))
-
-{--------------------------------------------------------------------
- Balance
---------------------------------------------------------------------}
-prop_Join :: Int -> Property
-prop_Join x
- = forValidUnitTree $ \t ->
- let (l,r) = split x t
- in valid (join x l r)
-
-prop_Merge :: Int -> Property
-prop_Merge x
- = forValidUnitTree $ \t ->
- let (l,r) = split x t
- in valid (merge l r)
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
-prop_UnionValid :: Property
-prop_UnionValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (union t1 t2)
-
-prop_UnionInsert :: Int -> Set Int -> Bool
-prop_UnionInsert x t
- = union t (singleton x) == insert x t
-
-prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool
-prop_UnionAssoc t1 t2 t3
- = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_UnionComm :: Set Int -> Set Int -> Bool
-prop_UnionComm t1 t2
- = (union t1 t2 == union t2 t1)
-
-
-prop_DiffValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (difference t1 t2)
-
-prop_Diff :: [Int] -> [Int] -> Bool
-prop_Diff xs ys
- = toAscList (difference (fromList xs) (fromList ys))
- == List.sort ((List.\\) (nub xs) (nub ys))
-
-prop_IntValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (intersection t1 t2)
-
-prop_Int :: [Int] -> [Int] -> Bool
-prop_Int xs ys
- = toAscList (intersection (fromList xs) (fromList ys))
- == List.sort (nub ((List.intersect) (xs) (ys)))
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [0..n::Int]
- in fromAscList xs == fromList xs
-
-prop_List :: [Int] -> Bool
-prop_List xs
- = (sort (nub xs) == toList (fromList xs))
--}
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.String
--- Copyright : (c) The University of Glasgow 2007
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Things related to the String type.
---
------------------------------------------------------------------------------
-
-module Data.String (
- IsString(..)
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-#endif
-
--- | Class for string-like datastructures; used by the overloaded string
--- extension (-foverloaded-strings in GHC).
-class IsString a where
- fromString :: String -> a
-
-instance IsString [Char] where
- fromString xs = xs
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Traversable
--- 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
---
--- Class of data structures that can be traversed from left to right,
--- performing an action on each element.
---
--- See also
---
--- * /Applicative Programming with Effects/,
--- by Conor McBride and Ross Paterson, online at
--- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.
---
--- * /The Essence of the Iterator Pattern/,
--- by Jeremy Gibbons and Bruno Oliveira,
--- in /Mathematically-Structured Functional Programming/, 2006, and online at
--- <http://web.comlab.ox.ac.uk/oucl/work/jeremy.gibbons/publications/#iterator>.
---
--- Note that the functions 'mapM' and 'sequence' generalize "Prelude"
--- functions of the same names from lists to any 'Traversable' functor.
--- To avoid ambiguity, either import the "Prelude" hiding these names
--- or qualify uses of these function names with an alias for this module.
-
-module Data.Traversable (
- Traversable(..),
- for,
- forM,
- fmapDefault,
- foldMapDefault,
- ) where
-
-import Prelude hiding (mapM, sequence, foldr)
-import qualified Prelude (mapM, foldr)
-import Control.Applicative
-import Data.Foldable (Foldable())
-import Data.Monoid (Monoid)
-import Data.Array
-
--- | Functors representing data structures that can be traversed from
--- left to right.
---
--- Minimal complete definition: 'traverse' or 'sequenceA'.
---
--- Instances are similar to 'Functor', e.g. given a data type
---
--- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)
---
--- a suitable instance would be
---
--- > instance Traversable Tree
--- > traverse f Empty = pure Empty
--- > traverse f (Leaf x) = Leaf <$> f x
--- > traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r
---
--- This is suitable even for abstract types, as the laws for '<*>'
--- imply a form of associativity.
---
--- The superclass instances should satisfy the following:
---
--- * In the 'Functor' instance, 'fmap' should be equivalent to traversal
--- with the identity applicative functor ('fmapDefault').
---
--- * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be
--- equivalent to traversal with a constant applicative functor
--- ('foldMapDefault').
---
-class (Functor t, Foldable t) => Traversable t where
- -- | Map each element of a structure to an action, evaluate
- -- these actions from left to right, and collect the results.
- traverse :: Applicative f => (a -> f b) -> t a -> f (t b)
- traverse f = sequenceA . fmap f
-
- -- | Evaluate each action in the structure from left to right,
- -- and collect the results.
- sequenceA :: Applicative f => t (f a) -> f (t a)
- sequenceA = traverse id
-
- -- | Map each element of a structure to a monadic action, evaluate
- -- these actions from left to right, and collect the results.
- mapM :: Monad m => (a -> m b) -> t a -> m (t b)
- mapM f = unwrapMonad . traverse (WrapMonad . f)
-
- -- | Evaluate each monadic action in the structure from left to right,
- -- and collect the results.
- sequence :: Monad m => t (m a) -> m (t a)
- sequence = mapM id
-
--- instances for Prelude types
-
-instance Traversable Maybe where
- traverse f Nothing = pure Nothing
- traverse f (Just x) = Just <$> f x
-
-instance Traversable [] where
- traverse f = Prelude.foldr cons_f (pure [])
- where cons_f x ys = (:) <$> f x <*> ys
-
- mapM = Prelude.mapM
-
-instance Ix i => Traversable (Array i) where
- traverse f arr = listArray (bounds arr) <$> traverse f (elems arr)
-
--- general functions
-
--- | 'for' is 'traverse' with its arguments flipped.
-for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)
-{-# INLINE for #-}
-for = flip traverse
-
--- | 'forM' is 'mapM' with its arguments flipped.
-forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b)
-{-# INLINE forM #-}
-forM = flip mapM
-
--- | This function may be used as a value for `fmap` in a `Functor` instance.
-fmapDefault :: Traversable t => (a -> b) -> t a -> t b
-fmapDefault f = getId . traverse (Id . f)
-
--- | This function may be used as a value for `Data.Foldable.foldMap`
--- in a `Foldable` instance.
-foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m
-foldMapDefault f = getConst . traverse (Const . f)
-
--- local instances
-
-newtype Id a = Id { getId :: a }
-
-instance Functor Id where
- fmap f (Id x) = Id (f x)
-
-instance Applicative Id where
- pure = Id
- Id f <*> Id x = Id (f x)
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Tree
--- Copyright : (c) The University of Glasgow 2002
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Multi-way trees (/aka/ rose trees) and forests.
---
------------------------------------------------------------------------------
-
-module Data.Tree(
- Tree(..), Forest,
- -- * Two-dimensional drawing
- drawTree, drawForest,
- -- * Extraction
- flatten, levels,
- -- * Building trees
- unfoldTree, unfoldForest,
- unfoldTreeM, unfoldForestM,
- unfoldTreeM_BF, unfoldForestM_BF,
- ) where
-
-#ifdef __HADDOCK__
-import Prelude
-#endif
-
-import Control.Applicative (Applicative(..), (<$>))
-import Control.Monad
-import Data.Monoid (Monoid(..))
-import Data.Sequence (Seq, empty, singleton, (<|), (|>), fromList,
- ViewL(..), ViewR(..), viewl, viewr)
-import Data.Foldable (Foldable(foldMap), toList)
-import Data.Traversable (Traversable(traverse))
-import Data.Typeable
-
-#ifdef __GLASGOW_HASKELL__
-import Data.Generics.Basics (Data)
-#endif
-
--- | Multi-way trees, also known as /rose trees/.
-data Tree a = Node {
- rootLabel :: a, -- ^ label value
- subForest :: Forest a -- ^ zero or more child trees
- }
-#ifndef __HADDOCK__
-# ifdef __GLASGOW_HASKELL__
- deriving (Eq, Read, Show, Data)
-# else
- deriving (Eq, Read, Show)
-# endif
-#else /* __HADDOCK__ (which can't figure these out by itself) */
-instance Eq a => Eq (Tree a)
-instance Read a => Read (Tree a)
-instance Show a => Show (Tree a)
-instance Data a => Data (Tree a)
-#endif
-type Forest a = [Tree a]
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(Tree,treeTc,"Tree")
-
-instance Functor Tree where
- fmap f (Node x ts) = Node (f x) (map (fmap f) ts)
-
-instance Applicative Tree where
- pure x = Node x []
- Node f tfs <*> tx@(Node x txs) =
- Node (f x) (map (f <$>) txs ++ map (<*> tx) tfs)
-
-instance Monad Tree where
- return x = Node x []
- Node x ts >>= f = Node x' (ts' ++ map (>>= f) ts)
- where Node x' ts' = f x
-
-instance Traversable Tree where
- traverse f (Node x ts) = Node <$> f x <*> traverse (traverse f) ts
-
-instance Foldable Tree where
- foldMap f (Node x ts) = f x `mappend` foldMap (foldMap f) ts
-
--- | Neat 2-dimensional drawing of a tree.
-drawTree :: Tree String -> String
-drawTree = unlines . draw
-
--- | Neat 2-dimensional drawing of a forest.
-drawForest :: Forest String -> String
-drawForest = unlines . map drawTree
-
-draw :: Tree String -> [String]
-draw (Node x ts0) = x : drawSubTrees ts0
- where drawSubTrees [] = []
- drawSubTrees [t] =
- "|" : shift "`- " " " (draw t)
- drawSubTrees (t:ts) =
- "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts
-
- shift first other = zipWith (++) (first : repeat other)
-
--- | The elements of a tree in pre-order.
-flatten :: Tree a -> [a]
-flatten t = squish t []
- where squish (Node x ts) xs = x:Prelude.foldr squish xs ts
-
--- | Lists of nodes at each level of the tree.
-levels :: Tree a -> [[a]]
-levels t = map (map rootLabel) $
- takeWhile (not . null) $
- iterate (concatMap subForest) [t]
-
--- | Build a tree from a seed value
-unfoldTree :: (b -> (a, [b])) -> b -> Tree a
-unfoldTree f b = let (a, bs) = f b in Node a (unfoldForest f bs)
-
--- | Build a forest from a list of seed values
-unfoldForest :: (b -> (a, [b])) -> [b] -> Forest a
-unfoldForest f = map (unfoldTree f)
-
--- | Monadic tree builder, in depth-first order
-unfoldTreeM :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a)
-unfoldTreeM f b = do
- (a, bs) <- f b
- ts <- unfoldForestM f bs
- return (Node a ts)
-
--- | Monadic forest builder, in depth-first order
-#ifndef __NHC__
-unfoldForestM :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a)
-#endif
-unfoldForestM f = Prelude.mapM (unfoldTreeM f)
-
--- | Monadic tree builder, in breadth-first order,
--- using an algorithm adapted from
--- /Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design/,
--- by Chris Okasaki, /ICFP'00/.
-unfoldTreeM_BF :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a)
-unfoldTreeM_BF f b = liftM getElement $ unfoldForestQ f (singleton b)
- where getElement xs = case viewl xs of
- x :< _ -> x
- EmptyL -> error "unfoldTreeM_BF"
-
--- | Monadic forest builder, in breadth-first order,
--- using an algorithm adapted from
--- /Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design/,
--- by Chris Okasaki, /ICFP'00/.
-unfoldForestM_BF :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a)
-unfoldForestM_BF f = liftM toList . unfoldForestQ f . fromList
-
--- takes a sequence (queue) of seeds
--- produces a sequence (reversed queue) of trees of the same length
-unfoldForestQ :: Monad m => (b -> m (a, [b])) -> Seq b -> m (Seq (Tree a))
-unfoldForestQ f aQ = case viewl aQ of
- EmptyL -> return empty
- a :< aQ -> do
- (b, as) <- f a
- tQ <- unfoldForestQ f (Prelude.foldl (|>) aQ as)
- let (tQ', ts) = splitOnto [] as tQ
- return (Node b ts <| tQ')
- where splitOnto :: [a'] -> [b'] -> Seq a' -> (Seq a', [a'])
- splitOnto as [] q = (q, as)
- splitOnto as (_:bs) q = case viewr q of
- q' :> a -> splitOnto (a:as) bs q'
- EmptyR -> error "unfoldForestQ"
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Tuple
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- The tuple data types, and associated functions.
---
------------------------------------------------------------------------------
-
-module Data.Tuple
- ( fst -- :: (a,b) -> a
- , snd -- :: (a,b) -> a
- , curry -- :: ((a, b) -> c) -> a -> b -> c
- , uncurry -- :: (a -> b -> c) -> ((a, b) -> c)
-#ifdef __NHC__
- , (,)(..)
- , (,,)(..)
- , (,,,)(..)
- , (,,,,)(..)
- , (,,,,,)(..)
- , (,,,,,,)(..)
- , (,,,,,,,)(..)
- , (,,,,,,,,)(..)
- , (,,,,,,,,,)(..)
- , (,,,,,,,,,,)(..)
- , (,,,,,,,,,,,)(..)
- , (,,,,,,,,,,,,)(..)
- , (,,,,,,,,,,,,,)(..)
- , (,,,,,,,,,,,,,,)(..)
-#endif
- )
- where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-#endif /* __GLASGOW_HASKELL__ */
-
-#ifdef __NHC__
-import Prelude
-import Prelude
- ( (,)(..)
- , (,,)(..)
- , (,,,)(..)
- , (,,,,)(..)
- , (,,,,,)(..)
- , (,,,,,,)(..)
- , (,,,,,,,)(..)
- , (,,,,,,,,)(..)
- , (,,,,,,,,,)(..)
- , (,,,,,,,,,,)(..)
- , (,,,,,,,,,,,)(..)
- , (,,,,,,,,,,,,)(..)
- , (,,,,,,,,,,,,,)(..)
- , (,,,,,,,,,,,,,,)(..)
- -- nhc98's prelude only supplies tuple instances up to size 15
- , fst, snd
- , curry, uncurry
- )
-#endif
-
-default () -- Double isn't available yet
-
-#ifdef __GLASGOW_HASKELL__
-data (,) a b = (,) a b deriving (Eq, Ord)
-data (,,) a b c = (,,) a b c deriving (Eq, Ord)
-data (,,,) a b c d = (,,,) a b c d deriving (Eq, Ord)
-data (,,,,) a b c d e = (,,,,) a b c d e deriving (Eq, Ord)
-data (,,,,,) a b c d e f = (,,,,,) a b c d e f deriving (Eq, Ord)
-data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g deriving (Eq, Ord)
-data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h deriving (Eq, Ord)
-data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i deriving (Eq, Ord)
-data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j deriving (Eq, Ord)
-data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k deriving (Eq, Ord)
-data (,,,,,,,,,,,) a b c d e f g h i j k l = (,,,,,,,,,,,) a b c d e f g h i j k l deriving (Eq, Ord)
-data (,,,,,,,,,,,,) a b c d e f g h i j k l m = (,,,,,,,,,,,,) a b c d e f g h i j k l m deriving (Eq, Ord)
-data (,,,,,,,,,,,,,) a b c d e f g h i j k l m n = (,,,,,,,,,,,,,) a b c d e f g h i j k l m n deriving (Eq, Ord)
-data (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o = (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o deriving (Eq, Ord)
-data (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p = (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p
-data (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q
- = (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q
-data (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r
- = (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r
-data (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s
- = (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s
-data (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t
- = (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t
-data (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u
- = (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u
-data (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v
- = (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v
-data (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w
- = (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w
-data (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x
- = (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x
-data (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y
- = (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y
-data (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z
- = (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__
-{- Manuel says: Including one more declaration gives a segmentation fault.
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ v___
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ v___
--}
-#endif /* __GLASGOW_HASKELL__ */
-
--- ---------------------------------------------------------------------------
--- Standard functions over tuples
-
-#if !defined(__HUGS__) && !defined(__NHC__)
--- | Extract the first component of a pair.
-fst :: (a,b) -> a
-fst (x,_) = x
-
--- | Extract the second component of a pair.
-snd :: (a,b) -> b
-snd (_,y) = y
-
--- | 'curry' converts an uncurried function to a curried function.
-curry :: ((a, b) -> c) -> a -> b -> c
-curry f x y = f (x, y)
-
--- | 'uncurry' converts a curried function to a function on pairs.
-uncurry :: (a -> b -> c) -> ((a, b) -> c)
-uncurry f p = f (fst p) (snd p)
-#endif /* neither __HUGS__ nor __NHC__ */
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude -fallow-overlapping-instances #-}
-
--- The -fallow-overlapping-instances flag allows the user to over-ride
--- the instances for Typeable given here. In particular, we provide an instance
--- instance ... => Typeable (s a)
--- But a user might want to say
--- instance ... => Typeable (MyType a b)
-
------------------------------------------------------------------------------
--- |
--- Module : Data.Typeable
--- Copyright : (c) The University of Glasgow, CWI 2001--2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- The 'Typeable' class reifies types to some extent by associating type
--- representations to types. These type representations can be compared,
--- and one can in turn define a type-safe cast operation. To this end,
--- an unsafe cast is guarded by a test for type (representation)
--- equivalence. The module "Data.Dynamic" uses Typeable for an
--- implementation of dynamics. The module "Data.Generics" uses Typeable
--- and type-safe cast (but not dynamics) to support the \"Scrap your
--- boilerplate\" style of generic programming.
---
------------------------------------------------------------------------------
-
-module Data.Typeable
- (
-
- -- * The Typeable class
- Typeable( typeOf ), -- :: a -> TypeRep
-
- -- * Type-safe cast
- cast, -- :: (Typeable a, Typeable b) => a -> Maybe b
- gcast, -- a generalisation of cast
-
- -- * Type representations
- TypeRep, -- abstract, instance of: Eq, Show, Typeable
- TyCon, -- abstract, instance of: Eq, Show, Typeable
- showsTypeRep,
-
- -- * Construction of type representations
- mkTyCon, -- :: String -> TyCon
- mkTyConApp, -- :: TyCon -> [TypeRep] -> TypeRep
- mkAppTy, -- :: TypeRep -> TypeRep -> TypeRep
- mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep
-
- -- * Observation of type representations
- splitTyConApp, -- :: TypeRep -> (TyCon, [TypeRep])
- funResultTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep
- typeRepTyCon, -- :: TypeRep -> TyCon
- typeRepArgs, -- :: TypeRep -> [TypeRep]
- tyConString, -- :: TyCon -> String
- typeRepKey, -- :: TypeRep -> IO Int
-
- -- * The other Typeable classes
- -- | /Note:/ The general instances are provided for GHC only.
- Typeable1( typeOf1 ), -- :: t a -> TypeRep
- Typeable2( typeOf2 ), -- :: t a b -> TypeRep
- Typeable3( typeOf3 ), -- :: t a b c -> TypeRep
- Typeable4( typeOf4 ), -- :: t a b c d -> TypeRep
- Typeable5( typeOf5 ), -- :: t a b c d e -> TypeRep
- Typeable6( typeOf6 ), -- :: t a b c d e f -> TypeRep
- Typeable7( typeOf7 ), -- :: t a b c d e f g -> TypeRep
- gcast1, -- :: ... => c (t a) -> Maybe (c (t' a))
- gcast2, -- :: ... => c (t a b) -> Maybe (c (t' a b))
-
- -- * Default instances
- -- | /Note:/ These are not needed by GHC, for which these instances
- -- are generated by general instance declarations.
- typeOfDefault, -- :: (Typeable1 t, Typeable a) => t a -> TypeRep
- typeOf1Default, -- :: (Typeable2 t, Typeable a) => t a b -> TypeRep
- typeOf2Default, -- :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
- typeOf3Default, -- :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
- typeOf4Default, -- :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
- typeOf5Default, -- :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
- typeOf6Default -- :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
-
- ) where
-
-import qualified Data.HashTable as HT
-import Data.Maybe
-import Data.Either
-import Data.Int
-import Data.Word
-import Data.List( foldl )
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.Show
-import GHC.Err
-import GHC.Num
-import GHC.Float
-import GHC.Real ( rem, Ratio )
-import GHC.IOBase (IORef,newIORef,unsafePerformIO)
-
--- These imports are so we can define Typeable instances
--- It'd be better to give Typeable instances in the modules themselves
--- but they all have to be compiled before Typeable
-import GHC.IOBase ( IO, MVar, Exception, ArithException, IOException,
- ArrayException, AsyncException, Handle )
-import GHC.ST ( ST )
-import GHC.STRef ( STRef )
-import GHC.Ptr ( Ptr, FunPtr )
-import GHC.ForeignPtr ( ForeignPtr )
-import GHC.Stable ( StablePtr, newStablePtr, freeStablePtr,
- deRefStablePtr, castStablePtrToPtr,
- castPtrToStablePtr )
-import GHC.Exception ( block )
-import GHC.Arr ( Array, STArray )
-
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude ( Key(..), TypeRep(..), TyCon(..), Ratio,
- Exception, ArithException, IOException,
- ArrayException, AsyncException, Handle,
- Ptr, FunPtr, ForeignPtr, StablePtr )
-import Hugs.IORef ( IORef, newIORef, readIORef, writeIORef )
-import Hugs.IOExts ( unsafePerformIO, unsafeCoerce )
- -- For the Typeable instance
-import Hugs.Array ( Array )
-import Hugs.ConcBase ( MVar )
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-unsafeCoerce :: a -> b
-unsafeCoerce = unsafeCoerce#
-#endif
-
-#ifdef __NHC__
-import NonStdUnsafeCoerce (unsafeCoerce)
-import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
-import IO (Handle)
-import Ratio (Ratio)
- -- For the Typeable instance
-import NHC.FFI ( Ptr,FunPtr,StablePtr,ForeignPtr )
-import Array ( Array )
-#endif
-
-#include "Typeable.h"
-
-#ifndef __HUGS__
-
--------------------------------------------------------------
---
--- Type representations
---
--------------------------------------------------------------
-
--- | A concrete representation of a (monomorphic) type. 'TypeRep'
--- supports reasonably efficient equality.
-data TypeRep = TypeRep !Key TyCon [TypeRep]
-
--- Compare keys for equality
-instance Eq TypeRep where
- (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
-
--- | An abstract representation of a type constructor. 'TyCon' objects can
--- be built using 'mkTyCon'.
-data TyCon = TyCon !Key String
-
-instance Eq TyCon where
- (TyCon t1 _) == (TyCon t2 _) = t1 == t2
-#endif
-
--- | Returns a unique integer associated with a 'TypeRep'. This can
--- be used for making a mapping ('Data.IntMap.IntMap') with TypeReps
--- as the keys, for example. It is guaranteed that @t1 == t2@ if and only if
--- @typeRepKey t1 == typeRepKey t2@.
---
--- It is in the 'IO' monad because the actual value of the key may
--- vary from run to run of the program. You should only rely on
--- the equality property, not any actual key value. The relative ordering
--- of keys has no meaning either.
---
-typeRepKey :: TypeRep -> IO Int
-typeRepKey (TypeRep (Key i) _ _) = return i
-
- --
- -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,")
- -- [fTy,fTy,fTy])
- --
- -- returns "(Foo,Foo,Foo)"
- --
- -- The TypeRep Show instance promises to print tuple types
- -- correctly. Tuple type constructors are specified by a
- -- sequence of commas, e.g., (mkTyCon ",,,,") returns
- -- the 5-tuple tycon.
-
------------------ Construction --------------------
-
--- | Applies a type constructor to a sequence of types
-mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
-mkTyConApp tc@(TyCon tc_k _) args
- = TypeRep (appKeys tc_k arg_ks) tc args
- where
- arg_ks = [k | TypeRep k _ _ <- args]
-
--- | A special case of 'mkTyConApp', which applies the function
--- type constructor to a pair of types.
-mkFunTy :: TypeRep -> TypeRep -> TypeRep
-mkFunTy f a = mkTyConApp funTc [f,a]
-
--- | Splits a type constructor application
-splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
-splitTyConApp (TypeRep _ tc trs) = (tc,trs)
-
--- | Applies a type to a function type. Returns: @'Just' u@ if the
--- first argument represents a function of type @t -> u@ and the
--- second argument represents a function of type @t@. Otherwise,
--- returns 'Nothing'.
-funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
-funResultTy trFun trArg
- = case splitTyConApp trFun of
- (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
- _ -> Nothing
-
--- | Adds a TypeRep argument to a TypeRep.
-mkAppTy :: TypeRep -> TypeRep -> TypeRep
-mkAppTy (TypeRep tr_k tc trs) arg_tr
- = let (TypeRep arg_k _ _) = arg_tr
- in TypeRep (appKey tr_k arg_k) tc (trs++[arg_tr])
-
--- If we enforce the restriction that there is only one
--- @TyCon@ for a type & it is shared among all its uses,
--- we can map them onto Ints very simply. The benefit is,
--- of course, that @TyCon@s can then be compared efficiently.
-
--- Provided the implementor of other @Typeable@ instances
--- takes care of making all the @TyCon@s CAFs (toplevel constants),
--- this will work.
-
--- If this constraint does turn out to be a sore thumb, changing
--- the Eq instance for TyCons is trivial.
-
--- | Builds a 'TyCon' object representing a type constructor. An
--- implementation of "Data.Typeable" should ensure that the following holds:
---
--- > mkTyCon "a" == mkTyCon "a"
---
-
-mkTyCon :: String -- ^ the name of the type constructor (should be unique
- -- in the program, so it might be wise to use the
- -- fully qualified name).
- -> TyCon -- ^ A unique 'TyCon' object
-mkTyCon str = TyCon (mkTyConKey str) str
-
------------------ Observation ---------------------
-
--- | Observe the type constructor of a type representation
-typeRepTyCon :: TypeRep -> TyCon
-typeRepTyCon (TypeRep _ tc _) = tc
-
--- | Observe the argument types of a type representation
-typeRepArgs :: TypeRep -> [TypeRep]
-typeRepArgs (TypeRep _ _ args) = args
-
--- | Observe string encoding of a type representation
-tyConString :: TyCon -> String
-tyConString (TyCon _ str) = str
-
------------------ Showing TypeReps --------------------
-
-instance Show TypeRep where
- showsPrec p (TypeRep _ tycon tys) =
- case tys of
- [] -> showsPrec p tycon
- [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
- [a,r] | tycon == funTc -> showParen (p > 8) $
- showsPrec 9 a .
- showString " -> " .
- showsPrec 8 r
- xs | isTupleTyCon tycon -> showTuple tycon xs
- | otherwise ->
- showParen (p > 9) $
- showsPrec p tycon .
- showChar ' ' .
- showArgs tys
-
-showsTypeRep :: TypeRep -> ShowS
-showsTypeRep = shows
-
-instance Show TyCon where
- showsPrec _ (TyCon _ s) = showString s
-
-isTupleTyCon :: TyCon -> Bool
-isTupleTyCon (TyCon _ (',':_)) = True
-isTupleTyCon _ = False
-
--- Some (Show.TypeRep) helpers:
-
-showArgs :: Show a => [a] -> ShowS
-showArgs [] = id
-showArgs [a] = showsPrec 10 a
-showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
-
-showTuple :: TyCon -> [TypeRep] -> ShowS
-showTuple (TyCon _ str) args = showChar '(' . go str args
- where
- go [] [a] = showsPrec 10 a . showChar ')'
- go _ [] = showChar ')' -- a failure condition, really.
- go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
- go _ _ = showChar ')'
-
--------------------------------------------------------------
---
--- The Typeable class and friends
---
--------------------------------------------------------------
-
--- | The class 'Typeable' allows a concrete representation of a type to
--- be calculated.
-class Typeable a where
- typeOf :: a -> TypeRep
- -- ^ Takes a value of type @a@ and returns a concrete representation
- -- of that type. The /value/ of the argument should be ignored by
- -- any instance of 'Typeable', so that it is safe to pass 'undefined' as
- -- the argument.
-
--- | Variant for unary type constructors
-class Typeable1 t where
- typeOf1 :: t a -> TypeRep
-
--- | For defining a 'Typeable' instance from any 'Typeable1' instance.
-typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep
-typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)
- where
- argType :: t a -> a
- argType = undefined
-
--- | Variant for binary type constructors
-class Typeable2 t where
- typeOf2 :: t a b -> TypeRep
-
--- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
-typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep
-typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)
- where
- argType :: t a b -> a
- argType = undefined
-
--- | Variant for 3-ary type constructors
-class Typeable3 t where
- typeOf3 :: t a b c -> TypeRep
-
--- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
-typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
-typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x)
- where
- argType :: t a b c -> a
- argType = undefined
-
--- | Variant for 4-ary type constructors
-class Typeable4 t where
- typeOf4 :: t a b c d -> TypeRep
-
--- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
-typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
-typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x)
- where
- argType :: t a b c d -> a
- argType = undefined
-
--- | Variant for 5-ary type constructors
-class Typeable5 t where
- typeOf5 :: t a b c d e -> TypeRep
-
--- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
-typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
-typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x)
- where
- argType :: t a b c d e -> a
- argType = undefined
-
--- | Variant for 6-ary type constructors
-class Typeable6 t where
- typeOf6 :: t a b c d e f -> TypeRep
-
--- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
-typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
-typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x)
- where
- argType :: t a b c d e f -> a
- argType = undefined
-
--- | Variant for 7-ary type constructors
-class Typeable7 t where
- typeOf7 :: t a b c d e f g -> TypeRep
-
--- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
-typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
-typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x)
- where
- argType :: t a b c d e f g -> a
- argType = undefined
-
-#ifdef __GLASGOW_HASKELL__
--- Given a @Typeable@/n/ instance for an /n/-ary type constructor,
--- define the instances for partial applications.
--- Programmers using non-GHC implementations must do this manually
--- for each type constructor.
--- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.)
-
--- | One Typeable instance for all Typeable1 instances
-instance (Typeable1 s, Typeable a)
- => Typeable (s a) where
- typeOf = typeOfDefault
-
--- | One Typeable1 instance for all Typeable2 instances
-instance (Typeable2 s, Typeable a)
- => Typeable1 (s a) where
- typeOf1 = typeOf1Default
-
--- | One Typeable2 instance for all Typeable3 instances
-instance (Typeable3 s, Typeable a)
- => Typeable2 (s a) where
- typeOf2 = typeOf2Default
-
--- | One Typeable3 instance for all Typeable4 instances
-instance (Typeable4 s, Typeable a)
- => Typeable3 (s a) where
- typeOf3 = typeOf3Default
-
--- | One Typeable4 instance for all Typeable5 instances
-instance (Typeable5 s, Typeable a)
- => Typeable4 (s a) where
- typeOf4 = typeOf4Default
-
--- | One Typeable5 instance for all Typeable6 instances
-instance (Typeable6 s, Typeable a)
- => Typeable5 (s a) where
- typeOf5 = typeOf5Default
-
--- | One Typeable6 instance for all Typeable7 instances
-instance (Typeable7 s, Typeable a)
- => Typeable6 (s a) where
- typeOf6 = typeOf6Default
-
-#endif /* __GLASGOW_HASKELL__ */
-
--------------------------------------------------------------
---
--- Type-safe cast
---
--------------------------------------------------------------
-
--- | The type-safe cast operation
-cast :: (Typeable a, Typeable b) => a -> Maybe b
-cast x = r
- where
- r = if typeOf x == typeOf (fromJust r)
- then Just $ unsafeCoerce x
- else Nothing
-
--- | A flexible variation parameterised in a type constructor
-gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b)
-gcast x = r
- where
- r = if typeOf (getArg x) == typeOf (getArg (fromJust r))
- then Just $ unsafeCoerce x
- else Nothing
- getArg :: c x -> x
- getArg = undefined
-
--- | Cast for * -> *
-gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a))
-gcast1 x = r
- where
- r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r))
- then Just $ unsafeCoerce x
- else Nothing
- getArg :: c x -> x
- getArg = undefined
-
--- | Cast for * -> * -> *
-gcast2 :: (Typeable2 t, Typeable2 t') => c (t a b) -> Maybe (c (t' a b))
-gcast2 x = r
- where
- r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r))
- then Just $ unsafeCoerce x
- else Nothing
- getArg :: c x -> x
- getArg = undefined
-
--------------------------------------------------------------
---
--- Instances of the Typeable classes for Prelude types
---
--------------------------------------------------------------
-
-INSTANCE_TYPEABLE0((),unitTc,"()")
-INSTANCE_TYPEABLE1([],listTc,"[]")
-INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
-INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
-INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
-INSTANCE_TYPEABLE2((->),funTc,"->")
-INSTANCE_TYPEABLE1(IO,ioTc,"IO")
-
-#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
--- Types defined in GHC.IOBase
-INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
-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")
-#endif
-
--- Types defined in GHC.Arr
-INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
-
-#ifdef __GLASGOW_HASKELL__
--- Hugs has these too, but their Typeable<n> instances are defined
--- elsewhere to keep this module within Haskell 98.
--- This is important because every invocation of runhugs or ffihugs
--- uses this module via Data.Dynamic.
-INSTANCE_TYPEABLE2(ST,stTc,"ST")
-INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
-INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
-#endif
-
-#ifndef __NHC__
-INSTANCE_TYPEABLE2((,),pairTc,",")
-INSTANCE_TYPEABLE3((,,),tup3Tc,",,")
-
-tup4Tc :: TyCon
-tup4Tc = mkTyCon ",,,"
-
-instance Typeable4 (,,,) where
- typeOf4 tu = mkTyConApp tup4Tc []
-
-tup5Tc :: TyCon
-tup5Tc = mkTyCon ",,,,"
-
-instance Typeable5 (,,,,) where
- typeOf5 tu = mkTyConApp tup5Tc []
-
-tup6Tc :: TyCon
-tup6Tc = mkTyCon ",,,,,"
-
-instance Typeable6 (,,,,,) where
- typeOf6 tu = mkTyConApp tup6Tc []
-
-tup7Tc :: TyCon
-tup7Tc = mkTyCon ",,,,,,"
-
-instance Typeable7 (,,,,,,) where
- typeOf7 tu = mkTyConApp tup7Tc []
-#endif /* __NHC__ */
-
-INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
-INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
-INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
-INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
-INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
-
--------------------------------------------------------
---
--- Generate Typeable instances for standard datatypes
---
--------------------------------------------------------
-
-INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
-INSTANCE_TYPEABLE0(Char,charTc,"Char")
-INSTANCE_TYPEABLE0(Float,floatTc,"Float")
-INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
-INSTANCE_TYPEABLE0(Int,intTc,"Int")
-#ifndef __NHC__
-INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
-#endif
-INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
-INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
-INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
-
-INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
-INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
-INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
-INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
-
-INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
-INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
-INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
-INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
-
-INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
-INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
-
-#ifdef __GLASGOW_HASKELL__
-INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")
-#endif
-
----------------------------------------------
---
--- Internals
---
----------------------------------------------
-
-#ifndef __HUGS__
-newtype Key = Key Int deriving( Eq )
-#endif
-
-data KeyPr = KeyPr !Key !Key deriving( Eq )
-
-hashKP :: KeyPr -> Int32
-hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime
-
-data Cache = Cache { next_key :: !(IORef Key), -- Not used by GHC (calls genSym instead)
- tc_tbl :: !(HT.HashTable String Key),
- ap_tbl :: !(HT.HashTable KeyPr Key) }
-
-{-# NOINLINE cache #-}
-#ifdef __GLASGOW_HASKELL__
-foreign import ccall unsafe "RtsTypeable.h getOrSetTypeableStore"
- getOrSetTypeableStore :: Ptr a -> IO (Ptr a)
-#endif
-
-cache :: Cache
-cache = unsafePerformIO $ do
- empty_tc_tbl <- HT.new (==) HT.hashString
- empty_ap_tbl <- HT.new (==) hashKP
- key_loc <- newIORef (Key 1)
- let ret = Cache { next_key = key_loc,
- tc_tbl = empty_tc_tbl,
- ap_tbl = empty_ap_tbl }
-#ifdef __GLASGOW_HASKELL__
- block $ do
- stable_ref <- newStablePtr ret
- let ref = castStablePtrToPtr stable_ref
- ref2 <- getOrSetTypeableStore ref
- if ref==ref2
- then deRefStablePtr stable_ref
- else do
- freeStablePtr stable_ref
- deRefStablePtr
- (castPtrToStablePtr ref2)
-#else
- return ret
-#endif
-
-newKey :: IORef Key -> IO Key
-#ifdef __GLASGOW_HASKELL__
-newKey kloc = do i <- genSym; return (Key i)
-#else
-newKey kloc = do { k@(Key i) <- readIORef kloc ;
- writeIORef kloc (Key (i+1)) ;
- return k }
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-foreign import ccall unsafe "genSymZh"
- genSym :: IO Int
-#endif
-
-mkTyConKey :: String -> Key
-mkTyConKey str
- = unsafePerformIO $ do
- let Cache {next_key = kloc, tc_tbl = tbl} = cache
- mb_k <- HT.lookup tbl str
- case mb_k of
- Just k -> return k
- Nothing -> do { k <- newKey kloc ;
- HT.insert tbl str k ;
- return k }
-
-appKey :: Key -> Key -> Key
-appKey k1 k2
- = unsafePerformIO $ do
- let Cache {next_key = kloc, ap_tbl = tbl} = cache
- mb_k <- HT.lookup tbl kpr
- case mb_k of
- Just k -> return k
- Nothing -> do { k <- newKey kloc ;
- HT.insert tbl kpr k ;
- return k }
- where
- kpr = KeyPr k1 k2
-
-appKeys :: Key -> [Key] -> Key
-appKeys k ks = foldl appKey k ks
+++ /dev/null
-
-{-# OPTIONS -fno-implicit-prelude #-}
-
-module Data.Typeable where
-
-import GHC.Base
-import GHC.Show
-
-data TypeRep
-data TyCon
-
-mkTyCon :: String -> TyCon
-mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
-showsTypeRep :: TypeRep -> ShowS
-
-class Typeable a where
- typeOf :: a -> TypeRep
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Unique
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable
---
--- An abstract interface to a unique symbol generator.
---
------------------------------------------------------------------------------
-
-module Data.Unique (
- -- * Unique objects
- Unique, -- instance (Eq, Ord)
- newUnique, -- :: IO Unique
- hashUnique -- :: Unique -> Int
- ) where
-
-import Prelude
-
-import Control.Concurrent.MVar
-import System.IO.Unsafe (unsafePerformIO)
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.Num ( Integer(..) )
-#endif
-
--- | An abstract unique object. Objects of type 'Unique' may be
--- compared for equality and ordering and hashed into 'Int'.
-newtype Unique = Unique Integer deriving (Eq,Ord)
-
-uniqSource :: MVar Integer
-uniqSource = unsafePerformIO (newMVar 0)
-{-# NOINLINE uniqSource #-}
-
--- | Creates a new object of type 'Unique'. The value returned will
--- not compare equal to any other value of type 'Unique' returned by
--- previous calls to 'newUnique'. There is no limit on the number of
--- times 'newUnique' may be called.
-newUnique :: IO Unique
-newUnique = do
- val <- takeMVar uniqSource
- let next = val+1
- putMVar uniqSource next
- return (Unique next)
-
--- | Hashes a 'Unique' into an 'Int'. Two 'Unique's may hash to the
--- same value, although in practice this is unlikely. The 'Int'
--- returned makes a good hash key.
-hashUnique :: Unique -> Int
-#ifdef __GLASGOW_HASKELL__
-hashUnique (Unique (S# i)) = I# i
-hashUnique (Unique (J# s d)) | s ==# 0# = 0
- | otherwise = I# (indexIntArray# d 0#)
-#else
-hashUnique (Unique u) = fromInteger (u `mod` (toInteger (maxBound :: Int) + 1))
-#endif
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Version
--- Copyright : (c) The University of Glasgow 2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (local universal quantification in ReadP)
---
--- A general library for representation and manipulation of versions.
---
--- Versioning schemes are many and varied, so the version
--- representation provided by this library is intended to be a
--- compromise between complete generality, where almost no common
--- functionality could reasonably be provided, and fixing a particular
--- versioning scheme, which would probably be too restrictive.
---
--- So the approach taken here is to provide a representation which
--- subsumes many of the versioning schemes commonly in use, and we
--- provide implementations of 'Eq', 'Ord' and conversion to\/from 'String'
--- which will be appropriate for some applications, but not all.
---
------------------------------------------------------------------------------
-
-module Data.Version (
- -- * The @Version@ type
- Version(..),
- -- * A concrete representation of @Version@
- showVersion, parseVersion,
- ) where
-
-import Prelude -- necessary to get dependencies right
-
--- These #ifdefs are necessary because this code might be compiled as
--- part of ghc/lib/compat, and hence might be compiled by an older version
--- of GHC. In which case, we might need to pick up ReadP from
--- Distribution.Compat.ReadP, because the version in
--- Text.ParserCombinators.ReadP doesn't have all the combinators we need.
-#if __GLASGOW_HASKELL__ >= 603 || __HUGS__ || __NHC__
-import Text.ParserCombinators.ReadP
-#else
-import Distribution.Compat.ReadP
-#endif
-
-#if !__GLASGOW_HASKELL__
-import Data.Typeable ( Typeable, TyCon, mkTyCon, mkTyConApp )
-#elif __GLASGOW_HASKELL__ < 602
-import Data.Dynamic ( Typeable(..), TyCon, mkTyCon, mkAppTy )
-#else
-import Data.Typeable ( Typeable )
-#endif
-
-import Data.List ( intersperse, sort )
-import Control.Monad ( liftM )
-import Data.Char ( isDigit, isAlphaNum )
-
-{- |
-A 'Version' represents the version of a software entity.
-
-An instance of 'Eq' is provided, which implements exact equality
-modulo reordering of the tags in the 'versionTags' field.
-
-An instance of 'Ord' is also provided, which gives lexicographic
-ordering on the 'versionBranch' fields (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2,
-etc.). This is expected to be sufficient for many uses, but note that
-you may need to use a more specific ordering for your versioning
-scheme. For example, some versioning schemes may include pre-releases
-which have tags @\"pre1\"@, @\"pre2\"@, and so on, and these would need to
-be taken into account when determining ordering. In some cases, date
-ordering may be more appropriate, so the application would have to
-look for @date@ tags in the 'versionTags' field and compare those.
-The bottom line is, don't always assume that 'compare' and other 'Ord'
-operations are the right thing for every 'Version'.
-
-Similarly, concrete representations of versions may differ. One
-possible concrete representation is provided (see 'showVersion' and
-'parseVersion'), but depending on the application a different concrete
-representation may be more appropriate.
--}
-data Version =
- Version { versionBranch :: [Int],
- -- ^ The numeric branch for this version. This reflects the
- -- fact that most software versions are tree-structured; there
- -- is a main trunk which is tagged with versions at various
- -- points (1,2,3...), and the first branch off the trunk after
- -- version 3 is 3.1, the second branch off the trunk after
- -- version 3 is 3.2, and so on. The tree can be branched
- -- arbitrarily, just by adding more digits.
- --
- -- We represent the branch as a list of 'Int', so
- -- version 3.2.1 becomes [3,2,1]. Lexicographic ordering
- -- (i.e. the default instance of 'Ord' for @[Int]@) gives
- -- the natural ordering of branches.
-
- versionTags :: [String] -- really a bag
- -- ^ A version can be tagged with an arbitrary list of strings.
- -- The interpretation of the list of tags is entirely dependent
- -- on the entity that this version applies to.
- }
- deriving (Read,Show
-#if __GLASGOW_HASKELL__ >= 602
- ,Typeable
-#endif
- )
-
-#if !__GLASGOW_HASKELL__
-versionTc :: TyCon
-versionTc = mkTyCon "Version"
-
-instance Typeable Version where
- typeOf _ = mkTyConApp versionTc []
-#elif __GLASGOW_HASKELL__ < 602
-versionTc :: TyCon
-versionTc = mkTyCon "Version"
-
-instance Typeable Version where
- typeOf _ = mkAppTy versionTc []
-#endif
-
-instance Eq Version where
- v1 == v2 = versionBranch v1 == versionBranch v2
- && sort (versionTags v1) == sort (versionTags v2)
- -- tags may be in any order
-
-instance Ord Version where
- v1 `compare` v2 = versionBranch v1 `compare` versionBranch v2
-
--- -----------------------------------------------------------------------------
--- A concrete representation of 'Version'
-
--- | Provides one possible concrete representation for 'Version'. For
--- a version with 'versionBranch' @= [1,2,3]@ and 'versionTags'
--- @= [\"tag1\",\"tag2\"]@, the output will be @1.2.3-tag1-tag2@.
---
-showVersion :: Version -> String
-showVersion (Version branch tags)
- = concat (intersperse "." (map show branch)) ++
- concatMap ('-':) tags
-
--- | A parser for versions in the format produced by 'showVersion'.
---
-#if __GLASGOW_HASKELL__ >= 603 || __HUGS__
-parseVersion :: ReadP Version
-#elif __NHC__
-parseVersion :: ReadPN r Version
-#else
-parseVersion :: ReadP r Version
-#endif
-parseVersion = do branch <- sepBy1 (liftM read $ munch1 isDigit) (char '.')
- tags <- many (char '-' >> munch1 isAlphaNum)
- return Version{versionBranch=branch, versionTags=tags}
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Word
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Unsigned integer types.
---
------------------------------------------------------------------------------
-
-module Data.Word
- (
- -- * Unsigned integral types
-
- Word,
- Word8, Word16, Word32, Word64,
-
- -- * Notes
-
- -- $notes
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Word
-#endif
-
-#ifdef __HUGS__
-import Hugs.Word
-#endif
-
-#ifdef __NHC__
-import NHC.FFI (Word8, Word16, Word32, Word64)
-import NHC.SizedTypes (Word8, Word16, Word32, Word64) -- instances of Bits
-type Word = Word32
-#endif
-
-{- $notes
-
-* All arithmetic is performed modulo 2^n, where n is the number of
- bits in the type. One non-obvious consequence of this is that 'Prelude.negate'
- should /not/ raise an error on negative arguments.
-
-* For coercing between any two integer types, use
- 'Prelude.fromIntegral', which is specialized for all the
- common cases so should be fast enough. Coercing word types to and
- from integer types preserves representation, not sign.
-
-* It would be very natural to add a type @Natural@ providing an unbounded
- size unsigned integer, just as 'Prelude.Integer' provides unbounded
- size signed integers. We do not do that yet since there is no demand
- for it.
-
-* The rules that hold for 'Prelude.Enum' instances over a bounded type
- such as 'Prelude.Int' (see the section of the Haskell report dealing
- with arithmetic sequences) also hold for the 'Prelude.Enum' instances
- over the various 'Word' types defined here.
-
-* Right and left shifts by amounts greater than or equal to the width
- of the type result in a zero result. This is contrary to the
- behaviour in C, which is undefined; a common interpretation is to
- truncate the shift count to the width of the type, for example @1 \<\<
- 32 == 1@ in some C implementations.
--}
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Debug.Trace
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- The 'trace' function.
---
------------------------------------------------------------------------------
-
-module Debug.Trace (
- -- * Tracing
- putTraceMsg, -- :: String -> IO ()
- trace -- :: String -> a -> a
- ) where
-
-import Prelude
-import System.IO.Unsafe
-
-#ifdef __GLASGOW_HASKELL__
-import Foreign.C.String
-#else
-import System.IO (hPutStrLn,stderr)
-#endif
-
--- | 'putTraceMsg' function outputs the trace message from IO monad.
--- Usually the output stream is 'System.IO.stderr' but if the function is called
--- from Windows GUI application then the output will be directed to the Windows
--- debug console.
-putTraceMsg :: String -> IO ()
-putTraceMsg msg = do
-#ifndef __GLASGOW_HASKELL__
- hPutStrLn stderr msg
-#else
- withCString "%s\n" $ \cfmt ->
- withCString msg $ \cmsg ->
- debugBelch cfmt cmsg
-
-foreign import ccall unsafe "RtsMessages.h debugBelch"
- debugBelch :: CString -> CString -> IO ()
-#endif
-
-{-# NOINLINE trace #-}
-{-|
-When called, 'trace' outputs the string in its first argument, before
-returning the second argument as its result. The 'trace' function is not
-referentially transparent, and should only be used for debugging, or for
-monitoring execution. Some implementations of 'trace' may decorate the string
-that\'s output to indicate that you\'re tracing. The function is implemented on
-top of 'putTraceMsg'.
--}
-trace :: String -> a -> a
-trace string expr = unsafePerformIO $ do
- putTraceMsg string
- return expr
-
-{-|
-Like 'trace', but uses 'show' on the argument to convert it to a 'String'.
-
-> traceShow = trace . show
--}
-traceShow :: (Show a) => a -> b -> b
-traceShow = trace . show
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign
--- Copyright : (c) The FFI task force 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- A collection of data types, classes, and functions for interfacing
--- with another programming language.
---
------------------------------------------------------------------------------
-
-module Foreign
- ( module Data.Bits
- , module Data.Int
- , module Data.Word
- , module Foreign.Ptr
- , module Foreign.ForeignPtr
- , module Foreign.StablePtr
- , module Foreign.Storable
- , module Foreign.Marshal
-
- -- | For compatibility with the FFI addendum only. The recommended
- -- place to get this from is "System.IO.Unsafe".
- , unsafePerformIO
- ) where
-
-import Data.Bits
-import Data.Int
-import Data.Word
-import Foreign.Ptr
-import Foreign.ForeignPtr
-import Foreign.StablePtr
-import Foreign.Storable
-import Foreign.Marshal
-
-import System.IO.Unsafe (unsafePerformIO)
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.C
--- Copyright : (c) The FFI task force 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Bundles the C specific FFI library functionality
---
------------------------------------------------------------------------------
-
-module Foreign.C
- ( module Foreign.C.Types
- , module Foreign.C.String
- , module Foreign.C.Error
- ) where
-
-import Foreign.C.Types
-import Foreign.C.String
-import Foreign.C.Error
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.C.Error
--- Copyright : (c) The FFI task force 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- C-specific Marshalling support: Handling of C \"errno\" error codes.
---
------------------------------------------------------------------------------
-
-module Foreign.C.Error (
-
- -- * Haskell representations of @errno@ values
-
- Errno(..), -- instance: Eq
-
- -- ** Common @errno@ symbols
- -- | Different operating systems and\/or C libraries often support
- -- different values of @errno@. This module defines the common values,
- -- but due to the open definition of 'Errno' users may add definitions
- -- which are not predefined.
- eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,
- eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,
- eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,
- eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,
- eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK,
- eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH,
- eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK,
- eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,
- eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO,
- eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL,
- ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE,
- eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN,
- eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT,
- eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV,
-
- -- ** 'Errno' functions
- -- :: Errno
- isValidErrno, -- :: Errno -> Bool
-
- -- access to the current thread's "errno" value
- --
- getErrno, -- :: IO Errno
- resetErrno, -- :: IO ()
-
- -- conversion of an "errno" value into IO error
- --
- errnoToIOError, -- :: String -- location
- -- -> Errno -- errno
- -- -> Maybe Handle -- handle
- -- -> Maybe String -- filename
- -- -> IOError
-
- -- throw current "errno" value
- --
- throwErrno, -- :: String -> IO a
-
- -- ** Guards for IO operations that may fail
-
- throwErrnoIf, -- :: (a -> Bool) -> String -> IO a -> IO a
- throwErrnoIf_, -- :: (a -> Bool) -> String -> IO a -> IO ()
- throwErrnoIfRetry, -- :: (a -> Bool) -> String -> IO a -> IO a
- throwErrnoIfRetry_, -- :: (a -> Bool) -> String -> IO a -> IO ()
- throwErrnoIfMinus1, -- :: Num a
- -- => String -> IO a -> IO a
- throwErrnoIfMinus1_, -- :: Num a
- -- => String -> IO a -> IO ()
- throwErrnoIfMinus1Retry,
- -- :: Num a
- -- => String -> IO a -> IO a
- throwErrnoIfMinus1Retry_,
- -- :: Num a
- -- => String -> IO a -> IO ()
- throwErrnoIfNull, -- :: String -> IO (Ptr a) -> IO (Ptr a)
- throwErrnoIfNullRetry,-- :: String -> IO (Ptr a) -> IO (Ptr a)
-
- throwErrnoIfRetryMayBlock,
- throwErrnoIfRetryMayBlock_,
- throwErrnoIfMinus1RetryMayBlock,
- throwErrnoIfMinus1RetryMayBlock_,
- throwErrnoIfNullRetryMayBlock
-) where
-
-
--- this is were we get the CONST_XXX definitions from that configure
--- calculated for us
---
-#ifndef __NHC__
-#include "HsBaseConfig.h"
-#endif
-
--- system dependent imports
--- ------------------------
-
--- GHC allows us to get at the guts inside IO errors/exceptions
---
-#if __GLASGOW_HASKELL__
-import GHC.IOBase (IOException(..), IOErrorType(..))
-#endif /* __GLASGOW_HASKELL__ */
-
-
--- regular imports
--- ---------------
-
-import Foreign.Storable
-import Foreign.Ptr
-import Foreign.C.Types
-import Foreign.C.String
-import Foreign.Marshal.Error ( void )
-import Data.Maybe
-
-#if __GLASGOW_HASKELL__
-import GHC.IOBase
-import GHC.Num
-import GHC.Base
-#else
-import System.IO ( Handle )
-import System.IO.Error ( IOError, ioError )
-import System.IO.Unsafe ( unsafePerformIO )
-#endif
-
-#ifdef __HUGS__
-{-# CFILES cbits/PrelIOUtils.c #-}
-#endif
-
-
--- "errno" type
--- ------------
-
--- | Haskell representation for @errno@ values.
--- The implementation is deliberately exposed, to allow users to add
--- their own definitions of 'Errno' values.
-
-newtype Errno = Errno CInt
-
-instance Eq Errno where
- errno1@(Errno no1) == errno2@(Errno no2)
- | isValidErrno errno1 && isValidErrno errno2 = no1 == no2
- | otherwise = False
-
--- common "errno" symbols
---
-eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,
- eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,
- eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,
- eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,
- eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK,
- eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH,
- eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK,
- eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,
- eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO,
- eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL,
- ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE,
- eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN,
- eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT,
- eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV :: Errno
---
--- the cCONST_XXX identifiers are cpp symbols whose value is computed by
--- configure
---
-eOK = Errno 0
-#ifdef __NHC__
-#include "Errno.hs"
-#else
-e2BIG = Errno (CONST_E2BIG)
-eACCES = Errno (CONST_EACCES)
-eADDRINUSE = Errno (CONST_EADDRINUSE)
-eADDRNOTAVAIL = Errno (CONST_EADDRNOTAVAIL)
-eADV = Errno (CONST_EADV)
-eAFNOSUPPORT = Errno (CONST_EAFNOSUPPORT)
-eAGAIN = Errno (CONST_EAGAIN)
-eALREADY = Errno (CONST_EALREADY)
-eBADF = Errno (CONST_EBADF)
-eBADMSG = Errno (CONST_EBADMSG)
-eBADRPC = Errno (CONST_EBADRPC)
-eBUSY = Errno (CONST_EBUSY)
-eCHILD = Errno (CONST_ECHILD)
-eCOMM = Errno (CONST_ECOMM)
-eCONNABORTED = Errno (CONST_ECONNABORTED)
-eCONNREFUSED = Errno (CONST_ECONNREFUSED)
-eCONNRESET = Errno (CONST_ECONNRESET)
-eDEADLK = Errno (CONST_EDEADLK)
-eDESTADDRREQ = Errno (CONST_EDESTADDRREQ)
-eDIRTY = Errno (CONST_EDIRTY)
-eDOM = Errno (CONST_EDOM)
-eDQUOT = Errno (CONST_EDQUOT)
-eEXIST = Errno (CONST_EEXIST)
-eFAULT = Errno (CONST_EFAULT)
-eFBIG = Errno (CONST_EFBIG)
-eFTYPE = Errno (CONST_EFTYPE)
-eHOSTDOWN = Errno (CONST_EHOSTDOWN)
-eHOSTUNREACH = Errno (CONST_EHOSTUNREACH)
-eIDRM = Errno (CONST_EIDRM)
-eILSEQ = Errno (CONST_EILSEQ)
-eINPROGRESS = Errno (CONST_EINPROGRESS)
-eINTR = Errno (CONST_EINTR)
-eINVAL = Errno (CONST_EINVAL)
-eIO = Errno (CONST_EIO)
-eISCONN = Errno (CONST_EISCONN)
-eISDIR = Errno (CONST_EISDIR)
-eLOOP = Errno (CONST_ELOOP)
-eMFILE = Errno (CONST_EMFILE)
-eMLINK = Errno (CONST_EMLINK)
-eMSGSIZE = Errno (CONST_EMSGSIZE)
-eMULTIHOP = Errno (CONST_EMULTIHOP)
-eNAMETOOLONG = Errno (CONST_ENAMETOOLONG)
-eNETDOWN = Errno (CONST_ENETDOWN)
-eNETRESET = Errno (CONST_ENETRESET)
-eNETUNREACH = Errno (CONST_ENETUNREACH)
-eNFILE = Errno (CONST_ENFILE)
-eNOBUFS = Errno (CONST_ENOBUFS)
-eNODATA = Errno (CONST_ENODATA)
-eNODEV = Errno (CONST_ENODEV)
-eNOENT = Errno (CONST_ENOENT)
-eNOEXEC = Errno (CONST_ENOEXEC)
-eNOLCK = Errno (CONST_ENOLCK)
-eNOLINK = Errno (CONST_ENOLINK)
-eNOMEM = Errno (CONST_ENOMEM)
-eNOMSG = Errno (CONST_ENOMSG)
-eNONET = Errno (CONST_ENONET)
-eNOPROTOOPT = Errno (CONST_ENOPROTOOPT)
-eNOSPC = Errno (CONST_ENOSPC)
-eNOSR = Errno (CONST_ENOSR)
-eNOSTR = Errno (CONST_ENOSTR)
-eNOSYS = Errno (CONST_ENOSYS)
-eNOTBLK = Errno (CONST_ENOTBLK)
-eNOTCONN = Errno (CONST_ENOTCONN)
-eNOTDIR = Errno (CONST_ENOTDIR)
-eNOTEMPTY = Errno (CONST_ENOTEMPTY)
-eNOTSOCK = Errno (CONST_ENOTSOCK)
-eNOTTY = Errno (CONST_ENOTTY)
-eNXIO = Errno (CONST_ENXIO)
-eOPNOTSUPP = Errno (CONST_EOPNOTSUPP)
-ePERM = Errno (CONST_EPERM)
-ePFNOSUPPORT = Errno (CONST_EPFNOSUPPORT)
-ePIPE = Errno (CONST_EPIPE)
-ePROCLIM = Errno (CONST_EPROCLIM)
-ePROCUNAVAIL = Errno (CONST_EPROCUNAVAIL)
-ePROGMISMATCH = Errno (CONST_EPROGMISMATCH)
-ePROGUNAVAIL = Errno (CONST_EPROGUNAVAIL)
-ePROTO = Errno (CONST_EPROTO)
-ePROTONOSUPPORT = Errno (CONST_EPROTONOSUPPORT)
-ePROTOTYPE = Errno (CONST_EPROTOTYPE)
-eRANGE = Errno (CONST_ERANGE)
-eREMCHG = Errno (CONST_EREMCHG)
-eREMOTE = Errno (CONST_EREMOTE)
-eROFS = Errno (CONST_EROFS)
-eRPCMISMATCH = Errno (CONST_ERPCMISMATCH)
-eRREMOTE = Errno (CONST_ERREMOTE)
-eSHUTDOWN = Errno (CONST_ESHUTDOWN)
-eSOCKTNOSUPPORT = Errno (CONST_ESOCKTNOSUPPORT)
-eSPIPE = Errno (CONST_ESPIPE)
-eSRCH = Errno (CONST_ESRCH)
-eSRMNT = Errno (CONST_ESRMNT)
-eSTALE = Errno (CONST_ESTALE)
-eTIME = Errno (CONST_ETIME)
-eTIMEDOUT = Errno (CONST_ETIMEDOUT)
-eTOOMANYREFS = Errno (CONST_ETOOMANYREFS)
-eTXTBSY = Errno (CONST_ETXTBSY)
-eUSERS = Errno (CONST_EUSERS)
-eWOULDBLOCK = Errno (CONST_EWOULDBLOCK)
-eXDEV = Errno (CONST_EXDEV)
-#endif
-
--- | Yield 'True' if the given 'Errno' value is valid on the system.
--- This implies that the 'Eq' instance of 'Errno' is also system dependent
--- as it is only defined for valid values of 'Errno'.
---
-isValidErrno :: Errno -> Bool
---
--- the configure script sets all invalid "errno"s to -1
---
-isValidErrno (Errno errno) = errno /= -1
-
-
--- access to the current thread's "errno" value
--- --------------------------------------------
-
--- | Get the current value of @errno@ in the current thread.
---
-getErrno :: IO Errno
-
--- We must call a C function to get the value of errno in general. On
--- threaded systems, errno is hidden behind a C macro so that each OS
--- thread gets its own copy.
-#ifdef __NHC__
-getErrno = do e <- peek _errno; return (Errno e)
-foreign import ccall unsafe "errno.h &errno" _errno :: Ptr CInt
-#else
-getErrno = do e <- get_errno; return (Errno e)
-foreign import ccall unsafe "HsBase.h __hscore_get_errno" get_errno :: IO CInt
-#endif
-
--- | Reset the current thread\'s @errno@ value to 'eOK'.
---
-resetErrno :: IO ()
-
--- Again, setting errno has to be done via a C function.
-#ifdef __NHC__
-resetErrno = poke _errno 0
-#else
-resetErrno = set_errno 0
-foreign import ccall unsafe "HsBase.h __hscore_set_errno" set_errno :: CInt -> IO ()
-#endif
-
--- throw current "errno" value
--- ---------------------------
-
--- | Throw an 'IOError' corresponding to the current value of 'getErrno'.
---
-throwErrno :: String -- ^ textual description of the error location
- -> IO a
-throwErrno loc =
- do
- errno <- getErrno
- ioError (errnoToIOError loc errno Nothing Nothing)
-
-
--- guards for IO operations that may fail
--- --------------------------------------
-
--- | Throw an 'IOError' corresponding to the current value of 'getErrno'
--- if the result value of the 'IO' action meets the given predicate.
---
-throwErrnoIf :: (a -> Bool) -- ^ predicate to apply to the result value
- -- of the 'IO' operation
- -> String -- ^ textual description of the location
- -> IO a -- ^ the 'IO' operation to be executed
- -> IO a
-throwErrnoIf pred loc f =
- do
- res <- f
- if pred res then throwErrno loc else return res
-
--- | as 'throwErrnoIf', but discards the result of the 'IO' action after
--- error handling.
---
-throwErrnoIf_ :: (a -> Bool) -> String -> IO a -> IO ()
-throwErrnoIf_ pred loc f = void $ throwErrnoIf pred loc f
-
--- | as 'throwErrnoIf', but retry the 'IO' action when it yields the
--- error code 'eINTR' - this amounts to the standard retry loop for
--- interrupted POSIX system calls.
---
-throwErrnoIfRetry :: (a -> Bool) -> String -> IO a -> IO a
-throwErrnoIfRetry pred loc f =
- do
- res <- f
- if pred res
- then do
- err <- getErrno
- if err == eINTR
- then throwErrnoIfRetry pred loc f
- else throwErrno loc
- else return res
-
--- | as 'throwErrnoIfRetry', but checks for operations that would block and
--- executes an alternative action before retrying in that case.
---
-throwErrnoIfRetryMayBlock
- :: (a -> Bool) -- ^ predicate to apply to the result value
- -- of the 'IO' operation
- -> String -- ^ textual description of the location
- -> IO a -- ^ the 'IO' operation to be executed
- -> IO b -- ^ action to execute before retrying if
- -- an immediate retry would block
- -> IO a
-throwErrnoIfRetryMayBlock pred loc f on_block =
- do
- res <- f
- if pred res
- then do
- err <- getErrno
- if err == eINTR
- then throwErrnoIfRetryMayBlock pred loc f on_block
- else if err == eWOULDBLOCK || err == eAGAIN
- then do on_block; throwErrnoIfRetryMayBlock pred loc f on_block
- else throwErrno loc
- else return res
-
--- | as 'throwErrnoIfRetry', but discards the result.
---
-throwErrnoIfRetry_ :: (a -> Bool) -> String -> IO a -> IO ()
-throwErrnoIfRetry_ pred loc f = void $ throwErrnoIfRetry pred loc f
-
--- | as 'throwErrnoIfRetryMayBlock', but discards the result.
---
-throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO ()
-throwErrnoIfRetryMayBlock_ pred loc f on_block
- = void $ throwErrnoIfRetryMayBlock pred loc f on_block
-
--- | Throw an 'IOError' corresponding to the current value of 'getErrno'
--- if the 'IO' action returns a result of @-1@.
---
-throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a
-throwErrnoIfMinus1 = throwErrnoIf (== -1)
-
--- | as 'throwErrnoIfMinus1', but discards the result.
---
-throwErrnoIfMinus1_ :: Num a => String -> IO a -> IO ()
-throwErrnoIfMinus1_ = throwErrnoIf_ (== -1)
-
--- | Throw an 'IOError' corresponding to the current value of 'getErrno'
--- if the 'IO' action returns a result of @-1@, but retries in case of
--- an interrupted operation.
---
-throwErrnoIfMinus1Retry :: Num a => String -> IO a -> IO a
-throwErrnoIfMinus1Retry = throwErrnoIfRetry (== -1)
-
--- | as 'throwErrnoIfMinus1', but discards the result.
---
-throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO ()
-throwErrnoIfMinus1Retry_ = throwErrnoIfRetry_ (== -1)
-
--- | as 'throwErrnoIfMinus1Retry', but checks for operations that would block.
---
-throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a
-throwErrnoIfMinus1RetryMayBlock = throwErrnoIfRetryMayBlock (== -1)
-
--- | as 'throwErrnoIfMinus1RetryMayBlock', but discards the result.
---
-throwErrnoIfMinus1RetryMayBlock_ :: Num a => String -> IO a -> IO b -> IO ()
-throwErrnoIfMinus1RetryMayBlock_ = throwErrnoIfRetryMayBlock_ (== -1)
-
--- | Throw an 'IOError' corresponding to the current value of 'getErrno'
--- if the 'IO' action returns 'nullPtr'.
---
-throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
-throwErrnoIfNull = throwErrnoIf (== nullPtr)
-
--- | Throw an 'IOError' corresponding to the current value of 'getErrno'
--- if the 'IO' action returns 'nullPtr',
--- but retry in case of an interrupted operation.
---
-throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a)
-throwErrnoIfNullRetry = throwErrnoIfRetry (== nullPtr)
-
--- | as 'throwErrnoIfNullRetry', but checks for operations that would block.
---
-throwErrnoIfNullRetryMayBlock :: String -> IO (Ptr a) -> IO b -> IO (Ptr a)
-throwErrnoIfNullRetryMayBlock = throwErrnoIfRetryMayBlock (== nullPtr)
-
--- conversion of an "errno" value into IO error
--- --------------------------------------------
-
--- | Construct a Haskell 98 I\/O error based on the given 'Errno' value.
--- The optional information can be used to improve the accuracy of
--- error messages.
---
-errnoToIOError :: String -- ^ the location where the error occurred
- -> Errno -- ^ the error number
- -> Maybe Handle -- ^ optional handle associated with the error
- -> Maybe String -- ^ optional filename associated with the error
- -> IOError
-errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do
- str <- strerror errno >>= peekCString
-#if __GLASGOW_HASKELL__
- return (IOError maybeHdl errType loc str maybeName)
- where
- errType
- | errno == eOK = OtherError
- | errno == e2BIG = ResourceExhausted
- | errno == eACCES = PermissionDenied
- | errno == eADDRINUSE = ResourceBusy
- | errno == eADDRNOTAVAIL = UnsupportedOperation
- | errno == eADV = OtherError
- | errno == eAFNOSUPPORT = UnsupportedOperation
- | errno == eAGAIN = ResourceExhausted
- | errno == eALREADY = AlreadyExists
- | errno == eBADF = InvalidArgument
- | errno == eBADMSG = InappropriateType
- | errno == eBADRPC = OtherError
- | errno == eBUSY = ResourceBusy
- | errno == eCHILD = NoSuchThing
- | errno == eCOMM = ResourceVanished
- | errno == eCONNABORTED = OtherError
- | errno == eCONNREFUSED = NoSuchThing
- | errno == eCONNRESET = ResourceVanished
- | errno == eDEADLK = ResourceBusy
- | errno == eDESTADDRREQ = InvalidArgument
- | errno == eDIRTY = UnsatisfiedConstraints
- | errno == eDOM = InvalidArgument
- | errno == eDQUOT = PermissionDenied
- | errno == eEXIST = AlreadyExists
- | errno == eFAULT = OtherError
- | errno == eFBIG = PermissionDenied
- | errno == eFTYPE = InappropriateType
- | errno == eHOSTDOWN = NoSuchThing
- | errno == eHOSTUNREACH = NoSuchThing
- | errno == eIDRM = ResourceVanished
- | errno == eILSEQ = InvalidArgument
- | errno == eINPROGRESS = AlreadyExists
- | errno == eINTR = Interrupted
- | errno == eINVAL = InvalidArgument
- | errno == eIO = HardwareFault
- | errno == eISCONN = AlreadyExists
- | errno == eISDIR = InappropriateType
- | errno == eLOOP = InvalidArgument
- | errno == eMFILE = ResourceExhausted
- | errno == eMLINK = ResourceExhausted
- | errno == eMSGSIZE = ResourceExhausted
- | errno == eMULTIHOP = UnsupportedOperation
- | errno == eNAMETOOLONG = InvalidArgument
- | errno == eNETDOWN = ResourceVanished
- | errno == eNETRESET = ResourceVanished
- | errno == eNETUNREACH = NoSuchThing
- | errno == eNFILE = ResourceExhausted
- | errno == eNOBUFS = ResourceExhausted
- | errno == eNODATA = NoSuchThing
- | errno == eNODEV = UnsupportedOperation
- | errno == eNOENT = NoSuchThing
- | errno == eNOEXEC = InvalidArgument
- | errno == eNOLCK = ResourceExhausted
- | errno == eNOLINK = ResourceVanished
- | errno == eNOMEM = ResourceExhausted
- | errno == eNOMSG = NoSuchThing
- | errno == eNONET = NoSuchThing
- | errno == eNOPROTOOPT = UnsupportedOperation
- | errno == eNOSPC = ResourceExhausted
- | errno == eNOSR = ResourceExhausted
- | errno == eNOSTR = InvalidArgument
- | errno == eNOSYS = UnsupportedOperation
- | errno == eNOTBLK = InvalidArgument
- | errno == eNOTCONN = InvalidArgument
- | errno == eNOTDIR = InappropriateType
- | errno == eNOTEMPTY = UnsatisfiedConstraints
- | errno == eNOTSOCK = InvalidArgument
- | errno == eNOTTY = IllegalOperation
- | errno == eNXIO = NoSuchThing
- | errno == eOPNOTSUPP = UnsupportedOperation
- | errno == ePERM = PermissionDenied
- | errno == ePFNOSUPPORT = UnsupportedOperation
- | errno == ePIPE = ResourceVanished
- | errno == ePROCLIM = PermissionDenied
- | errno == ePROCUNAVAIL = UnsupportedOperation
- | errno == ePROGMISMATCH = ProtocolError
- | errno == ePROGUNAVAIL = UnsupportedOperation
- | errno == ePROTO = ProtocolError
- | errno == ePROTONOSUPPORT = ProtocolError
- | errno == ePROTOTYPE = ProtocolError
- | errno == eRANGE = UnsupportedOperation
- | errno == eREMCHG = ResourceVanished
- | errno == eREMOTE = IllegalOperation
- | errno == eROFS = PermissionDenied
- | errno == eRPCMISMATCH = ProtocolError
- | errno == eRREMOTE = IllegalOperation
- | errno == eSHUTDOWN = IllegalOperation
- | errno == eSOCKTNOSUPPORT = UnsupportedOperation
- | errno == eSPIPE = UnsupportedOperation
- | errno == eSRCH = NoSuchThing
- | errno == eSRMNT = UnsatisfiedConstraints
- | errno == eSTALE = ResourceVanished
- | errno == eTIME = TimeExpired
- | errno == eTIMEDOUT = TimeExpired
- | errno == eTOOMANYREFS = ResourceExhausted
- | errno == eTXTBSY = ResourceBusy
- | errno == eUSERS = ResourceExhausted
- | errno == eWOULDBLOCK = OtherError
- | errno == eXDEV = UnsupportedOperation
- | otherwise = OtherError
-#else
- return (userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName))
-#endif
-
-foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar)
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.C.String
--- Copyright : (c) The FFI task force 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Utilities for primitive marshalling of C strings.
---
--- The marshalling converts each Haskell character, representing a Unicode
--- code point, to one or more bytes in a manner that, by default, is
--- determined by the current locale. As a consequence, no guarantees
--- can be made about the relative length of a Haskell string and its
--- corresponding C string, and therefore all the marshalling routines
--- include memory allocation. The translation between Unicode and the
--- encoding of the current locale may be lossy.
---
------------------------------------------------------------------------------
-
-module Foreign.C.String ( -- representation of strings in C
-
- -- * C strings
-
- CString, -- = Ptr CChar
- CStringLen, -- = (Ptr CChar, Int)
-
- -- ** Using a locale-dependent encoding
-
- -- | Currently these functions are identical to their @CAString@ counterparts;
- -- eventually they will use an encoding determined by the current locale.
-
- -- conversion of C strings into Haskell strings
- --
- peekCString, -- :: CString -> IO String
- peekCStringLen, -- :: CStringLen -> IO String
-
- -- conversion of Haskell strings into C strings
- --
- newCString, -- :: String -> IO CString
- newCStringLen, -- :: String -> IO CStringLen
-
- -- conversion of Haskell strings into C strings using temporary storage
- --
- withCString, -- :: String -> (CString -> IO a) -> IO a
- withCStringLen, -- :: String -> (CStringLen -> IO a) -> IO a
-
- charIsRepresentable, -- :: Char -> IO Bool
-
- -- ** Using 8-bit characters
-
- -- | These variants of the above functions are for use with C libraries
- -- that are ignorant of Unicode. These functions should be used with
- -- care, as a loss of information can occur.
-
- castCharToCChar, -- :: Char -> CChar
- castCCharToChar, -- :: CChar -> Char
-
- peekCAString, -- :: CString -> IO String
- peekCAStringLen, -- :: CStringLen -> IO String
- newCAString, -- :: String -> IO CString
- newCAStringLen, -- :: String -> IO CStringLen
- withCAString, -- :: String -> (CString -> IO a) -> IO a
- withCAStringLen, -- :: String -> (CStringLen -> IO a) -> IO a
-
- -- * C wide strings
-
- -- | These variants of the above functions are for use with C libraries
- -- that encode Unicode using the C @wchar_t@ type in a system-dependent
- -- way. The only encodings supported are
- --
- -- * UTF-32 (the C compiler defines @__STDC_ISO_10646__@), or
- --
- -- * UTF-16 (as used on Windows systems).
-
- CWString, -- = Ptr CWchar
- CWStringLen, -- = (Ptr CWchar, Int)
-
- peekCWString, -- :: CWString -> IO String
- peekCWStringLen, -- :: CWStringLen -> IO String
- newCWString, -- :: String -> IO CWString
- newCWStringLen, -- :: String -> IO CWStringLen
- withCWString, -- :: String -> (CWString -> IO a) -> IO a
- withCWStringLen, -- :: String -> (CWStringLen -> IO a) -> IO a
-
- ) where
-
-import Foreign.Marshal.Array
-import Foreign.C.Types
-import Foreign.Ptr
-import Foreign.Storable
-
-import Data.Word
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.List
-import GHC.Real
-import GHC.Num
-import GHC.IOBase
-import GHC.Base
-#else
-import Data.Char ( chr, ord )
-#define unsafeChr chr
-#endif
-
------------------------------------------------------------------------------
--- Strings
-
--- representation of strings in C
--- ------------------------------
-
--- | A C string is a reference to an array of C characters terminated by NUL.
-type CString = Ptr CChar
-
--- | A string with explicit length information in bytes instead of a
--- terminating NUL (allowing NUL characters in the middle of the string).
-type CStringLen = (Ptr CChar, Int)
-
--- exported functions
--- ------------------
---
--- * the following routines apply the default conversion when converting the
--- C-land character encoding into the Haskell-land character encoding
-
--- | Marshal a NUL terminated C string into a Haskell string.
---
-peekCString :: CString -> IO String
-peekCString = peekCAString
-
--- | Marshal a C string with explicit length into a Haskell string.
---
-peekCStringLen :: CStringLen -> IO String
-peekCStringLen = peekCAStringLen
-
--- | Marshal a Haskell string into a NUL terminated C string.
---
--- * the Haskell string may /not/ contain any NUL characters
---
--- * new storage is allocated for the C string and must be
--- explicitly freed using 'Foreign.Marshal.Alloc.free' or
--- 'Foreign.Marshal.Alloc.finalizerFree'.
---
-newCString :: String -> IO CString
-newCString = newCAString
-
--- | Marshal a Haskell string into a C string (ie, character array) with
--- explicit length information.
---
--- * new storage is allocated for the C string and must be
--- explicitly freed using 'Foreign.Marshal.Alloc.free' or
--- 'Foreign.Marshal.Alloc.finalizerFree'.
---
-newCStringLen :: String -> IO CStringLen
-newCStringLen = newCAStringLen
-
--- | Marshal a Haskell string into a NUL terminated C string using temporary
--- storage.
---
--- * the Haskell string may /not/ contain any NUL characters
---
--- * the memory is freed when the subcomputation terminates (either
--- normally or via an exception), so the pointer to the temporary
--- storage must /not/ be used after this.
---
-withCString :: String -> (CString -> IO a) -> IO a
-withCString = withCAString
-
--- | Marshal a Haskell string into a C string (ie, character array)
--- in temporary storage, with explicit length information.
---
--- * the memory is freed when the subcomputation terminates (either
--- normally or via an exception), so the pointer to the temporary
--- storage must /not/ be used after this.
---
-withCStringLen :: String -> (CStringLen -> IO a) -> IO a
-withCStringLen = withCAStringLen
-
--- | Determines whether a character can be accurately encoded in a 'CString'.
--- Unrepresentable characters are converted to @\'?\'@.
---
--- Currently only Latin-1 characters are representable.
-charIsRepresentable :: Char -> IO Bool
-charIsRepresentable c = return (ord c < 256)
-
--- single byte characters
--- ----------------------
---
--- ** NOTE: These routines don't handle conversions! **
-
--- | Convert a C byte, representing a Latin-1 character, to the corresponding
--- Haskell character.
-castCCharToChar :: CChar -> Char
-castCCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8))
-
--- | Convert a Haskell character to a C character.
--- This function is only safe on the first 256 characters.
-castCharToCChar :: Char -> CChar
-castCharToCChar ch = fromIntegral (ord ch)
-
--- | Marshal a NUL terminated C string into a Haskell string.
---
-peekCAString :: CString -> IO String
-#ifndef __GLASGOW_HASKELL__
-peekCAString cp = do
- cs <- peekArray0 nUL cp
- return (cCharsToChars cs)
-#else
-peekCAString cp = do
- l <- lengthArray0 nUL cp
- if l <= 0 then return "" else loop "" (l-1)
- where
- loop s i = do
- xval <- peekElemOff cp i
- let val = castCCharToChar xval
- val `seq` if i <= 0 then return (val:s) else loop (val:s) (i-1)
-#endif
-
--- | Marshal a C string with explicit length into a Haskell string.
---
-peekCAStringLen :: CStringLen -> IO String
-#ifndef __GLASGOW_HASKELL__
-peekCAStringLen (cp, len) = do
- cs <- peekArray len cp
- return (cCharsToChars cs)
-#else
-peekCAStringLen (cp, len)
- | len <= 0 = return "" -- being (too?) nice.
- | otherwise = loop [] (len-1)
- where
- loop acc i = do
- xval <- peekElemOff cp i
- let val = castCCharToChar xval
- -- blow away the coercion ASAP.
- if (val `seq` (i == 0))
- then return (val:acc)
- else loop (val:acc) (i-1)
-#endif
-
--- | Marshal a Haskell string into a NUL terminated C string.
---
--- * the Haskell string may /not/ contain any NUL characters
---
--- * new storage is allocated for the C string and must be
--- explicitly freed using 'Foreign.Marshal.Alloc.free' or
--- 'Foreign.Marshal.Alloc.finalizerFree'.
---
-newCAString :: String -> IO CString
-#ifndef __GLASGOW_HASKELL__
-newCAString = newArray0 nUL . charsToCChars
-#else
-newCAString str = do
- ptr <- mallocArray0 (length str)
- let
- go [] n = pokeElemOff ptr n nUL
- go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
- go str 0
- return ptr
-#endif
-
--- | Marshal a Haskell string into a C string (ie, character array) with
--- explicit length information.
---
--- * new storage is allocated for the C string and must be
--- explicitly freed using 'Foreign.Marshal.Alloc.free' or
--- 'Foreign.Marshal.Alloc.finalizerFree'.
---
-newCAStringLen :: String -> IO CStringLen
-#ifndef __GLASGOW_HASKELL__
-newCAStringLen str = do
- a <- newArray (charsToCChars str)
- return (pairLength str a)
-#else
-newCAStringLen str = do
- ptr <- mallocArray0 len
- let
- go [] n = n `seq` return () -- make it strict in n
- go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
- go str 0
- return (ptr, len)
- where
- len = length str
-#endif
-
--- | Marshal a Haskell string into a NUL terminated C string using temporary
--- storage.
---
--- * the Haskell string may /not/ contain any NUL characters
---
--- * the memory is freed when the subcomputation terminates (either
--- normally or via an exception), so the pointer to the temporary
--- storage must /not/ be used after this.
---
-withCAString :: String -> (CString -> IO a) -> IO a
-#ifndef __GLASGOW_HASKELL__
-withCAString = withArray0 nUL . charsToCChars
-#else
-withCAString str f =
- allocaArray0 (length str) $ \ptr ->
- let
- go [] n = pokeElemOff ptr n nUL
- go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
- in do
- go str 0
- f ptr
-#endif
-
--- | Marshal a Haskell string into a C string (ie, character array)
--- in temporary storage, with explicit length information.
---
--- * the memory is freed when the subcomputation terminates (either
--- normally or via an exception), so the pointer to the temporary
--- storage must /not/ be used after this.
---
-withCAStringLen :: String -> (CStringLen -> IO a) -> IO a
-#ifndef __GLASGOW_HASKELL__
-withCAStringLen str act = withArray (charsToCChars str) $ act . pairLength str
-#else
-withCAStringLen str f =
- allocaArray len $ \ptr ->
- let
- go [] n = n `seq` return () -- make it strict in n
- go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
- in do
- go str 0
- f (ptr,len)
- where
- len = length str
-#endif
-
--- auxiliary definitions
--- ----------------------
-
--- C's end of string character
---
-nUL :: CChar
-nUL = 0
-
--- pair a C string with the length of the given Haskell string
---
-pairLength :: String -> a -> (a, Int)
-pairLength = flip (,) . length
-
-#ifndef __GLASGOW_HASKELL__
--- cast [CChar] to [Char]
---
-cCharsToChars :: [CChar] -> [Char]
-cCharsToChars xs = map castCCharToChar xs
-
--- cast [Char] to [CChar]
---
-charsToCChars :: [Char] -> [CChar]
-charsToCChars xs = map castCharToCChar xs
-#endif
-
------------------------------------------------------------------------------
--- Wide strings
-
--- representation of wide strings in C
--- -----------------------------------
-
--- | A C wide string is a reference to an array of C wide characters
--- terminated by NUL.
-type CWString = Ptr CWchar
-
--- | A wide character string with explicit length information in bytes
--- instead of a terminating NUL (allowing NUL characters in the middle
--- of the string).
-type CWStringLen = (Ptr CWchar, Int)
-
--- | Marshal a NUL terminated C wide string into a Haskell string.
---
-peekCWString :: CWString -> IO String
-peekCWString cp = do
- cs <- peekArray0 wNUL cp
- return (cWcharsToChars cs)
-
--- | Marshal a C wide string with explicit length into a Haskell string.
---
-peekCWStringLen :: CWStringLen -> IO String
-peekCWStringLen (cp, len) = do
- cs <- peekArray len cp
- return (cWcharsToChars cs)
-
--- | Marshal a Haskell string into a NUL terminated C wide string.
---
--- * the Haskell string may /not/ contain any NUL characters
---
--- * new storage is allocated for the C wide string and must
--- be explicitly freed using 'Foreign.Marshal.Alloc.free' or
--- 'Foreign.Marshal.Alloc.finalizerFree'.
---
-newCWString :: String -> IO CWString
-newCWString = newArray0 wNUL . charsToCWchars
-
--- | Marshal a Haskell string into a C wide string (ie, wide character array)
--- with explicit length information.
---
--- * new storage is allocated for the C wide string and must
--- be explicitly freed using 'Foreign.Marshal.Alloc.free' or
--- 'Foreign.Marshal.Alloc.finalizerFree'.
---
-newCWStringLen :: String -> IO CWStringLen
-newCWStringLen str = do
- a <- newArray (charsToCWchars str)
- return (pairLength str a)
-
--- | Marshal a Haskell string into a NUL terminated C wide string using
--- temporary storage.
---
--- * the Haskell string may /not/ contain any NUL characters
---
--- * the memory is freed when the subcomputation terminates (either
--- normally or via an exception), so the pointer to the temporary
--- storage must /not/ be used after this.
---
-withCWString :: String -> (CWString -> IO a) -> IO a
-withCWString = withArray0 wNUL . charsToCWchars
-
--- | Marshal a Haskell string into a NUL terminated C wide string using
--- temporary storage.
---
--- * the Haskell string may /not/ contain any NUL characters
---
--- * the memory is freed when the subcomputation terminates (either
--- normally or via an exception), so the pointer to the temporary
--- storage must /not/ be used after this.
---
-withCWStringLen :: String -> (CWStringLen -> IO a) -> IO a
-withCWStringLen str act = withArray (charsToCWchars str) $ act . pairLength str
-
--- auxiliary definitions
--- ----------------------
-
-wNUL :: CWchar
-wNUL = 0
-
-cWcharsToChars :: [CWchar] -> [Char]
-charsToCWchars :: [Char] -> [CWchar]
-
-#ifdef mingw32_HOST_OS
-
--- On Windows, wchar_t is 16 bits wide and CWString uses the UTF-16 encoding.
-
--- coding errors generate Chars in the surrogate range
-cWcharsToChars = map chr . fromUTF16 . map fromIntegral
- where
- fromUTF16 (c1:c2:wcs)
- | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff =
- ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs
- fromUTF16 (c:wcs) = c : fromUTF16 wcs
- fromUTF16 [] = []
-
-charsToCWchars = foldr utf16Char [] . map ord
- where
- utf16Char c wcs
- | c < 0x10000 = fromIntegral c : wcs
- | otherwise = let c' = c - 0x10000 in
- fromIntegral (c' `div` 0x400 + 0xd800) :
- fromIntegral (c' `mod` 0x400 + 0xdc00) : wcs
-
-#else /* !mingw32_HOST_OS */
-
-cWcharsToChars xs = map castCWcharToChar xs
-charsToCWchars xs = map castCharToCWchar xs
-
--- These conversions only make sense if __STDC_ISO_10646__ is defined
--- (meaning that wchar_t is ISO 10646, aka Unicode)
-
-castCWcharToChar :: CWchar -> Char
-castCWcharToChar ch = chr (fromIntegral ch )
-
-castCharToCWchar :: Char -> CWchar
-castCharToCWchar ch = fromIntegral (ord ch)
-
-#endif /* !mingw32_HOST_OS */
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.C.Types
--- Copyright : (c) The FFI task force 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Mapping of C types to corresponding Haskell types.
---
------------------------------------------------------------------------------
-
-module Foreign.C.Types
- ( -- * Representations of C types
-#ifndef __NHC__
- -- $ctypes
-
- -- ** Integral types
- -- | These types are are represented as @newtype@s of
- -- types in "Data.Int" and "Data.Word", and are instances of
- -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read',
- -- 'Prelude.Show', 'Prelude.Enum', 'Typeable', 'Storable',
- -- 'Prelude.Bounded', 'Prelude.Real', 'Prelude.Integral' and
- -- 'Bits'.
- CChar, CSChar, CUChar
- , CShort, CUShort, CInt, CUInt
- , CLong, CULong
- , CPtrdiff, CSize, CWchar, CSigAtomic
- , CLLong, CULLong
- , CIntPtr, CUIntPtr
- , CIntMax, CUIntMax
-
- -- ** Numeric types
- -- | These types are are represented as @newtype@s of basic
- -- foreign types, and are instances of
- -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read',
- -- 'Prelude.Show', 'Prelude.Enum', 'Typeable' and 'Storable'.
- , CClock, CTime
-
- -- ** Floating types
- -- | These types are are represented as @newtype@s of
- -- 'Prelude.Float' and 'Prelude.Double', and are instances of
- -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read',
- -- 'Prelude.Show', 'Prelude.Enum', 'Typeable', 'Storable',
- -- 'Prelude.Real', 'Prelude.Fractional', 'Prelude.Floating',
- -- 'Prelude.RealFrac' and 'Prelude.RealFloat'.
- , CFloat, CDouble, CLDouble
-#else
- -- Exported non-abstractly in nhc98 to fix an interface file problem.
- CChar(..), CSChar(..), CUChar(..)
- , CShort(..), CUShort(..), CInt(..), CUInt(..)
- , CLong(..), CULong(..)
- , CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..)
- , CLLong(..), CULLong(..)
- , CClock(..), CTime(..)
- , CFloat(..), CDouble(..), CLDouble(..)
-#endif
- -- ** Other types
-
- -- Instances of: Eq and Storable
- , CFile, CFpos, CJmpBuf
- ) where
-
-#ifndef __NHC__
-
-import {-# SOURCE #-} Foreign.Storable
-import Data.Bits ( Bits(..) )
-import Data.Int ( Int8, Int16, Int32, Int64 )
-import Data.Word ( Word8, Word16, Word32, Word64 )
-import {-# SOURCE #-} Data.Typeable
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.Float
-import GHC.Enum
-import GHC.Real
-import GHC.Show
-import GHC.Read
-import GHC.Num
-#else
-import Control.Monad ( liftM )
-#endif
-
-#ifdef __HUGS__
-import Hugs.Ptr ( castPtr )
-#endif
-
-#include "HsBaseConfig.h"
-#include "CTypes.h"
-
--- | Haskell type representing the C @char@ type.
-INTEGRAL_TYPE(CChar,tyConCChar,"CChar",HTYPE_CHAR)
--- | Haskell type representing the C @signed char@ type.
-INTEGRAL_TYPE(CSChar,tyConCSChar,"CSChar",HTYPE_SIGNED_CHAR)
--- | Haskell type representing the C @unsigned char@ type.
-INTEGRAL_TYPE(CUChar,tyConCUChar,"CUChar",HTYPE_UNSIGNED_CHAR)
-
--- | Haskell type representing the C @short@ type.
-INTEGRAL_TYPE(CShort,tyConCShort,"CShort",HTYPE_SHORT)
--- | Haskell type representing the C @unsigned short@ type.
-INTEGRAL_TYPE(CUShort,tyConCUShort,"CUShort",HTYPE_UNSIGNED_SHORT)
-
--- | Haskell type representing the C @int@ type.
-INTEGRAL_TYPE(CInt,tyConCInt,"CInt",HTYPE_INT)
--- | Haskell type representing the C @unsigned int@ type.
-INTEGRAL_TYPE(CUInt,tyConCUInt,"CUInt",HTYPE_UNSIGNED_INT)
-
--- | Haskell type representing the C @long@ type.
-INTEGRAL_TYPE(CLong,tyConCLong,"CLong",HTYPE_LONG)
--- | Haskell type representing the C @unsigned long@ type.
-INTEGRAL_TYPE(CULong,tyConCULong,"CULong",HTYPE_UNSIGNED_LONG)
-
--- | Haskell type representing the C @long long@ type.
-INTEGRAL_TYPE(CLLong,tyConCLLong,"CLLong",HTYPE_LONG_LONG)
--- | Haskell type representing the C @unsigned long long@ type.
-INTEGRAL_TYPE(CULLong,tyConCULLong,"CULLong",HTYPE_UNSIGNED_LONG_LONG)
-
-{-# RULES
-"fromIntegral/a->CChar" fromIntegral = \x -> CChar (fromIntegral x)
-"fromIntegral/a->CSChar" fromIntegral = \x -> CSChar (fromIntegral x)
-"fromIntegral/a->CUChar" fromIntegral = \x -> CUChar (fromIntegral x)
-"fromIntegral/a->CShort" fromIntegral = \x -> CShort (fromIntegral x)
-"fromIntegral/a->CUShort" fromIntegral = \x -> CUShort (fromIntegral x)
-"fromIntegral/a->CInt" fromIntegral = \x -> CInt (fromIntegral x)
-"fromIntegral/a->CUInt" fromIntegral = \x -> CUInt (fromIntegral x)
-"fromIntegral/a->CLong" fromIntegral = \x -> CLong (fromIntegral x)
-"fromIntegral/a->CULong" fromIntegral = \x -> CULong (fromIntegral x)
-"fromIntegral/a->CLLong" fromIntegral = \x -> CLLong (fromIntegral x)
-"fromIntegral/a->CULLong" fromIntegral = \x -> CULLong (fromIntegral x)
-
-"fromIntegral/CChar->a" fromIntegral = \(CChar x) -> fromIntegral x
-"fromIntegral/CSChar->a" fromIntegral = \(CSChar x) -> fromIntegral x
-"fromIntegral/CUChar->a" fromIntegral = \(CUChar x) -> fromIntegral x
-"fromIntegral/CShort->a" fromIntegral = \(CShort x) -> fromIntegral x
-"fromIntegral/CUShort->a" fromIntegral = \(CUShort x) -> fromIntegral x
-"fromIntegral/CInt->a" fromIntegral = \(CInt x) -> fromIntegral x
-"fromIntegral/CUInt->a" fromIntegral = \(CUInt x) -> fromIntegral x
-"fromIntegral/CLong->a" fromIntegral = \(CLong x) -> fromIntegral x
-"fromIntegral/CULong->a" fromIntegral = \(CULong x) -> fromIntegral x
-"fromIntegral/CLLong->a" fromIntegral = \(CLLong x) -> fromIntegral x
-"fromIntegral/CULLong->a" fromIntegral = \(CULLong x) -> fromIntegral x
- #-}
-
--- | Haskell type representing the C @float@ type.
-FLOATING_TYPE(CFloat,tyConCFloat,"CFloat",HTYPE_FLOAT)
--- | Haskell type representing the C @double@ type.
-FLOATING_TYPE(CDouble,tyConCDouble,"CDouble",HTYPE_DOUBLE)
--- HACK: Currently no long double in the FFI, so we simply re-use double
--- | Haskell type representing the C @long double@ type.
-FLOATING_TYPE(CLDouble,tyConCLDouble,"CLDouble",HTYPE_DOUBLE)
-
-{-# RULES
-"realToFrac/a->CFloat" realToFrac = \x -> CFloat (realToFrac x)
-"realToFrac/a->CDouble" realToFrac = \x -> CDouble (realToFrac x)
-"realToFrac/a->CLDouble" realToFrac = \x -> CLDouble (realToFrac x)
-
-"realToFrac/CFloat->a" realToFrac = \(CFloat x) -> realToFrac x
-"realToFrac/CDouble->a" realToFrac = \(CDouble x) -> realToFrac x
-"realToFrac/CLDouble->a" realToFrac = \(CLDouble x) -> realToFrac x
- #-}
-
--- | Haskell type representing the C @ptrdiff_t@ type.
-INTEGRAL_TYPE(CPtrdiff,tyConCPtrdiff,"CPtrdiff",HTYPE_PTRDIFF_T)
--- | Haskell type representing the C @size_t@ type.
-INTEGRAL_TYPE(CSize,tyConCSize,"CSize",HTYPE_SIZE_T)
--- | Haskell type representing the C @wchar_t@ type.
-INTEGRAL_TYPE(CWchar,tyConCWchar,"CWchar",HTYPE_WCHAR_T)
--- | Haskell type representing the C @sig_atomic_t@ type.
-INTEGRAL_TYPE(CSigAtomic,tyConCSigAtomic,"CSigAtomic",HTYPE_SIG_ATOMIC_T)
-
-{-# RULES
-"fromIntegral/a->CPtrdiff" fromIntegral = \x -> CPtrdiff (fromIntegral x)
-"fromIntegral/a->CSize" fromIntegral = \x -> CSize (fromIntegral x)
-"fromIntegral/a->CWchar" fromIntegral = \x -> CWchar (fromIntegral x)
-"fromIntegral/a->CSigAtomic" fromIntegral = \x -> CSigAtomic (fromIntegral x)
-
-"fromIntegral/CPtrdiff->a" fromIntegral = \(CPtrdiff x) -> fromIntegral x
-"fromIntegral/CSize->a" fromIntegral = \(CSize x) -> fromIntegral x
-"fromIntegral/CWchar->a" fromIntegral = \(CWchar x) -> fromIntegral x
-"fromIntegral/CSigAtomic->a" fromIntegral = \(CSigAtomic x) -> fromIntegral x
- #-}
-
--- | Haskell type representing the C @clock_t@ type.
-ARITHMETIC_TYPE(CClock,tyConCClock,"CClock",HTYPE_CLOCK_T)
--- | Haskell type representing the C @time_t@ type.
-ARITHMETIC_TYPE(CTime,tyConCTime,"CTime",HTYPE_TIME_T)
-
--- FIXME: Implement and provide instances for Eq and Storable
--- | Haskell type representing the C @FILE@ type.
-data CFile = CFile
--- | Haskell type representing the C @fpos_t@ type.
-data CFpos = CFpos
--- | Haskell type representing the C @jmp_buf@ type.
-data CJmpBuf = CJmpBuf
-
-INTEGRAL_TYPE(CIntPtr,tyConCIntPtr,"CIntPtr",HTYPE_INTPTR_T)
-INTEGRAL_TYPE(CUIntPtr,tyConCUIntPtr,"CUIntPtr",HTYPE_UINTPTR_T)
-INTEGRAL_TYPE(CIntMax,tyConCIntMax,"CIntMax",HTYPE_INTMAX_T)
-INTEGRAL_TYPE(CUIntMax,tyConCUIntMax,"CUIntMax",HTYPE_UINTMAX_T)
-
-{-# RULES
-"fromIntegral/a->CIntPtr" fromIntegral = \x -> CIntPtr (fromIntegral x)
-"fromIntegral/a->CUIntPtr" fromIntegral = \x -> CUIntPtr (fromIntegral x)
-"fromIntegral/a->CIntMax" fromIntegral = \x -> CIntMax (fromIntegral x)
-"fromIntegral/a->CUIntMax" fromIntegral = \x -> CUIntMax (fromIntegral x)
- #-}
-
--- C99 types which are still missing include:
--- wint_t, wctrans_t, wctype_t
-
-{- $ctypes
-
-These types are needed to accurately represent C function prototypes,
-in order to access C library interfaces in Haskell. The Haskell system
-is not required to represent those types exactly as C does, but the
-following guarantees are provided concerning a Haskell type @CT@
-representing a C type @t@:
-
-* If a C function prototype has @t@ as an argument or result type, the
- use of @CT@ in the corresponding position in a foreign declaration
- permits the Haskell program to access the full range of values encoded
- by the C type; and conversely, any Haskell value for @CT@ has a valid
- representation in C.
-
-* @'sizeOf' ('Prelude.undefined' :: CT)@ will yield the same value as
- @sizeof (t)@ in C.
-
-* @'alignment' ('Prelude.undefined' :: CT)@ matches the alignment
- constraint enforced by the C implementation for @t@.
-
-* The members 'peek' and 'poke' of the 'Storable' class map all values
- of @CT@ to the corresponding value of @t@ and vice versa.
-
-* When an instance of 'Prelude.Bounded' is defined for @CT@, the values
- of 'Prelude.minBound' and 'Prelude.maxBound' coincide with @t_MIN@
- and @t_MAX@ in C.
-
-* When an instance of 'Prelude.Eq' or 'Prelude.Ord' is defined for @CT@,
- the predicates defined by the type class implement the same relation
- as the corresponding predicate in C on @t@.
-
-* When an instance of 'Prelude.Num', 'Prelude.Read', 'Prelude.Integral',
- 'Prelude.Fractional', 'Prelude.Floating', 'Prelude.RealFrac', or
- 'Prelude.RealFloat' is defined for @CT@, the arithmetic operations
- defined by the type class implement the same function as the
- corresponding arithmetic operations (if available) in C on @t@.
-
-* When an instance of 'Bits' is defined for @CT@, the bitwise operation
- defined by the type class implement the same function as the
- corresponding bitwise operation in C on @t@.
-
--}
-
-#else /* __NHC__ */
-
-import NHC.FFI
- ( CChar(..), CSChar(..), CUChar(..)
- , CShort(..), CUShort(..), CInt(..), CUInt(..)
- , CLong(..), CULong(..), CLLong(..), CULLong(..)
- , CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..)
- , CClock(..), CTime(..)
- , CFloat(..), CDouble(..), CLDouble(..)
- , CFile, CFpos, CJmpBuf
- , Storable(..)
- )
-import Data.Bits
-import NHC.SizedTypes
-
-#define INSTANCE_BITS(T) \
-instance Bits T where { \
- (T x) .&. (T y) = T (x .&. y) ; \
- (T x) .|. (T y) = T (x .|. y) ; \
- (T x) `xor` (T y) = T (x `xor` y) ; \
- complement (T x) = T (complement x) ; \
- shift (T x) n = T (shift x n) ; \
- rotate (T x) n = T (rotate x n) ; \
- bit n = T (bit n) ; \
- setBit (T x) n = T (setBit x n) ; \
- clearBit (T x) n = T (clearBit x n) ; \
- complementBit (T x) n = T (complementBit x n) ; \
- testBit (T x) n = testBit x n ; \
- bitSize (T x) = bitSize x ; \
- isSigned (T x) = isSigned x }
-
-INSTANCE_BITS(CChar)
-INSTANCE_BITS(CSChar)
-INSTANCE_BITS(CUChar)
-INSTANCE_BITS(CShort)
-INSTANCE_BITS(CUShort)
-INSTANCE_BITS(CInt)
-INSTANCE_BITS(CUInt)
-INSTANCE_BITS(CLong)
-INSTANCE_BITS(CULong)
-INSTANCE_BITS(CLLong)
-INSTANCE_BITS(CULLong)
-INSTANCE_BITS(CPtrdiff)
-INSTANCE_BITS(CWchar)
-INSTANCE_BITS(CSigAtomic)
-INSTANCE_BITS(CSize)
-
-#endif
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.Concurrent
--- Copyright : (c) The University of Glasgow 2003
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : non-portable (requires concurrency)
---
--- FFI datatypes and operations that use or require concurrency (GHC only).
---
------------------------------------------------------------------------------
-
-module Foreign.Concurrent
- (
- -- * Concurrency-based 'ForeignPtr' operations
-
- -- | These functions generalize their namesakes in the portable
- -- "Foreign.ForeignPtr" module by allowing arbitrary 'IO' actions
- -- as finalizers. These finalizers necessarily run in a separate
- -- thread, cf. /Destructors, Finalizers and Synchronization/,
- -- by Hans Boehm, /POPL/, 2003.
-
- newForeignPtr,
- addForeignPtrFinalizer,
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase ( IO )
-import GHC.Ptr ( Ptr )
-import GHC.ForeignPtr ( ForeignPtr )
-import qualified GHC.ForeignPtr
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-newForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a)
--- ^Turns a plain memory reference into a foreign object by associating
--- a finalizer - given by the monadic operation - with the reference.
--- The finalizer will be executed after the last reference to the
--- foreign object is dropped. Note that there is no guarantee on how
--- soon the finalizer is executed after the last reference was dropped;
--- this depends on the details of the Haskell storage manager. The only
--- guarantee is that the finalizer runs before the program terminates.
-newForeignPtr = GHC.ForeignPtr.newConcForeignPtr
-
-addForeignPtrFinalizer :: ForeignPtr a -> IO () -> IO ()
--- ^This function adds a finalizer to the given 'ForeignPtr'.
--- The finalizer will run after the last reference to the foreign object
--- is dropped, but /before/ all previously registered finalizers for the
--- same object.
-addForeignPtrFinalizer = GHC.ForeignPtr.addForeignPtrConcFinalizer
-#endif
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.ForeignPtr
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- The 'ForeignPtr' type and operations. This module is part of the
--- Foreign Function Interface (FFI) and will usually be imported via
--- the "Foreign" module.
---
------------------------------------------------------------------------------
-
-module Foreign.ForeignPtr
- (
- -- * Finalised data pointers
- ForeignPtr
- , FinalizerPtr
-#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__)
- , FinalizerEnvPtr
-#endif
- -- ** Basic operations
- , newForeignPtr
- , newForeignPtr_
- , addForeignPtrFinalizer
-#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__)
- , newForeignPtrEnv
- , addForeignPtrFinalizerEnv
-#endif
- , withForeignPtr
-
-#ifdef __GLASGOW_HASKELL__
- , finalizeForeignPtr
-#endif
-
- -- ** Low-level operations
- , unsafeForeignPtrToPtr
- , touchForeignPtr
- , castForeignPtr
-
- -- ** Allocating managed memory
- , mallocForeignPtr
- , mallocForeignPtrBytes
- , mallocForeignPtrArray
- , mallocForeignPtrArray0
- )
- where
-
-import Foreign.Ptr
-
-#ifdef __NHC__
-import NHC.FFI
- ( ForeignPtr
- , FinalizerPtr
- , newForeignPtr
- , newForeignPtr_
- , addForeignPtrFinalizer
- , withForeignPtr
- , unsafeForeignPtrToPtr
- , touchForeignPtr
- , castForeignPtr
- , Storable(sizeOf)
- , malloc, mallocBytes, finalizerFree
- )
-#endif
-
-#ifdef __HUGS__
-import Hugs.ForeignPtr
-#endif
-
-#ifndef __NHC__
-import Foreign.Storable ( Storable(sizeOf) )
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.IOBase
-import GHC.Num
-import GHC.Err ( undefined )
-import GHC.ForeignPtr
-#endif
-
-#if !defined(__NHC__) && !defined(__GLASGOW_HASKELL__)
-import Foreign.Marshal.Alloc ( malloc, mallocBytes, finalizerFree )
-
-instance Eq (ForeignPtr a) where
- p == q = unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q
-
-instance Ord (ForeignPtr a) where
- compare p q = compare (unsafeForeignPtrToPtr p) (unsafeForeignPtrToPtr q)
-
-instance Show (ForeignPtr a) where
- showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f)
-#endif
-
-
-#ifndef __NHC__
-newForeignPtr :: FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
--- ^Turns a plain memory reference into a foreign pointer, and
--- associates a finaliser with the reference. The finaliser will be executed
--- after the last reference to the foreign object is dropped. Note that there
--- is no guarantee on how soon the finaliser is executed after the last
--- reference was dropped; this depends on the details of the Haskell storage
--- manager. Indeed, there is no guarantee that the finalizer is executed at
--- all; a program may exit with finalizers outstanding. (This is true
--- of GHC, other implementations may give stronger guarantees).
-newForeignPtr finalizer p
- = do fObj <- newForeignPtr_ p
- addForeignPtrFinalizer finalizer fObj
- return fObj
-
-withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
--- ^This is a way to look at the pointer living inside a
--- foreign object. This function takes a function which is
--- applied to that pointer. The resulting 'IO' action is then
--- executed. The foreign object is kept alive at least during
--- the whole action, even if it is not used directly
--- inside. Note that it is not safe to return the pointer from
--- the action and use it after the action completes. All uses
--- of the pointer should be inside the
--- 'withForeignPtr' bracket. The reason for
--- this unsafeness is the same as for
--- 'unsafeForeignPtrToPtr' below: the finalizer
--- may run earlier than expected, because the compiler can only
--- track usage of the 'ForeignPtr' object, not
--- a 'Ptr' object made from it.
---
--- This function is normally used for marshalling data to
--- or from the object pointed to by the
--- 'ForeignPtr', using the operations from the
--- 'Storable' class.
-withForeignPtr fo io
- = do r <- io (unsafeForeignPtrToPtr fo)
- touchForeignPtr fo
- return r
-#endif /* ! __NHC__ */
-
-#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__)
--- | This variant of 'newForeignPtr' adds a finalizer that expects an
--- environment in addition to the finalized pointer. The environment
--- that will be passed to the finalizer is fixed by the second argument to
--- 'newForeignPtrEnv'.
-newForeignPtrEnv ::
- FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO (ForeignPtr a)
-newForeignPtrEnv finalizer env p
- = do fObj <- newForeignPtr_ p
- addForeignPtrFinalizerEnv finalizer env fObj
- return fObj
-#endif /* __HUGS__ */
-
-#ifdef __GLASGOW_HASKELL__
-type FinalizerEnvPtr env a = FunPtr (Ptr env -> Ptr a -> IO ())
-
--- | like 'addForeignPtrFinalizerEnv' but allows the finalizer to be
--- passed an additional environment parameter to be passed to the
--- finalizer. The environment passed to the finalizer is fixed by the
--- second argument to 'addForeignPtrFinalizerEnv'
-addForeignPtrFinalizerEnv ::
- FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO ()
-addForeignPtrFinalizerEnv finalizer env fptr =
- addForeignPtrConcFinalizer fptr
- (mkFinalizerEnv finalizer env (unsafeForeignPtrToPtr fptr))
-
-foreign import ccall "dynamic"
- mkFinalizerEnv :: FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO ()
-#endif
-
-
-#ifndef __GLASGOW_HASKELL__
-mallocForeignPtr :: Storable a => IO (ForeignPtr a)
-mallocForeignPtr = do
- r <- malloc
- newForeignPtr finalizerFree r
-
-mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
-mallocForeignPtrBytes n = do
- r <- mallocBytes n
- newForeignPtr finalizerFree r
-#endif /* !__GLASGOW_HASKELL__ */
-
--- | This function is similar to 'Foreign.Marshal.Array.mallocArray',
--- but yields a memory area that has a finalizer attached that releases
--- the memory area. As with 'mallocForeignPtr', it is not guaranteed that
--- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'.
-mallocForeignPtrArray :: Storable a => Int -> IO (ForeignPtr a)
-mallocForeignPtrArray = doMalloc undefined
- where
- doMalloc :: Storable b => b -> Int -> IO (ForeignPtr b)
- doMalloc dummy size = mallocForeignPtrBytes (size * sizeOf dummy)
-
--- | This function is similar to 'Foreign.Marshal.Array.mallocArray0',
--- but yields a memory area that has a finalizer attached that releases
--- the memory area. As with 'mallocForeignPtr', it is not guaranteed that
--- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'.
-mallocForeignPtrArray0 :: Storable a => Int -> IO (ForeignPtr a)
-mallocForeignPtrArray0 size = mallocForeignPtrArray (size + 1)
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.Marshal
--- Copyright : (c) The FFI task force 2003
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Marshalling support
---
------------------------------------------------------------------------------
-
-module Foreign.Marshal
- ( module Foreign.Marshal.Alloc
- , module Foreign.Marshal.Array
- , module Foreign.Marshal.Error
- , module Foreign.Marshal.Pool
- , module Foreign.Marshal.Utils
- ) where
-
-import Foreign.Marshal.Alloc
-import Foreign.Marshal.Array
-import Foreign.Marshal.Error
-import Foreign.Marshal.Pool
-import Foreign.Marshal.Utils
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.Marshal.Alloc
--- Copyright : (c) The FFI task force 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Marshalling support: basic routines for memory allocation
---
------------------------------------------------------------------------------
-
-module Foreign.Marshal.Alloc (
- -- * Memory allocation
- -- ** Local allocation
- alloca, -- :: Storable a => (Ptr a -> IO b) -> IO b
- allocaBytes, -- :: Int -> (Ptr a -> IO b) -> IO b
-
- -- ** Dynamic allocation
- malloc, -- :: Storable a => IO (Ptr a)
- mallocBytes, -- :: Int -> IO (Ptr a)
-
- realloc, -- :: Storable b => Ptr a -> IO (Ptr b)
- reallocBytes, -- :: Ptr a -> Int -> IO (Ptr a)
-
- free, -- :: Ptr a -> IO ()
- finalizerFree -- :: FinalizerPtr a
-) where
-
-import Data.Maybe
-import Foreign.Ptr ( Ptr, nullPtr, FunPtr )
-import Foreign.C.Types ( CSize )
-import Foreign.Storable ( Storable(sizeOf) )
-
-#ifdef __GLASGOW_HASKELL__
-import Foreign.ForeignPtr ( FinalizerPtr )
-import GHC.IOBase
-import GHC.Real
-import GHC.Ptr
-import GHC.Err
-import GHC.Base
-import GHC.Num
-#elif defined(__NHC__)
-import NHC.FFI ( FinalizerPtr, CInt(..) )
-import IO ( bracket )
-#else
-import Control.Exception ( bracket )
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude ( IOException(IOError),
- IOErrorType(ResourceExhausted) )
-import Hugs.ForeignPtr ( FinalizerPtr )
-#endif
-
-
--- exported functions
--- ------------------
-
--- |Allocate a block of memory that is sufficient to hold values of type
--- @a@. The size of the area allocated is determined by the 'sizeOf'
--- method from the instance of 'Storable' for the appropriate type.
---
--- The memory may be deallocated using 'free' or 'finalizerFree' when
--- no longer required.
---
-malloc :: Storable a => IO (Ptr a)
-malloc = doMalloc undefined
- where
- doMalloc :: Storable b => b -> IO (Ptr b)
- doMalloc dummy = mallocBytes (sizeOf dummy)
-
--- |Allocate a block of memory of the given number of bytes.
--- The block of memory is sufficiently aligned for any of the basic
--- foreign types that fits into a memory block of the allocated size.
---
--- The memory may be deallocated using 'free' or 'finalizerFree' when
--- no longer required.
---
-mallocBytes :: Int -> IO (Ptr a)
-mallocBytes size = failWhenNULL "malloc" (_malloc (fromIntegral size))
-
--- |@'alloca' f@ executes the computation @f@, passing as argument
--- a pointer to a temporarily allocated block of memory sufficient to
--- hold values of type @a@.
---
--- The memory is freed when @f@ terminates (either normally or via an
--- exception), so the pointer passed to @f@ must /not/ be used after this.
---
-alloca :: Storable a => (Ptr a -> IO b) -> IO b
-alloca = doAlloca undefined
- where
- doAlloca :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b'
- doAlloca dummy = allocaBytes (sizeOf dummy)
-
--- |@'allocaBytes' n f@ executes the computation @f@, passing as argument
--- a pointer to a temporarily allocated block of memory of @n@ bytes.
--- The block of memory is sufficiently aligned for any of the basic
--- foreign types that fits into a memory block of the allocated size.
---
--- The memory is freed when @f@ terminates (either normally or via an
--- exception), so the pointer passed to @f@ must /not/ be used after this.
---
-#ifdef __GLASGOW_HASKELL__
-allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
-allocaBytes (I# size) action = IO $ \ s ->
- case newPinnedByteArray# size s of { (# s, mbarr# #) ->
- case unsafeFreezeByteArray# mbarr# s of { (# s, barr# #) ->
- let addr = Ptr (byteArrayContents# barr#) in
- case action addr of { IO action ->
- case action s of { (# s, r #) ->
- case touch# barr# s of { s ->
- (# s, r #)
- }}}}}
-#else
-allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
-allocaBytes size = bracket (mallocBytes size) free
-#endif
-
--- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
--- to the size needed to store values of type @b@. The returned pointer
--- may refer to an entirely different memory area, but will be suitably
--- aligned to hold values of type @b@. The contents of the referenced
--- memory area will be the same as of the original pointer up to the
--- minimum of the original size and the size of values of type @b@.
---
--- If the argument to 'realloc' is 'nullPtr', 'realloc' behaves like
--- 'malloc'.
---
-realloc :: Storable b => Ptr a -> IO (Ptr b)
-realloc = doRealloc undefined
- where
- doRealloc :: Storable b' => b' -> Ptr a' -> IO (Ptr b')
- doRealloc dummy ptr = let
- size = fromIntegral (sizeOf dummy)
- in
- failWhenNULL "realloc" (_realloc ptr size)
-
--- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
--- to the given size. The returned pointer may refer to an entirely
--- different memory area, but will be sufficiently aligned for any of the
--- basic foreign types that fits into a memory block of the given size.
--- The contents of the referenced memory area will be the same as of
--- the original pointer up to the minimum of the original size and the
--- given size.
---
--- If the pointer argument to 'reallocBytes' is 'nullPtr', 'reallocBytes'
--- behaves like 'malloc'. If the requested size is 0, 'reallocBytes'
--- behaves like 'free'.
---
-reallocBytes :: Ptr a -> Int -> IO (Ptr a)
-reallocBytes ptr 0 = do free ptr; return nullPtr
-reallocBytes ptr size =
- failWhenNULL "realloc" (_realloc ptr (fromIntegral size))
-
--- |Free a block of memory that was allocated with 'malloc',
--- 'mallocBytes', 'realloc', 'reallocBytes', 'Foreign.Marshal.Utils.new'
--- or any of the @new@/X/ functions in "Foreign.Marshal.Array" or
--- "Foreign.C.String".
---
-free :: Ptr a -> IO ()
-free = _free
-
-
--- auxilliary routines
--- -------------------
-
--- asserts that the pointer returned from the action in the second argument is
--- non-null
---
-failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)
-failWhenNULL name f = do
- addr <- f
- if addr == nullPtr
-#if __GLASGOW_HASKELL__ || __HUGS__
- then ioError (IOError Nothing ResourceExhausted name
- "out of memory" Nothing)
-#else
- then ioError (userError (name++": out of memory"))
-#endif
- else return addr
-
--- basic C routines needed for memory allocation
---
-foreign import ccall unsafe "stdlib.h malloc" _malloc :: CSize -> IO (Ptr a)
-foreign import ccall unsafe "stdlib.h realloc" _realloc :: Ptr a -> CSize -> IO (Ptr b)
-foreign import ccall unsafe "stdlib.h free" _free :: Ptr a -> IO ()
-
--- | A pointer to a foreign function equivalent to 'free', which may be
--- used as a finalizer (cf 'Foreign.ForeignPtr.ForeignPtr') for storage
--- allocated with 'malloc', 'mallocBytes', 'realloc' or 'reallocBytes'.
-foreign import ccall unsafe "stdlib.h &free" finalizerFree :: FinalizerPtr a
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.Marshal.Array
--- Copyright : (c) The FFI task force 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Marshalling support: routines allocating, storing, and retrieving Haskell
--- lists that are represented as arrays in the foreign language
---
------------------------------------------------------------------------------
-
-module Foreign.Marshal.Array (
- -- * Marshalling arrays
-
- -- ** Allocation
- --
- mallocArray, -- :: Storable a => Int -> IO (Ptr a)
- mallocArray0, -- :: Storable a => Int -> IO (Ptr a)
-
- allocaArray, -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b
- allocaArray0, -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b
-
- reallocArray, -- :: Storable a => Ptr a -> Int -> IO (Ptr a)
- reallocArray0, -- :: Storable a => Ptr a -> Int -> IO (Ptr a)
-
- -- ** Marshalling
- --
- peekArray, -- :: Storable a => Int -> Ptr a -> IO [a]
- peekArray0, -- :: (Storable a, Eq a) => a -> Ptr a -> IO [a]
-
- pokeArray, -- :: Storable a => Ptr a -> [a] -> IO ()
- pokeArray0, -- :: Storable a => a -> Ptr a -> [a] -> IO ()
-
- -- ** Combined allocation and marshalling
- --
- newArray, -- :: Storable a => [a] -> IO (Ptr a)
- newArray0, -- :: Storable a => a -> [a] -> IO (Ptr a)
-
- withArray, -- :: Storable a => [a] -> (Ptr a -> IO b) -> IO b
- withArray0, -- :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
-
- withArrayLen, -- :: Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
- withArrayLen0, -- :: Storable a => a -> [a] -> (Int -> Ptr a -> IO b) -> IO b
-
- -- ** Copying
-
- -- | (argument order: destination, source)
- copyArray, -- :: Storable a => Ptr a -> Ptr a -> Int -> IO ()
- moveArray, -- :: Storable a => Ptr a -> Ptr a -> Int -> IO ()
-
- -- ** Finding the length
- --
- lengthArray0, -- :: (Storable a, Eq a) => a -> Ptr a -> IO Int
-
- -- ** Indexing
- --
- advancePtr, -- :: Storable a => Ptr a -> Int -> Ptr a
-) where
-
-import Control.Monad
-import Foreign.Ptr (Ptr, plusPtr)
-import Foreign.Storable (Storable(sizeOf,peekElemOff,pokeElemOff))
-import Foreign.Marshal.Alloc (mallocBytes, allocaBytes, reallocBytes)
-import Foreign.Marshal.Utils (copyBytes, moveBytes)
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase
-import GHC.Num
-import GHC.List
-import GHC.Err
-import GHC.Base
-#endif
-
--- allocation
--- ----------
-
--- |Allocate storage for the given number of elements of a storable type
--- (like 'Foreign.Marshal.Alloc.malloc', but for multiple elements).
---
-mallocArray :: Storable a => Int -> IO (Ptr a)
-mallocArray = doMalloc undefined
- where
- doMalloc :: Storable a' => a' -> Int -> IO (Ptr a')
- doMalloc dummy size = mallocBytes (size * sizeOf dummy)
-
--- |Like 'mallocArray', but add an extra position to hold a special
--- termination element.
---
-mallocArray0 :: Storable a => Int -> IO (Ptr a)
-mallocArray0 size = mallocArray (size + 1)
-
--- |Temporarily allocate space for the given number of elements
--- (like 'Foreign.Marshal.Alloc.alloca', but for multiple elements).
---
-allocaArray :: Storable a => Int -> (Ptr a -> IO b) -> IO b
-allocaArray = doAlloca undefined
- where
- doAlloca :: Storable a' => a' -> Int -> (Ptr a' -> IO b') -> IO b'
- doAlloca dummy size = allocaBytes (size * sizeOf dummy)
-
--- |Like 'allocaArray', but add an extra position to hold a special
--- termination element.
---
-allocaArray0 :: Storable a => Int -> (Ptr a -> IO b) -> IO b
-allocaArray0 size = allocaArray (size + 1)
-
--- |Adjust the size of an array
---
-reallocArray :: Storable a => Ptr a -> Int -> IO (Ptr a)
-reallocArray = doRealloc undefined
- where
- doRealloc :: Storable a' => a' -> Ptr a' -> Int -> IO (Ptr a')
- doRealloc dummy ptr size = reallocBytes ptr (size * sizeOf dummy)
-
--- |Adjust the size of an array including an extra position for the end marker.
---
-reallocArray0 :: Storable a => Ptr a -> Int -> IO (Ptr a)
-reallocArray0 ptr size = reallocArray ptr (size + 1)
-
-
--- marshalling
--- -----------
-
--- |Convert an array of given length into a Haskell list. This version
--- traverses the array backwards using an accumulating parameter,
--- which uses constant stack space. The previous version using mapM
--- needed linear stack space.
---
-peekArray :: Storable a => Int -> Ptr a -> IO [a]
-peekArray size ptr | size <= 0 = return []
- | otherwise = f (size-1) []
- where
- f 0 acc = do e <- peekElemOff ptr 0; return (e:acc)
- f n acc = do e <- peekElemOff ptr n; f (n-1) (e:acc)
-
--- |Convert an array terminated by the given end marker into a Haskell list
---
-peekArray0 :: (Storable a, Eq a) => a -> Ptr a -> IO [a]
-peekArray0 marker ptr = do
- size <- lengthArray0 marker ptr
- peekArray size ptr
-
--- |Write the list elements consecutive into memory
---
-pokeArray :: Storable a => Ptr a -> [a] -> IO ()
-#ifndef __GLASGOW_HASKELL__
-pokeArray ptr vals = zipWithM_ (pokeElemOff ptr) [0..] vals
-#else
-pokeArray ptr vals = go vals 0#
- where go [] n# = return ()
- go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)
-#endif
-
--- |Write the list elements consecutive into memory and terminate them with the
--- given marker element
---
-pokeArray0 :: Storable a => a -> Ptr a -> [a] -> IO ()
-#ifndef __GLASGOW_HASKELL__
-pokeArray0 marker ptr vals = do
- pokeArray ptr vals
- pokeElemOff ptr (length vals) marker
-#else
-pokeArray0 marker ptr vals = go vals 0#
- where go [] n# = pokeElemOff ptr (I# n#) marker
- go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)
-#endif
-
-
--- combined allocation and marshalling
--- -----------------------------------
-
--- |Write a list of storable elements into a newly allocated, consecutive
--- sequence of storable values
--- (like 'Foreign.Marshal.Utils.new', but for multiple elements).
---
-newArray :: Storable a => [a] -> IO (Ptr a)
-newArray vals = do
- ptr <- mallocArray (length vals)
- pokeArray ptr vals
- return ptr
-
--- |Write a list of storable elements into a newly allocated, consecutive
--- sequence of storable values, where the end is fixed by the given end marker
---
-newArray0 :: Storable a => a -> [a] -> IO (Ptr a)
-newArray0 marker vals = do
- ptr <- mallocArray0 (length vals)
- pokeArray0 marker ptr vals
- return ptr
-
--- |Temporarily store a list of storable values in memory
--- (like 'Foreign.Marshal.Utils.with', but for multiple elements).
---
-withArray :: Storable a => [a] -> (Ptr a -> IO b) -> IO b
-withArray vals = withArrayLen vals . const
-
--- |Like 'withArray', but the action gets the number of values
--- as an additional parameter
---
-withArrayLen :: Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
-withArrayLen vals f =
- allocaArray len $ \ptr -> do
- pokeArray ptr vals
- res <- f len ptr
- return res
- where
- len = length vals
-
--- |Like 'withArray', but a terminator indicates where the array ends
---
-withArray0 :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
-withArray0 marker vals = withArrayLen0 marker vals . const
-
--- |Like 'withArrayLen', but a terminator indicates where the array ends
---
-withArrayLen0 :: Storable a => a -> [a] -> (Int -> Ptr a -> IO b) -> IO b
-withArrayLen0 marker vals f =
- allocaArray0 len $ \ptr -> do
- pokeArray0 marker ptr vals
- res <- f len ptr
- return res
- where
- len = length vals
-
-
--- copying (argument order: destination, source)
--- -------
-
--- |Copy the given number of elements from the second array (source) into the
--- first array (destination); the copied areas may /not/ overlap
---
-copyArray :: Storable a => Ptr a -> Ptr a -> Int -> IO ()
-copyArray = doCopy undefined
- where
- doCopy :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO ()
- doCopy dummy dest src size = copyBytes dest src (size * sizeOf dummy)
-
--- |Copy the given number of elements from the second array (source) into the
--- first array (destination); the copied areas /may/ overlap
---
-moveArray :: Storable a => Ptr a -> Ptr a -> Int -> IO ()
-moveArray = doMove undefined
- where
- doMove :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO ()
- doMove dummy dest src size = moveBytes dest src (size * sizeOf dummy)
-
-
--- finding the length
--- ------------------
-
--- |Return the number of elements in an array, excluding the terminator
---
-lengthArray0 :: (Storable a, Eq a) => a -> Ptr a -> IO Int
-lengthArray0 marker ptr = loop 0
- where
- loop i = do
- val <- peekElemOff ptr i
- if val == marker then return i else loop (i+1)
-
-
--- indexing
--- --------
-
--- |Advance a pointer into an array by the given number of elements
---
-advancePtr :: Storable a => Ptr a -> Int -> Ptr a
-advancePtr = doAdvance undefined
- where
- doAdvance :: Storable a' => a' -> Ptr a' -> Int -> Ptr a'
- doAdvance dummy ptr i = ptr `plusPtr` (i * sizeOf dummy)
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.Marshal.Error
--- Copyright : (c) The FFI task force 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Routines for testing return values and raising a 'userError' exception
--- in case of values indicating an error state.
---
------------------------------------------------------------------------------
-
-module Foreign.Marshal.Error (
- throwIf, -- :: (a -> Bool) -> (a -> String) -> IO a -> IO a
- throwIf_, -- :: (a -> Bool) -> (a -> String) -> IO a -> IO ()
- throwIfNeg, -- :: (Ord a, Num a)
- -- => (a -> String) -> IO a -> IO a
- throwIfNeg_, -- :: (Ord a, Num a)
- -- => (a -> String) -> IO a -> IO ()
- throwIfNull, -- :: String -> IO (Ptr a) -> IO (Ptr a)
-
- -- Discard return value
- --
- void -- IO a -> IO ()
-) where
-
-import Foreign.Ptr
-
-#ifdef __GLASGOW_HASKELL__
-#ifdef __HADDOCK__
-import Data.Bool
-import System.IO.Error
-#endif
-import GHC.Base
-import GHC.Num
-import GHC.IOBase
-#endif
-
--- exported functions
--- ------------------
-
--- |Execute an 'IO' action, throwing a 'userError' if the predicate yields
--- 'True' when applied to the result returned by the 'IO' action.
--- If no exception is raised, return the result of the computation.
---
-throwIf :: (a -> Bool) -- ^ error condition on the result of the 'IO' action
- -> (a -> String) -- ^ computes an error message from erroneous results
- -- of the 'IO' action
- -> IO a -- ^ the 'IO' action to be executed
- -> IO a
-throwIf pred msgfct act =
- do
- res <- act
- (if pred res then ioError . userError . msgfct else return) res
-
--- |Like 'throwIf', but discarding the result
---
-throwIf_ :: (a -> Bool) -> (a -> String) -> IO a -> IO ()
-throwIf_ pred msgfct act = void $ throwIf pred msgfct act
-
--- |Guards against negative result values
---
-throwIfNeg :: (Ord a, Num a) => (a -> String) -> IO a -> IO a
-throwIfNeg = throwIf (< 0)
-
--- |Like 'throwIfNeg', but discarding the result
---
-throwIfNeg_ :: (Ord a, Num a) => (a -> String) -> IO a -> IO ()
-throwIfNeg_ = throwIf_ (< 0)
-
--- |Guards against null pointers
---
-throwIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
-throwIfNull = throwIf (== nullPtr) . const
-
--- |Discard the return value of an 'IO' action
---
-void :: IO a -> IO ()
-void act = act >> return ()
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
---------------------------------------------------------------------------------
--- |
--- Module : Foreign.Marshal.Pool
--- Copyright : (c) Sven Panne 2002-2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : sven.panne@aedion.de
--- Stability : provisional
--- Portability : portable
---
--- This module contains support for pooled memory management. Under this scheme,
--- (re-)allocations belong to a given pool, and everything in a pool is
--- deallocated when the pool itself is deallocated. This is useful when
--- 'Foreign.Marshal.Alloc.alloca' with its implicit allocation and deallocation
--- is not flexible enough, but explicit uses of 'Foreign.Marshal.Alloc.malloc'
--- and 'free' are too awkward.
---
---------------------------------------------------------------------------------
-
-module Foreign.Marshal.Pool (
- -- * Pool management
- Pool,
- newPool, -- :: IO Pool
- freePool, -- :: Pool -> IO ()
- withPool, -- :: (Pool -> IO b) -> IO b
-
- -- * (Re-)Allocation within a pool
- pooledMalloc, -- :: Storable a => Pool -> IO (Ptr a)
- pooledMallocBytes, -- :: Pool -> Int -> IO (Ptr a)
-
- pooledRealloc, -- :: Storable a => Pool -> Ptr a -> IO (Ptr a)
- pooledReallocBytes, -- :: Pool -> Ptr a -> Int -> IO (Ptr a)
-
- pooledMallocArray, -- :: Storable a => Pool -> Int -> IO (Ptr a)
- pooledMallocArray0, -- :: Storable a => Pool -> Int -> IO (Ptr a)
-
- pooledReallocArray, -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
- pooledReallocArray0, -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
-
- -- * Combined allocation and marshalling
- pooledNew, -- :: Storable a => Pool -> a -> IO (Ptr a)
- pooledNewArray, -- :: Storable a => Pool -> [a] -> IO (Ptr a)
- pooledNewArray0 -- :: Storable a => Pool -> a -> [a] -> IO (Ptr a)
-) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base ( Int, Monad(..), (.), not )
-import GHC.Err ( undefined )
-import GHC.Exception ( block, unblock, throw, catchException )
-import GHC.IOBase ( IO, IORef, newIORef, readIORef, writeIORef, )
-import GHC.List ( elem, length )
-import GHC.Num ( Num(..) )
-#else
-import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
-#if defined(__NHC__)
-import IO ( bracket )
-#else
-import Control.Exception ( bracket )
-#endif
-#endif
-
-import Control.Monad ( liftM )
-import Data.List ( delete )
-import Foreign.Marshal.Alloc ( mallocBytes, reallocBytes, free )
-import Foreign.Marshal.Array ( pokeArray, pokeArray0 )
-import Foreign.Marshal.Error ( throwIf )
-import Foreign.Ptr ( Ptr, castPtr )
-import Foreign.Storable ( Storable(sizeOf, poke) )
-
---------------------------------------------------------------------------------
-
--- To avoid non-H98 stuff like existentially quantified data constructors, we
--- simply use pointers to () below. Not very nice, but...
-
--- | A memory pool.
-
-newtype Pool = Pool (IORef [Ptr ()])
-
--- | Allocate a fresh memory pool.
-
-newPool :: IO Pool
-newPool = liftM Pool (newIORef [])
-
--- | Deallocate a memory pool and everything which has been allocated in the
--- pool itself.
-
-freePool :: Pool -> IO ()
-freePool (Pool pool) = readIORef pool >>= freeAll
- where freeAll [] = return ()
- freeAll (p:ps) = free p >> freeAll ps
-
--- | Execute an action with a fresh memory pool, which gets automatically
--- deallocated (including its contents) after the action has finished.
-
-withPool :: (Pool -> IO b) -> IO b
-#ifdef __GLASGOW_HASKELL__
-withPool act = -- ATTENTION: cut-n-paste from Control.Exception below!
- block (do
- pool <- newPool
- val <- catchException
- (unblock (act pool))
- (\e -> do freePool pool; throw e)
- freePool pool
- return val)
-#else
-withPool = bracket newPool freePool
-#endif
-
---------------------------------------------------------------------------------
-
--- | Allocate space for storable type in the given pool. The size of the area
--- allocated is determined by the 'sizeOf' method from the instance of
--- 'Storable' for the appropriate type.
-
-pooledMalloc :: Storable a => Pool -> IO (Ptr a)
-pooledMalloc = pm undefined
- where
- pm :: Storable a' => a' -> Pool -> IO (Ptr a')
- pm dummy pool = pooledMallocBytes pool (sizeOf dummy)
-
--- | Allocate the given number of bytes of storage in the pool.
-
-pooledMallocBytes :: Pool -> Int -> IO (Ptr a)
-pooledMallocBytes (Pool pool) size = do
- ptr <- mallocBytes size
- ptrs <- readIORef pool
- writeIORef pool (ptr:ptrs)
- return (castPtr ptr)
-
--- | Adjust the storage area for an element in the pool to the given size of
--- the required type.
-
-pooledRealloc :: Storable a => Pool -> Ptr a -> IO (Ptr a)
-pooledRealloc = pr undefined
- where
- pr :: Storable a' => a' -> Pool -> Ptr a' -> IO (Ptr a')
- pr dummy pool ptr = pooledReallocBytes pool ptr (sizeOf dummy)
-
--- | Adjust the storage area for an element in the pool to the given size.
-
-pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a)
-pooledReallocBytes (Pool pool) ptr size = do
- let cPtr = castPtr ptr
- throwIf (not . (cPtr `elem`)) (\_ -> "pointer not in pool") (readIORef pool)
- newPtr <- reallocBytes cPtr size
- ptrs <- readIORef pool
- writeIORef pool (newPtr : delete cPtr ptrs)
- return (castPtr newPtr)
-
--- | Allocate storage for the given number of elements of a storable type in the
--- pool.
-
-pooledMallocArray :: Storable a => Pool -> Int -> IO (Ptr a)
-pooledMallocArray = pma undefined
- where
- pma :: Storable a' => a' -> Pool -> Int -> IO (Ptr a')
- pma dummy pool size = pooledMallocBytes pool (size * sizeOf dummy)
-
--- | Allocate storage for the given number of elements of a storable type in the
--- pool, but leave room for an extra element to signal the end of the array.
-
-pooledMallocArray0 :: Storable a => Pool -> Int -> IO (Ptr a)
-pooledMallocArray0 pool size =
- pooledMallocArray pool (size + 1)
-
--- | Adjust the size of an array in the given pool.
-
-pooledReallocArray :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
-pooledReallocArray = pra undefined
- where
- pra :: Storable a' => a' -> Pool -> Ptr a' -> Int -> IO (Ptr a')
- pra dummy pool ptr size = pooledReallocBytes pool ptr (size * sizeOf dummy)
-
--- | Adjust the size of an array with an end marker in the given pool.
-
-pooledReallocArray0 :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
-pooledReallocArray0 pool ptr size =
- pooledReallocArray pool ptr (size + 1)
-
---------------------------------------------------------------------------------
-
--- | Allocate storage for a value in the given pool and marshal the value into
--- this storage.
-
-pooledNew :: Storable a => Pool -> a -> IO (Ptr a)
-pooledNew pool val = do
- ptr <- pooledMalloc pool
- poke ptr val
- return ptr
-
--- | Allocate consecutive storage for a list of values in the given pool and
--- marshal these values into it.
-
-pooledNewArray :: Storable a => Pool -> [a] -> IO (Ptr a)
-pooledNewArray pool vals = do
- ptr <- pooledMallocArray pool (length vals)
- pokeArray ptr vals
- return ptr
-
--- | Allocate consecutive storage for a list of values in the given pool and
--- marshal these values into it, terminating the end with the given marker.
-
-pooledNewArray0 :: Storable a => Pool -> a -> [a] -> IO (Ptr a)
-pooledNewArray0 pool marker vals = do
- ptr <- pooledMallocArray0 pool (length vals)
- pokeArray0 marker ptr vals
- return ptr
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.Marshal.Utils
--- Copyright : (c) The FFI task force 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Utilities for primitive marshaling
---
------------------------------------------------------------------------------
-
-module Foreign.Marshal.Utils (
- -- * General marshalling utilities
-
- -- ** Combined allocation and marshalling
- --
- with, -- :: Storable a => a -> (Ptr a -> IO b) -> IO b
- new, -- :: Storable a => a -> IO (Ptr a)
-
- -- ** Marshalling of Boolean values (non-zero corresponds to 'True')
- --
- fromBool, -- :: Num a => Bool -> a
- toBool, -- :: Num a => a -> Bool
-
- -- ** Marshalling of Maybe values
- --
- maybeNew, -- :: ( a -> IO (Ptr a))
- -- -> (Maybe a -> IO (Ptr a))
- maybeWith, -- :: ( a -> (Ptr b -> IO c) -> IO c)
- -- -> (Maybe a -> (Ptr b -> IO c) -> IO c)
- maybePeek, -- :: (Ptr a -> IO b )
- -- -> (Ptr a -> IO (Maybe b))
-
- -- ** Marshalling lists of storable objects
- --
- withMany, -- :: (a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res
-
- -- ** Haskellish interface to memcpy and memmove
- -- | (argument order: destination, source)
- --
- copyBytes, -- :: Ptr a -> Ptr a -> Int -> IO ()
- moveBytes, -- :: Ptr a -> Ptr a -> Int -> IO ()
-) where
-
-import Data.Maybe
-import Foreign.Ptr ( Ptr, nullPtr )
-import Foreign.Storable ( Storable(poke) )
-import Foreign.C.Types ( CSize )
-import Foreign.Marshal.Alloc ( malloc, alloca )
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase
-import GHC.Real ( fromIntegral )
-import GHC.Num
-import GHC.Base
-#endif
-
-#ifdef __NHC__
-import Foreign.C.Types ( CInt(..) )
-#endif
-
--- combined allocation and marshalling
--- -----------------------------------
-
--- |Allocate a block of memory and marshal a value into it
--- (the combination of 'malloc' and 'poke').
--- The size of the area allocated is determined by the 'Foreign.Storable.sizeOf'
--- method from the instance of 'Storable' for the appropriate type.
---
--- The memory may be deallocated using 'Foreign.Marshal.Alloc.free' or
--- 'Foreign.Marshal.Alloc.finalizerFree' when no longer required.
---
-new :: Storable a => a -> IO (Ptr a)
-new val =
- do
- ptr <- malloc
- poke ptr val
- return ptr
-
--- |@'with' val f@ executes the computation @f@, passing as argument
--- a pointer to a temporarily allocated block of memory into which
--- @val@ has been marshalled (the combination of 'alloca' and 'poke').
---
--- The memory is freed when @f@ terminates (either normally or via an
--- exception), so the pointer passed to @f@ must /not/ be used after this.
---
-with :: Storable a => a -> (Ptr a -> IO b) -> IO b
-with val f =
- alloca $ \ptr -> do
- poke ptr val
- res <- f ptr
- return res
-
-
--- marshalling of Boolean values (non-zero corresponds to 'True')
--- -----------------------------
-
--- |Convert a Haskell 'Bool' to its numeric representation
---
-fromBool :: Num a => Bool -> a
-fromBool False = 0
-fromBool True = 1
-
--- |Convert a Boolean in numeric representation to a Haskell value
---
-toBool :: Num a => a -> Bool
-toBool = (/= 0)
-
-
--- marshalling of Maybe values
--- ---------------------------
-
--- |Allocate storage and marshall a storable value wrapped into a 'Maybe'
---
--- * the 'nullPtr' is used to represent 'Nothing'
---
-maybeNew :: ( a -> IO (Ptr a))
- -> (Maybe a -> IO (Ptr a))
-maybeNew = maybe (return nullPtr)
-
--- |Converts a @withXXX@ combinator into one marshalling a value wrapped
--- into a 'Maybe', using 'nullPtr' to represent 'Nothing'.
---
-maybeWith :: ( a -> (Ptr b -> IO c) -> IO c)
- -> (Maybe a -> (Ptr b -> IO c) -> IO c)
-maybeWith = maybe ($ nullPtr)
-
--- |Convert a peek combinator into a one returning 'Nothing' if applied to a
--- 'nullPtr'
---
-maybePeek :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
-maybePeek peek ptr | ptr == nullPtr = return Nothing
- | otherwise = do a <- peek ptr; return (Just a)
-
-
--- marshalling lists of storable objects
--- -------------------------------------
-
--- |Replicates a @withXXX@ combinator over a list of objects, yielding a list of
--- marshalled objects
---
-withMany :: (a -> (b -> res) -> res) -- withXXX combinator for one object
- -> [a] -- storable objects
- -> ([b] -> res) -- action on list of marshalled obj.s
- -> res
-withMany _ [] f = f []
-withMany withFoo (x:xs) f = withFoo x $ \x' ->
- withMany withFoo xs (\xs' -> f (x':xs'))
-
-
--- Haskellish interface to memcpy and memmove
--- ------------------------------------------
-
--- |Copies the given number of bytes from the second area (source) into the
--- first (destination); the copied areas may /not/ overlap
---
-copyBytes :: Ptr a -> Ptr a -> Int -> IO ()
-copyBytes dest src size = do memcpy dest src (fromIntegral size)
- return ()
-
--- |Copies the given number of bytes from the second area (source) into the
--- first (destination); the copied areas /may/ overlap
---
-moveBytes :: Ptr a -> Ptr a -> Int -> IO ()
-moveBytes dest src size = do memmove dest src (fromIntegral size)
- return ()
-
-
--- auxilliary routines
--- -------------------
-
--- |Basic C routines needed for memory copying
---
-foreign import ccall unsafe "string.h" memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)
-foreign import ccall unsafe "string.h" memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.Ptr
--- Copyright : (c) The FFI task force 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- This module provides typed pointers to foreign data. It is part
--- of the Foreign Function Interface (FFI) and will normally be
--- imported via the "Foreign" module.
---
------------------------------------------------------------------------------
-
-module Foreign.Ptr (
-
- -- * Data pointers
-
- Ptr, -- data Ptr a
- nullPtr, -- :: Ptr a
- castPtr, -- :: Ptr a -> Ptr b
- plusPtr, -- :: Ptr a -> Int -> Ptr b
- alignPtr, -- :: Ptr a -> Int -> Ptr a
- minusPtr, -- :: Ptr a -> Ptr b -> Int
-
- -- * Function pointers
-
- FunPtr, -- data FunPtr a
- nullFunPtr, -- :: FunPtr a
- castFunPtr, -- :: FunPtr a -> FunPtr b
- castFunPtrToPtr, -- :: FunPtr a -> Ptr b
- castPtrToFunPtr, -- :: Ptr a -> FunPtr b
-
- freeHaskellFunPtr, -- :: FunPtr a -> IO ()
- -- Free the function pointer created by foreign export dynamic.
-
-#ifndef __NHC__
- -- * Integral types with lossless conversion to and from pointers
- IntPtr,
- ptrToIntPtr,
- intPtrToPtr,
- WordPtr,
- ptrToWordPtr,
- wordPtrToPtr
-#endif
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Ptr
-import GHC.IOBase
-import GHC.Base
-import GHC.Num
-import GHC.Read
-import GHC.Real
-import GHC.Show
-import GHC.Enum
-import GHC.Word ( Word(..) )
-
-import Data.Int
-import Data.Word
-#else
-import Control.Monad ( liftM )
-import Foreign.C.Types
-#endif
-
-import Data.Bits
-import Data.Typeable ( Typeable(..), mkTyCon, mkTyConApp )
-import Foreign.Storable ( Storable(..) )
-
-#ifdef __NHC__
-import NHC.FFI
- ( Ptr
- , nullPtr
- , castPtr
- , plusPtr
- , alignPtr
- , minusPtr
- , FunPtr
- , nullFunPtr
- , castFunPtr
- , castFunPtrToPtr
- , castPtrToFunPtr
- , freeHaskellFunPtr
- )
-#endif
-
-#ifdef __HUGS__
-import Hugs.Ptr
-#endif
-
-#ifdef __GLASGOW_HASKELL__
--- | Release the storage associated with the given 'FunPtr', which
--- must have been obtained from a wrapper stub. This should be called
--- whenever the return value from a foreign import wrapper function is
--- no longer required; otherwise, the storage it uses will leak.
-foreign import ccall unsafe "freeHaskellFunctionPtr"
- freeHaskellFunPtr :: FunPtr a -> IO ()
-#endif
-
-#ifndef __NHC__
-# include "HsBaseConfig.h"
-# include "CTypes.h"
-
-# ifdef __GLASGOW_HASKELL__
--- | An unsigned integral type that can be losslessly converted to and from
--- @Ptr@.
-INTEGRAL_TYPE(WordPtr,tyConWordPtr,"WordPtr",Word)
- -- Word and Int are guaranteed pointer-sized in GHC
-
--- | A signed integral type that can be losslessly converted to and from
--- @Ptr@.
-INTEGRAL_TYPE(IntPtr,tyConIntPtr,"IntPtr",Int)
- -- Word and Int are guaranteed pointer-sized in GHC
-
--- | casts a @Ptr@ to a @WordPtr@
-ptrToWordPtr :: Ptr a -> WordPtr
-ptrToWordPtr (Ptr a#) = WordPtr (W# (int2Word# (addr2Int# a#)))
-
--- | casts a @WordPtr@ to a @Ptr@
-wordPtrToPtr :: WordPtr -> Ptr a
-wordPtrToPtr (WordPtr (W# w#)) = Ptr (int2Addr# (word2Int# w#))
-
--- | casts a @Ptr@ to an @IntPtr@
-ptrToIntPtr :: Ptr a -> IntPtr
-ptrToIntPtr (Ptr a#) = IntPtr (I# (addr2Int# a#))
-
--- | casts an @IntPtr@ to a @Ptr@
-intPtrToPtr :: IntPtr -> Ptr a
-intPtrToPtr (IntPtr (I# i#)) = Ptr (int2Addr# i#)
-
-# else /* !__GLASGOW_HASKELL__ */
-
-INTEGRAL_TYPE(WordPtr,tyConWordPtr,"WordPtr",CUIntPtr)
-INTEGRAL_TYPE(IntPtr,tyConIntPtr,"IntPtr",CIntPtr)
-
-{-# CFILES cbits/PrelIOUtils.c #-}
-
-foreign import ccall unsafe "__hscore_to_uintptr"
- ptrToWordPtr :: Ptr a -> WordPtr
-
-foreign import ccall unsafe "__hscore_from_uintptr"
- wordPtrToPtr :: WordPtr -> Ptr a
-
-foreign import ccall unsafe "__hscore_to_intptr"
- ptrToIntPtr :: Ptr a -> IntPtr
-
-foreign import ccall unsafe "__hscore_from_intptr"
- intPtrToPtr :: IntPtr -> Ptr a
-
-# endif /* !__GLASGOW_HASKELL__ */
-#endif /* !__NHC_ */
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.StablePtr
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- This module is part of the Foreign Function Interface (FFI) and will usually
--- be imported via the module "Foreign".
---
------------------------------------------------------------------------------
-
-
-module Foreign.StablePtr
- ( -- * Stable references to Haskell values
- StablePtr -- abstract
- , newStablePtr -- :: a -> IO (StablePtr a)
- , deRefStablePtr -- :: StablePtr a -> IO a
- , freeStablePtr -- :: StablePtr a -> IO ()
- , castStablePtrToPtr -- :: StablePtr a -> Ptr ()
- , castPtrToStablePtr -- :: Ptr () -> StablePtr a
- , -- ** The C-side interface
-
- -- $cinterface
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Stable
-#endif
-
-#ifdef __HUGS__
-import Hugs.StablePtr
-#endif
-
-#ifdef __NHC__
-import NHC.FFI
- ( StablePtr
- , newStablePtr
- , deRefStablePtr
- , freeStablePtr
- , castStablePtrToPtr
- , castPtrToStablePtr
- )
-#endif
-
--- $cinterface
---
--- The following definition is available to C programs inter-operating with
--- Haskell code when including the header @HsFFI.h@.
---
--- > typedef void *HsStablePtr; /* C representation of a StablePtr */
---
--- Note that no assumptions may be made about the values representing stable
--- pointers. In fact, they need not even be valid memory addresses. The only
--- guarantee provided is that if they are passed back to Haskell land, the
--- function 'deRefStablePtr' will be able to reconstruct the
--- Haskell value referred to by the stable pointer.
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Foreign.Storable
--- Copyright : (c) The FFI task force 2001
--- License : see libraries/base/LICENSE
---
--- Maintainer : ffi@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- The module "Foreign.Storable" provides most elementary support for
--- marshalling and is part of the language-independent portion of the
--- Foreign Function Interface (FFI), and will normally be imported via
--- the "Foreign" module.
---
------------------------------------------------------------------------------
-
-module Foreign.Storable
- ( Storable(
- sizeOf, -- :: a -> Int
- alignment, -- :: a -> Int
- peekElemOff, -- :: Ptr a -> Int -> IO a
- pokeElemOff, -- :: Ptr a -> Int -> a -> IO ()
- peekByteOff, -- :: Ptr b -> Int -> IO a
- pokeByteOff, -- :: Ptr b -> Int -> a -> IO ()
- peek, -- :: Ptr a -> IO a
- poke) -- :: Ptr a -> a -> IO ()
- ) where
-
-
-#ifdef __NHC__
-import NHC.FFI (Storable(..),Ptr,FunPtr,StablePtr
- ,Int8,Int16,Int32,Int64,Word8,Word16,Word32,Word64)
-#else
-
-import Control.Monad ( liftM )
-
-#include "MachDeps.h"
-#include "HsBaseConfig.h"
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Storable
-import GHC.Stable ( StablePtr )
-import GHC.Num
-import GHC.Int
-import GHC.Word
-import GHC.Ptr
-import GHC.Float
-import GHC.Err
-import GHC.IOBase
-import GHC.Base
-#else
-import Data.Int
-import Data.Word
-import Foreign.StablePtr
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude
-import Hugs.Ptr
-import Hugs.Storable
-#endif
-
-{- |
-The member functions of this class facilitate writing values of
-primitive types to raw memory (which may have been allocated with the
-above mentioned routines) and reading values from blocks of raw
-memory. The class, furthermore, includes support for computing the
-storage requirements and alignment restrictions of storable types.
-
-Memory addresses are represented as values of type @'Ptr' a@, for some
-@a@ which is an instance of class 'Storable'. The type argument to
-'Ptr' helps provide some valuable type safety in FFI code (you can\'t
-mix pointers of different types without an explicit cast), while
-helping the Haskell type system figure out which marshalling method is
-needed for a given pointer.
-
-All marshalling between Haskell and a foreign language ultimately
-boils down to translating Haskell data structures into the binary
-representation of a corresponding data structure of the foreign
-language and vice versa. To code this marshalling in Haskell, it is
-necessary to manipulate primitive data types stored in unstructured
-memory blocks. The class 'Storable' facilitates this manipulation on
-all types for which it is instantiated, which are the standard basic
-types of Haskell, the fixed size @Int@ types ('Int8', 'Int16',
-'Int32', 'Int64'), the fixed size @Word@ types ('Word8', 'Word16',
-'Word32', 'Word64'), 'StablePtr', all types from "Foreign.C.Types",
-as well as 'Ptr'.
-
-Minimal complete definition: 'sizeOf', 'alignment', one of 'peek',
-'peekElemOff' and 'peekByteOff', and one of 'poke', 'pokeElemOff' and
-'pokeByteOff'.
--}
-
-class Storable a where
-
- sizeOf :: a -> Int
- -- ^ Computes the storage requirements (in bytes) of the argument.
- -- The value of the argument is not used.
-
- alignment :: a -> Int
- -- ^ Computes the alignment constraint of the argument. An
- -- alignment constraint @x@ is fulfilled by any address divisible
- -- by @x@. The value of the argument is not used.
-
- peekElemOff :: Ptr a -> Int -> IO a
- -- ^ Read a value from a memory area regarded as an array
- -- of values of the same kind. The first argument specifies
- -- the start address of the array and the second the index into
- -- the array (the first element of the array has index
- -- @0@). The following equality holds,
- --
- -- > peekElemOff addr idx = IOExts.fixIO $ \result ->
- -- > peek (addr `plusPtr` (idx * sizeOf result))
- --
- -- Note that this is only a specification, not
- -- necessarily the concrete implementation of the
- -- function.
-
- pokeElemOff :: Ptr a -> Int -> a -> IO ()
- -- ^ Write a value to a memory area regarded as an array of
- -- values of the same kind. The following equality holds:
- --
- -- > pokeElemOff addr idx x =
- -- > poke (addr `plusPtr` (idx * sizeOf x)) x
-
- peekByteOff :: Ptr b -> Int -> IO a
- -- ^ Read a value from a memory location given by a base
- -- address and offset. The following equality holds:
- --
- -- > peekByteOff addr off = peek (addr `plusPtr` off)
-
- pokeByteOff :: Ptr b -> Int -> a -> IO ()
- -- ^ Write a value to a memory location given by a base
- -- address and offset. The following equality holds:
- --
- -- > pokeByteOff addr off x = poke (addr `plusPtr` off) x
-
- peek :: Ptr a -> IO a
- -- ^ Read a value from the given memory location.
- --
- -- Note that the peek and poke functions might require properly
- -- aligned addresses to function correctly. This is architecture
- -- dependent; thus, portable code should ensure that when peeking or
- -- poking values of some type @a@, the alignment
- -- constraint for @a@, as given by the function
- -- 'alignment' is fulfilled.
-
- poke :: Ptr a -> a -> IO ()
- -- ^ Write the given value to the given memory location. Alignment
- -- restrictions might apply; see 'peek'.
-
- -- circular default instances
-#ifdef __GLASGOW_HASKELL__
- peekElemOff = peekElemOff_ undefined
- where peekElemOff_ :: a -> Ptr a -> Int -> IO a
- peekElemOff_ undef ptr off = peekByteOff ptr (off * sizeOf undef)
-#else
- peekElemOff ptr off = peekByteOff ptr (off * sizeOfPtr ptr undefined)
-#endif
- pokeElemOff ptr off val = pokeByteOff ptr (off * sizeOf val) val
-
- peekByteOff ptr off = peek (ptr `plusPtr` off)
- pokeByteOff ptr off = poke (ptr `plusPtr` off)
-
- peek ptr = peekElemOff ptr 0
- poke ptr = pokeElemOff ptr 0
-
-#ifndef __GLASGOW_HASKELL__
-sizeOfPtr :: Storable a => Ptr a -> a -> Int
-sizeOfPtr px x = sizeOf x
-#endif
-
--- System-dependent, but rather obvious instances
-
-instance Storable Bool where
- sizeOf _ = sizeOf (undefined::HTYPE_INT)
- alignment _ = alignment (undefined::HTYPE_INT)
- peekElemOff p i = liftM (/= (0::HTYPE_INT)) $ peekElemOff (castPtr p) i
- pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::HTYPE_INT)
-
-#define STORABLE(T,size,align,read,write) \
-instance Storable (T) where { \
- sizeOf _ = size; \
- alignment _ = align; \
- peekElemOff = read; \
- pokeElemOff = write }
-
-#ifdef __GLASGOW_HASKELL__
-STORABLE(Char,SIZEOF_INT32,ALIGNMENT_INT32,
- readWideCharOffPtr,writeWideCharOffPtr)
-#elif defined(__HUGS__)
-STORABLE(Char,SIZEOF_HSCHAR,ALIGNMENT_HSCHAR,
- readCharOffPtr,writeCharOffPtr)
-#endif
-
-STORABLE(Int,SIZEOF_HSINT,ALIGNMENT_HSINT,
- readIntOffPtr,writeIntOffPtr)
-
-#ifndef __NHC__
-STORABLE(Word,SIZEOF_HSWORD,ALIGNMENT_HSWORD,
- readWordOffPtr,writeWordOffPtr)
-#endif
-
-STORABLE((Ptr a),SIZEOF_HSPTR,ALIGNMENT_HSPTR,
- readPtrOffPtr,writePtrOffPtr)
-
-STORABLE((FunPtr a),SIZEOF_HSFUNPTR,ALIGNMENT_HSFUNPTR,
- readFunPtrOffPtr,writeFunPtrOffPtr)
-
-STORABLE((StablePtr a),SIZEOF_HSSTABLEPTR,ALIGNMENT_HSSTABLEPTR,
- readStablePtrOffPtr,writeStablePtrOffPtr)
-
-STORABLE(Float,SIZEOF_HSFLOAT,ALIGNMENT_HSFLOAT,
- readFloatOffPtr,writeFloatOffPtr)
-
-STORABLE(Double,SIZEOF_HSDOUBLE,ALIGNMENT_HSDOUBLE,
- readDoubleOffPtr,writeDoubleOffPtr)
-
-STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8,
- readWord8OffPtr,writeWord8OffPtr)
-
-STORABLE(Word16,SIZEOF_WORD16,ALIGNMENT_WORD16,
- readWord16OffPtr,writeWord16OffPtr)
-
-STORABLE(Word32,SIZEOF_WORD32,ALIGNMENT_WORD32,
- readWord32OffPtr,writeWord32OffPtr)
-
-STORABLE(Word64,SIZEOF_WORD64,ALIGNMENT_WORD64,
- readWord64OffPtr,writeWord64OffPtr)
-
-STORABLE(Int8,SIZEOF_INT8,ALIGNMENT_INT8,
- readInt8OffPtr,writeInt8OffPtr)
-
-STORABLE(Int16,SIZEOF_INT16,ALIGNMENT_INT16,
- readInt16OffPtr,writeInt16OffPtr)
-
-STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32,
- readInt32OffPtr,writeInt32OffPtr)
-
-STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64,
- readInt64OffPtr,writeInt64OffPtr)
-
-#endif
+++ /dev/null
-
-{-# OPTIONS -fno-implicit-prelude #-}
-
-module Foreign.Storable where
-
-import GHC.Float
-import GHC.Int
-import GHC.Word
-
-class Storable a
-
-instance Storable Int8
-instance Storable Int16
-instance Storable Int32
-instance Storable Int64
-instance Storable Word8
-instance Storable Word16
-instance Storable Word32
-instance Storable Word64
-instance Storable Float
-instance Storable Double
-
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude -fno-bang-patterns #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Arr
--- Copyright : (c) The University of Glasgow, 1994-2000
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC extensions)
---
--- GHC\'s array implementation.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Arr where
-
-import {-# SOURCE #-} GHC.Err ( error )
-import GHC.Enum
-import GHC.Num
-import GHC.ST
-import GHC.Base
-import GHC.List
-import GHC.Show
-
-infixl 9 !, //
-
-default ()
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{The @Ix@ class}
-%* *
-%*********************************************************
-
-\begin{code}
--- | The 'Ix' class is used to map a contiguous subrange of values in
--- a type onto integers. It is used primarily for array indexing
--- (see "Data.Array", "Data.Array.IArray" and "Data.Array.MArray").
---
--- The first argument @(l,u)@ of each of these operations is a pair
--- specifying the lower and upper bounds of a contiguous subrange of values.
---
--- An implementation is entitled to assume the following laws about these
--- operations:
---
--- * @'inRange' (l,u) i == 'elem' i ('range' (l,u))@
---
--- * @'range' (l,u) '!!' 'index' (l,u) i == i@, when @'inRange' (l,u) i@
---
--- * @'map' ('index' (l,u)) ('range' (l,u))) == [0..'rangeSize' (l,u)-1]@
---
--- * @'rangeSize' (l,u) == 'length' ('range' (l,u))@
---
--- Minimal complete instance: 'range', 'index' and 'inRange'.
---
-class (Ord a) => Ix a where
- -- | The list of values in the subrange defined by a bounding pair.
- range :: (a,a) -> [a]
- -- | The position of a subscript in the subrange.
- index :: (a,a) -> a -> Int
- -- | Like 'index', but without checking that the value is in range.
- unsafeIndex :: (a,a) -> a -> Int
- -- | Returns 'True' the given subscript lies in the range defined
- -- the bounding pair.
- inRange :: (a,a) -> a -> Bool
- -- | The size of the subrange defined by a bounding pair.
- rangeSize :: (a,a) -> Int
- -- | like 'rangeSize', but without checking that the upper bound is
- -- in range.
- unsafeRangeSize :: (a,a) -> Int
-
- -- Must specify one of index, unsafeIndex
- index b i | inRange b i = unsafeIndex b i
- | otherwise = error "Error in array index"
- unsafeIndex b i = index b i
-
- rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1
- | otherwise = 0 -- This case is only here to
- -- check for an empty range
- -- NB: replacing (inRange b h) by (l <= h) fails for
- -- tuples. E.g. (1,2) <= (2,1) but the range is empty
-
- unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1
-\end{code}
-
-Note that the following is NOT right
- rangeSize (l,h) | l <= h = index b h + 1
- | otherwise = 0
-
-Because it might be the case that l<h, but the range
-is nevertheless empty. Consider
- ((1,2),(2,1))
-Here l<h, but the second index ranges from 2..1 and
-hence is empty
-
-%*********************************************************
-%* *
-\subsection{Instances of @Ix@}
-%* *
-%*********************************************************
-
-\begin{code}
--- abstract these errors from the relevant index functions so that
--- the guts of the function will be small enough to inline.
-
-{-# NOINLINE indexError #-}
-indexError :: Show a => (a,a) -> a -> String -> b
-indexError rng i tp
- = error (showString "Ix{" . showString tp . showString "}.index: Index " .
- showParen True (showsPrec 0 i) .
- showString " out of range " $
- showParen True (showsPrec 0 rng) "")
-
-----------------------------------------------------------------------
-instance Ix Char where
- {-# INLINE range #-}
- range (m,n) = [m..n]
-
- {-# INLINE unsafeIndex #-}
- unsafeIndex (m,_n) i = fromEnum i - fromEnum m
-
- index b i | inRange b i = unsafeIndex b i
- | otherwise = indexError b i "Char"
-
- inRange (m,n) i = m <= i && i <= n
-
-----------------------------------------------------------------------
-instance Ix Int where
- {-# INLINE range #-}
- -- The INLINE stops the build in the RHS from getting inlined,
- -- so that callers can fuse with the result of range
- range (m,n) = [m..n]
-
- {-# INLINE unsafeIndex #-}
- unsafeIndex (m,_n) i = i - m
-
- index b i | inRange b i = unsafeIndex b i
- | otherwise = indexError b i "Int"
-
- {-# INLINE inRange #-}
- inRange (I# m,I# n) (I# i) = m <=# i && i <=# n
-
-----------------------------------------------------------------------
-instance Ix Integer where
- {-# INLINE range #-}
- range (m,n) = [m..n]
-
- {-# INLINE unsafeIndex #-}
- unsafeIndex (m,_n) i = fromInteger (i - m)
-
- index b i | inRange b i = unsafeIndex b i
- | otherwise = indexError b i "Integer"
-
- inRange (m,n) i = m <= i && i <= n
-
-----------------------------------------------------------------------
-instance Ix Bool where -- as derived
- {-# INLINE range #-}
- range (m,n) = [m..n]
-
- {-# INLINE unsafeIndex #-}
- unsafeIndex (l,_) i = fromEnum i - fromEnum l
-
- index b i | inRange b i = unsafeIndex b i
- | otherwise = indexError b i "Bool"
-
- inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u
-
-----------------------------------------------------------------------
-instance Ix Ordering where -- as derived
- {-# INLINE range #-}
- range (m,n) = [m..n]
-
- {-# INLINE unsafeIndex #-}
- unsafeIndex (l,_) i = fromEnum i - fromEnum l
-
- index b i | inRange b i = unsafeIndex b i
- | otherwise = indexError b i "Ordering"
-
- inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u
-
-----------------------------------------------------------------------
-instance Ix () where
- {-# INLINE range #-}
- range ((), ()) = [()]
- {-# INLINE unsafeIndex #-}
- unsafeIndex ((), ()) () = 0
- {-# INLINE inRange #-}
- inRange ((), ()) () = True
- {-# INLINE index #-}
- index b i = unsafeIndex b i
-
-----------------------------------------------------------------------
-instance (Ix a, Ix b) => Ix (a, b) where -- as derived
- {-# SPECIALISE instance Ix (Int,Int) #-}
-
- {-# INLINE range #-}
- range ((l1,l2),(u1,u2)) =
- [ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ]
-
- {-# INLINE unsafeIndex #-}
- unsafeIndex ((l1,l2),(u1,u2)) (i1,i2) =
- unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2
-
- {-# INLINE inRange #-}
- inRange ((l1,l2),(u1,u2)) (i1,i2) =
- inRange (l1,u1) i1 && inRange (l2,u2) i2
-
- -- Default method for index
-
-----------------------------------------------------------------------
-instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where
- {-# SPECIALISE instance Ix (Int,Int,Int) #-}
-
- range ((l1,l2,l3),(u1,u2,u3)) =
- [(i1,i2,i3) | i1 <- range (l1,u1),
- i2 <- range (l2,u2),
- i3 <- range (l3,u3)]
-
- unsafeIndex ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) =
- unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (
- unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (
- unsafeIndex (l1,u1) i1))
-
- inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) =
- inRange (l1,u1) i1 && inRange (l2,u2) i2 &&
- inRange (l3,u3) i3
-
- -- Default method for index
-
-----------------------------------------------------------------------
-instance (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4) where
- range ((l1,l2,l3,l4),(u1,u2,u3,u4)) =
- [(i1,i2,i3,i4) | i1 <- range (l1,u1),
- i2 <- range (l2,u2),
- i3 <- range (l3,u3),
- i4 <- range (l4,u4)]
-
- unsafeIndex ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) =
- unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (
- unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (
- unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (
- unsafeIndex (l1,u1) i1)))
-
- inRange ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) =
- inRange (l1,u1) i1 && inRange (l2,u2) i2 &&
- inRange (l3,u3) i3 && inRange (l4,u4) i4
-
- -- Default method for index
-
-instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where
- range ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) =
- [(i1,i2,i3,i4,i5) | i1 <- range (l1,u1),
- i2 <- range (l2,u2),
- i3 <- range (l3,u3),
- i4 <- range (l4,u4),
- i5 <- range (l5,u5)]
-
- unsafeIndex ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) =
- unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (
- unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (
- unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (
- unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (
- unsafeIndex (l1,u1) i1))))
-
- inRange ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) =
- inRange (l1,u1) i1 && inRange (l2,u2) i2 &&
- inRange (l3,u3) i3 && inRange (l4,u4) i4 &&
- inRange (l5,u5) i5
-
- -- Default method for index
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{The @Array@ types}
-%* *
-%*********************************************************
-
-\begin{code}
-type IPr = (Int, Int)
-
--- | The type of immutable non-strict (boxed) arrays
--- with indices in @i@ and elements in @e@.
-data Ix i => Array i e = Array !i !i (Array# e)
-
--- | Mutable, boxed, non-strict arrays in the 'ST' monad. The type
--- arguments are as follows:
---
--- * @s@: the state variable argument for the 'ST' type
---
--- * @i@: the index type of the array (should be an instance of 'Ix')
---
--- * @e@: the element type of the array.
---
-data STArray s i e = STArray !i !i (MutableArray# s e)
- -- No Ix context for STArray. They are stupid,
- -- and force an Ix context on the equality instance.
-
--- Just pointer equality on mutable arrays:
-instance Eq (STArray s i e) where
- STArray _ _ arr1# == STArray _ _ arr2# =
- sameMutableArray# arr1# arr2#
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Operations on immutable arrays}
-%* *
-%*********************************************************
-
-\begin{code}
-{-# NOINLINE arrEleBottom #-}
-arrEleBottom :: a
-arrEleBottom = error "(Array.!): undefined array element"
-
--- | Construct an array with the specified bounds and containing values
--- for given indices within these bounds.
---
--- The array is undefined (i.e. bottom) if any index in the list is
--- out of bounds. The Haskell 98 Report further specifies that if any
--- two associations in the list have the same index, the value at that
--- index is undefined (i.e. bottom). However in GHC's implementation,
--- the value at such an index is the value part of the last association
--- with that index in the list.
---
--- Because the indices must be checked for these errors, 'array' is
--- strict in the bounds argument and in the indices of the association
--- list, but nonstrict in the values. Thus, recurrences such as the
--- following are possible:
---
--- > a = array (1,100) ((1,1) : [(i, i * a!(i-1)) | i <- [2..100]])
---
--- Not every index within the bounds of the array need appear in the
--- association list, but the values associated with indices that do not
--- appear will be undefined (i.e. bottom).
---
--- If, in any dimension, the lower bound is greater than the upper bound,
--- then the array is legal, but empty. Indexing an empty array always
--- gives an array-bounds error, but 'bounds' still yields the bounds
--- with which the array was constructed.
-{-# INLINE array #-}
-array :: Ix i
- => (i,i) -- ^ a pair of /bounds/, each of the index type
- -- of the array. These bounds are the lowest and
- -- highest indices in the array, in that order.
- -- For example, a one-origin vector of length
- -- '10' has bounds '(1,10)', and a one-origin '10'
- -- by '10' matrix has bounds '((1,1),(10,10))'.
- -> [(i, e)] -- ^ a list of /associations/ of the form
- -- (/index/, /value/). Typically, this list will
- -- be expressed as a comprehension. An
- -- association '(i, x)' defines the value of
- -- the array at index 'i' to be 'x'.
- -> Array i e
-array (l,u) ies = unsafeArray (l,u) [(index (l,u) i, e) | (i, e) <- ies]
-
-{-# INLINE unsafeArray #-}
-unsafeArray :: Ix i => (i,i) -> [(Int, e)] -> Array i e
-unsafeArray (l,u) ies = runST (ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) ->
- foldr (fill marr#) (done l u marr#) ies s2# }})
-
-{-# INLINE fill #-}
-fill :: MutableArray# s e -> (Int, e) -> STRep s a -> STRep s a
-fill marr# (I# i#, e) next s1# =
- case writeArray# marr# i# e s1# of { s2# ->
- next s2# }
-
-{-# INLINE done #-}
-done :: Ix i => i -> i -> MutableArray# s e -> STRep s (Array i e)
-done l u marr# s1# =
- case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) ->
- (# s2#, Array l u arr# #) }
-
--- This is inefficient and I'm not sure why:
--- listArray (l,u) es = unsafeArray (l,u) (zip [0 .. rangeSize (l,u) - 1] es)
--- The code below is better. It still doesn't enable foldr/build
--- transformation on the list of elements; I guess it's impossible
--- using mechanisms currently available.
-
--- | Construct an array from a pair of bounds and a list of values in
--- index order.
-{-# INLINE listArray #-}
-listArray :: Ix i => (i,i) -> [e] -> Array i e
-listArray (l,u) es = runST (ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) ->
- let fillFromList i# xs s3# | i# ==# n# = s3#
- | otherwise = case xs of
- [] -> s3#
- y:ys -> case writeArray# marr# i# y s3# of { s4# ->
- fillFromList (i# +# 1#) ys s4# } in
- case fillFromList 0# es s2# of { s3# ->
- done l u marr# s3# }}})
-
--- | The value at the given index in an array.
-{-# INLINE (!) #-}
-(!) :: Ix i => Array i e -> i -> e
-arr@(Array l u _) ! i = unsafeAt arr (index (l,u) i)
-
-{-# INLINE unsafeAt #-}
-unsafeAt :: Ix i => Array i e -> Int -> e
-unsafeAt (Array _ _ arr#) (I# i#) =
- case indexArray# arr# i# of (# e #) -> e
-
--- | The bounds with which an array was constructed.
-{-# INLINE bounds #-}
-bounds :: Ix i => Array i e -> (i,i)
-bounds (Array l u _) = (l,u)
-
--- | The list of indices of an array in ascending order.
-{-# INLINE indices #-}
-indices :: Ix i => Array i e -> [i]
-indices (Array l u _) = range (l,u)
-
--- | The list of elements of an array in index order.
-{-# INLINE elems #-}
-elems :: Ix i => Array i e -> [e]
-elems arr@(Array l u _) =
- [unsafeAt arr i | i <- [0 .. rangeSize (l,u) - 1]]
-
--- | The list of associations of an array in index order.
-{-# INLINE assocs #-}
-assocs :: Ix i => Array i e -> [(i, e)]
-assocs arr@(Array l u _) =
- [(i, unsafeAt arr (unsafeIndex (l,u) i)) | i <- range (l,u)]
-
--- | The 'accumArray' deals with repeated indices in the association
--- list using an /accumulating function/ which combines the values of
--- associations with the same index.
--- For example, given a list of values of some index type, @hist@
--- produces a histogram of the number of occurrences of each index within
--- a specified range:
---
--- > hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b
--- > hist bnds is = accumArray (+) 0 bnds [(i, 1) | i<-is, inRange bnds i]
---
--- If the accumulating function is strict, then 'accumArray' is strict in
--- the values, as well as the indices, in the association list. Thus,
--- unlike ordinary arrays built with 'array', accumulated arrays should
--- not in general be recursive.
-{-# INLINE accumArray #-}
-accumArray :: Ix i
- => (e -> a -> e) -- ^ accumulating function
- -> e -- ^ initial value
- -> (i,i) -- ^ bounds of the array
- -> [(i, a)] -- ^ association list
- -> Array i e
-accumArray f init (l,u) ies =
- unsafeAccumArray f init (l,u) [(index (l,u) i, e) | (i, e) <- ies]
-
-{-# INLINE unsafeAccumArray #-}
-unsafeAccumArray :: Ix i => (e -> a -> e) -> e -> (i,i) -> [(Int, a)] -> Array i e
-unsafeAccumArray f init (l,u) ies = runST (ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newArray# n# init s1# of { (# s2#, marr# #) ->
- foldr (adjust f marr#) (done l u marr#) ies s2# }})
-
-{-# INLINE adjust #-}
-adjust :: (e -> a -> e) -> MutableArray# s e -> (Int, a) -> STRep s b -> STRep s b
-adjust f marr# (I# i#, new) next s1# =
- case readArray# marr# i# s1# of { (# s2#, old #) ->
- case writeArray# marr# i# (f old new) s2# of { s3# ->
- next s3# }}
-
--- | Constructs an array identical to the first argument except that it has
--- been updated by the associations in the right argument.
--- For example, if @m@ is a 1-origin, @n@ by @n@ matrix, then
---
--- > m//[((i,i), 0) | i <- [1..n]]
---
--- is the same matrix, except with the diagonal zeroed.
---
--- Repeated indices in the association list are handled as for 'array':
--- Haskell 98 specifies that the resulting array is undefined (i.e. bottom),
--- but GHC's implementation uses the last association for each index.
-{-# INLINE (//) #-}
-(//) :: Ix i => Array i e -> [(i, e)] -> Array i e
-arr@(Array l u _) // ies =
- unsafeReplace arr [(index (l,u) i, e) | (i, e) <- ies]
-
-{-# INLINE unsafeReplace #-}
-unsafeReplace :: Ix i => Array i e -> [(Int, e)] -> Array i e
-unsafeReplace arr@(Array l u _) ies = runST (do
- STArray _ _ marr# <- thawSTArray arr
- ST (foldr (fill marr#) (done l u marr#) ies))
-
--- | @'accum' f@ takes an array and an association list and accumulates
--- pairs from the list into the array with the accumulating function @f@.
--- Thus 'accumArray' can be defined using 'accum':
---
--- > accumArray f z b = accum f (array b [(i, z) | i <- range b])
---
-{-# INLINE accum #-}
-accum :: Ix i => (e -> a -> e) -> Array i e -> [(i, a)] -> Array i e
-accum f arr@(Array l u _) ies =
- unsafeAccum f arr [(index (l,u) i, e) | (i, e) <- ies]
-
-{-# INLINE unsafeAccum #-}
-unsafeAccum :: Ix i => (e -> a -> e) -> Array i e -> [(Int, a)] -> Array i e
-unsafeAccum f arr@(Array l u _) ies = runST (do
- STArray _ _ marr# <- thawSTArray arr
- ST (foldr (adjust f marr#) (done l u marr#) ies))
-
-{-# INLINE amap #-}
-amap :: Ix i => (a -> b) -> Array i a -> Array i b
-amap f arr@(Array l u _) =
- unsafeArray (l,u) [(i, f (unsafeAt arr i)) | i <- [0 .. rangeSize (l,u) - 1]]
-
--- | 'ixmap' allows for transformations on array indices.
--- It may be thought of as providing function composition on the right
--- with the mapping that the original array embodies.
---
--- A similar transformation of array values may be achieved using 'fmap'
--- from the 'Array' instance of the 'Functor' class.
-{-# INLINE ixmap #-}
-ixmap :: (Ix i, Ix j) => (i,i) -> (i -> j) -> Array j e -> Array i e
-ixmap (l,u) f arr =
- unsafeArray (l,u) [(unsafeIndex (l,u) i, arr ! f i) | i <- range (l,u)]
-
-{-# INLINE eqArray #-}
-eqArray :: (Ix i, Eq e) => Array i e -> Array i e -> Bool
-eqArray arr1@(Array l1 u1 _) arr2@(Array l2 u2 _) =
- if rangeSize (l1,u1) == 0 then rangeSize (l2,u2) == 0 else
- l1 == l2 && u1 == u2 &&
- and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. rangeSize (l1,u1) - 1]]
-
-{-# INLINE cmpArray #-}
-cmpArray :: (Ix i, Ord e) => Array i e -> Array i e -> Ordering
-cmpArray arr1 arr2 = compare (assocs arr1) (assocs arr2)
-
-{-# INLINE cmpIntArray #-}
-cmpIntArray :: Ord e => Array Int e -> Array Int e -> Ordering
-cmpIntArray arr1@(Array l1 u1 _) arr2@(Array l2 u2 _) =
- if rangeSize (l1,u1) == 0 then if rangeSize (l2,u2) == 0 then EQ else LT else
- if rangeSize (l2,u2) == 0 then GT else
- case compare l1 l2 of
- EQ -> foldr cmp (compare u1 u2) [0 .. rangeSize (l1, min u1 u2) - 1]
- other -> other
- where
- cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of
- EQ -> rest
- other -> other
-
-{-# RULES "cmpArray/Int" cmpArray = cmpIntArray #-}
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Array instances}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Ix i => Functor (Array i) where
- fmap = amap
-
-instance (Ix i, Eq e) => Eq (Array i e) where
- (==) = eqArray
-
-instance (Ix i, Ord e) => Ord (Array i e) where
- compare = cmpArray
-
-instance (Ix a, Show a, Show b) => Show (Array a b) where
- showsPrec p a =
- showParen (p > appPrec) $
- showString "array " .
- showsPrec appPrec1 (bounds a) .
- showChar ' ' .
- showsPrec appPrec1 (assocs a)
- -- Precedence of 'array' is the precedence of application
-
--- The Read instance is in GHC.Read
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Operations on mutable arrays}
-%* *
-%*********************************************************
-
-Idle ADR question: What's the tradeoff here between flattening these
-datatypes into @STArray ix ix (MutableArray# s elt)@ and using
-it as is? As I see it, the former uses slightly less heap and
-provides faster access to the individual parts of the bounds while the
-code used has the benefit of providing a ready-made @(lo, hi)@ pair as
-required by many array-related functions. Which wins? Is the
-difference significant (probably not).
-
-Idle AJG answer: When I looked at the outputted code (though it was 2
-years ago) it seems like you often needed the tuple, and we build
-it frequently. Now we've got the overloading specialiser things
-might be different, though.
-
-\begin{code}
-{-# INLINE newSTArray #-}
-newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e)
-newSTArray (l,u) init = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newArray# n# init s1# of { (# s2#, marr# #) ->
- (# s2#, STArray l u marr# #) }}
-
-{-# INLINE boundsSTArray #-}
-boundsSTArray :: STArray s i e -> (i,i)
-boundsSTArray (STArray l u _) = (l,u)
-
-{-# INLINE readSTArray #-}
-readSTArray :: Ix i => STArray s i e -> i -> ST s e
-readSTArray marr@(STArray l u _) i =
- unsafeReadSTArray marr (index (l,u) i)
-
-{-# INLINE unsafeReadSTArray #-}
-unsafeReadSTArray :: Ix i => STArray s i e -> Int -> ST s e
-unsafeReadSTArray (STArray _ _ marr#) (I# i#) = ST $ \s1# ->
- readArray# marr# i# s1#
-
-{-# INLINE writeSTArray #-}
-writeSTArray :: Ix i => STArray s i e -> i -> e -> ST s ()
-writeSTArray marr@(STArray l u _) i e =
- unsafeWriteSTArray marr (index (l,u) i) e
-
-{-# INLINE unsafeWriteSTArray #-}
-unsafeWriteSTArray :: Ix i => STArray s i e -> Int -> e -> ST s ()
-unsafeWriteSTArray (STArray _ _ marr#) (I# i#) e = ST $ \s1# ->
- case writeArray# marr# i# e s1# of { s2# ->
- (# s2#, () #) }
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Moving between mutable and immutable}
-%* *
-%*********************************************************
-
-\begin{code}
-freezeSTArray :: Ix i => STArray s i e -> ST s (Array i e)
-freezeSTArray (STArray l u marr#) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newArray# n# arrEleBottom s1# of { (# s2#, marr'# #) ->
- let copy i# s3# | i# ==# n# = s3#
- | otherwise =
- case readArray# marr# i# s3# of { (# s4#, e #) ->
- case writeArray# marr'# i# e s4# of { s5# ->
- copy (i# +# 1#) s5# }} in
- case copy 0# s2# of { s3# ->
- case unsafeFreezeArray# marr'# s3# of { (# s4#, arr# #) ->
- (# s4#, Array l u arr# #) }}}}
-
-{-# INLINE unsafeFreezeSTArray #-}
-unsafeFreezeSTArray :: Ix i => STArray s i e -> ST s (Array i e)
-unsafeFreezeSTArray (STArray l u marr#) = ST $ \s1# ->
- case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) ->
- (# s2#, Array l u arr# #) }
-
-thawSTArray :: Ix i => Array i e -> ST s (STArray s i e)
-thawSTArray (Array l u arr#) = ST $ \s1# ->
- case rangeSize (l,u) of { I# n# ->
- case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) ->
- let copy i# s3# | i# ==# n# = s3#
- | otherwise =
- case indexArray# arr# i# of { (# e #) ->
- case writeArray# marr# i# e s3# of { s4# ->
- copy (i# +# 1#) s4# }} in
- case copy 0# s2# of { s3# ->
- (# s3#, STArray l u marr# #) }}}
-
-{-# INLINE unsafeThawSTArray #-}
-unsafeThawSTArray :: Ix i => Array i e -> ST s (STArray s i e)
-unsafeThawSTArray (Array l u arr#) = ST $ \s1# ->
- case unsafeThawArray# arr# s1# of { (# s2#, marr# #) ->
- (# s2#, STArray l u marr# #) }
-\end{code}
+++ /dev/null
-\section[GHC.Base]{Module @GHC.Base@}
-
-The overall structure of the GHC Prelude is a bit tricky.
-
- a) We want to avoid "orphan modules", i.e. ones with instance
- decls that don't belong either to a tycon or a class
- defined in the same module
-
- b) We want to avoid giant modules
-
-So the rough structure is as follows, in (linearised) dependency order
-
-
-GHC.Prim Has no implementation. It defines built-in things, and
- by importing it you bring them into scope.
- The source file is GHC.Prim.hi-boot, which is just
- copied to make GHC.Prim.hi
-
-GHC.Base Classes: Eq, Ord, Functor, Monad
- Types: list, (), Int, Bool, Ordering, Char, String
-
-Data.Tuple Types: tuples, plus instances for GHC.Base classes
-
-GHC.Show Class: Show, plus instances for GHC.Base/GHC.Tup types
-
-GHC.Enum Class: Enum, plus instances for GHC.Base/GHC.Tup types
-
-Data.Maybe Type: Maybe, plus instances for GHC.Base classes
-
-GHC.List List functions
-
-GHC.Num Class: Num, plus instances for Int
- Type: Integer, plus instances for all classes so far (Eq, Ord, Num, Show)
-
- Integer is needed here because it is mentioned in the signature
- of 'fromInteger' in class Num
-
-GHC.Real Classes: Real, Integral, Fractional, RealFrac
- plus instances for Int, Integer
- Types: Ratio, Rational
- plus intances for classes so far
-
- Rational is needed here because it is mentioned in the signature
- of 'toRational' in class Real
-
-GHC.ST The ST monad, instances and a few helper functions
-
-Ix Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples
-
-GHC.Arr Types: Array, MutableArray, MutableVar
-
- Arrays are used by a function in GHC.Float
-
-GHC.Float Classes: Floating, RealFloat
- Types: Float, Double, plus instances of all classes so far
-
- This module contains everything to do with floating point.
- It is a big module (900 lines)
- With a bit of luck, many modules can be compiled without ever reading GHC.Float.hi
-
-
-Other Prelude modules are much easier with fewer complex dependencies.
-
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Base
--- Copyright : (c) The University of Glasgow, 1992-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC extensions)
---
--- Basic data types and classes.
---
------------------------------------------------------------------------------
-
-#include "MachDeps.h"
-
--- #hide
-module GHC.Base
- (
- module GHC.Base,
- module GHC.Prim, -- Re-export GHC.Prim and GHC.Err, to avoid lots
- module GHC.Err -- of people having to import it explicitly
- )
- where
-
-import GHC.Prim
-import {-# SOURCE #-} GHC.Err
-
-infixr 9 .
-infixr 5 ++, :
-infix 4 ==, /=, <, <=, >=, >
-infixr 3 &&
-infixr 2 ||
-infixl 1 >>, >>=
-infixr 0 $
-
-default () -- Double isn't available yet
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{DEBUGGING STUFF}
-%* (for use when compiling GHC.Base itself doesn't work)
-%* *
-%*********************************************************
-
-\begin{code}
-{-
-data Bool = False | True
-data Ordering = LT | EQ | GT
-data Char = C# Char#
-type String = [Char]
-data Int = I# Int#
-data () = ()
-data [] a = MkNil
-
-not True = False
-(&&) True True = True
-otherwise = True
-
-build = error "urk"
-foldr = error "urk"
-
-unpackCString# :: Addr# -> [Char]
-unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
-unpackAppendCString# :: Addr# -> [Char] -> [Char]
-unpackCStringUtf8# :: Addr# -> [Char]
-unpackCString# a = error "urk"
-unpackFoldrCString# a = error "urk"
-unpackAppendCString# a = error "urk"
-unpackCStringUtf8# a = error "urk"
--}
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Standard classes @Eq@, @Ord@}
-%* *
-%*********************************************************
-
-\begin{code}
-
--- | The 'Eq' class defines equality ('==') and inequality ('/=').
--- All the basic datatypes exported by the "Prelude" are instances of 'Eq',
--- and 'Eq' may be derived for any datatype whose constituents are also
--- instances of 'Eq'.
---
--- Minimal complete definition: either '==' or '/='.
---
-class Eq a where
- (==), (/=) :: a -> a -> Bool
-
- x /= y = not (x == y)
- x == y = not (x /= y)
-
--- | The 'Ord' class is used for totally ordered datatypes.
---
--- Instances of 'Ord' can be derived for any user-defined
--- datatype whose constituent types are in 'Ord'. The declared order
--- of the constructors in the data declaration determines the ordering
--- in derived 'Ord' instances. The 'Ordering' datatype allows a single
--- comparison to determine the precise ordering of two objects.
---
--- Minimal complete definition: either 'compare' or '<='.
--- Using 'compare' can be more efficient for complex types.
---
-class (Eq a) => Ord a where
- compare :: a -> a -> Ordering
- (<), (<=), (>), (>=) :: a -> a -> Bool
- max, min :: a -> a -> a
-
- compare x y
- | x == y = EQ
- | x <= y = LT -- NB: must be '<=' not '<' to validate the
- -- above claim about the minimal things that
- -- can be defined for an instance of Ord
- | otherwise = GT
-
- x < y = case compare x y of { LT -> True; _other -> False }
- x <= y = case compare x y of { GT -> False; _other -> True }
- x > y = case compare x y of { GT -> True; _other -> False }
- x >= y = case compare x y of { LT -> False; _other -> True }
-
- -- These two default methods use '<=' rather than 'compare'
- -- because the latter is often more expensive
- max x y = if x <= y then y else x
- min x y = if x <= y then x else y
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Monadic classes @Functor@, @Monad@ }
-%* *
-%*********************************************************
-
-\begin{code}
-{- | The 'Functor' class is used for types that can be mapped over.
-Instances of 'Functor' should satisfy the following laws:
-
-> fmap id == id
-> fmap (f . g) == fmap f . fmap g
-
-The instances of 'Functor' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'
-defined in the "Prelude" satisfy these laws.
--}
-
-class Functor f where
- fmap :: (a -> b) -> f a -> f b
-
-{- | The 'Monad' class defines the basic operations over a /monad/,
-a concept from a branch of mathematics known as /category theory/.
-From the perspective of a Haskell programmer, however, it is best to
-think of a monad as an /abstract datatype/ of actions.
-Haskell's @do@ expressions provide a convenient syntax for writing
-monadic expressions.
-
-Minimal complete definition: '>>=' and 'return'.
-
-Instances of 'Monad' should satisfy the following laws:
-
-> return a >>= k == k a
-> m >>= return == m
-> m >>= (\x -> k x >>= h) == (m >>= k) >>= h
-
-Instances of both 'Monad' and 'Functor' should additionally satisfy the law:
-
-> fmap f xs == xs >>= return . f
-
-The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'
-defined in the "Prelude" satisfy these laws.
--}
-
-class Monad m where
- -- | Sequentially compose two actions, passing any value produced
- -- by the first as an argument to the second.
- (>>=) :: forall a b. m a -> (a -> m b) -> m b
- -- | Sequentially compose two actions, discarding any value produced
- -- by the first, like sequencing operators (such as the semicolon)
- -- in imperative languages.
- (>>) :: forall a b. m a -> m b -> m b
- -- Explicit for-alls so that we know what order to
- -- give type arguments when desugaring
-
- -- | Inject a value into the monadic type.
- return :: a -> m a
- -- | Fail with a message. This operation is not part of the
- -- mathematical definition of a monad, but is invoked on pattern-match
- -- failure in a @do@ expression.
- fail :: String -> m a
-
- m >> k = m >>= \_ -> k
- fail s = error s
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{The list type}
-%* *
-%*********************************************************
-
-\begin{code}
-data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord)
- -- to avoid weird names like con2tag_[]#
-
-
-instance (Eq a) => Eq [a] where
- {-# SPECIALISE instance Eq [Char] #-}
- [] == [] = True
- (x:xs) == (y:ys) = x == y && xs == ys
- _xs == _ys = False
-
-instance (Ord a) => Ord [a] where
- {-# SPECIALISE instance Ord [Char] #-}
- compare [] [] = EQ
- compare [] (_:_) = LT
- compare (_:_) [] = GT
- compare (x:xs) (y:ys) = case compare x y of
- EQ -> compare xs ys
- other -> other
-
-instance Functor [] where
- fmap = map
-
-instance Monad [] where
- m >>= k = foldr ((++) . k) [] m
- m >> k = foldr ((++) . (\ _ -> k)) [] m
- return x = [x]
- fail _ = []
-\end{code}
-
-A few list functions that appear here because they are used here.
-The rest of the prelude list functions are in GHC.List.
-
-----------------------------------------------
--- foldr/build/augment
-----------------------------------------------
-
-\begin{code}
--- | 'foldr', applied to a binary operator, a starting value (typically
--- the right-identity of the operator), and a list, reduces the list
--- using the binary operator, from right to left:
---
--- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...)
-
-foldr :: (a -> b -> b) -> b -> [a] -> b
--- foldr _ z [] = z
--- foldr f z (x:xs) = f x (foldr f z xs)
-{-# INLINE [0] foldr #-}
--- Inline only in the final stage, after the foldr/cons rule has had a chance
-foldr k z xs = go xs
- where
- go [] = z
- go (y:ys) = y `k` go ys
-
--- | A list producer that can be fused with 'foldr'.
--- This function is merely
---
--- > build g = g (:) []
---
--- but GHC's simplifier will transform an expression of the form
--- @'foldr' k z ('build' g)@, which may arise after inlining, to @g k z@,
--- which avoids producing an intermediate list.
-
-build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
-{-# INLINE [1] build #-}
- -- The INLINE is important, even though build is tiny,
- -- because it prevents [] getting inlined in the version that
- -- appears in the interface file. If [] *is* inlined, it
- -- won't match with [] appearing in rules in an importing module.
- --
- -- The "1" says to inline in phase 1
-
-build g = g (:) []
-
--- | A list producer that can be fused with 'foldr'.
--- This function is merely
---
--- > augment g xs = g (:) xs
---
--- but GHC's simplifier will transform an expression of the form
--- @'foldr' k z ('augment' g xs)@, which may arise after inlining, to
--- @g k ('foldr' k z xs)@, which avoids producing an intermediate list.
-
-augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]
-{-# INLINE [1] augment #-}
-augment g xs = g (:) xs
-
-{-# RULES
-"fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) .
- foldr k z (build g) = g k z
-
-"foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) .
- foldr k z (augment g xs) = g k (foldr k z xs)
-
-"foldr/id" foldr (:) [] = \x -> x
-"foldr/app" [1] forall ys. foldr (:) ys = \xs -> xs ++ ys
- -- Only activate this from phase 1, because that's
- -- when we disable the rule that expands (++) into foldr
-
--- The foldr/cons rule looks nice, but it can give disastrously
--- bloated code when commpiling
--- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ]
--- i.e. when there are very very long literal lists
--- So I've disabled it for now. We could have special cases
--- for short lists, I suppose.
--- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)
-
-"foldr/single" forall k z x. foldr k z [x] = k x z
-"foldr/nil" forall k z. foldr k z [] = z
-
-"augment/build" forall (g::forall b. (a->b->b) -> b -> b)
- (h::forall b. (a->b->b) -> b -> b) .
- augment g (build h) = build (\c n -> g c (h c n))
-"augment/nil" forall (g::forall b. (a->b->b) -> b -> b) .
- augment g [] = build g
- #-}
-
--- This rule is true, but not (I think) useful:
--- augment g (augment h t) = augment (\cn -> g c (h c n)) t
-\end{code}
-
-
-----------------------------------------------
--- map
-----------------------------------------------
-
-\begin{code}
--- | 'map' @f xs@ is the list obtained by applying @f@ to each element
--- of @xs@, i.e.,
---
--- > map f [x1, x2, ..., xn] == [f x1, f x2, ..., f xn]
--- > map f [x1, x2, ...] == [f x1, f x2, ...]
-
-map :: (a -> b) -> [a] -> [b]
-map _ [] = []
-map f (x:xs) = f x : map f xs
-
--- Note eta expanded
-mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst
-{-# INLINE [0] mapFB #-}
-mapFB c f x ys = c (f x) ys
-
--- The rules for map work like this.
---
--- Up to (but not including) phase 1, we use the "map" rule to
--- rewrite all saturated applications of map with its build/fold
--- form, hoping for fusion to happen.
--- In phase 1 and 0, we switch off that rule, inline build, and
--- switch on the "mapList" rule, which rewrites the foldr/mapFB
--- thing back into plain map.
---
--- It's important that these two rules aren't both active at once
--- (along with build's unfolding) else we'd get an infinite loop
--- in the rules. Hence the activation control below.
---
--- The "mapFB" rule optimises compositions of map.
---
--- This same pattern is followed by many other functions:
--- e.g. append, filter, iterate, repeat, etc.
-
-{-# RULES
-"map" [~1] forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs)
-"mapList" [1] forall f. foldr (mapFB (:) f) [] = map f
-"mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g)
- #-}
-\end{code}
-
-
-----------------------------------------------
--- append
-----------------------------------------------
-\begin{code}
--- | Append two lists, i.e.,
---
--- > [x1, ..., xm] ++ [y1, ..., yn] == [x1, ..., xm, y1, ..., yn]
--- > [x1, ..., xm] ++ [y1, ...] == [x1, ..., xm, y1, ...]
---
--- If the first list is not finite, the result is the first list.
-
-(++) :: [a] -> [a] -> [a]
-(++) [] ys = ys
-(++) (x:xs) ys = x : xs ++ ys
-
-{-# RULES
-"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys
- #-}
-
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Type @Bool@}
-%* *
-%*********************************************************
-
-\begin{code}
--- |The 'Bool' type is an enumeration. It is defined with 'False'
--- first so that the corresponding 'Prelude.Enum' instance will give
--- 'Prelude.fromEnum' 'False' the value zero, and
--- 'Prelude.fromEnum' 'True' the value 1.
-data Bool = False | True deriving (Eq, Ord)
- -- Read in GHC.Read, Show in GHC.Show
-
--- Boolean functions
-
--- | Boolean \"and\"
-(&&) :: Bool -> Bool -> Bool
-True && x = x
-False && _ = False
-
--- | Boolean \"or\"
-(||) :: Bool -> Bool -> Bool
-True || _ = True
-False || x = x
-
--- | Boolean \"not\"
-not :: Bool -> Bool
-not True = False
-not False = True
-
--- |'otherwise' is defined as the value 'True'. It helps to make
--- guards more readable. eg.
---
--- > f x | x < 0 = ...
--- > | otherwise = ...
-otherwise :: Bool
-otherwise = True
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{The @()@ type}
-%* *
-%*********************************************************
-
-The Unit type is here because virtually any program needs it (whereas
-some programs may get away without consulting GHC.Tup). Furthermore,
-the renamer currently *always* asks for () to be in scope, so that
-ccalls can use () as their default type; so when compiling GHC.Base we
-need (). (We could arrange suck in () only if -fglasgow-exts, but putting
-it here seems more direct.)
-
-\begin{code}
--- | The unit datatype @()@ has one non-undefined member, the nullary
--- constructor @()@.
-data () = ()
-
-instance Eq () where
- () == () = True
- () /= () = False
-
-instance Ord () where
- () <= () = True
- () < () = False
- () >= () = True
- () > () = False
- max () () = ()
- min () () = ()
- compare () () = EQ
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Type @Ordering@}
-%* *
-%*********************************************************
-
-\begin{code}
--- | Represents an ordering relationship between two values: less
--- than, equal to, or greater than. An 'Ordering' is returned by
--- 'compare'.
-data Ordering = LT | EQ | GT deriving (Eq, Ord)
- -- Read in GHC.Read, Show in GHC.Show
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Type @Char@ and @String@}
-%* *
-%*********************************************************
-
-\begin{code}
--- | A 'String' is a list of characters. String constants in Haskell are values
--- of type 'String'.
---
-type String = [Char]
-
-{-| The character type 'Char' is an enumeration whose values represent
-Unicode (or equivalently ISO\/IEC 10646) characters
-(see <http://www.unicode.org/> for details).
-This set extends the ISO 8859-1 (Latin-1) character set
-(the first 256 charachers), which is itself an extension of the ASCII
-character set (the first 128 characters).
-A character literal in Haskell has type 'Char'.
-
-To convert a 'Char' to or from the corresponding 'Int' value defined
-by Unicode, use 'Prelude.toEnum' and 'Prelude.fromEnum' from the
-'Prelude.Enum' class respectively (or equivalently 'ord' and 'chr').
--}
-data Char = C# Char#
-
--- We don't use deriving for Eq and Ord, because for Ord the derived
--- instance defines only compare, which takes two primops. Then
--- '>' uses compare, and therefore takes two primops instead of one.
-
-instance Eq Char where
- (C# c1) == (C# c2) = c1 `eqChar#` c2
- (C# c1) /= (C# c2) = c1 `neChar#` c2
-
-instance Ord Char where
- (C# c1) > (C# c2) = c1 `gtChar#` c2
- (C# c1) >= (C# c2) = c1 `geChar#` c2
- (C# c1) <= (C# c2) = c1 `leChar#` c2
- (C# c1) < (C# c2) = c1 `ltChar#` c2
-
-{-# RULES
-"x# `eqChar#` x#" forall x#. x# `eqChar#` x# = True
-"x# `neChar#` x#" forall x#. x# `neChar#` x# = False
-"x# `gtChar#` x#" forall x#. x# `gtChar#` x# = False
-"x# `geChar#` x#" forall x#. x# `geChar#` x# = True
-"x# `leChar#` x#" forall x#. x# `leChar#` x# = True
-"x# `ltChar#` x#" forall x#. x# `ltChar#` x# = False
- #-}
-
--- | The 'Prelude.toEnum' method restricted to the type 'Data.Char.Char'.
-chr :: Int -> Char
-chr (I# i#) | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#)
- | otherwise = error "Prelude.chr: bad argument"
-
-unsafeChr :: Int -> Char
-unsafeChr (I# i#) = C# (chr# i#)
-
--- | The 'Prelude.fromEnum' method restricted to the type 'Data.Char.Char'.
-ord :: Char -> Int
-ord (C# c#) = I# (ord# c#)
-\end{code}
-
-String equality is used when desugaring pattern-matches against strings.
-
-\begin{code}
-eqString :: String -> String -> Bool
-eqString [] [] = True
-eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2
-eqString cs1 cs2 = False
-
-{-# RULES "eqString" (==) = eqString #-}
--- eqString also has a BuiltInRule in PrelRules.lhs:
--- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Type @Int@}
-%* *
-%*********************************************************
-
-\begin{code}
-data Int = I# Int#
--- ^A fixed-precision integer type with at least the range @[-2^29 .. 2^29-1]@.
--- The exact range for a given implementation can be determined by using
--- 'Prelude.minBound' and 'Prelude.maxBound' from the 'Prelude.Bounded' class.
-
-zeroInt, oneInt, twoInt, maxInt, minInt :: Int
-zeroInt = I# 0#
-oneInt = I# 1#
-twoInt = I# 2#
-
-{- Seems clumsy. Should perhaps put minInt and MaxInt directly into MachDeps.h -}
-#if WORD_SIZE_IN_BITS == 31
-minInt = I# (-0x40000000#)
-maxInt = I# 0x3FFFFFFF#
-#elif WORD_SIZE_IN_BITS == 32
-minInt = I# (-0x80000000#)
-maxInt = I# 0x7FFFFFFF#
-#else
-minInt = I# (-0x8000000000000000#)
-maxInt = I# 0x7FFFFFFFFFFFFFFF#
-#endif
-
-instance Eq Int where
- (==) = eqInt
- (/=) = neInt
-
-instance Ord Int where
- compare = compareInt
- (<) = ltInt
- (<=) = leInt
- (>=) = geInt
- (>) = gtInt
-
-compareInt :: Int -> Int -> Ordering
-(I# x#) `compareInt` (I# y#) = compareInt# x# y#
-
-compareInt# :: Int# -> Int# -> Ordering
-compareInt# x# y#
- | x# <# y# = LT
- | x# ==# y# = EQ
- | otherwise = GT
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{The function type}
-%* *
-%*********************************************************
-
-\begin{code}
--- | Identity function.
-id :: a -> a
-id x = x
-
--- | The call '(lazy e)' means the same as 'e', but 'lazy' has a
--- magical strictness property: it is lazy in its first argument,
--- even though its semantics is strict.
-lazy :: a -> a
-lazy x = x
--- Implementation note: its strictness and unfolding are over-ridden
--- by the definition in MkId.lhs; in both cases to nothing at all.
--- That way, 'lazy' does not get inlined, and the strictness analyser
--- sees it as lazy. Then the worker/wrapper phase inlines it.
--- Result: happiness
-
-
--- | The call '(inline f)' reduces to 'f', but 'inline' has a BuiltInRule
--- that tries to inline 'f' (if it has an unfolding) unconditionally
--- The 'NOINLINE' pragma arranges that inline only gets inlined (and
--- hence eliminated) late in compilation, after the rule has had
--- a god chance to fire.
-inline :: a -> a
-{-# NOINLINE[0] inline #-}
-inline x = x
-
--- Assertion function. This simply ignores its boolean argument.
--- The compiler may rewrite it to @('assertError' line)@.
-
--- | If the first argument evaluates to 'True', then the result is the
--- second argument. Otherwise an 'AssertionFailed' exception is raised,
--- containing a 'String' with the source file and line number of the
--- call to 'assert'.
---
--- Assertions can normally be turned on or off with a compiler flag
--- (for GHC, assertions are normally on unless optimisation is turned on
--- with @-O@ or the @-fignore-asserts@
--- option is given). When assertions are turned off, the first
--- argument to 'assert' is ignored, and the second argument is
--- returned as the result.
-
--- SLPJ: in 5.04 etc 'assert' is in GHC.Prim,
--- but from Template Haskell onwards it's simply
--- defined here in Base.lhs
-assert :: Bool -> a -> a
-assert pred r = r
-
-breakpoint :: a -> a
-breakpoint r = r
-
-breakpointCond :: Bool -> a -> a
-breakpointCond _ r = r
-
-data Opaque = forall a. O a
-
--- | Constant function.
-const :: a -> b -> a
-const x _ = x
-
--- | Function composition.
-{-# INLINE (.) #-}
-(.) :: (b -> c) -> (a -> b) -> a -> c
-(.) f g x = f (g x)
-
--- | @'flip' f@ takes its (first) two arguments in the reverse order of @f@.
-flip :: (a -> b -> c) -> b -> a -> c
-flip f x y = f y x
-
--- | Application operator. This operator is redundant, since ordinary
--- application @(f x)@ means the same as @(f '$' x)@. However, '$' has
--- low, right-associative binding precedence, so it sometimes allows
--- parentheses to be omitted; for example:
---
--- > f $ g $ h x = f (g (h x))
---
--- It is also useful in higher-order situations, such as @'map' ('$' 0) xs@,
--- or @'Data.List.zipWith' ('$') fs xs@.
-{-# INLINE ($) #-}
-($) :: (a -> b) -> a -> b
-f $ x = f x
-
--- | @'until' p f@ yields the result of applying @f@ until @p@ holds.
-until :: (a -> Bool) -> (a -> a) -> a -> a
-until p f x | p x = x
- | otherwise = until p f (f x)
-
--- | 'asTypeOf' is a type-restricted version of 'const'. It is usually
--- used as an infix operator, and its typing forces its first argument
--- (which is usually overloaded) to have the same type as the second.
-asTypeOf :: a -> a -> a
-asTypeOf = const
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Generics}
-%* *
-%*********************************************************
-
-\begin{code}
-data Unit = Unit
-#ifndef __HADDOCK__
-data (:+:) a b = Inl a | Inr b
-data (:*:) a b = a :*: b
-#endif
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{@getTag@}
-%* *
-%*********************************************************
-
-Returns the 'tag' of a constructor application; this function is used
-by the deriving code for Eq, Ord and Enum.
-
-The primitive dataToTag# requires an evaluated constructor application
-as its argument, so we provide getTag as a wrapper that performs the
-evaluation before calling dataToTag#. We could have dataToTag#
-evaluate its argument, but we prefer to do it this way because (a)
-dataToTag# can be an inline primop if it doesn't need to do any
-evaluation, and (b) we want to expose the evaluation to the
-simplifier, because it might be possible to eliminate the evaluation
-in the case when the argument is already known to be evaluated.
-
-\begin{code}
-{-# INLINE getTag #-}
-getTag :: a -> Int#
-getTag x = x `seq` dataToTag# x
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Numeric primops}
-%* *
-%*********************************************************
-
-\begin{code}
-divInt# :: Int# -> Int# -> Int#
-x# `divInt#` y#
- -- Be careful NOT to overflow if we do any additional arithmetic
- -- on the arguments... the following previous version of this
- -- code has problems with overflow:
--- | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y#
--- | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y#
- | (x# ># 0#) && (y# <# 0#) = ((x# -# 1#) `quotInt#` y#) -# 1#
- | (x# <# 0#) && (y# ># 0#) = ((x# +# 1#) `quotInt#` y#) -# 1#
- | otherwise = x# `quotInt#` y#
-
-modInt# :: Int# -> Int# -> Int#
-x# `modInt#` y#
- | (x# ># 0#) && (y# <# 0#) ||
- (x# <# 0#) && (y# ># 0#) = if r# /=# 0# then r# +# y# else 0#
- | otherwise = r#
- where
- r# = x# `remInt#` y#
-\end{code}
-
-Definitions of the boxed PrimOps; these will be
-used in the case of partial applications, etc.
-
-\begin{code}
-{-# INLINE eqInt #-}
-{-# INLINE neInt #-}
-{-# INLINE gtInt #-}
-{-# INLINE geInt #-}
-{-# INLINE ltInt #-}
-{-# INLINE leInt #-}
-{-# INLINE plusInt #-}
-{-# INLINE minusInt #-}
-{-# INLINE timesInt #-}
-{-# INLINE quotInt #-}
-{-# INLINE remInt #-}
-{-# INLINE negateInt #-}
-
-plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt, gcdInt :: Int -> Int -> Int
-(I# x) `plusInt` (I# y) = I# (x +# y)
-(I# x) `minusInt` (I# y) = I# (x -# y)
-(I# x) `timesInt` (I# y) = I# (x *# y)
-(I# x) `quotInt` (I# y) = I# (x `quotInt#` y)
-(I# x) `remInt` (I# y) = I# (x `remInt#` y)
-(I# x) `divInt` (I# y) = I# (x `divInt#` y)
-(I# x) `modInt` (I# y) = I# (x `modInt#` y)
-
-{-# RULES
-"x# +# 0#" forall x#. x# +# 0# = x#
-"0# +# x#" forall x#. 0# +# x# = x#
-"x# -# 0#" forall x#. x# -# 0# = x#
-"x# -# x#" forall x#. x# -# x# = 0#
-"x# *# 0#" forall x#. x# *# 0# = 0#
-"0# *# x#" forall x#. 0# *# x# = 0#
-"x# *# 1#" forall x#. x# *# 1# = x#
-"1# *# x#" forall x#. 1# *# x# = x#
- #-}
-
-gcdInt (I# a) (I# b) = g a b
- where g 0# 0# = error "GHC.Base.gcdInt: gcd 0 0 is undefined"
- g 0# _ = I# absB
- g _ 0# = I# absA
- g _ _ = I# (gcdInt# absA absB)
-
- absInt x = if x <# 0# then negateInt# x else x
-
- absA = absInt a
- absB = absInt b
-
-negateInt :: Int -> Int
-negateInt (I# x) = I# (negateInt# x)
-
-gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool
-(I# x) `gtInt` (I# y) = x ># y
-(I# x) `geInt` (I# y) = x >=# y
-(I# x) `eqInt` (I# y) = x ==# y
-(I# x) `neInt` (I# y) = x /=# y
-(I# x) `ltInt` (I# y) = x <# y
-(I# x) `leInt` (I# y) = x <=# y
-
-{-# RULES
-"x# ># x#" forall x#. x# ># x# = False
-"x# >=# x#" forall x#. x# >=# x# = True
-"x# ==# x#" forall x#. x# ==# x# = True
-"x# /=# x#" forall x#. x# /=# x# = False
-"x# <# x#" forall x#. x# <# x# = False
-"x# <=# x#" forall x#. x# <=# x# = True
- #-}
-
-{-# RULES
-"plusFloat x 0.0" forall x#. plusFloat# x# 0.0# = x#
-"plusFloat 0.0 x" forall x#. plusFloat# 0.0# x# = x#
-"minusFloat x 0.0" forall x#. minusFloat# x# 0.0# = x#
-"minusFloat x x" forall x#. minusFloat# x# x# = 0.0#
-"timesFloat x 0.0" forall x#. timesFloat# x# 0.0# = 0.0#
-"timesFloat0.0 x" forall x#. timesFloat# 0.0# x# = 0.0#
-"timesFloat x 1.0" forall x#. timesFloat# x# 1.0# = x#
-"timesFloat 1.0 x" forall x#. timesFloat# 1.0# x# = x#
-"divideFloat x 1.0" forall x#. divideFloat# x# 1.0# = x#
- #-}
-
-{-# RULES
-"plusDouble x 0.0" forall x#. (+##) x# 0.0## = x#
-"plusDouble 0.0 x" forall x#. (+##) 0.0## x# = x#
-"minusDouble x 0.0" forall x#. (-##) x# 0.0## = x#
-"minusDouble x x" forall x#. (-##) x# x# = 0.0##
-"timesDouble x 0.0" forall x#. (*##) x# 0.0## = 0.0##
-"timesDouble 0.0 x" forall x#. (*##) 0.0## x# = 0.0##
-"timesDouble x 1.0" forall x#. (*##) x# 1.0## = x#
-"timesDouble 1.0 x" forall x#. (*##) 1.0## x# = x#
-"divideDouble x 1.0" forall x#. (/##) x# 1.0## = x#
- #-}
-
--- Wrappers for the shift operations. The uncheckedShift# family are
--- undefined when the amount being shifted by is greater than the size
--- in bits of Int#, so these wrappers perform a check and return
--- either zero or -1 appropriately.
---
--- Note that these wrappers still produce undefined results when the
--- second argument (the shift amount) is negative.
-
--- | Shift the argument left by the specified number of bits
--- (which must be non-negative).
-shiftL# :: Word# -> Int# -> Word#
-a `shiftL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0#
- | otherwise = a `uncheckedShiftL#` b
-
--- | Shift the argument right by the specified number of bits
--- (which must be non-negative).
-shiftRL# :: Word# -> Int# -> Word#
-a `shiftRL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0#
- | otherwise = a `uncheckedShiftRL#` b
-
--- | Shift the argument left by the specified number of bits
--- (which must be non-negative).
-iShiftL# :: Int# -> Int# -> Int#
-a `iShiftL#` b | b >=# WORD_SIZE_IN_BITS# = 0#
- | otherwise = a `uncheckedIShiftL#` b
-
--- | Shift the argument right (signed) by the specified number of bits
--- (which must be non-negative).
-iShiftRA# :: Int# -> Int# -> Int#
-a `iShiftRA#` b | b >=# WORD_SIZE_IN_BITS# = if a <# 0# then (-1#) else 0#
- | otherwise = a `uncheckedIShiftRA#` b
-
--- | Shift the argument right (unsigned) by the specified number of bits
--- (which must be non-negative).
-iShiftRL# :: Int# -> Int# -> Int#
-a `iShiftRL#` b | b >=# WORD_SIZE_IN_BITS# = 0#
- | otherwise = a `uncheckedIShiftRL#` b
-
-#if WORD_SIZE_IN_BITS == 32
-{-# RULES
-"narrow32Int#" forall x#. narrow32Int# x# = x#
-"narrow32Word#" forall x#. narrow32Word# x# = x#
- #-}
-#endif
-
-{-# RULES
-"int2Word2Int" forall x#. int2Word# (word2Int# x#) = x#
-"word2Int2Word" forall x#. word2Int# (int2Word# x#) = x#
- #-}
-\end{code}
-
-
-%********************************************************
-%* *
-\subsection{Unpacking C strings}
-%* *
-%********************************************************
-
-This code is needed for virtually all programs, since it's used for
-unpacking the strings of error messages.
-
-\begin{code}
-unpackCString# :: Addr# -> [Char]
-{-# NOINLINE [1] unpackCString# #-}
-unpackCString# addr
- = unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = []
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
-
-unpackAppendCString# :: Addr# -> [Char] -> [Char]
-unpackAppendCString# addr rest
- = unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = rest
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
-
-unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
-{-# NOINLINE [0] unpackFoldrCString# #-}
--- Don't inline till right at the end;
--- usually the unpack-list rule turns it into unpackCStringList
--- It also has a BuiltInRule in PrelRules.lhs:
--- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
--- = unpackFoldrCString# "foobaz" c n
-unpackFoldrCString# addr f z
- = unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = z
- | otherwise = C# ch `f` unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
-
-unpackCStringUtf8# :: Addr# -> [Char]
-unpackCStringUtf8# addr
- = unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = []
- | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#)
- | ch `leChar#` '\xDF'# =
- C# (chr# (((ord# ch -# 0xC0#) `uncheckedIShiftL#` 6#) +#
- (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) :
- unpack (nh +# 2#)
- | ch `leChar#` '\xEF'# =
- C# (chr# (((ord# ch -# 0xE0#) `uncheckedIShiftL#` 12#) +#
- ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 6#) +#
- (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) :
- unpack (nh +# 3#)
- | otherwise =
- C# (chr# (((ord# ch -# 0xF0#) `uncheckedIShiftL#` 18#) +#
- ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12#) +#
- ((ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#` 6#) +#
- (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) :
- unpack (nh +# 4#)
- where
- ch = indexCharOffAddr# addr nh
-
-unpackNBytes# :: Addr# -> Int# -> [Char]
-unpackNBytes# _addr 0# = []
-unpackNBytes# addr len# = unpack [] (len# -# 1#)
- where
- unpack acc i#
- | i# <# 0# = acc
- | otherwise =
- case indexCharOffAddr# addr i# of
- ch -> unpack (C# ch : acc) (i# -# 1#)
-
-{-# RULES
-"unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a)
-"unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCString# a
-"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n
-
--- There's a built-in rule (in PrelRules.lhs) for
--- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n
-
- #-}
-\end{code}
-
-#ifdef __HADDOCK__
-\begin{code}
--- | A special argument for the 'Control.Monad.ST.ST' type constructor,
--- indexing a state embedded in the 'Prelude.IO' monad by
--- 'Control.Monad.ST.stToIO'.
-data RealWorld
-\end{code}
-#endif
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Conc
--- Copyright : (c) The University of Glasgow, 1994-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC extensions)
---
--- Basic concurrency stuff.
---
------------------------------------------------------------------------------
-
--- No: #hide, because bits of this module are exposed by the stm package.
--- However, we don't want this module to be the home location for the
--- bits it exports, we'd rather have Control.Concurrent and the other
--- higher level modules be the home. Hence:
-
-#include "Typeable.h"
-
--- #not-home
-module GHC.Conc
- ( ThreadId(..)
-
- -- * Forking and suchlike
- , forkIO -- :: IO a -> IO ThreadId
- , forkOnIO -- :: Int -> IO a -> IO ThreadId
- , childHandler -- :: Exception -> IO ()
- , myThreadId -- :: IO ThreadId
- , killThread -- :: ThreadId -> IO ()
- , throwTo -- :: ThreadId -> Exception -> IO ()
- , par -- :: a -> b -> b
- , pseq -- :: a -> b -> b
- , yield -- :: IO ()
- , labelThread -- :: ThreadId -> String -> IO ()
-
- -- * Waiting
- , threadDelay -- :: Int -> IO ()
- , registerDelay -- :: Int -> IO (TVar Bool)
- , threadWaitRead -- :: Int -> IO ()
- , threadWaitWrite -- :: Int -> IO ()
-
- -- * MVars
- , MVar -- abstract
- , newMVar -- :: a -> IO (MVar a)
- , newEmptyMVar -- :: IO (MVar a)
- , takeMVar -- :: MVar a -> IO a
- , putMVar -- :: MVar a -> a -> IO ()
- , tryTakeMVar -- :: MVar a -> IO (Maybe a)
- , tryPutMVar -- :: MVar a -> a -> IO Bool
- , isEmptyMVar -- :: MVar a -> IO Bool
- , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
-
- -- * TVars
- , STM -- abstract
- , atomically -- :: STM a -> IO a
- , retry -- :: STM a
- , orElse -- :: STM a -> STM a -> STM a
- , catchSTM -- :: STM a -> (Exception -> STM a) -> STM a
- , alwaysSucceeds -- :: STM a -> STM ()
- , always -- :: STM Bool -> STM ()
- , TVar -- abstract
- , newTVar -- :: a -> STM (TVar a)
- , newTVarIO -- :: a -> STM (TVar a)
- , readTVar -- :: TVar a -> STM a
- , writeTVar -- :: a -> TVar a -> STM ()
- , unsafeIOToSTM -- :: IO a -> STM a
-
- -- * Miscellaneous
-#ifdef mingw32_HOST_OS
- , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
- , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
- , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
-
- , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
- , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
-#endif
-
- , ensureIOManagerIsRunning
- ) where
-
-import System.Posix.Types
-#ifndef mingw32_HOST_OS
-import System.Posix.Internals
-#endif
-import Foreign
-import Foreign.C
-
-#ifndef __HADDOCK__
-import {-# SOURCE #-} GHC.TopHandler ( reportError, reportStackOverflow )
-#endif
-
-import Data.Maybe
-
-import GHC.Base
-import GHC.IOBase
-import GHC.Num ( Num(..) )
-import GHC.Real ( fromIntegral, div )
-#ifndef mingw32_HOST_OS
-import GHC.Base ( Int(..) )
-#endif
-import GHC.Exception ( catchException, Exception(..), AsyncException(..) )
-import GHC.Pack ( packCString# )
-import GHC.Ptr ( Ptr(..), plusPtr, FunPtr(..) )
-import GHC.STRef
-import GHC.Show ( Show(..), showString )
-import Data.Typeable
-
-infixr 0 `par`, `pseq`
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{@ThreadId@, @par@, and @fork@}
-%* *
-%************************************************************************
-
-\begin{code}
-data ThreadId = ThreadId ThreadId# deriving( Typeable )
--- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
--- But since ThreadId# is unlifted, the Weak type must use open
--- type variables.
-{- ^
-A 'ThreadId' is an abstract type representing a handle to a thread.
-'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
-the 'Ord' instance implements an arbitrary total ordering over
-'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
-'ThreadId' to string form; showing a 'ThreadId' value is occasionally
-useful when debugging or diagnosing the behaviour of a concurrent
-program.
-
-/Note/: in GHC, if you have a 'ThreadId', you essentially have
-a pointer to the thread itself. This means the thread itself can\'t be
-garbage collected until you drop the 'ThreadId'.
-This misfeature will hopefully be corrected at a later date.
-
-/Note/: Hugs does not provide any operations on other threads;
-it defines 'ThreadId' as a synonym for ().
--}
-
-instance Show ThreadId where
- showsPrec d t =
- showString "ThreadId " .
- showsPrec d (getThreadId (id2TSO t))
-
-foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
-
-id2TSO :: ThreadId -> ThreadId#
-id2TSO (ThreadId t) = t
-
-foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt
--- Returns -1, 0, 1
-
-cmpThread :: ThreadId -> ThreadId -> Ordering
-cmpThread t1 t2 =
- case cmp_thread (id2TSO t1) (id2TSO t2) of
- -1 -> LT
- 0 -> EQ
- _ -> GT -- must be 1
-
-instance Eq ThreadId where
- t1 == t2 =
- case t1 `cmpThread` t2 of
- EQ -> True
- _ -> False
-
-instance Ord ThreadId where
- compare = cmpThread
-
-{- |
-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.
-
-The new thread will be a lightweight thread; if you want to use a foreign
-library that uses thread-local storage, use 'forkOS' instead.
--}
-forkIO :: IO () -> IO ThreadId
-forkIO action = IO $ \ s ->
- case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
- where
- action_plus = catchException action childHandler
-
-forkOnIO :: Int -> IO () -> IO ThreadId
-forkOnIO (I# cpu) action = IO $ \ s ->
- case (forkOn# cpu action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
- where
- action_plus = catchException action childHandler
-
-childHandler :: Exception -> IO ()
-childHandler err = catchException (real_handler err) childHandler
-
-real_handler :: Exception -> IO ()
-real_handler ex =
- case ex of
- -- ignore thread GC and killThread exceptions:
- BlockedOnDeadMVar -> return ()
- BlockedIndefinitely -> return ()
- AsyncException ThreadKilled -> return ()
-
- -- report all others:
- AsyncException StackOverflow -> reportStackOverflow
- other -> reportError other
-
-{- | 'killThread' terminates the given thread (GHC only).
-Any work already done by the thread isn\'t
-lost: the computation is suspended until required by another thread.
-The memory used by the thread will be garbage collected if it isn\'t
-referenced from anywhere. The 'killThread' function is defined in
-terms of 'throwTo':
-
-> killThread tid = throwTo tid (AsyncException ThreadKilled)
-
--}
-killThread :: ThreadId -> IO ()
-killThread tid = throwTo tid (AsyncException ThreadKilled)
-
-{- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
-
-'throwTo' does not return until the exception has been raised in the
-target thread.
-The calling thread can thus be certain that the target
-thread has received the exception. This is a useful property to know
-when dealing with race conditions: eg. if there are two threads that
-can kill each other, it is guaranteed that only one of the threads
-will get to kill the other.
-
-If the target thread is currently making a foreign call, then the
-exception will not be raised (and hence 'throwTo' will not return)
-until the call has completed. This is the case regardless of whether
-the call is inside a 'block' or not.
-
-Important note: the behaviour of 'throwTo' differs from that described in
-the paper "Asynchronous exceptions in Haskell"
-(<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>).
-In the paper, 'throwTo' is non-blocking; but the library implementation adopts
-a more synchronous design in which 'throwTo' does not return until the exception
-is received by the target thread. The trade-off is discussed in Section 8 of the paper.
-Like any blocking operation, 'throwTo' is therefore interruptible (see Section 4.3 of
-the paper).
-
-There is currently no guarantee that the exception delivered by 'throwTo' will be
-delivered at the first possible opportunity. In particular, if a thread may
-unblock and then re-block exceptions (using 'unblock' and 'block') without receiving
-a pending 'throwTo'. This is arguably undesirable behaviour.
-
- -}
-throwTo :: ThreadId -> Exception -> IO ()
-throwTo (ThreadId id) ex = IO $ \ s ->
- case (killThread# id ex s) of s1 -> (# s1, () #)
-
--- | Returns the 'ThreadId' of the calling thread (GHC only).
-myThreadId :: IO ThreadId
-myThreadId = IO $ \s ->
- case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
-
-
--- |The 'yield' action allows (forces, in a co-operative multitasking
--- implementation) a context-switch to any other currently runnable
--- threads (if any), and is occasionally useful when implementing
--- concurrency abstractions.
-yield :: IO ()
-yield = IO $ \s ->
- case (yield# s) of s1 -> (# s1, () #)
-
-{- | 'labelThread' stores a string as identifier for this thread if
-you built a RTS with debugging support. This identifier will be used in
-the debugging output to make distinction of different threads easier
-(otherwise you only have the thread state object\'s address in the heap).
-
-Other applications like the graphical Concurrent Haskell Debugger
-(<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
-'labelThread' for their purposes as well.
--}
-
-labelThread :: ThreadId -> String -> IO ()
-labelThread (ThreadId t) str = IO $ \ s ->
- let ps = packCString# str
- adr = byteArrayContents# ps in
- case (labelThread# t adr s) of s1 -> (# s1, () #)
-
--- Nota Bene: 'pseq' used to be 'seq'
--- but 'seq' is now defined in PrelGHC
---
--- "pseq" is defined a bit weirdly (see below)
---
--- The reason for the strange "lazy" call is that
--- it fools the compiler into thinking that pseq and par are non-strict in
--- their second argument (even if it inlines pseq at the call site).
--- If it thinks pseq is strict in "y", then it often evaluates
--- "y" before "x", which is totally wrong.
-
-{-# INLINE pseq #-}
-pseq :: a -> b -> b
-pseq x y = x `seq` lazy y
-
-{-# INLINE par #-}
-par :: a -> b -> b
-par x y = case (par# x) of { _ -> lazy y }
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[stm]{Transactional heap operations}
-%* *
-%************************************************************************
-
-TVars are shared memory locations which support atomic memory
-transactions.
-
-\begin{code}
--- |A monad supporting atomic memory transactions.
-newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
-
-unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
-unSTM (STM a) = a
-
-INSTANCE_TYPEABLE1(STM,stmTc,"STM")
-
-instance Functor STM where
- fmap f x = x >>= (return . f)
-
-instance Monad STM where
- {-# INLINE return #-}
- {-# INLINE (>>) #-}
- {-# INLINE (>>=) #-}
- m >> k = thenSTM m k
- return x = returnSTM x
- m >>= k = bindSTM m k
-
-bindSTM :: STM a -> (a -> STM b) -> STM b
-bindSTM (STM m) k = STM ( \s ->
- case m s of
- (# new_s, a #) -> unSTM (k a) new_s
- )
-
-thenSTM :: STM a -> STM b -> STM b
-thenSTM (STM m) k = STM ( \s ->
- case m s of
- (# new_s, a #) -> unSTM k new_s
- )
-
-returnSTM :: a -> STM a
-returnSTM x = STM (\s -> (# s, x #))
-
--- | Unsafely performs IO in the STM monad.
-unsafeIOToSTM :: IO a -> STM a
-unsafeIOToSTM (IO m) = STM m
-
--- |Perform a series of STM actions atomically.
---
--- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'.
--- Any attempt to do so will result in a runtime error. (Reason: allowing
--- this would effectively allow a transaction inside a transaction, depending
--- on exactly when the thunk is evaluated.)
---
--- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',
--- and which allows top-level TVars to be allocated.
-
-atomically :: STM a -> IO a
-atomically (STM m) = IO (\s -> (atomically# m) s )
-
--- |Retry execution of the current memory transaction because it has seen
--- values in TVars which mean that it should not continue (e.g. the TVars
--- represent a shared buffer that is now empty). The implementation may
--- block the thread until one of the TVars that it has read from has been
--- udpated. (GHC only)
-retry :: STM a
-retry = STM $ \s# -> retry# s#
-
--- |Compose two alternative STM actions (GHC only). If the first action
--- completes without retrying then it forms the result of the orElse.
--- Otherwise, if the first action retries, then the second action is
--- tried in its place. If both actions retry then the orElse as a
--- whole retries.
-orElse :: STM a -> STM a -> STM a
-orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
-
--- |Exception handling within STM actions.
-catchSTM :: STM a -> (Exception -> STM a) -> STM a
-catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s
-
--- | Low-level primitive on which always and alwaysSucceeds are built.
--- checkInv differs form these in that (i) the invariant is not
--- checked when checkInv is called, only at the end of this and
--- subsequent transcations, (ii) the invariant failure is indicated
--- by raising an exception.
-checkInv :: STM a -> STM ()
-checkInv (STM m) = STM (\s -> (check# m) s)
-
--- | alwaysSucceeds adds a new invariant that must be true when passed
--- to alwaysSucceeds, at the end of the current transaction, and at
--- the end of every subsequent transaction. If it fails at any
--- of those points then the transaction violating it is aborted
--- and the exception raised by the invariant is propagated.
-alwaysSucceeds :: STM a -> STM ()
-alwaysSucceeds i = do ( do i ; retry ) `orElse` ( return () )
- checkInv i
-
--- | always is a variant of alwaysSucceeds in which the invariant is
--- expressed as an STM Bool action that must return True. Returning
--- False or raising an exception are both treated as invariant failures.
-always :: STM Bool -> STM ()
-always i = alwaysSucceeds ( do v <- i
- if (v) then return () else ( error "Transacional invariant violation" ) )
-
--- |Shared memory locations that support atomic memory transactions.
-data TVar a = TVar (TVar# RealWorld a)
-
-INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar")
-
-instance Eq (TVar a) where
- (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
-
--- |Create a new TVar holding a value supplied
-newTVar :: a -> STM (TVar a)
-newTVar val = STM $ \s1# ->
- case newTVar# val s1# of
- (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
-
--- |@IO@ version of 'newTVar'. This is useful for creating top-level
--- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
--- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
--- possible.
-newTVarIO :: a -> IO (TVar a)
-newTVarIO val = IO $ \s1# ->
- case newTVar# val s1# of
- (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
-
--- |Return the current value stored in a TVar
-readTVar :: TVar a -> STM a
-readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
-
--- |Write the supplied value into a TVar
-writeTVar :: TVar a -> a -> STM ()
-writeTVar (TVar tvar#) val = STM $ \s1# ->
- case writeTVar# tvar# val s1# of
- s2# -> (# s2#, () #)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[mvars]{M-Structures}
-%* *
-%************************************************************************
-
-M-Vars are rendezvous points for concurrent threads. They begin
-empty, and any attempt to read an empty M-Var blocks. When an M-Var
-is written, a single blocked thread may be freed. Reading an M-Var
-toggles its state from full back to empty. Therefore, any value
-written to an M-Var may only be read once. Multiple reads and writes
-are allowed, but there must be at least one read between any two
-writes.
-
-\begin{code}
---Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
-
--- |Create an 'MVar' which is initially empty.
-newEmptyMVar :: IO (MVar a)
-newEmptyMVar = IO $ \ s# ->
- case newMVar# s# of
- (# s2#, svar# #) -> (# s2#, MVar svar# #)
-
--- |Create an 'MVar' which contains the supplied value.
-newMVar :: a -> IO (MVar a)
-newMVar value =
- newEmptyMVar >>= \ mvar ->
- putMVar mvar value >>
- return mvar
-
--- |Return the contents of the 'MVar'. If the 'MVar' is currently
--- empty, 'takeMVar' will wait until it is full. After a 'takeMVar',
--- the 'MVar' is left empty.
---
--- There are two further important properties of 'takeMVar':
---
--- * 'takeMVar' is single-wakeup. That is, if there are multiple
--- threads blocked in 'takeMVar', and the 'MVar' becomes full,
--- only one thread will be woken up. The runtime guarantees that
--- the woken thread completes its 'takeMVar' operation.
---
--- * When multiple threads are blocked on an 'MVar', they are
--- woken up in FIFO order. This is useful for providing
--- fairness properties of abstractions built using 'MVar's.
---
-takeMVar :: MVar a -> IO a
-takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
-
--- |Put a value into an 'MVar'. If the 'MVar' is currently full,
--- 'putMVar' will wait until it becomes empty.
---
--- There are two further important properties of 'putMVar':
---
--- * 'putMVar' is single-wakeup. That is, if there are multiple
--- threads blocked in 'putMVar', and the 'MVar' becomes empty,
--- only one thread will be woken up. The runtime guarantees that
--- the woken thread completes its 'putMVar' operation.
---
--- * When multiple threads are blocked on an 'MVar', they are
--- woken up in FIFO order. This is useful for providing
--- fairness properties of abstractions built using 'MVar's.
---
-putMVar :: MVar a -> a -> IO ()
-putMVar (MVar mvar#) x = IO $ \ s# ->
- case putMVar# mvar# x s# of
- s2# -> (# s2#, () #)
-
--- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function
--- returns immediately, with 'Nothing' if the 'MVar' was empty, or
--- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar',
--- the 'MVar' is left empty.
-tryTakeMVar :: MVar a -> IO (Maybe a)
-tryTakeMVar (MVar m) = IO $ \ s ->
- case tryTakeMVar# m s of
- (# s, 0#, _ #) -> (# s, Nothing #) -- MVar is empty
- (# s, _, a #) -> (# s, Just a #) -- MVar is full
-
--- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function
--- attempts to put the value @a@ into the 'MVar', returning 'True' if
--- it was successful, or 'False' otherwise.
-tryPutMVar :: MVar a -> a -> IO Bool
-tryPutMVar (MVar mvar#) x = IO $ \ s# ->
- case tryPutMVar# mvar# x s# of
- (# s, 0# #) -> (# s, False #)
- (# s, _ #) -> (# s, True #)
-
--- |Check whether a given 'MVar' is empty.
---
--- Notice that the boolean value returned is just a snapshot of
--- the state of the MVar. By the time you get to react on its result,
--- the MVar may have been filled (or emptied) - so be extremely
--- careful when using this operation. Use 'tryTakeMVar' instead if possible.
-isEmptyMVar :: MVar a -> IO Bool
-isEmptyMVar (MVar mv#) = IO $ \ s# ->
- case isEmptyMVar# mv# s# of
- (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
-
--- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and
--- "System.Mem.Weak" for more about finalizers.
-addMVarFinalizer :: MVar a -> IO () -> IO ()
-addMVarFinalizer (MVar m) finalizer =
- IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Thread waiting}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef mingw32_HOST_OS
-
--- Note: threadDelay, threadWaitRead and threadWaitWrite aren't really functional
--- on Win32, but left in there because lib code (still) uses them (the manner
--- in which they're used doesn't cause problems on a Win32 platform though.)
-
-asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
-asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) =
- IO $ \s -> case asyncRead# fd isSock len buf s of
- (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
-
-asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
-asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) =
- IO $ \s -> case asyncWrite# fd isSock len buf s of
- (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
-
-asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
-asyncDoProc (FunPtr proc) (Ptr param) =
- -- the 'length' value is ignored; simplifies implementation of
- -- the async*# primops to have them all return the same result.
- IO $ \s -> case asyncDoProc# proc param s of
- (# s, len#, err# #) -> (# s, I# err# #)
-
--- to aid the use of these primops by the IO Handle implementation,
--- provide the following convenience funs:
-
--- this better be a pinned byte array!
-asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
-asyncReadBA fd isSock len off bufB =
- asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
-
-asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
-asyncWriteBA fd isSock len off bufB =
- asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
-
-#endif
-
--- -----------------------------------------------------------------------------
--- Thread IO API
-
--- | Block the current thread until data is available to read on the
--- given file descriptor (GHC only).
-threadWaitRead :: Fd -> IO ()
-threadWaitRead fd
-#ifndef mingw32_HOST_OS
- | threaded = waitForReadEvent fd
-#endif
- | otherwise = IO $ \s ->
- case fromIntegral fd of { I# fd# ->
- case waitRead# fd# s of { s -> (# s, () #)
- }}
-
--- | Block the current thread until data can be written to the
--- given file descriptor (GHC only).
-threadWaitWrite :: Fd -> IO ()
-threadWaitWrite fd
-#ifndef mingw32_HOST_OS
- | threaded = waitForWriteEvent fd
-#endif
- | otherwise = IO $ \s ->
- case fromIntegral fd of { I# fd# ->
- case waitWrite# fd# s of { s -> (# s, () #)
- }}
-
--- | Suspends the current thread for a given number of microseconds
--- (GHC only).
---
--- There is no guarantee that the thread will be rescheduled promptly
--- when the delay has expired, but the thread will never continue to
--- run /earlier/ than specified.
---
-threadDelay :: Int -> IO ()
-threadDelay time
- | threaded = waitForDelayEvent time
- | otherwise = IO $ \s ->
- case fromIntegral time of { I# time# ->
- case delay# time# s of { s -> (# s, () #)
- }}
-
-
--- | Set the value of returned TVar to True after a given number of
--- microseconds. The caveats associated with threadDelay also apply.
---
-registerDelay :: Int -> IO (TVar Bool)
-registerDelay usecs
- | threaded = waitForDelayEventSTM usecs
- | otherwise = error "registerDelay: requires -threaded"
-
-foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
-
-waitForDelayEvent :: Int -> IO ()
-waitForDelayEvent usecs = do
- m <- newEmptyMVar
- target <- calculateTarget usecs
- atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
- prodServiceThread
- takeMVar m
-
--- Delays for use in STM
-waitForDelayEventSTM :: Int -> IO (TVar Bool)
-waitForDelayEventSTM usecs = do
- t <- atomically $ newTVar False
- target <- calculateTarget usecs
- atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ()))
- prodServiceThread
- return t
-
-calculateTarget :: Int -> IO USecs
-calculateTarget usecs = do
- now <- getUSecOfDay
- return $ now + (fromIntegral usecs)
-
-
--- ----------------------------------------------------------------------------
--- Threaded RTS implementation of threadWaitRead, threadWaitWrite, threadDelay
-
--- In the threaded RTS, we employ a single IO Manager thread to wait
--- for all outstanding IO requests (threadWaitRead,threadWaitWrite)
--- and delays (threadDelay).
---
--- We can do this because in the threaded RTS the IO Manager can make
--- a non-blocking call to select(), so we don't have to do select() in
--- the scheduler as we have to in the non-threaded RTS. We get performance
--- benefits from doing it this way, because we only have to restart the select()
--- when a new request arrives, rather than doing one select() each time
--- around the scheduler loop. Furthermore, the scheduler can be simplified
--- by not having to check for completed IO requests.
-
--- Issues, possible problems:
---
--- - we might want bound threads to just do the blocking
--- operation rather than communicating with the IO manager
--- thread. This would prevent simgle-threaded programs which do
--- IO from requiring multiple OS threads. However, it would also
--- prevent bound threads waiting on IO from being killed or sent
--- exceptions.
---
--- - Apprently exec() doesn't work on Linux in a multithreaded program.
--- I couldn't repeat this.
---
--- - How do we handle signal delivery in the multithreaded RTS?
---
--- - forkProcess will kill the IO manager thread. Let's just
--- hope we don't need to do any blocking IO between fork & exec.
-
-#ifndef mingw32_HOST_OS
-data IOReq
- = Read {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
- | Write {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
-#endif
-
-data DelayReq
- = Delay {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())
- | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)
-
-#ifndef mingw32_HOST_OS
-pendingEvents :: IORef [IOReq]
-#endif
-pendingDelays :: IORef [DelayReq]
- -- could use a strict list or array here
-{-# NOINLINE pendingEvents #-}
-{-# NOINLINE pendingDelays #-}
-(pendingEvents,pendingDelays) = unsafePerformIO $ do
- startIOManagerThread
- reqs <- newIORef []
- dels <- newIORef []
- return (reqs, dels)
- -- the first time we schedule an IO request, the service thread
- -- will be created (cool, huh?)
-
-ensureIOManagerIsRunning :: IO ()
-ensureIOManagerIsRunning
- | threaded = seq pendingEvents $ return ()
- | otherwise = return ()
-
-insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
-insertDelay d [] = [d]
-insertDelay d1 ds@(d2 : rest)
- | delayTime d1 <= delayTime d2 = d1 : ds
- | otherwise = d2 : insertDelay d1 rest
-
-delayTime :: DelayReq -> USecs
-delayTime (Delay t _) = t
-delayTime (DelaySTM t _) = t
-
-type USecs = Word64
-
--- XXX: move into GHC.IOBase from Data.IORef?
-atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b
-atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s
-
-foreign import ccall unsafe "getUSecOfDay"
- getUSecOfDay :: IO USecs
-
-prodding :: IORef Bool
-{-# NOINLINE prodding #-}
-prodding = unsafePerformIO (newIORef False)
-
-prodServiceThread :: IO ()
-prodServiceThread = do
- was_set <- atomicModifyIORef prodding (\a -> (True,a))
- if (not (was_set)) then wakeupIOManager else return ()
-
-#ifdef mingw32_HOST_OS
--- ----------------------------------------------------------------------------
--- Windows IO manager thread
-
-startIOManagerThread :: IO ()
-startIOManagerThread = do
- wakeup <- c_getIOManagerEvent
- forkIO $ service_loop wakeup []
- return ()
-
-service_loop :: HANDLE -- read end of pipe
- -> [DelayReq] -- current delay requests
- -> IO ()
-
-service_loop wakeup old_delays = do
- -- pick up new delay requests
- new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
- let delays = foldr insertDelay old_delays new_delays
-
- now <- getUSecOfDay
- (delays', timeout) <- getDelay now delays
-
- r <- c_WaitForSingleObject wakeup timeout
- case r of
- 0xffffffff -> do c_maperrno; throwErrno "service_loop"
- 0 -> do
- r <- c_readIOManagerEvent
- exit <-
- case r of
- _ | r == io_MANAGER_WAKEUP -> return False
- _ | r == io_MANAGER_DIE -> return True
- 0 -> return False -- spurious wakeup
- r -> do start_console_handler (r `shiftR` 1); return False
- if exit
- then return ()
- else service_cont wakeup delays'
-
- _other -> service_cont wakeup delays' -- probably timeout
-
-service_cont wakeup delays = do
- atomicModifyIORef prodding (\_ -> (False,False))
- service_loop wakeup delays
-
--- must agree with rts/win32/ThrIOManager.c
-io_MANAGER_WAKEUP = 0xffffffff :: Word32
-io_MANAGER_DIE = 0xfffffffe :: Word32
-
-start_console_handler :: Word32 -> IO ()
-start_console_handler r = do
- stableptr <- peek console_handler
- forkIO $ do io <- deRefStablePtr stableptr; io (fromIntegral r)
- return ()
-
-foreign import ccall "&console_handler"
- console_handler :: Ptr (StablePtr (CInt -> IO ()))
-
-stick :: IORef HANDLE
-{-# NOINLINE stick #-}
-stick = unsafePerformIO (newIORef nullPtr)
-
-wakeupIOManager = do
- hdl <- readIORef stick
- c_sendIOManagerEvent io_MANAGER_WAKEUP
-
--- Walk the queue of pending delays, waking up any that have passed
--- and return the smallest delay to wait for. The queue of pending
--- delays is kept ordered.
-getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
-getDelay now [] = return ([], iNFINITE)
-getDelay now all@(d : rest)
- = case d of
- Delay time m | now >= time -> do
- putMVar m ()
- getDelay now rest
- DelaySTM time t | now >= time -> do
- atomically $ writeTVar t True
- getDelay now rest
- _otherwise ->
- -- delay is in millisecs for WaitForSingleObject
- let micro_seconds = delayTime d - now
- milli_seconds = (micro_seconds + 999) `div` 1000
- in return (all, fromIntegral milli_seconds)
-
--- ToDo: this just duplicates part of System.Win32.Types, which isn't
--- available yet. We should move some Win32 functionality down here,
--- maybe as part of the grand reorganisation of the base package...
-type HANDLE = Ptr ()
-type DWORD = Word32
-
-iNFINITE = 0xFFFFFFFF :: DWORD -- urgh
-
-foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
- c_getIOManagerEvent :: IO HANDLE
-
-foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
- c_readIOManagerEvent :: IO Word32
-
-foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
- c_sendIOManagerEvent :: Word32 -> IO ()
-
-foreign import ccall unsafe "maperrno" -- in runProcess.c
- c_maperrno :: IO ()
-
-foreign import stdcall "WaitForSingleObject"
- c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD
-
-#else
--- ----------------------------------------------------------------------------
--- Unix IO manager thread, using select()
-
-startIOManagerThread :: IO ()
-startIOManagerThread = do
- allocaArray 2 $ \fds -> do
- throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds)
- rd_end <- peekElemOff fds 0
- wr_end <- peekElemOff fds 1
- writeIORef stick (fromIntegral wr_end)
- c_setIOManagerPipe wr_end
- forkIO $ do
- allocaBytes sizeofFdSet $ \readfds -> do
- allocaBytes sizeofFdSet $ \writefds -> do
- allocaBytes sizeofTimeVal $ \timeval -> do
- service_loop (fromIntegral rd_end) readfds writefds timeval [] []
- return ()
-
-service_loop
- :: Fd -- listen to this for wakeup calls
- -> Ptr CFdSet
- -> Ptr CFdSet
- -> Ptr CTimeVal
- -> [IOReq]
- -> [DelayReq]
- -> IO ()
-service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
-
- -- pick up new IO requests
- new_reqs <- atomicModifyIORef pendingEvents (\a -> ([],a))
- let reqs = new_reqs ++ old_reqs
-
- -- pick up new delay requests
- new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
- let delays = foldr insertDelay old_delays new_delays
-
- -- build the FDSets for select()
- fdZero readfds
- fdZero writefds
- fdSet wakeup readfds
- maxfd <- buildFdSets 0 readfds writefds reqs
-
- -- perform the select()
- let do_select delays = do
- -- check the current time and wake up any thread in
- -- threadDelay whose timeout has expired. Also find the
- -- timeout value for the select() call.
- now <- getUSecOfDay
- (delays', timeout) <- getDelay now ptimeval delays
-
- res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds
- nullPtr timeout
- if (res == -1)
- then do
- err <- getErrno
- case err of
- _ | err == eINTR -> do_select delays'
- -- EINTR: just redo the select()
- _ | err == eBADF -> return (True, delays)
- -- EBADF: one of the file descriptors is closed or bad,
- -- we don't know which one, so wake everyone up.
- _ | otherwise -> throwErrno "select"
- -- otherwise (ENOMEM or EINVAL) something has gone
- -- wrong; report the error.
- else
- return (False,delays')
-
- (wakeup_all,delays') <- do_select delays
-
- exit <-
- if wakeup_all then return False
- else do
- b <- fdIsSet wakeup readfds
- if b == 0
- then return False
- else alloca $ \p -> do
- c_read (fromIntegral wakeup) p 1; return ()
- s <- peek p
- case s of
- _ | s == io_MANAGER_WAKEUP -> return False
- _ | s == io_MANAGER_DIE -> return True
- _ -> do handler_tbl <- peek handlers
- sp <- peekElemOff handler_tbl (fromIntegral s)
- forkIO (do io <- deRefStablePtr sp; io)
- return False
-
- if exit then return () else do
-
- atomicModifyIORef prodding (\_ -> (False,False))
-
- reqs' <- if wakeup_all then do wakeupAll reqs; return []
- else completeRequests reqs readfds writefds []
-
- service_loop wakeup readfds writefds ptimeval reqs' delays'
-
-io_MANAGER_WAKEUP = 0xff :: CChar
-io_MANAGER_DIE = 0xfe :: CChar
-
-stick :: IORef Fd
-{-# NOINLINE stick #-}
-stick = unsafePerformIO (newIORef 0)
-
-wakeupIOManager :: IO ()
-wakeupIOManager = do
- fd <- readIORef stick
- with io_MANAGER_WAKEUP $ \pbuf -> do
- c_write (fromIntegral fd) pbuf 1; return ()
-
-foreign import ccall "&signal_handlers" handlers :: Ptr (Ptr (StablePtr (IO ())))
-
-foreign import ccall "setIOManagerPipe"
- c_setIOManagerPipe :: CInt -> IO ()
-
--- -----------------------------------------------------------------------------
--- IO requests
-
-buildFdSets maxfd readfds writefds [] = return maxfd
-buildFdSets maxfd readfds writefds (Read fd m : reqs)
- | fd >= fD_SETSIZE = error "buildFdSets: file descriptor out of range"
- | otherwise = do
- fdSet fd readfds
- buildFdSets (max maxfd fd) readfds writefds reqs
-buildFdSets maxfd readfds writefds (Write fd m : reqs)
- | fd >= fD_SETSIZE = error "buildFdSets: file descriptor out of range"
- | otherwise = do
- fdSet fd writefds
- buildFdSets (max maxfd fd) readfds writefds reqs
-
-completeRequests [] _ _ reqs' = return reqs'
-completeRequests (Read fd m : reqs) readfds writefds reqs' = do
- b <- fdIsSet fd readfds
- if b /= 0
- then do putMVar m (); completeRequests reqs readfds writefds reqs'
- else completeRequests reqs readfds writefds (Read fd m : reqs')
-completeRequests (Write fd m : reqs) readfds writefds reqs' = do
- b <- fdIsSet fd writefds
- if b /= 0
- then do putMVar m (); completeRequests reqs readfds writefds reqs'
- else completeRequests reqs readfds writefds (Write fd m : reqs')
-
-wakeupAll [] = return ()
-wakeupAll (Read fd m : reqs) = do putMVar m (); wakeupAll reqs
-wakeupAll (Write fd m : reqs) = do putMVar m (); wakeupAll reqs
-
-waitForReadEvent :: Fd -> IO ()
-waitForReadEvent fd = do
- m <- newEmptyMVar
- atomicModifyIORef pendingEvents (\xs -> (Read fd m : xs, ()))
- prodServiceThread
- takeMVar m
-
-waitForWriteEvent :: Fd -> IO ()
-waitForWriteEvent fd = do
- m <- newEmptyMVar
- atomicModifyIORef pendingEvents (\xs -> (Write fd m : xs, ()))
- prodServiceThread
- takeMVar m
-
--- -----------------------------------------------------------------------------
--- Delays
-
--- Walk the queue of pending delays, waking up any that have passed
--- and return the smallest delay to wait for. The queue of pending
--- delays is kept ordered.
-getDelay :: USecs -> Ptr CTimeVal -> [DelayReq] -> IO ([DelayReq], Ptr CTimeVal)
-getDelay now ptimeval [] = return ([],nullPtr)
-getDelay now ptimeval all@(d : rest)
- = case d of
- Delay time m | now >= time -> do
- putMVar m ()
- getDelay now ptimeval rest
- DelaySTM time t | now >= time -> do
- atomically $ writeTVar t True
- getDelay now ptimeval rest
- _otherwise -> do
- setTimevalTicks ptimeval (delayTime d - now)
- return (all,ptimeval)
-
-newtype CTimeVal = CTimeVal ()
-
-foreign import ccall unsafe "sizeofTimeVal"
- sizeofTimeVal :: Int
-
-foreign import ccall unsafe "setTimevalTicks"
- setTimevalTicks :: Ptr CTimeVal -> USecs -> IO ()
-
-{-
- On Win32 we're going to have a single Pipe, and a
- waitForSingleObject with the delay time. For signals, we send a
- byte down the pipe just like on Unix.
--}
-
--- ----------------------------------------------------------------------------
--- select() interface
-
--- ToDo: move to System.Posix.Internals?
-
-newtype CFdSet = CFdSet ()
-
-foreign import ccall safe "select"
- c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
- -> IO CInt
-
-foreign import ccall unsafe "hsFD_SETSIZE"
- c_fD_SETSIZE :: CInt
-
-fD_SETSIZE :: Fd
-fD_SETSIZE = fromIntegral c_fD_SETSIZE
-
-foreign import ccall unsafe "hsFD_CLR"
- c_fdClr :: CInt -> Ptr CFdSet -> IO ()
-
-fdClr :: Fd -> Ptr CFdSet -> IO ()
-fdClr (Fd fd) fdset = c_fdClr fd fdset
-
-foreign import ccall unsafe "hsFD_ISSET"
- c_fdIsSet :: CInt -> Ptr CFdSet -> IO CInt
-
-fdIsSet :: Fd -> Ptr CFdSet -> IO CInt
-fdIsSet (Fd fd) fdset = c_fdIsSet fd fdset
-
-foreign import ccall unsafe "hsFD_SET"
- c_fdSet :: CInt -> Ptr CFdSet -> IO ()
-
-fdSet :: Fd -> Ptr CFdSet -> IO ()
-fdSet (Fd fd) fdset = c_fdSet fd fdset
-
-foreign import ccall unsafe "hsFD_ZERO"
- fdZero :: Ptr CFdSet -> IO ()
-
-foreign import ccall unsafe "sizeof_fd_set"
- sizeofFdSet :: Int
-
-#endif
-
-\end{code}
+++ /dev/null
-{-# OPTIONS_GHC -cpp #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.ConsoleHandler
--- Copyright : (c) The University of Glasgow
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC extensions)
---
--- NB. the contents of this module are only available on Windows.
---
--- Installing Win32 console handlers.
---
------------------------------------------------------------------------------
-
-module GHC.ConsoleHandler
-#if !defined(mingw32_HOST_OS) && !defined(__HADDOCK__)
- where
-import Prelude -- necessary to get dependencies right
-#else /* whole file */
- ( Handler(..)
- , installHandler
- , ConsoleEvent(..)
- , flushConsole
- ) where
-
-{-
-#include "Signals.h"
--}
-
-import Prelude -- necessary to get dependencies right
-
-import Foreign
-import Foreign.C
-import GHC.IOBase
-import GHC.Handle
-import Data.Typeable
-
-data Handler
- = Default
- | Ignore
- | Catch (ConsoleEvent -> IO ())
-
-data ConsoleEvent
- = ControlC
- | Break
- | Close
- -- these are sent to Services only.
- | Logoff
- | Shutdown
- deriving (Eq, Ord, Enum, Show, Read, Typeable)
-
--- | Allows Windows console events to be caught and handled. To
--- handle a console event, call 'installHandler' passing the
--- appropriate 'Handler' value. When the event is received, if the
--- 'Handler' value is @Catch f@, then a new thread will be spawned by
--- the system to execute @f e@, where @e@ is the 'ConsoleEvent' that
--- was received.
---
--- Note that console events can only be received by an application
--- running in a Windows console. Certain environments that look like consoles
--- do not support console events, these include:
---
--- * Cygwin shells with @CYGWIN=tty@ set (if you don't set @CYGWIN=tty@,
--- then a Cygwin shell behaves like a Windows console).
--- * Cygwin xterm and rxvt windows
--- * MSYS rxvt windows
---
--- In order for your application to receive console events, avoid running
--- it in one of these environments.
---
-installHandler :: Handler -> IO Handler
-installHandler handler =
- alloca $ \ p_sp -> do
- rc <-
- case handler of
- Default -> rts_installHandler STG_SIG_DFL p_sp
- Ignore -> rts_installHandler STG_SIG_IGN p_sp
- Catch h -> do
- v <- newStablePtr (toHandler h)
- poke p_sp v
- rts_installHandler STG_SIG_HAN p_sp
- case rc of
- STG_SIG_DFL -> return Default
- STG_SIG_IGN -> return Ignore
- STG_SIG_HAN -> do
- osptr <- peek p_sp
- oldh <- deRefStablePtr osptr
- -- stable pointer is no longer in use, free it.
- freeStablePtr osptr
- return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
- where
- toConsoleEvent ev =
- case ev of
- 0 {- CTRL_C_EVENT-} -> Just ControlC
- 1 {- CTRL_BREAK_EVENT-} -> Just Break
- 2 {- CTRL_CLOSE_EVENT-} -> Just Close
- 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff
- 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
- _ -> Nothing
- fromConsoleEvent ev =
- case ev of
- ControlC -> 0 {- CTRL_C_EVENT-}
- Break -> 1 {- CTRL_BREAK_EVENT-}
- Close -> 2 {- CTRL_CLOSE_EVENT-}
- Logoff -> 5 {- CTRL_LOGOFF_EVENT-}
- Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
-
- toHandler hdlr ev = do
- case toConsoleEvent ev of
- -- see rts/win32/ConsoleHandler.c for comments as to why
- -- rts_ConsoleHandlerDone is called here.
- Just x -> hdlr x >> rts_ConsoleHandlerDone ev
- Nothing -> return () -- silently ignore..
-
-foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"
- rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
-foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
- rts_ConsoleHandlerDone :: CInt -> IO ()
-
-
-flushConsole :: Handle -> IO ()
-flushConsole h =
- wantReadableHandle "flushConsole" h $ \ h_ ->
- throwErrnoIfMinus1Retry_ "flushConsole"
- (flush_console_fd (fromIntegral (haFD h_)))
-
-foreign import ccall unsafe "consUtils.h flush_input_console__"
- flush_console_fd :: CInt -> IO CInt
-#endif /* mingw32_HOST_OS */
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Dotnet
--- Copyright : (c) sof, 2003
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC extensions)
---
--- Primitive operations and types for doing .NET interop
---
------------------------------------------------------------------------------
-
-module GHC.Dotnet
- ( Object
- , unmarshalObject
- , marshalObject
- , unmarshalString
- , marshalString
- , checkResult
- ) where
-
-import GHC.Prim
-import GHC.Base
-import GHC.IO
-import GHC.IOBase
-import GHC.Ptr
-import Foreign.Marshal.Array
-import Foreign.Marshal.Alloc
-import Foreign.Storable
-import Foreign.C.String
-
-data Object a
- = Object Addr#
-
-checkResult :: (State# RealWorld -> (# State# RealWorld, a, Addr# #))
- -> IO a
-checkResult fun = IO $ \ st ->
- case fun st of
- (# st1, res, err #)
- | err `eqAddr#` nullAddr# -> (# st1, res #)
- | otherwise -> throw (IOException (raiseError err)) st1
-
--- ToDo: attach finaliser.
-unmarshalObject :: Addr# -> Object a
-unmarshalObject x = Object x
-
-marshalObject :: Object a -> (Addr# -> IO b) -> IO b
-marshalObject (Object x) cont = cont x
-
--- dotnet interop support passing and returning
--- strings.
-marshalString :: String
- -> (Addr# -> IO a)
- -> IO a
-marshalString str cont = withCString str (\ (Ptr x) -> cont x)
-
--- char** received back from a .NET interop layer.
-unmarshalString :: Addr# -> String
-unmarshalString p = unsafePerformIO $ do
- let ptr = Ptr p
- str <- peekCString ptr
- free ptr
- return str
-
-
--- room for improvement..
-raiseError :: Addr# -> IOError
-raiseError p = userError (".NET error: " ++ unmarshalString p)
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Enum
--- Copyright : (c) The University of Glasgow, 1992-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC extensions)
---
--- The 'Enum' and 'Bounded' classes.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Enum(
- Bounded(..), Enum(..),
- boundedEnumFrom, boundedEnumFromThen,
-
- -- Instances for Bounded and Enum: (), Char, Int
-
- ) where
-
-import GHC.Base
-import Data.Tuple () -- for dependencies
-default () -- Double isn't available yet
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Class declarations}
-%* *
-%*********************************************************
-
-\begin{code}
--- | The 'Bounded' class is used to name the upper and lower limits of a
--- type. 'Ord' is not a superclass of 'Bounded' since types that are not
--- totally ordered may also have upper and lower bounds.
---
--- The 'Bounded' class may be derived for any enumeration type;
--- 'minBound' is the first constructor listed in the @data@ declaration
--- and 'maxBound' is the last.
--- 'Bounded' may also be derived for single-constructor datatypes whose
--- constituent types are in 'Bounded'.
-
-class Bounded a where
- minBound, maxBound :: a
-
--- | Class 'Enum' defines operations on sequentially ordered types.
---
--- The @enumFrom@... methods are used in Haskell's translation of
--- arithmetic sequences.
---
--- Instances of 'Enum' may be derived for any enumeration type (types
--- whose constructors have no fields). The nullary constructors are
--- assumed to be numbered left-to-right by 'fromEnum' from @0@ through @n-1@.
--- See Chapter 10 of the /Haskell Report/ for more details.
---
--- For any type that is an instance of class 'Bounded' as well as 'Enum',
--- the following should hold:
---
--- * The calls @'succ' 'maxBound'@ and @'pred' 'minBound'@ should result in
--- a runtime error.
---
--- * 'fromEnum' and 'toEnum' should give a runtime error if the
--- result value is not representable in the result type.
--- For example, @'toEnum' 7 :: 'Bool'@ is an error.
---
--- * 'enumFrom' and 'enumFromThen' should be defined with an implicit bound,
--- thus:
---
--- > enumFrom x = enumFromTo x maxBound
--- > enumFromThen x y = enumFromThenTo x y bound
--- > where
--- > bound | fromEnum y >= fromEnum x = maxBound
--- > | otherwise = minBound
---
-class Enum a where
- -- | the successor of a value. For numeric types, 'succ' adds 1.
- succ :: a -> a
- -- | the predecessor of a value. For numeric types, 'pred' subtracts 1.
- pred :: a -> a
- -- | Convert from an 'Int'.
- toEnum :: Int -> a
- -- | Convert to an 'Int'.
- -- It is implementation-dependent what 'fromEnum' returns when
- -- applied to a value that is too large to fit in an 'Int'.
- fromEnum :: a -> Int
-
- -- | Used in Haskell's translation of @[n..]@.
- enumFrom :: a -> [a]
- -- | Used in Haskell's translation of @[n,n'..]@.
- enumFromThen :: a -> a -> [a]
- -- | Used in Haskell's translation of @[n..m]@.
- enumFromTo :: a -> a -> [a]
- -- | Used in Haskell's translation of @[n,n'..m]@.
- enumFromThenTo :: a -> a -> a -> [a]
-
- succ = toEnum . (`plusInt` oneInt) . fromEnum
- pred = toEnum . (`minusInt` oneInt) . fromEnum
- enumFrom x = map toEnum [fromEnum x ..]
- enumFromThen x y = map toEnum [fromEnum x, fromEnum y ..]
- enumFromTo x y = map toEnum [fromEnum x .. fromEnum y]
- enumFromThenTo x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y]
-
--- Default methods for bounded enumerations
-boundedEnumFrom :: (Enum a, Bounded a) => a -> [a]
-boundedEnumFrom n = map toEnum [fromEnum n .. fromEnum (maxBound `asTypeOf` n)]
-
-boundedEnumFromThen :: (Enum a, Bounded a) => a -> a -> [a]
-boundedEnumFromThen n1 n2
- | i_n2 >= i_n1 = map toEnum [i_n1, i_n2 .. fromEnum (maxBound `asTypeOf` n1)]
- | otherwise = map toEnum [i_n1, i_n2 .. fromEnum (minBound `asTypeOf` n1)]
- where
- i_n1 = fromEnum n1
- i_n2 = fromEnum n2
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Tuples}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Bounded () where
- minBound = ()
- maxBound = ()
-
-instance Enum () where
- succ _ = error "Prelude.Enum.().succ: bad argument"
- pred _ = error "Prelude.Enum.().pred: bad argument"
-
- toEnum x | x == zeroInt = ()
- | otherwise = error "Prelude.Enum.().toEnum: bad argument"
-
- fromEnum () = zeroInt
- enumFrom () = [()]
- enumFromThen () () = let many = ():many in many
- enumFromTo () () = [()]
- enumFromThenTo () () () = let many = ():many in many
-\end{code}
-
-\begin{code}
--- Report requires instances up to 15
-instance (Bounded a, Bounded b) => Bounded (a,b) where
- minBound = (minBound, minBound)
- maxBound = (maxBound, maxBound)
-
-instance (Bounded a, Bounded b, Bounded c) => Bounded (a,b,c) where
- minBound = (minBound, minBound, minBound)
- maxBound = (maxBound, maxBound, maxBound)
-
-instance (Bounded a, Bounded b, Bounded c, Bounded d) => Bounded (a,b,c,d) where
- minBound = (minBound, minBound, minBound, minBound)
- maxBound = (maxBound, maxBound, maxBound, maxBound)
-
-instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e) => Bounded (a,b,c,d,e) where
- minBound = (minBound, minBound, minBound, minBound, minBound)
- maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound)
-
-instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f)
- => Bounded (a,b,c,d,e,f) where
- minBound = (minBound, minBound, minBound, minBound, minBound, minBound)
- maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)
-
-instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g)
- => Bounded (a,b,c,d,e,f,g) where
- minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound)
- maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)
-
-instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h)
- => Bounded (a,b,c,d,e,f,g,h) where
- minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound)
- maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)
-
-instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i)
- => Bounded (a,b,c,d,e,f,g,h,i) where
- minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound)
- maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound)
-
-instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i, Bounded j)
- => Bounded (a,b,c,d,e,f,g,h,i,j) where
- minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound, minBound)
- maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound, maxBound)
-
-instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i, Bounded j, Bounded k)
- => Bounded (a,b,c,d,e,f,g,h,i,j,k) where
- minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound, minBound, minBound)
- maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound, maxBound, maxBound)
-
-instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i, Bounded j, Bounded k, Bounded l)
- => Bounded (a,b,c,d,e,f,g,h,i,j,k,l) where
- minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound, minBound, minBound, minBound)
- maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound, maxBound, maxBound, maxBound)
-
-instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m)
- => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m) where
- minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound, minBound, minBound, minBound, minBound)
- maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound, maxBound, maxBound, maxBound, maxBound)
-
-instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m, Bounded n)
- => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
- minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound, minBound, minBound, minBound, minBound, minBound)
- maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)
-
-instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m, Bounded n, Bounded o)
- => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
- minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound, minBound, minBound, minBound, minBound, minBound, minBound)
- maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Type @Bool@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Bounded Bool where
- minBound = False
- maxBound = True
-
-instance Enum Bool where
- succ False = True
- succ True = error "Prelude.Enum.Bool.succ: bad argument"
-
- pred True = False
- pred False = error "Prelude.Enum.Bool.pred: bad argument"
-
- toEnum n | n == zeroInt = False
- | n == oneInt = True
- | otherwise = error "Prelude.Enum.Bool.toEnum: bad argument"
-
- fromEnum False = zeroInt
- fromEnum True = oneInt
-
- -- Use defaults for the rest
- enumFrom = boundedEnumFrom
- enumFromThen = boundedEnumFromThen
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Type @Ordering@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Bounded Ordering where
- minBound = LT
- maxBound = GT
-
-instance Enum Ordering where
- succ LT = EQ
- succ EQ = GT
- succ GT = error "Prelude.Enum.Ordering.succ: bad argument"
-
- pred GT = EQ
- pred EQ = LT
- pred LT = error "Prelude.Enum.Ordering.pred: bad argument"
-
- toEnum n | n == zeroInt = LT
- | n == oneInt = EQ
- | n == twoInt = GT
- toEnum _ = error "Prelude.Enum.Ordering.toEnum: bad argument"
-
- fromEnum LT = zeroInt
- fromEnum EQ = oneInt
- fromEnum GT = twoInt
-
- -- Use defaults for the rest
- enumFrom = boundedEnumFrom
- enumFromThen = boundedEnumFromThen
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Type @Char@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Bounded Char where
- minBound = '\0'
- maxBound = '\x10FFFF'
-
-instance Enum Char where
- succ (C# c#)
- | not (ord# c# ==# 0x10FFFF#) = C# (chr# (ord# c# +# 1#))
- | otherwise = error ("Prelude.Enum.Char.succ: bad argument")
- pred (C# c#)
- | not (ord# c# ==# 0#) = C# (chr# (ord# c# -# 1#))
- | otherwise = error ("Prelude.Enum.Char.pred: bad argument")
-
- toEnum = chr
- fromEnum = ord
-
- {-# INLINE enumFrom #-}
- enumFrom (C# x) = eftChar (ord# x) 0x10FFFF#
- -- Blarg: technically I guess enumFrom isn't strict!
-
- {-# INLINE enumFromTo #-}
- enumFromTo (C# x) (C# y) = eftChar (ord# x) (ord# y)
-
- {-# INLINE enumFromThen #-}
- enumFromThen (C# x1) (C# x2) = efdChar (ord# x1) (ord# x2)
-
- {-# INLINE enumFromThenTo #-}
- enumFromThenTo (C# x1) (C# x2) (C# y) = efdtChar (ord# x1) (ord# x2) (ord# y)
-
-{-# RULES
-"eftChar" [~1] forall x y. eftChar x y = build (\c n -> eftCharFB c n x y)
-"efdChar" [~1] forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2)
-"efdtChar" [~1] forall x1 x2 l. efdtChar x1 x2 l = build (\ c n -> efdtCharFB c n x1 x2 l)
-"eftCharList" [1] eftCharFB (:) [] = eftChar
-"efdCharList" [1] efdCharFB (:) [] = efdChar
-"efdtCharList" [1] efdtCharFB (:) [] = efdtChar
- #-}
-
-
--- We can do better than for Ints because we don't
--- have hassles about arithmetic overflow at maxBound
-{-# INLINE [0] eftCharFB #-}
-eftCharFB c n x y = go x
- where
- go x | x ># y = n
- | otherwise = C# (chr# x) `c` go (x +# 1#)
-
-eftChar x y | x ># y = []
- | otherwise = C# (chr# x) : eftChar (x +# 1#) y
-
-
--- For enumFromThenTo we give up on inlining
-{-# NOINLINE [0] efdCharFB #-}
-efdCharFB c n x1 x2
- | delta >=# 0# = go_up_char_fb c n x1 delta 0x10FFFF#
- | otherwise = go_dn_char_fb c n x1 delta 0#
- where
- delta = x2 -# x1
-
-efdChar x1 x2
- | delta >=# 0# = go_up_char_list x1 delta 0x10FFFF#
- | otherwise = go_dn_char_list x1 delta 0#
- where
- delta = x2 -# x1
-
-{-# NOINLINE [0] efdtCharFB #-}
-efdtCharFB c n x1 x2 lim
- | delta >=# 0# = go_up_char_fb c n x1 delta lim
- | otherwise = go_dn_char_fb c n x1 delta lim
- where
- delta = x2 -# x1
-
-efdtChar x1 x2 lim
- | delta >=# 0# = go_up_char_list x1 delta lim
- | otherwise = go_dn_char_list x1 delta lim
- where
- delta = x2 -# x1
-
-go_up_char_fb c n x delta lim
- = go_up x
- where
- go_up x | x ># lim = n
- | otherwise = C# (chr# x) `c` go_up (x +# delta)
-
-go_dn_char_fb c n x delta lim
- = go_dn x
- where
- go_dn x | x <# lim = n
- | otherwise = C# (chr# x) `c` go_dn (x +# delta)
-
-go_up_char_list x delta lim
- = go_up x
- where
- go_up x | x ># lim = []
- | otherwise = C# (chr# x) : go_up (x +# delta)
-
-go_dn_char_list x delta lim
- = go_dn x
- where
- go_dn x | x <# lim = []
- | otherwise = C# (chr# x) : go_dn (x +# delta)
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Type @Int@}
-%* *
-%*********************************************************
-
-Be careful about these instances.
- (a) remember that you have to count down as well as up e.g. [13,12..0]
- (b) be careful of Int overflow
- (c) remember that Int is bounded, so [1..] terminates at maxInt
-
-Also NB that the Num class isn't available in this module.
-
-\begin{code}
-instance Bounded Int where
- minBound = minInt
- maxBound = maxInt
-
-instance Enum Int where
- succ x
- | x == maxBound = error "Prelude.Enum.succ{Int}: tried to take `succ' of maxBound"
- | otherwise = x `plusInt` oneInt
- pred x
- | x == minBound = error "Prelude.Enum.pred{Int}: tried to take `pred' of minBound"
- | otherwise = x `minusInt` oneInt
-
- toEnum x = x
- fromEnum x = x
-
- {-# INLINE enumFrom #-}
- enumFrom (I# x) = eftInt x maxInt#
- where I# maxInt# = maxInt
- -- Blarg: technically I guess enumFrom isn't strict!
-
- {-# INLINE enumFromTo #-}
- enumFromTo (I# x) (I# y) = eftInt x y
-
- {-# INLINE enumFromThen #-}
- enumFromThen (I# x1) (I# x2) = efdInt x1 x2
-
- {-# INLINE enumFromThenTo #-}
- enumFromThenTo (I# x1) (I# x2) (I# y) = efdtInt x1 x2 y
-
-
------------------------------------------------------
--- eftInt and eftIntFB deal with [a..b], which is the
--- most common form, so we take a lot of care
--- In particular, we have rules for deforestation
-
-{-# RULES
-"eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
-"eftIntList" [1] eftIntFB (:) [] = eftInt
- #-}
-
-eftInt :: Int# -> Int# -> [Int]
--- [x1..x2]
-eftInt x y | x ># y = []
- | otherwise = go x
- where
- go x = I# x : if x ==# y then [] else go (x +# 1#)
-
-{-# INLINE [0] eftIntFB #-}
-eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
-eftIntFB c n x y | x ># y = n
- | otherwise = go x
- where
- go x = I# x `c` if x ==# y then n else go (x +# 1#)
- -- Watch out for y=maxBound; hence ==, not >
- -- Be very careful not to have more than one "c"
- -- so that when eftInfFB is inlined we can inline
- -- whatver is bound to "c"
-
-
------------------------------------------------------
--- efdInt and efdtInt deal with [a,b..] and [a,b..c], which are much less common
--- so we are less elaborate. The code is more complicated anyway, because
--- of worries about Int overflow, so we don't both with rules and deforestation
-
-efdInt :: Int# -> Int# -> [Int]
--- [x1,x2..maxInt]
-efdInt x1 x2
- | x2 >=# x1 = case maxInt of I# y -> efdtIntUp x1 x2 y
- | otherwise = case minInt of I# y -> efdtIntDn x1 x2 y
-
-efdtInt :: Int# -> Int# -> Int# -> [Int]
--- [x1,x2..y]
-efdtInt x1 x2 y
- | x2 >=# x1 = efdtIntUp x1 x2 y
- | otherwise = efdtIntDn x1 x2 y
-
-efdtIntUp :: Int# -> Int# -> Int# -> [Int]
-efdtIntUp x1 x2 y -- Be careful about overflow!
- | y <# x2 = if y <# x1 then [] else [I# x1]
- | otherwise
- = -- Common case: x1 < x2 <= y
- let
- delta = x2 -# x1
- y' = y -# delta
- -- NB: x1 <= y'; hence y' is representable
-
- -- Invariant: x <= y; and x+delta won't overflow
- go_up x | x ># y' = [I# x]
- | otherwise = I# x : go_up (x +# delta)
- in
- I# x1 : go_up x2
-
-efdtIntDn :: Int# -> Int# -> Int# -> [Int]
-efdtIntDn x1 x2 y -- x2 < x1
- | y ># x2 = if y ># x1 then [] else [I# x1]
- | otherwise
- = -- Common case: x1 > x2 >= y
- let
- delta = x2 -# x1
- y' = y -# delta
- -- NB: x1 <= y'; hence y' is representable
-
- -- Invariant: x >= y; and x+delta won't overflow
- go_dn x | x <# y' = [I# x]
- | otherwise = I# x : go_dn (x +# delta)
- in
- I# x1 : go_dn x2
-\end{code}
-
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Err
--- Copyright : (c) The University of Glasgow, 1994-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC extensions)
---
--- The "GHC.Err" module defines the code for the wired-in error functions,
--- which have a special type in the compiler (with \"open tyvars\").
---
--- We cannot define these functions in a module where they might be used
--- (e.g., "GHC.Base"), because the magical wired-in type will get confused
--- with what the typechecker figures out.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Err
- (
- irrefutPatError
- , noMethodBindingError
- , nonExhaustiveGuardsError
- , patError
- , recSelError
- , recConError
- , runtimeError -- :: Addr# -> a -- Addr# points to UTF8 encoded C string
-
- , absentErr -- :: a
- , divZeroError -- :: a
- , overflowError -- :: a
-
- , error -- :: String -> a
- , assertError -- :: String -> Bool -> a -> a
-
- , undefined -- :: a
- ) where
-
-#ifndef __HADDOCK__
-import GHC.Base
-import GHC.List ( span )
-import GHC.Exception
-#endif
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Error-ish functions}
-%* *
-%*********************************************************
-
-\begin{code}
--- | 'error' stops execution and displays an error message.
-error :: String -> a
-error s = throw (ErrorCall s)
-
--- | A special case of 'error'.
--- It is expected that compilers will recognize this and insert error
--- messages which are more appropriate to the context in which 'undefined'
--- appears.
-
-undefined :: a
-undefined = error "Prelude.undefined"
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Compiler generated errors + local utils}
-%* *
-%*********************************************************
-
-Used for compiler-generated error message;
-encoding saves bytes of string junk.
-
-\begin{code}
-absentErr :: a
-
-absentErr = error "Oops! The program has entered an `absent' argument!\n"
-\end{code}
-
-\begin{code}
-recSelError, recConError, irrefutPatError, runtimeError,
- nonExhaustiveGuardsError, patError, noMethodBindingError
- :: Addr# -> a -- All take a UTF8-encoded C string
-
-recSelError s = throw (RecSelError (unpackCStringUtf8# s)) -- No location info unfortunately
-runtimeError s = error (unpackCStringUtf8# s) -- No location info unfortunately
-
-nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))
-irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
-recConError s = throw (RecConError (untangle s "Missing field in record construction"))
-noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
-patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
-
-assertError :: Addr# -> Bool -> a -> a
-assertError str pred v
- | pred = v
- | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
-\end{code}
-
-
-(untangle coded message) expects "coded" to be of the form
-
- "location|details"
-
-It prints
-
- location message details
-
-\begin{code}
-untangle :: Addr# -> String -> String
-untangle coded message
- = location
- ++ ": "
- ++ message
- ++ details
- ++ "\n"
- where
- coded_str = unpackCStringUtf8# coded
-
- (location, details)
- = case (span not_bar coded_str) of { (loc, rest) ->
- case rest of
- ('|':det) -> (loc, ' ' : det)
- _ -> (loc, "")
- }
- not_bar c = c /= '|'
-\end{code}
-
-Divide by zero and arithmetic overflow.
-We put them here because they are needed relatively early
-in the libraries before the Exception type has been defined yet.
-
-\begin{code}
-{-# NOINLINE divZeroError #-}
-divZeroError :: a
-divZeroError = throw (ArithException DivideByZero)
-
-{-# NOINLINE overflowError #-}
-overflowError :: a
-overflowError = throw (ArithException Overflow)
-\end{code}
-
+++ /dev/null
-\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
----------------------------------------------------------------------------
--- Ghc.Err.hs-boot
----------------------------------------------------------------------------
-
-module GHC.Err( error, divZeroError, overflowError ) where
-
--- The type signature for 'error' is a gross hack.
--- First, we can't give an accurate type for error, because it mentions
--- an open type variable.
--- Second, we can't even say error :: [Char] -> a, because Char is defined
--- in GHC.Base, and that would make Err.lhs-boot mutually recursive
--- with GHC.Base.
--- Fortunately it doesn't matter what type we give here because the
--- compiler will use its wired-in version. But we have
--- to mention 'error' so that it gets exported from this .hi-boot
--- file.
-error :: a
-
--- divide by zero is needed quite early
-divZeroError :: a
-
--- overflow is needed quite early
-overflowError :: a
-\end{code}
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Exception
--- Copyright : (c) The University of Glasgow, 1998-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC extensions)
---
--- Exceptions and exception-handling functions.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Exception
- ( module GHC.Exception,
- Exception(..), AsyncException(..),
- IOException(..), ArithException(..), ArrayException(..),
- throw, throwIO, ioError )
- where
-
-import GHC.Base
-import GHC.IOBase
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Primitive catch}
-%* *
-%*********************************************************
-
-catchException used to handle the passing around of the state to the
-action and the handler. This turned out to be a bad idea - it meant
-that we had to wrap both arguments in thunks so they could be entered
-as normal (remember IO returns an unboxed pair...).
-
-Now catch# has type
-
- catch# :: IO a -> (b -> IO a) -> IO a
-
-(well almost; the compiler doesn't know about the IO newtype so we
-have to work around that in the definition of catchException below).
-
-\begin{code}
-catchException :: IO a -> (Exception -> IO a) -> IO a
-catchException (IO m) k = IO $ \s -> catch# m (\ex -> unIO (k ex)) s
-
--- | The 'catch' function establishes a handler that receives any 'IOError'
--- raised in the action protected by 'catch'. An 'IOError' is caught by
--- the most recent handler established by 'catch'. These handlers are
--- not selective: all 'IOError's are caught. Exception propagation
--- must be explicitly provided in a handler by re-raising any unwanted
--- exceptions. For example, in
---
--- > f = catch g (\e -> if IO.isEOFError e then return [] else ioError e)
---
--- the function @f@ returns @[]@ when an end-of-file exception
--- (cf. 'System.IO.Error.isEOFError') occurs in @g@; otherwise, the
--- exception is propagated to the next outer handler.
---
--- When an exception propagates outside the main program, the Haskell
--- system prints the associated 'IOError' value and exits the program.
---
--- Non-I\/O exceptions are not caught by this variant; to catch all
--- exceptions, use 'Control.Exception.catch' from "Control.Exception".
-catch :: IO a -> (IOError -> IO a) -> IO a
-catch m k = catchException m handler
- where handler (IOException err) = k err
- handler other = throw other
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Controlling asynchronous exception delivery}
-%* *
-%*********************************************************
-
-\begin{code}
--- | Applying 'block' to a computation will
--- execute that computation with asynchronous exceptions
--- /blocked/. That is, any thread which
--- attempts to raise an exception in the current thread will be
--- blocked until asynchronous exceptions are enabled again. There\'s
--- no need to worry about re-enabling asynchronous exceptions; that is
--- done automatically on exiting the scope of
--- 'block'.
-block :: IO a -> IO a
-
--- | To re-enable asynchronous exceptions inside the scope of
--- 'block', 'unblock' can be
--- used. It scopes in exactly the same way, so on exit from
--- 'unblock' asynchronous exception delivery will
--- be disabled again.
-unblock :: IO a -> IO a
-
-block (IO io) = IO $ blockAsyncExceptions# io
-unblock (IO io) = IO $ unblockAsyncExceptions# io
-\end{code}
-
-\begin{code}
--- | Forces its argument to be evaluated when the resultant 'IO' action
--- is executed. It can be used to order evaluation with respect to
--- other 'IO' operations; its semantics are given by
---
--- > evaluate x `seq` y ==> y
--- > evaluate x `catch` f ==> (return $! x) `catch` f
--- > evaluate x >>= f ==> (return $! x) >>= f
---
--- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the
--- same as @(return $! x)@. A correct definition is
---
--- > evaluate x = (return $! x) >>= return
---
-evaluate :: a -> IO a
-evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #)
- -- NB. can't write
- -- a `seq` (# s, a #)
- -- because we can't have an unboxed tuple as a function argument
-\end{code}
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : GHC.Exts
--- Copyright : (c) The University of Glasgow 2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- GHC Extensions: this is the Approved Way to get at GHC-specific extensions.
---
------------------------------------------------------------------------------
-
-module GHC.Exts
- (
- -- * Representations of some basic types
- Int(..),Word(..),Float(..),Double(..),Integer(..),Char(..),
- Ptr(..), FunPtr(..),
-
- -- * Primitive operations
- module GHC.Prim,
- shiftL#, shiftRL#, iShiftL#, iShiftRA#, iShiftRL#,
-
- -- * Fusion
- build, augment,
-
- -- * Overloaded string literals
- IsString(..),
-
- -- * Debugging
- breakpoint, breakpointCond,
-
- -- * Ids with special behaviour
- lazy, inline,
-
- ) where
-
-import Prelude
-
-import GHC.Prim
-import GHC.Base
-import GHC.Word
-import GHC.Num
-import GHC.Float
-import GHC.Ptr
-import Data.String
-
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Float
--- Copyright : (c) The University of Glasgow 1994-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- The types 'Float' and 'Double', and the classes 'Floating' and 'RealFloat'.
---
------------------------------------------------------------------------------
-
-#include "ieee-flpt.h"
-
--- #hide
-module GHC.Float( module GHC.Float, Float#, Double# ) where
-
-import Data.Maybe
-
-import GHC.Base
-import GHC.List
-import GHC.Enum
-import GHC.Show
-import GHC.Num
-import GHC.Real
-import GHC.Arr
-
-infixr 8 **
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Standard numeric classes}
-%* *
-%*********************************************************
-
-\begin{code}
--- | Trigonometric and hyperbolic functions and related functions.
---
--- Minimal complete definition:
--- 'pi', 'exp', 'log', 'sin', 'cos', 'sinh', 'cosh',
--- 'asin', 'acos', 'atan', 'asinh', 'acosh' and 'atanh'
-class (Fractional a) => Floating a where
- pi :: a
- exp, log, sqrt :: a -> a
- (**), logBase :: a -> a -> a
- sin, cos, tan :: a -> a
- asin, acos, atan :: a -> a
- sinh, cosh, tanh :: a -> a
- asinh, acosh, atanh :: a -> a
-
- x ** y = exp (log x * y)
- logBase x y = log y / log x
- sqrt x = x ** 0.5
- tan x = sin x / cos x
- tanh x = sinh x / cosh x
-
--- | Efficient, machine-independent access to the components of a
--- floating-point number.
---
--- Minimal complete definition:
--- all except 'exponent', 'significand', 'scaleFloat' and 'atan2'
-class (RealFrac a, Floating a) => RealFloat a where
- -- | a constant function, returning the radix of the representation
- -- (often @2@)
- floatRadix :: a -> Integer
- -- | a constant function, returning the number of digits of
- -- 'floatRadix' in the significand
- floatDigits :: a -> Int
- -- | a constant function, returning the lowest and highest values
- -- the exponent may assume
- floatRange :: a -> (Int,Int)
- -- | The function 'decodeFloat' applied to a real floating-point
- -- number returns the significand expressed as an 'Integer' and an
- -- appropriately scaled exponent (an 'Int'). If @'decodeFloat' x@
- -- yields @(m,n)@, then @x@ is equal in value to @m*b^^n@, where @b@
- -- is the floating-point radix, and furthermore, either @m@ and @n@
- -- are both zero or else @b^(d-1) <= m < b^d@, where @d@ is the value
- -- of @'floatDigits' x@. In particular, @'decodeFloat' 0 = (0,0)@.
- decodeFloat :: a -> (Integer,Int)
- -- | 'encodeFloat' performs the inverse of 'decodeFloat'
- encodeFloat :: Integer -> Int -> a
- -- | the second component of 'decodeFloat'.
- exponent :: a -> Int
- -- | the first component of 'decodeFloat', scaled to lie in the open
- -- interval (@-1@,@1@)
- significand :: a -> a
- -- | multiplies a floating-point number by an integer power of the radix
- scaleFloat :: Int -> a -> a
- -- | 'True' if the argument is an IEEE \"not-a-number\" (NaN) value
- isNaN :: a -> Bool
- -- | 'True' if the argument is an IEEE infinity or negative infinity
- isInfinite :: a -> Bool
- -- | 'True' if the argument is too small to be represented in
- -- normalized format
- isDenormalized :: a -> Bool
- -- | 'True' if the argument is an IEEE negative zero
- isNegativeZero :: a -> Bool
- -- | 'True' if the argument is an IEEE floating point number
- isIEEE :: a -> Bool
- -- | a version of arctangent taking two real floating-point arguments.
- -- For real floating @x@ and @y@, @'atan2' y x@ computes the angle
- -- (from the positive x-axis) of the vector from the origin to the
- -- point @(x,y)@. @'atan2' y x@ returns a value in the range [@-pi@,
- -- @pi@]. It follows the Common Lisp semantics for the origin when
- -- signed zeroes are supported. @'atan2' y 1@, with @y@ in a type
- -- that is 'RealFloat', should return the same value as @'atan' y@.
- -- A default definition of 'atan2' is provided, but implementors
- -- can provide a more accurate implementation.
- atan2 :: a -> a -> a
-
-
- exponent x = if m == 0 then 0 else n + floatDigits x
- where (m,n) = decodeFloat x
-
- significand x = encodeFloat m (negate (floatDigits x))
- where (m,_) = decodeFloat x
-
- scaleFloat k x = encodeFloat m (n+k)
- where (m,n) = decodeFloat x
-
- atan2 y x
- | x > 0 = atan (y/x)
- | x == 0 && y > 0 = pi/2
- | x < 0 && y > 0 = pi + atan (y/x)
- |(x <= 0 && y < 0) ||
- (x < 0 && isNegativeZero y) ||
- (isNegativeZero x && isNegativeZero y)
- = -atan2 (-y) x
- | y == 0 && (x < 0 || isNegativeZero x)
- = pi -- must be after the previous test on zero y
- | x==0 && y==0 = y -- must be after the other double zero tests
- | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Type @Integer@, @Float@, @Double@}
-%* *
-%*********************************************************
-
-\begin{code}
--- | Single-precision floating point numbers.
--- It is desirable that this type be at least equal in range and precision
--- to the IEEE single-precision type.
-data Float = F# Float#
-
--- | Double-precision floating point numbers.
--- It is desirable that this type be at least equal in range and precision
--- to the IEEE double-precision type.
-data Double = D# Double#
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Type @Float@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Eq Float where
- (F# x) == (F# y) = x `eqFloat#` y
-
-instance Ord Float where
- (F# x) `compare` (F# y) | x `ltFloat#` y = LT
- | x `eqFloat#` y = EQ
- | otherwise = GT
-
- (F# x) < (F# y) = x `ltFloat#` y
- (F# x) <= (F# y) = x `leFloat#` y
- (F# x) >= (F# y) = x `geFloat#` y
- (F# x) > (F# y) = x `gtFloat#` y
-
-instance Num Float where
- (+) x y = plusFloat x y
- (-) x y = minusFloat x y
- negate x = negateFloat x
- (*) x y = timesFloat x y
- abs x | x >= 0.0 = x
- | otherwise = negateFloat x
- signum x | x == 0.0 = 0
- | x > 0.0 = 1
- | otherwise = negate 1
-
- {-# INLINE fromInteger #-}
- fromInteger (S# i#) = case (int2Float# i#) of { d# -> F# d# }
- fromInteger (J# s# d#) = encodeFloat# s# d# 0
- -- previous code: fromInteger n = encodeFloat n 0
- -- doesn't work too well, because encodeFloat is defined in
- -- terms of ccalls which can never be simplified away. We
- -- want simple literals like (fromInteger 3 :: Float) to turn
- -- into (F# 3.0), hence the special case for S# here.
-
-instance Real Float where
- toRational x = (m%1)*(b%1)^^n
- where (m,n) = decodeFloat x
- b = floatRadix x
-
-instance Fractional Float where
- (/) x y = divideFloat x y
- fromRational x = fromRat x
- recip x = 1.0 / x
-
-{-# RULES "truncate/Float->Int" truncate = float2Int #-}
-instance RealFrac Float where
-
- {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-}
- {-# SPECIALIZE round :: Float -> Int #-}
-
- {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-}
- {-# SPECIALIZE round :: Float -> Integer #-}
-
- -- ceiling, floor, and truncate are all small
- {-# INLINE ceiling #-}
- {-# INLINE floor #-}
- {-# INLINE truncate #-}
-
- properFraction x
- = case (decodeFloat x) of { (m,n) ->
- let b = floatRadix x in
- if n >= 0 then
- (fromInteger m * fromInteger b ^ n, 0.0)
- else
- case (quotRem m (b^(negate n))) of { (w,r) ->
- (fromInteger w, encodeFloat r n)
- }
- }
-
- truncate x = case properFraction x of
- (n,_) -> n
-
- round x = case properFraction x of
- (n,r) -> let
- m = if r < 0.0 then n - 1 else n + 1
- half_down = abs r - 0.5
- in
- case (compare half_down 0.0) of
- LT -> n
- EQ -> if even n then n else m
- GT -> m
-
- ceiling x = case properFraction x of
- (n,r) -> if r > 0.0 then n + 1 else n
-
- floor x = case properFraction x of
- (n,r) -> if r < 0.0 then n - 1 else n
-
-instance Floating Float where
- pi = 3.141592653589793238
- exp x = expFloat x
- log x = logFloat x
- sqrt x = sqrtFloat x
- sin x = sinFloat x
- cos x = cosFloat x
- tan x = tanFloat x
- asin x = asinFloat x
- acos x = acosFloat x
- atan x = atanFloat x
- sinh x = sinhFloat x
- cosh x = coshFloat x
- tanh x = tanhFloat x
- (**) x y = powerFloat x y
- logBase x y = log y / log x
-
- asinh x = log (x + sqrt (1.0+x*x))
- acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
- atanh x = log ((x+1.0) / sqrt (1.0-x*x))
-
-instance RealFloat Float where
- floatRadix _ = FLT_RADIX -- from float.h
- floatDigits _ = FLT_MANT_DIG -- ditto
- floatRange _ = (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto
-
- decodeFloat (F# f#)
- = case decodeFloat# f# of
- (# exp#, s#, d# #) -> (J# s# d#, I# exp#)
-
- encodeFloat (S# i) j = int_encodeFloat# i j
- encodeFloat (J# s# d#) e = encodeFloat# s# d# e
-
- exponent x = case decodeFloat x of
- (m,n) -> if m == 0 then 0 else n + floatDigits x
-
- significand x = case decodeFloat x of
- (m,_) -> encodeFloat m (negate (floatDigits x))
-
- scaleFloat k x = case decodeFloat x of
- (m,n) -> encodeFloat m (n+k)
- isNaN x = 0 /= isFloatNaN x
- isInfinite x = 0 /= isFloatInfinite x
- isDenormalized x = 0 /= isFloatDenormalized x
- isNegativeZero x = 0 /= isFloatNegativeZero x
- isIEEE _ = True
-
-instance Show Float where
- showsPrec x = showSigned showFloat x
- showList = showList__ (showsPrec 0)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Type @Double@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Eq Double where
- (D# x) == (D# y) = x ==## y
-
-instance Ord Double where
- (D# x) `compare` (D# y) | x <## y = LT
- | x ==## y = EQ
- | otherwise = GT
-
- (D# x) < (D# y) = x <## y
- (D# x) <= (D# y) = x <=## y
- (D# x) >= (D# y) = x >=## y
- (D# x) > (D# y) = x >## y
-
-instance Num Double where
- (+) x y = plusDouble x y
- (-) x y = minusDouble x y
- negate x = negateDouble x
- (*) x y = timesDouble x y
- abs x | x >= 0.0 = x
- | otherwise = negateDouble x
- signum x | x == 0.0 = 0
- | x > 0.0 = 1
- | otherwise = negate 1
-
- {-# INLINE fromInteger #-}
- -- See comments with Num Float
- fromInteger (S# i#) = case (int2Double# i#) of { d# -> D# d# }
- fromInteger (J# s# d#) = encodeDouble# s# d# 0
-
-
-instance Real Double where
- toRational x = (m%1)*(b%1)^^n
- where (m,n) = decodeFloat x
- b = floatRadix x
-
-instance Fractional Double where
- (/) x y = divideDouble x y
- fromRational x = fromRat x
- recip x = 1.0 / x
-
-instance Floating Double where
- pi = 3.141592653589793238
- exp x = expDouble x
- log x = logDouble x
- sqrt x = sqrtDouble x
- sin x = sinDouble x
- cos x = cosDouble x
- tan x = tanDouble x
- asin x = asinDouble x
- acos x = acosDouble x
- atan x = atanDouble x
- sinh x = sinhDouble x
- cosh x = coshDouble x
- tanh x = tanhDouble x
- (**) x y = powerDouble x y
- logBase x y = log y / log x
-
- asinh x = log (x + sqrt (1.0+x*x))
- acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
- atanh x = log ((x+1.0) / sqrt (1.0-x*x))
-
-{-# RULES "truncate/Double->Int" truncate = double2Int #-}
-instance RealFrac Double where
-
- {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-}
- {-# SPECIALIZE round :: Double -> Int #-}
-
- {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-}
- {-# SPECIALIZE round :: Double -> Integer #-}
-
- -- ceiling, floor, and truncate are all small
- {-# INLINE ceiling #-}
- {-# INLINE floor #-}
- {-# INLINE truncate #-}
-
- properFraction x
- = case (decodeFloat x) of { (m,n) ->
- let b = floatRadix x in
- if n >= 0 then
- (fromInteger m * fromInteger b ^ n, 0.0)
- else
- case (quotRem m (b^(negate n))) of { (w,r) ->
- (fromInteger w, encodeFloat r n)
- }
- }
-
- truncate x = case properFraction x of
- (n,_) -> n
-
- round x = case properFraction x of
- (n,r) -> let
- m = if r < 0.0 then n - 1 else n + 1
- half_down = abs r - 0.5
- in
- case (compare half_down 0.0) of
- LT -> n
- EQ -> if even n then n else m
- GT -> m
-
- ceiling x = case properFraction x of
- (n,r) -> if r > 0.0 then n + 1 else n
-
- floor x = case properFraction x of
- (n,r) -> if r < 0.0 then n - 1 else n
-
-instance RealFloat Double where
- floatRadix _ = FLT_RADIX -- from float.h
- floatDigits _ = DBL_MANT_DIG -- ditto
- floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto
-
- decodeFloat (D# x#)
- = case decodeDouble# x# of
- (# exp#, s#, d# #) -> (J# s# d#, I# exp#)
-
- encodeFloat (S# i) j = int_encodeDouble# i j
- encodeFloat (J# s# d#) e = encodeDouble# s# d# e
-
- exponent x = case decodeFloat x of
- (m,n) -> if m == 0 then 0 else n + floatDigits x
-
- significand x = case decodeFloat x of
- (m,_) -> encodeFloat m (negate (floatDigits x))
-
- scaleFloat k x = case decodeFloat x of
- (m,n) -> encodeFloat m (n+k)
-
- isNaN x = 0 /= isDoubleNaN x
- isInfinite x = 0 /= isDoubleInfinite x
- isDenormalized x = 0 /= isDoubleDenormalized x
- isNegativeZero x = 0 /= isDoubleNegativeZero x
- isIEEE _ = True
-
-instance Show Double where
- showsPrec x = showSigned showFloat x
- showList = showList__ (showsPrec 0)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{@Enum@ instances}
-%* *
-%*********************************************************
-
-The @Enum@ instances for Floats and Doubles are slightly unusual.
-The @toEnum@ function truncates numbers to Int. The definitions
-of @enumFrom@ and @enumFromThen@ allow floats to be used in arithmetic
-series: [0,0.1 .. 1.0]. However, roundoff errors make these somewhat
-dubious. This example may have either 10 or 11 elements, depending on
-how 0.1 is represented.
-
-NOTE: The instances for Float and Double do not make use of the default
-methods for @enumFromTo@ and @enumFromThenTo@, as these rely on there being
-a `non-lossy' conversion to and from Ints. Instead we make use of the
-1.2 default methods (back in the days when Enum had Ord as a superclass)
-for these (@numericEnumFromTo@ and @numericEnumFromThenTo@ below.)
-
-\begin{code}
-instance Enum Float where
- succ x = x + 1
- pred x = x - 1
- toEnum = int2Float
- fromEnum = fromInteger . truncate -- may overflow
- enumFrom = numericEnumFrom
- enumFromTo = numericEnumFromTo
- enumFromThen = numericEnumFromThen
- enumFromThenTo = numericEnumFromThenTo
-
-instance Enum Double where
- succ x = x + 1
- pred x = x - 1
- toEnum = int2Double
- fromEnum = fromInteger . truncate -- may overflow
- enumFrom = numericEnumFrom
- enumFromTo = numericEnumFromTo
- enumFromThen = numericEnumFromThen
- enumFromThenTo = numericEnumFromThenTo
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Printing floating point}
-%* *
-%*********************************************************
-
-
-\begin{code}
--- | Show a signed 'RealFloat' value to full precision
--- using standard decimal notation for arguments whose absolute value lies
--- between @0.1@ and @9,999,999@, and scientific notation otherwise.
-showFloat :: (RealFloat a) => a -> ShowS
-showFloat x = showString (formatRealFloat FFGeneric Nothing x)
-
--- These are the format types. This type is not exported.
-
-data FFFormat = FFExponent | FFFixed | FFGeneric
-
-formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
-formatRealFloat fmt decs x
- | isNaN x = "NaN"
- | isInfinite x = if x < 0 then "-Infinity" else "Infinity"
- | x < 0 || isNegativeZero x = '-':doFmt fmt (floatToDigits (toInteger base) (-x))
- | otherwise = doFmt fmt (floatToDigits (toInteger base) x)
- where
- base = 10
-
- doFmt format (is, e) =
- let ds = map intToDigit is in
- case format of
- FFGeneric ->
- doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
- (is,e)
- FFExponent ->
- case decs of
- Nothing ->
- let show_e' = show (e-1) in
- case ds of
- "0" -> "0.0e0"
- [d] -> d : ".0e" ++ show_e'
- (d:ds') -> d : '.' : ds' ++ "e" ++ show_e'
- Just dec ->
- let dec' = max dec 1 in
- case is of
- [0] -> '0' :'.' : take dec' (repeat '0') ++ "e0"
- _ ->
- let
- (ei,is') = roundTo base (dec'+1) is
- (d:ds') = map intToDigit (if ei > 0 then init is' else is')
- in
- d:'.':ds' ++ 'e':show (e-1+ei)
- FFFixed ->
- let
- mk0 ls = case ls of { "" -> "0" ; _ -> ls}
- in
- case decs of
- Nothing
- | e <= 0 -> "0." ++ replicate (-e) '0' ++ ds
- | otherwise ->
- let
- f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs
- f n s "" = f (n-1) ('0':s) ""
- f n s (r:rs) = f (n-1) (r:s) rs
- in
- f e "" ds
- Just dec ->
- let dec' = max dec 0 in
- if e >= 0 then
- let
- (ei,is') = roundTo base (dec' + e) is
- (ls,rs) = splitAt (e+ei) (map intToDigit is')
- in
- mk0 ls ++ (if null rs then "" else '.':rs)
- else
- let
- (ei,is') = roundTo base dec' (replicate (-e) 0 ++ is)
- d:ds' = map intToDigit (if ei > 0 then is' else 0:is')
- in
- d : (if null ds' then "" else '.':ds')
-
-
-roundTo :: Int -> Int -> [Int] -> (Int,[Int])
-roundTo base d is =
- case f d is of
- x@(0,_) -> x
- (1,xs) -> (1, 1:xs)
- where
- b2 = base `div` 2
-
- f n [] = (0, replicate n 0)
- f 0 (x:_) = (if x >= b2 then 1 else 0, [])
- f n (i:xs)
- | i' == base = (1,0:ds)
- | otherwise = (0,i':ds)
- where
- (c,ds) = f (n-1) xs
- i' = c + i
-
--- Based on "Printing Floating-Point Numbers Quickly and Accurately"
--- by R.G. Burger and R.K. Dybvig in PLDI 96.
--- This version uses a much slower logarithm estimator. It should be improved.
-
--- | 'floatToDigits' takes a base and a non-negative 'RealFloat' number,
--- and returns a list of digits and an exponent.
--- In particular, if @x>=0@, and
---
--- > floatToDigits base x = ([d1,d2,...,dn], e)
---
--- then
---
--- (1) @n >= 1@
---
--- (2) @x = 0.d1d2...dn * (base**e)@
---
--- (3) @0 <= di <= base-1@
-
-floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
-floatToDigits _ 0 = ([0], 0)
-floatToDigits base x =
- let
- (f0, e0) = decodeFloat x
- (minExp0, _) = floatRange x
- p = floatDigits x
- b = floatRadix x
- minExp = minExp0 - p -- the real minimum exponent
- -- Haskell requires that f be adjusted so denormalized numbers
- -- will have an impossibly low exponent. Adjust for this.
- (f, e) =
- let n = minExp - e0 in
- if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
- (r, s, mUp, mDn) =
- if e >= 0 then
- let be = b^ e in
- if f == b^(p-1) then
- (f*be*b*2, 2*b, be*b, b)
- else
- (f*be*2, 2, be, be)
- else
- if e > minExp && f == b^(p-1) then
- (f*b*2, b^(-e+1)*2, b, 1)
- else
- (f*2, b^(-e)*2, 1, 1)
- k :: Int
- k =
- let
- k0 :: Int
- k0 =
- if b == 2 && base == 10 then
- -- logBase 10 2 is slightly bigger than 3/10 so
- -- the following will err on the low side. Ignoring
- -- the fraction will make it err even more.
- -- Haskell promises that p-1 <= logBase b f < p.
- (p - 1 + e0) * 3 `div` 10
- else
- ceiling ((log (fromInteger (f+1)) +
- fromInteger (int2Integer e) * log (fromInteger b)) /
- log (fromInteger base))
---WAS: fromInt e * log (fromInteger b))
-
- fixup n =
- if n >= 0 then
- if r + mUp <= expt base n * s then n else fixup (n+1)
- else
- if expt base (-n) * (r + mUp) <= s then n else fixup (n+1)
- in
- fixup k0
-
- gen ds rn sN mUpN mDnN =
- let
- (dn, rn') = (rn * base) `divMod` sN
- mUpN' = mUpN * base
- mDnN' = mDnN * base
- in
- case (rn' < mDnN', rn' + mUpN' > sN) of
- (True, False) -> dn : ds
- (False, True) -> dn+1 : ds
- (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
- (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
-
- rds =
- if k >= 0 then
- gen [] r (s * expt base k) mUp mDn
- else
- let bk = expt base (-k) in
- gen [] (r * bk) s (mUp * bk) (mDn * bk)
- in
- (map fromIntegral (reverse rds), k)
-
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Converting from a Rational to a RealFloat
-%* *
-%*********************************************************
-
-[In response to a request for documentation of how fromRational works,
-Joe Fasel writes:] A quite reasonable request! This code was added to
-the Prelude just before the 1.2 release, when Lennart, working with an
-early version of hbi, noticed that (read . show) was not the identity
-for floating-point numbers. (There was a one-bit error about half the
-time.) The original version of the conversion function was in fact
-simply a floating-point divide, as you suggest above. The new version
-is, I grant you, somewhat denser.
-
-Unfortunately, Joe's code doesn't work! Here's an example:
-
-main = putStr (shows (1.82173691287639817263897126389712638972163e-300::Double) "\n")
-
-This program prints
- 0.0000000000000000
-instead of
- 1.8217369128763981e-300
-
-Here's Joe's code:
-
-\begin{pseudocode}
-fromRat :: (RealFloat a) => Rational -> a
-fromRat x = x'
- where x' = f e
-
--- If the exponent of the nearest floating-point number to x
--- is e, then the significand is the integer nearest xb^(-e),
--- where b is the floating-point radix. We start with a good
--- guess for e, and if it is correct, the exponent of the
--- floating-point number we construct will again be e. If
--- not, one more iteration is needed.
-
- f e = if e' == e then y else f e'
- where y = encodeFloat (round (x * (1 % b)^^e)) e
- (_,e') = decodeFloat y
- b = floatRadix x'
-
--- We obtain a trial exponent by doing a floating-point
--- division of x's numerator by its denominator. The
--- result of this division may not itself be the ultimate
--- result, because of an accumulation of three rounding
--- errors.
-
- (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
- / fromInteger (denominator x))
-\end{pseudocode}
-
-Now, here's Lennart's code (which works)
-
-\begin{code}
--- | Converts a 'Rational' value into any type in class 'RealFloat'.
-{-# SPECIALISE fromRat :: Rational -> Double,
- Rational -> Float #-}
-fromRat :: (RealFloat a) => Rational -> a
-
--- Deal with special cases first, delegating the real work to fromRat'
-fromRat (n :% 0) | n > 0 = 1/0 -- +Infinity
- | n == 0 = 0/0 -- NaN
- | n < 0 = -1/0 -- -Infinity
-
-fromRat (n :% d) | n > 0 = fromRat' (n :% d)
- | n == 0 = encodeFloat 0 0 -- Zero
- | n < 0 = - fromRat' ((-n) :% d)
-
--- Conversion process:
--- Scale the rational number by the RealFloat base until
--- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).
--- Then round the rational to an Integer and encode it with the exponent
--- that we got from the scaling.
--- To speed up the scaling process we compute the log2 of the number to get
--- a first guess of the exponent.
-
-fromRat' :: (RealFloat a) => Rational -> a
--- Invariant: argument is strictly positive
-fromRat' x = r
- where b = floatRadix r
- p = floatDigits r
- (minExp0, _) = floatRange r
- minExp = minExp0 - p -- the real minimum exponent
- xMin = toRational (expt b (p-1))
- xMax = toRational (expt b p)
- p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp
- f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
- (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
- r = encodeFloat (round x') p'
-
--- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
-scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int)
-scaleRat b minExp xMin xMax p x
- | p <= minExp = (x, p)
- | x >= xMax = scaleRat b minExp xMin xMax (p+1) (x/b)
- | x < xMin = scaleRat b minExp xMin xMax (p-1) (x*b)
- | otherwise = (x, p)
-
--- Exponentiation with a cache for the most common numbers.
-minExpt, maxExpt :: Int
-minExpt = 0
-maxExpt = 1100
-
-expt :: Integer -> Int -> Integer
-expt base n =
- if base == 2 && n >= minExpt && n <= maxExpt then
- expts!n
- else
- base^n
-
-expts :: Array Int Integer
-expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
-
--- Compute the (floor of the) log of i in base b.
--- Simplest way would be just divide i by b until it's smaller then b, but that would
--- be very slow! We are just slightly more clever.
-integerLogBase :: Integer -> Integer -> Int
-integerLogBase b i
- | i < b = 0
- | otherwise = doDiv (i `div` (b^l)) l
- where
- -- Try squaring the base first to cut down the number of divisions.
- l = 2 * integerLogBase (b*b) i
-
- doDiv :: Integer -> Int -> Int
- doDiv x y
- | x < b = y
- | otherwise = doDiv (x `div` b) (y+1)
-
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Floating point numeric primops}
-%* *
-%*********************************************************
-
-Definitions of the boxed PrimOps; these will be
-used in the case of partial applications, etc.
-
-\begin{code}
-plusFloat, minusFloat, timesFloat, divideFloat :: Float -> Float -> Float
-plusFloat (F# x) (F# y) = F# (plusFloat# x y)
-minusFloat (F# x) (F# y) = F# (minusFloat# x y)
-timesFloat (F# x) (F# y) = F# (timesFloat# x y)
-divideFloat (F# x) (F# y) = F# (divideFloat# x y)
-
-negateFloat :: Float -> Float
-negateFloat (F# x) = F# (negateFloat# x)
-
-gtFloat, geFloat, eqFloat, neFloat, ltFloat, leFloat :: Float -> Float -> Bool
-gtFloat (F# x) (F# y) = gtFloat# x y
-geFloat (F# x) (F# y) = geFloat# x y
-eqFloat (F# x) (F# y) = eqFloat# x y
-neFloat (F# x) (F# y) = neFloat# x y
-ltFloat (F# x) (F# y) = ltFloat# x y
-leFloat (F# x) (F# y) = leFloat# x y
-
-float2Int :: Float -> Int
-float2Int (F# x) = I# (float2Int# x)
-
-int2Float :: Int -> Float
-int2Float (I# x) = F# (int2Float# x)
-
-expFloat, logFloat, sqrtFloat :: Float -> Float
-sinFloat, cosFloat, tanFloat :: Float -> Float
-asinFloat, acosFloat, atanFloat :: Float -> Float
-sinhFloat, coshFloat, tanhFloat :: Float -> Float
-expFloat (F# x) = F# (expFloat# x)
-logFloat (F# x) = F# (logFloat# x)
-sqrtFloat (F# x) = F# (sqrtFloat# x)
-sinFloat (F# x) = F# (sinFloat# x)
-cosFloat (F# x) = F# (cosFloat# x)
-tanFloat (F# x) = F# (tanFloat# x)
-asinFloat (F# x) = F# (asinFloat# x)
-acosFloat (F# x) = F# (acosFloat# x)
-atanFloat (F# x) = F# (atanFloat# x)
-sinhFloat (F# x) = F# (sinhFloat# x)
-coshFloat (F# x) = F# (coshFloat# x)
-tanhFloat (F# x) = F# (tanhFloat# x)
-
-powerFloat :: Float -> Float -> Float
-powerFloat (F# x) (F# y) = F# (powerFloat# x y)
-
--- definitions of the boxed PrimOps; these will be
--- used in the case of partial applications, etc.
-
-plusDouble, minusDouble, timesDouble, divideDouble :: Double -> Double -> Double
-plusDouble (D# x) (D# y) = D# (x +## y)
-minusDouble (D# x) (D# y) = D# (x -## y)
-timesDouble (D# x) (D# y) = D# (x *## y)
-divideDouble (D# x) (D# y) = D# (x /## y)
-
-negateDouble :: Double -> Double
-negateDouble (D# x) = D# (negateDouble# x)
-
-gtDouble, geDouble, eqDouble, neDouble, leDouble, ltDouble :: Double -> Double -> Bool
-gtDouble (D# x) (D# y) = x >## y
-geDouble (D# x) (D# y) = x >=## y
-eqDouble (D# x) (D# y) = x ==## y
-neDouble (D# x) (D# y) = x /=## y
-ltDouble (D# x) (D# y) = x <## y
-leDouble (D# x) (D# y) = x <=## y
-
-double2Int :: Double -> Int
-double2Int (D# x) = I# (double2Int# x)
-
-int2Double :: Int -> Double
-int2Double (I# x) = D# (int2Double# x)
-
-double2Float :: Double -> Float
-double2Float (D# x) = F# (double2Float# x)
-
-float2Double :: Float -> Double
-float2Double (F# x) = D# (float2Double# x)
-
-expDouble, logDouble, sqrtDouble :: Double -> Double
-sinDouble, cosDouble, tanDouble :: Double -> Double
-asinDouble, acosDouble, atanDouble :: Double -> Double
-sinhDouble, coshDouble, tanhDouble :: Double -> Double
-expDouble (D# x) = D# (expDouble# x)
-logDouble (D# x) = D# (logDouble# x)
-sqrtDouble (D# x) = D# (sqrtDouble# x)
-sinDouble (D# x) = D# (sinDouble# x)
-cosDouble (D# x) = D# (cosDouble# x)
-tanDouble (D# x) = D# (tanDouble# x)
-asinDouble (D# x) = D# (asinDouble# x)
-acosDouble (D# x) = D# (acosDouble# x)
-atanDouble (D# x) = D# (atanDouble# x)
-sinhDouble (D# x) = D# (sinhDouble# x)
-coshDouble (D# x) = D# (coshDouble# x)
-tanhDouble (D# x) = D# (tanhDouble# x)
-
-powerDouble :: Double -> Double -> Double
-powerDouble (D# x) (D# y) = D# (x **## y)
-\end{code}
-
-\begin{code}
-foreign import ccall unsafe "__encodeFloat"
- encodeFloat# :: Int# -> ByteArray# -> Int -> Float
-foreign import ccall unsafe "__int_encodeFloat"
- int_encodeFloat# :: Int# -> Int -> Float
-
-
-foreign import ccall unsafe "isFloatNaN" isFloatNaN :: Float -> Int
-foreign import ccall unsafe "isFloatInfinite" isFloatInfinite :: Float -> Int
-foreign import ccall unsafe "isFloatDenormalized" isFloatDenormalized :: Float -> Int
-foreign import ccall unsafe "isFloatNegativeZero" isFloatNegativeZero :: Float -> Int
-
-
-foreign import ccall unsafe "__encodeDouble"
- encodeDouble# :: Int# -> ByteArray# -> Int -> Double
-foreign import ccall unsafe "__int_encodeDouble"
- int_encodeDouble# :: Int# -> Int -> Double
-
-foreign import ccall unsafe "isDoubleNaN" isDoubleNaN :: Double -> Int
-foreign import ccall unsafe "isDoubleInfinite" isDoubleInfinite :: Double -> Int
-foreign import ccall unsafe "isDoubleDenormalized" isDoubleDenormalized :: Double -> Int
-foreign import ccall unsafe "isDoubleNegativeZero" isDoubleNegativeZero :: Double -> Int
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Coercion rules}
-%* *
-%*********************************************************
-
-\begin{code}
-{-# RULES
-"fromIntegral/Int->Float" fromIntegral = int2Float
-"fromIntegral/Int->Double" fromIntegral = int2Double
-"realToFrac/Float->Float" realToFrac = id :: Float -> Float
-"realToFrac/Float->Double" realToFrac = float2Double
-"realToFrac/Double->Float" realToFrac = double2Float
-"realToFrac/Double->Double" realToFrac = id :: Double -> Double
- #-}
-\end{code}
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.ForeignPtr
--- Copyright : (c) The University of Glasgow, 1992-2003
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC extensions)
---
--- GHC's implementation of the 'ForeignPtr' data type.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.ForeignPtr
- (
- ForeignPtr(..),
- FinalizerPtr,
- newForeignPtr_,
- mallocForeignPtr,
- mallocPlainForeignPtr,
- mallocForeignPtrBytes,
- mallocPlainForeignPtrBytes,
- addForeignPtrFinalizer,
- touchForeignPtr,
- unsafeForeignPtrToPtr,
- castForeignPtr,
- newConcForeignPtr,
- addForeignPtrConcFinalizer,
- finalizeForeignPtr
- ) where
-
-import Control.Monad ( sequence_ )
-import Foreign.Storable
-
-import GHC.Show
-import GHC.List ( null )
-import GHC.Base
-import GHC.IOBase
-import GHC.STRef ( STRef(..) )
-import GHC.Ptr ( Ptr(..), FunPtr )
-import GHC.Err
-
--- |The type 'ForeignPtr' represents references to objects that are
--- maintained in a foreign language, i.e., that are not part of the
--- data structures usually managed by the Haskell storage manager.
--- The essential difference between 'ForeignPtr's and vanilla memory
--- references of type @Ptr a@ is that the former may be associated
--- with /finalizers/. A finalizer is a routine that is invoked when
--- the Haskell storage manager detects that - within the Haskell heap
--- and stack - there are no more references left that are pointing to
--- the 'ForeignPtr'. Typically, the finalizer will, then, invoke
--- routines in the foreign language that free the resources bound by
--- the foreign object.
---
--- The 'ForeignPtr' is parameterised in the same way as 'Ptr'. The
--- type argument of 'ForeignPtr' should normally be an instance of
--- class 'Storable'.
---
-data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents
- -- we cache the Addr# in the ForeignPtr object, but attach
- -- the finalizer to the IORef (or the MutableByteArray# in
- -- the case of a MallocPtr). The aim of the representation
- -- is to make withForeignPtr efficient; in fact, withForeignPtr
- -- should be just as efficient as unpacking a Ptr, and multiple
- -- withForeignPtrs can share an unpacked ForeignPtr. Note
- -- that touchForeignPtr only has to touch the ForeignPtrContents
- -- object, because that ensures that whatever the finalizer is
- -- attached to is kept alive.
-
-data ForeignPtrContents
- = PlainForeignPtr !(IORef [IO ()])
- | MallocPtr (MutableByteArray# RealWorld) !(IORef [IO ()])
- | PlainPtr (MutableByteArray# RealWorld)
-
-instance Eq (ForeignPtr a) where
- p == q = unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q
-
-instance Ord (ForeignPtr a) where
- compare p q = compare (unsafeForeignPtrToPtr p) (unsafeForeignPtrToPtr q)
-
-instance Show (ForeignPtr a) where
- showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f)
-
-
--- |A Finalizer is represented as a pointer to a foreign function that, at
--- finalisation time, gets as an argument a plain pointer variant of the
--- foreign pointer that the finalizer is associated with.
---
-type FinalizerPtr a = FunPtr (Ptr a -> IO ())
-
-newConcForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a)
---
--- ^Turns a plain memory reference into a foreign object by
--- associating a finalizer - given by the monadic operation - with the
--- reference. The storage manager will start the finalizer, in a
--- separate thread, some time after the last reference to the
--- @ForeignPtr@ is dropped. There is no guarantee of promptness, and
--- in fact there is no guarantee that the finalizer will eventually
--- run at all.
---
--- Note that references from a finalizer do not necessarily prevent
--- another object from being finalized. If A's finalizer refers to B
--- (perhaps using 'touchForeignPtr', then the only guarantee is that
--- B's finalizer will never be started before A's. If both A and B
--- are unreachable, then both finalizers will start together. See
--- 'touchForeignPtr' for more on finalizer ordering.
---
-newConcForeignPtr p finalizer
- = do fObj <- newForeignPtr_ p
- addForeignPtrConcFinalizer fObj finalizer
- return fObj
-
-mallocForeignPtr :: Storable a => IO (ForeignPtr a)
--- ^ Allocate some memory and return a 'ForeignPtr' to it. The memory
--- will be released automatically when the 'ForeignPtr' is discarded.
---
--- 'mallocForeignPtr' is equivalent to
---
--- > do { p <- malloc; newForeignPtr finalizerFree p }
---
--- although it may be implemented differently internally: you may not
--- assume that the memory returned by 'mallocForeignPtr' has been
--- allocated with 'Foreign.Marshal.Alloc.malloc'.
---
--- GHC notes: 'mallocForeignPtr' has a heavily optimised
--- implementation in GHC. It uses pinned memory in the garbage
--- collected heap, so the 'ForeignPtr' does not require a finalizer to
--- free the memory. Use of 'mallocForeignPtr' and associated
--- functions is strongly recommended in preference to 'newForeignPtr'
--- with a finalizer.
---
-mallocForeignPtr = doMalloc undefined
- where doMalloc :: Storable b => b -> IO (ForeignPtr b)
- doMalloc a = do
- r <- newIORef []
- IO $ \s ->
- case newPinnedByteArray# size s of { (# s, mbarr# #) ->
- (# s, ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
- (MallocPtr mbarr# r) #)
- }
- where (I# size) = sizeOf a
-
--- | This function is similar to 'mallocForeignPtr', except that the
--- size of the memory required is given explicitly as a number of bytes.
-mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
-mallocForeignPtrBytes (I# size) = do
- r <- newIORef []
- IO $ \s ->
- case newPinnedByteArray# size s of { (# s, mbarr# #) ->
- (# s, ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
- (MallocPtr mbarr# r) #)
- }
-
--- | Allocate some memory and return a 'ForeignPtr' to it. The memory
--- will be released automatically when the 'ForeignPtr' is discarded.
---
--- GHC notes: 'mallocPlainForeignPtr' has a heavily optimised
--- implementation in GHC. It uses pinned memory in the garbage
--- collected heap, as for mallocForeignPtr. Unlike mallocForeignPtr, a
--- ForeignPtr created with mallocPlainForeignPtr carries no finalizers.
--- It is not possible to add a finalizer to a ForeignPtr created with
--- mallocPlainForeignPtr. This is useful for ForeignPtrs that will live
--- only inside Haskell (such as those created for packed strings).
--- Attempts to add a finalizer to a ForeignPtr created this way, or to
--- finalize such a pointer, will throw an exception.
---
-mallocPlainForeignPtr :: Storable a => IO (ForeignPtr a)
-mallocPlainForeignPtr = doMalloc undefined
- where doMalloc :: Storable b => b -> IO (ForeignPtr b)
- doMalloc a = IO $ \s ->
- case newPinnedByteArray# size s of { (# s, mbarr# #) ->
- (# s, ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
- (PlainPtr mbarr#) #)
- }
- where (I# size) = sizeOf a
-
--- | This function is similar to 'mallocForeignPtrBytes', except that
--- the internally an optimised ForeignPtr representation with no
--- finalizer is used. Attempts to add a finalizer will cause an
--- exception to be thrown.
-mallocPlainForeignPtrBytes :: Int -> IO (ForeignPtr a)
-mallocPlainForeignPtrBytes (I# size) = IO $ \s ->
- case newPinnedByteArray# size s of { (# s, mbarr# #) ->
- (# s, ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
- (PlainPtr mbarr#) #)
- }
-
-addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO ()
--- ^This function adds a finalizer to the given foreign object. The
--- finalizer will run /before/ all other finalizers for the same
--- object which have already been registered.
-addForeignPtrFinalizer finalizer fptr =
- addForeignPtrConcFinalizer fptr
- (mkFinalizer finalizer (unsafeForeignPtrToPtr fptr))
-
-addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO ()
--- ^This function adds a finalizer to the given @ForeignPtr@. The
--- finalizer will run /before/ all other finalizers for the same
--- object which have already been registered.
---
--- This is a variant of @addForeignPtrFinalizer@, where the finalizer
--- is an arbitrary @IO@ action. When it is invoked, the finalizer
--- will run in a new thread.
---
--- NB. Be very careful with these finalizers. One common trap is that
--- if a finalizer references another finalized value, it does not
--- prevent that value from being finalized. In particular, 'Handle's
--- are finalized objects, so a finalizer should not refer to a 'Handle'
--- (including @stdout@, @stdin@ or @stderr@).
---
-addForeignPtrConcFinalizer (ForeignPtr a c) finalizer =
- addForeignPtrConcFinalizer_ c finalizer
-
-addForeignPtrConcFinalizer_ f@(PlainForeignPtr r) finalizer = do
- fs <- readIORef r
- writeIORef r (finalizer : fs)
- if (null fs)
- then IO $ \s ->
- case r of { IORef (STRef r#) ->
- case mkWeak# r# () (foreignPtrFinalizer r) s of { (# s1, w #) ->
- (# s1, () #) }}
- else return ()
-addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do
- fs <- readIORef r
- writeIORef r (finalizer : fs)
- if (null fs)
- then IO $ \s ->
- case mkWeak# fo () (do foreignPtrFinalizer r; touch f) s of
- (# s1, w #) -> (# s1, () #)
- else return ()
-
-addForeignPtrConcFinalizer_ _ _ =
- error "GHC.ForeignPtr: attempt to add a finalizer to plain pointer"
-
-foreign import ccall "dynamic"
- mkFinalizer :: FinalizerPtr a -> Ptr a -> IO ()
-
-foreignPtrFinalizer :: IORef [IO ()] -> IO ()
-foreignPtrFinalizer r = do fs <- readIORef r; sequence_ fs
-
-newForeignPtr_ :: Ptr a -> IO (ForeignPtr a)
--- ^Turns a plain memory reference into a foreign pointer that may be
--- associated with finalizers by using 'addForeignPtrFinalizer'.
-newForeignPtr_ (Ptr obj) = do
- r <- newIORef []
- return (ForeignPtr obj (PlainForeignPtr r))
-
-touchForeignPtr :: ForeignPtr a -> IO ()
--- ^This function ensures that the foreign object in
--- question is alive at the given place in the sequence of IO
--- actions. In particular 'Foreign.ForeignPtr.withForeignPtr'
--- does a 'touchForeignPtr' after it
--- executes the user action.
---
--- Note that this function should not be used to express dependencies
--- between finalizers on 'ForeignPtr's. For example, if the finalizer
--- for a 'ForeignPtr' @F1@ calls 'touchForeignPtr' on a second
--- 'ForeignPtr' @F2@, then the only guarantee is that the finalizer
--- for @F2@ is never started before the finalizer for @F1@. They
--- might be started together if for example both @F1@ and @F2@ are
--- otherwise unreachable, and in that case the scheduler might end up
--- running the finalizer for @F2@ first.
---
--- In general, it is not recommended to use finalizers on separate
--- objects with ordering constraints between them. To express the
--- ordering robustly requires explicit synchronisation using @MVar@s
--- between the finalizers, but even then the runtime sometimes runs
--- multiple finalizers sequentially in a single thread (for
--- performance reasons), so synchronisation between finalizers could
--- result in artificial deadlock. Another alternative is to use
--- explicit reference counting.
---
-touchForeignPtr (ForeignPtr fo r) = touch r
-
-touch r = IO $ \s -> case touch# r s of s -> (# s, () #)
-
-unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a
--- ^This function extracts the pointer component of a foreign
--- pointer. This is a potentially dangerous operations, as if the
--- argument to 'unsafeForeignPtrToPtr' is the last usage
--- occurrence of the given foreign pointer, then its finalizer(s) will
--- be run, which potentially invalidates the plain pointer just
--- obtained. Hence, 'touchForeignPtr' must be used
--- wherever it has to be guaranteed that the pointer lives on - i.e.,
--- has another usage occurrence.
---
--- To avoid subtle coding errors, hand written marshalling code
--- should preferably use 'Foreign.ForeignPtr.withForeignPtr' rather
--- than combinations of 'unsafeForeignPtrToPtr' and
--- 'touchForeignPtr'. However, the later routines
--- are occasionally preferred in tool generated marshalling code.
-unsafeForeignPtrToPtr (ForeignPtr fo r) = Ptr fo
-
-castForeignPtr :: ForeignPtr a -> ForeignPtr b
--- ^This function casts a 'ForeignPtr'
--- parameterised by one type into another type.
-castForeignPtr f = unsafeCoerce# f
-
--- | Causes the finalizers associated with a foreign pointer to be run
--- immediately.
-finalizeForeignPtr :: ForeignPtr a -> IO ()
-finalizeForeignPtr (ForeignPtr _ (PlainPtr _)) = return () -- no effect
-finalizeForeignPtr (ForeignPtr _ foreignPtr) = do
- finalizers <- readIORef refFinalizers
- sequence_ finalizers
- writeIORef refFinalizers []
- where
- refFinalizers = case foreignPtr of
- (PlainForeignPtr ref) -> ref
- (MallocPtr _ ref) -> ref
-
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
-
-#undef DEBUG_DUMP
-#undef DEBUG
-
------------------------------------------------------------------------------
--- |
--- Module : GHC.Handle
--- Copyright : (c) The University of Glasgow, 1994-2001
--- License : see libraries/base/LICENSE
---
--- Maintainer : libraries@haskell.org
--- Stability : internal
--- Portability : non-portable
---
--- This module defines the basic operations on I\/O \"handles\".
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Handle (
- withHandle, withHandle', withHandle_,
- wantWritableHandle, wantReadableHandle, wantSeekableHandle,
-
- newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
- flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
- fillReadBuffer, fillReadBufferWithoutBlocking,
- readRawBuffer, readRawBufferPtr,
- writeRawBuffer, writeRawBufferPtr,
-
-#ifndef mingw32_HOST_OS
- unlockFile,
-#endif
-
- ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
-
- stdin, stdout, stderr,
- IOMode(..), openFile, openBinaryFile, openTempFile, openBinaryTempFile, openFd, fdToHandle,
- hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
- hFlush, hDuplicate, hDuplicateTo,
-
- hClose, hClose_help,
-
- HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
- SeekMode(..), hSeek, hTell,
-
- hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
- hSetEcho, hGetEcho, hIsTerminalDevice,
-
- hShow,
-
-#ifdef DEBUG_DUMP
- puts,
-#endif
-
- ) where
-
-import System.Directory.Internals
-import Control.Monad
-import Data.Bits
-import Data.Maybe
-import Foreign
-import Foreign.C
-import System.IO.Error
-import System.Posix.Internals
-
-import GHC.Real
-
-import GHC.Arr
-import GHC.Base
-import GHC.Read ( Read )
-import GHC.List
-import GHC.IOBase
-import GHC.Exception
-import GHC.Enum
-import GHC.Num ( Integer(..), Num(..) )
-import GHC.Show
-import GHC.Real ( toInteger )
-#if defined(DEBUG_DUMP)
-import GHC.Pack
-#endif
-
-import GHC.Conc
-
--- -----------------------------------------------------------------------------
--- TODO:
-
--- hWaitForInput blocks (should use a timeout)
-
--- unbuffered hGetLine is a bit dodgy
-
--- hSetBuffering: can't change buffering on a stream,
--- when the read buffer is non-empty? (no way to flush the buffer)
-
--- ---------------------------------------------------------------------------
--- Are files opened by default in text or binary mode, if the user doesn't
--- specify?
-
-dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
-
--- ---------------------------------------------------------------------------
--- Creating a new handle
-
-newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
-newFileHandle filepath finalizer hc = do
- m <- newMVar hc
- addMVarFinalizer m (finalizer m)
- return (FileHandle filepath m)
-
--- ---------------------------------------------------------------------------
--- Working with Handles
-
-{-
-In the concurrent world, handles are locked during use. This is done
-by wrapping an MVar around the handle which acts as a mutex over
-operations on the handle.
-
-To avoid races, we use the following bracketing operations. The idea
-is to obtain the lock, do some operation and replace the lock again,
-whether the operation succeeded or failed. We also want to handle the
-case where the thread receives an exception while processing the IO
-operation: in these cases we also want to relinquish the lock.
-
-There are three versions of @withHandle@: corresponding to the three
-possible combinations of:
-
- - the operation may side-effect the handle
- - the operation may return a result
-
-If the operation generates an error or an exception is raised, the
-original handle is always replaced [ this is the case at the moment,
-but we might want to revisit this in the future --SDM ].
--}
-
-{-# INLINE withHandle #-}
-withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
-withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act
-withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act
-
-withHandle' :: String -> Handle -> MVar Handle__
- -> (Handle__ -> IO (Handle__,a)) -> IO a
-withHandle' fun h m act =
- block $ do
- h_ <- takeMVar m
- checkBufferInvariants h_
- (h',v) <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
- checkBufferInvariants h'
- putMVar m h'
- return v
-
-{-# INLINE withHandle_ #-}
-withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
-withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act
-withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
-
-withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
-withHandle_' fun h m act =
- block $ do
- h_ <- takeMVar m
- checkBufferInvariants h_
- v <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
- checkBufferInvariants h_
- putMVar m h_
- return v
-
-withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
-withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act
-withAllHandles__ fun h@(DuplexHandle _ r w) act = do
- withHandle__' fun h r act
- withHandle__' fun h w act
-
-withHandle__' fun h m act =
- block $ do
- h_ <- takeMVar m
- checkBufferInvariants h_
- h' <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
- checkBufferInvariants h'
- putMVar m h'
- return ()
-
-augmentIOError (IOError _ iot _ str fp) fun h
- = IOError (Just h) iot fun str filepath
- where filepath
- | Just _ <- fp = fp
- | otherwise = case h of
- FileHandle fp _ -> Just fp
- DuplexHandle fp _ _ -> Just fp
-
--- ---------------------------------------------------------------------------
--- Wrapper for write operations.
-
-wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantWritableHandle fun h@(FileHandle _ m) act
- = wantWritableHandle' fun h m act
-wantWritableHandle fun h@(DuplexHandle _ _ m) act
- = wantWritableHandle' fun h m act
- -- ToDo: in the Duplex case, we don't need to checkWritableHandle
-
-wantWritableHandle'
- :: String -> Handle -> MVar Handle__
- -> (Handle__ -> IO a) -> IO a
-wantWritableHandle' fun h m act
- = withHandle_' fun h m (checkWritableHandle act)
-
-checkWritableHandle act handle_
- = case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- ReadHandle -> ioe_notWritable
- ReadWriteHandle -> do
- let ref = haBuffer handle_
- buf <- readIORef ref
- new_buf <-
- if not (bufferIsWritable buf)
- then do b <- flushReadBuffer (haFD handle_) buf
- return b{ bufState=WriteBuffer }
- else return buf
- writeIORef ref new_buf
- act handle_
- _other -> act handle_
-
--- ---------------------------------------------------------------------------
--- Wrapper for read operations.
-
-wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantReadableHandle fun h@(FileHandle _ m) act
- = wantReadableHandle' fun h m act
-wantReadableHandle fun h@(DuplexHandle _ m _) act
- = wantReadableHandle' fun h m act
- -- ToDo: in the Duplex case, we don't need to checkReadableHandle
-
-wantReadableHandle'
- :: String -> Handle -> MVar Handle__
- -> (Handle__ -> IO a) -> IO a
-wantReadableHandle' fun h m act
- = withHandle_' fun h m (checkReadableHandle act)
-
-checkReadableHandle act handle_ =
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- AppendHandle -> ioe_notReadable
- WriteHandle -> ioe_notReadable
- ReadWriteHandle -> do
- let ref = haBuffer handle_
- buf <- readIORef ref
- when (bufferIsWritable buf) $ do
- new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
- writeIORef ref new_buf{ bufState=ReadBuffer }
- act handle_
- _other -> act handle_
-
--- ---------------------------------------------------------------------------
--- Wrapper for seek operations.
-
-wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
- ioException (IOError (Just h) IllegalOperation fun
- "handle is not seekable" Nothing)
-wantSeekableHandle fun h@(FileHandle _ m) act =
- withHandle_' fun h m (checkSeekableHandle act)
-
-checkSeekableHandle act handle_ =
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- AppendHandle -> ioe_notSeekable
- _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
- | otherwise -> ioe_notSeekable_notBin
-
--- -----------------------------------------------------------------------------
--- Handy IOErrors
-
-ioe_closedHandle, ioe_EOF,
- ioe_notReadable, ioe_notWritable,
- ioe_notSeekable, ioe_notSeekable_notBin :: IO a
-
-ioe_closedHandle = ioException
- (IOError Nothing IllegalOperation ""
- "handle is closed" Nothing)
-ioe_EOF = ioException
- (IOError Nothing EOF "" "" Nothing)
-ioe_notReadable = ioException
- (IOError Nothing IllegalOperation ""
- "handle is not open for reading" Nothing)
-ioe_notWritable = ioException
- (IOError Nothing IllegalOperation ""
- "handle is not open for writing" Nothing)
-ioe_notSeekable = ioException
- (IOError Nothing IllegalOperation ""
- "handle is not seekable" Nothing)
-ioe_notSeekable_notBin = ioException
- (IOError Nothing IllegalOperation ""
- "seek operations on text-mode handles are not allowed on this platform"
- Nothing)
-
-ioe_finalizedHandle fp = throw (IOException
- (IOError Nothing IllegalOperation ""
- "handle is finalized" (Just fp)))
-
-ioe_bufsiz :: Int -> IO a
-ioe_bufsiz n = ioException
- (IOError Nothing InvalidArgument "hSetBuffering"
- ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
- -- 9 => should be parens'ified.
-
--- -----------------------------------------------------------------------------
--- Handle Finalizers
-
--- For a duplex handle, we arrange that the read side points to the write side
--- (and hence keeps it alive if the read side is alive). This is done by
--- having the haOtherSide field of the read side point to the read side.
--- The finalizer is then placed on the write side, and the handle only gets
--- finalized once, when both sides are no longer required.
-
--- NOTE about finalized handles: It's possible that a handle can be
--- finalized and then we try to use it later, for example if the
--- handle is referenced from another finalizer, or from a thread that
--- has become unreferenced and then resurrected (arguably in the
--- latter case we shouldn't finalize the Handle...). Anyway,
--- we try to emit a helpful message which is better than nothing.
-
-stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
-stdHandleFinalizer fp m = do
- h_ <- takeMVar m
- flushWriteBufferOnly h_
- putMVar m (ioe_finalizedHandle fp)
-
-handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
-handleFinalizer fp m = do
- handle_ <- takeMVar m
- case haType handle_ of
- ClosedHandle -> return ()
- _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
- -- ignore errors and async exceptions, and close the
- -- descriptor anyway...
- hClose_handle_ handle_
- return ()
- putMVar m (ioe_finalizedHandle fp)
-
--- ---------------------------------------------------------------------------
--- Grimy buffer operations
-
-#ifdef DEBUG
-checkBufferInvariants h_ = do
- let ref = haBuffer h_
- Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
- if not (
- size > 0
- && r <= w
- && w <= size
- && ( r /= w || (r == 0 && w == 0) )
- && ( state /= WriteBuffer || r == 0 )
- && ( state /= WriteBuffer || w < size ) -- write buffer is never full
- )
- then error "buffer invariant violation"
- else return ()
-#else
-checkBufferInvariants h_ = return ()
-#endif
-
-newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
-newEmptyBuffer b state size
- = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
-
-allocateBuffer :: Int -> BufferState -> IO Buffer
-allocateBuffer sz@(I# size) state = IO $ \s ->
-#ifdef mingw32_HOST_OS
- -- To implement asynchronous I/O under Win32, we have to pass
- -- buffer references to external threads that handles the
- -- filling/emptying of their contents. Hence, the buffer cannot
- -- be moved around by the GC.
- case newPinnedByteArray# size s of { (# s, b #) ->
-#else
- case newByteArray# size s of { (# s, b #) ->
-#endif
- (# s, newEmptyBuffer b state sz #) }
-
-writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
-writeCharIntoBuffer slab (I# off) (C# c)
- = IO $ \s -> case writeCharArray# slab off c s of
- s -> (# s, I# (off +# 1#) #)
-
-readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
-readCharFromBuffer slab (I# off)
- = IO $ \s -> case readCharArray# slab off s of
- (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
-
-getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
-getBuffer fd state = do
- buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
- ioref <- newIORef buffer
- is_tty <- fdIsTTY fd
-
- let buffer_mode
- | is_tty = LineBuffering
- | otherwise = BlockBuffering Nothing
-
- return (ioref, buffer_mode)
-
-mkUnBuffer :: IO (IORef Buffer)
-mkUnBuffer = do
- buffer <- allocateBuffer 1 ReadBuffer
- newIORef buffer
-
--- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
-flushWriteBufferOnly :: Handle__ -> IO ()
-flushWriteBufferOnly h_ = do
- let fd = haFD h_
- ref = haBuffer h_
- buf <- readIORef ref
- new_buf <- if bufferIsWritable buf
- then flushWriteBuffer fd (haIsStream h_) buf
- else return buf
- writeIORef ref new_buf
-
--- flushBuffer syncs the file with the buffer, including moving the
--- file pointer backwards in the case of a read buffer.
-flushBuffer :: Handle__ -> IO ()
-flushBuffer h_ = do
- let ref = haBuffer h_
- buf <- readIORef ref
-
- flushed_buf <-
- case bufState buf of
- ReadBuffer -> flushReadBuffer (haFD h_) buf
- WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
-
- writeIORef ref flushed_buf
-
--- When flushing a read buffer, we seek backwards by the number of
--- characters in the buffer. The file descriptor must therefore be
--- seekable: attempting to flush the read buffer on an unseekable
--- handle is not allowed.
-
-flushReadBuffer :: FD -> Buffer -> IO Buffer
-flushReadBuffer fd buf
- | bufferEmpty buf = return buf
- | otherwise = do
- let off = negate (bufWPtr buf - bufRPtr buf)
-# ifdef DEBUG_DUMP
- puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
-# endif
- throwErrnoIfMinus1Retry "flushReadBuffer"
- (c_lseek fd (fromIntegral off) sEEK_CUR)
- return buf{ bufWPtr=0, bufRPtr=0 }
-
-flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
-flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } =
- seq fd $ do -- strictness hack
- let bytes = w - r
-#ifdef DEBUG_DUMP
- puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
-#endif
- if bytes == 0
- then return (buf{ bufRPtr=0, bufWPtr=0 })
- else do
- res <- writeRawBuffer "flushWriteBuffer" fd is_stream b
- (fromIntegral r) (fromIntegral bytes)
- let res' = fromIntegral res
- if res' < bytes
- then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
- else return buf{ bufRPtr=0, bufWPtr=0 }
-
-fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
-fillReadBuffer fd is_line is_stream
- buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
- -- buffer better be empty:
- assert (r == 0 && w == 0) $ do
- fillReadBufferLoop fd is_line is_stream buf b w size
-
--- For a line buffer, we just get the first chunk of data to arrive,
--- and don't wait for the whole buffer to be full (but we *do* wait
--- until some data arrives). This isn't really line buffering, but it
--- appears to be what GHC has done for a long time, and I suspect it
--- is more useful than line buffering in most cases.
-
-fillReadBufferLoop fd is_line is_stream buf b w size = do
- let bytes = size - w
- if bytes == 0 -- buffer full?
- then return buf{ bufRPtr=0, bufWPtr=w }
- else do
-#ifdef DEBUG_DUMP
- puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
-#endif
- res <- readRawBuffer "fillReadBuffer" fd is_stream b
- (fromIntegral w) (fromIntegral bytes)
- let res' = fromIntegral res
-#ifdef DEBUG_DUMP
- puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
-#endif
- if res' == 0
- then if w == 0
- then ioe_EOF
- else return buf{ bufRPtr=0, bufWPtr=w }
- else if res' < bytes && not is_line
- then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
- else return buf{ bufRPtr=0, bufWPtr=w+res' }
-
-
-fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer
-fillReadBufferWithoutBlocking fd is_stream
- buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
- -- buffer better be empty:
- assert (r == 0 && w == 0) $ do
-#ifdef DEBUG_DUMP
- puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")
-#endif
- res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
- 0 (fromIntegral size)
- let res' = fromIntegral res
-#ifdef DEBUG_DUMP
- puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n")
-#endif
- return buf{ bufRPtr=0, bufWPtr=res' }
-
--- Low level routines for reading/writing to (raw)buffers:
-
-#ifndef mingw32_HOST_OS
-
-{-
-NOTE [nonblock]:
-
-Unix has broken semantics when it comes to non-blocking I/O: you can
-set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
-attached to the same underlying file, pipe or TTY; there's no way to
-have private non-blocking behaviour for an FD. See bug #724.
-
-We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
-come from external sources or are exposed externally are left in
-blocking mode. This solution has some problems though. We can't
-completely simulate a non-blocking read without O_NONBLOCK: several
-cases are wrong here. The cases that are wrong:
-
- * reading/writing to a blocking FD in non-threaded mode.
- In threaded mode, we just make a safe call to read().
- In non-threaded mode we call select() before attempting to read,
- but that leaves a small race window where the data can be read
- from the file descriptor before we issue our blocking read().
- * readRawBufferNoBlock for a blocking FD
--}
-
-readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBuffer loc fd is_nonblock buf off len
- | is_nonblock = unsafe_read
- | threaded = safe_read
- | otherwise = do r <- throwErrnoIfMinus1 loc
- (fdReady (fromIntegral fd) 0 0 False)
- if r /= 0
- then unsafe_read
- else do threadWaitRead (fromIntegral fd); unsafe_read
- where
- do_read call = throwErrnoIfMinus1RetryMayBlock loc call
- (threadWaitRead (fromIntegral fd))
- unsafe_read = do_read (read_rawBuffer fd buf off len)
- safe_read = do_read (safe_read_rawBuffer fd buf off len)
-
-readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-readRawBufferPtr loc fd is_nonblock buf off len
- | is_nonblock = unsafe_read
- | threaded = safe_read
- | otherwise = do r <- throwErrnoIfMinus1 loc
- (fdReady (fromIntegral fd) 0 0 False)
- if r /= 0
- then unsafe_read
- else do threadWaitRead (fromIntegral fd); unsafe_read
- where
- do_read call = throwErrnoIfMinus1RetryMayBlock loc call
- (threadWaitRead (fromIntegral fd))
- unsafe_read = do_read (read_off fd buf off len)
- safe_read = do_read (safe_read_off fd buf off len)
-
-readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBufferNoBlock loc fd is_nonblock buf off len
- | is_nonblock = unsafe_read
- | otherwise = do r <- fdReady (fromIntegral fd) 0 0 False
- if r /= 0 then safe_read
- else return 0
- -- XXX see note [nonblock]
- where
- do_read call = throwErrnoIfMinus1RetryMayBlock loc call (return 0)
- unsafe_read = do_read (read_rawBuffer fd buf off len)
- safe_read = do_read (safe_read_rawBuffer fd buf off len)
-
-writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-writeRawBuffer loc fd is_nonblock buf off len
- | is_nonblock = unsafe_write
- | threaded = safe_write
- | otherwise = do r <- fdReady (fromIntegral fd) 1 0 False
- if r /= 0 then safe_write
- else return 0
- where
- do_write call = throwErrnoIfMinus1RetryMayBlock loc call
- (threadWaitWrite (fromIntegral fd))
- unsafe_write = do_write (write_rawBuffer fd buf off len)
- safe_write = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len)
-
-writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-writeRawBufferPtr loc fd is_nonblock buf off len
- | is_nonblock = unsafe_write
- | threaded = safe_write
- | otherwise = do r <- fdReady (fromIntegral fd) 1 0 False
- if r /= 0 then safe_write
- else return 0
- where
- do_write call = throwErrnoIfMinus1RetryMayBlock loc call
- (threadWaitWrite (fromIntegral fd))
- unsafe_write = do_write (write_off fd buf off len)
- safe_write = do_write (safe_write_off (fromIntegral fd) buf off len)
-
-foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "fdReady"
- fdReady :: CInt -> CInt -> CInt -> Bool -> IO CInt
-
-#else /* mingw32_HOST_OS.... */
-
-readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBuffer loc fd is_stream buf off len
- | threaded = blockingReadRawBuffer loc fd is_stream buf off len
- | otherwise = asyncReadRawBuffer loc fd is_stream buf off len
-
-readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-readRawBufferPtr loc fd is_stream buf off len
- | threaded = blockingReadRawBufferPtr loc fd is_stream buf off len
- | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len
-
-writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-writeRawBuffer loc fd is_stream buf off len
- | threaded = blockingWriteRawBuffer loc fd is_stream buf off len
- | otherwise = asyncWriteRawBuffer loc fd is_stream buf off len
-
-writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-writeRawBufferPtr loc fd is_stream buf off len
- | threaded = blockingWriteRawBufferPtr loc fd is_stream buf off len
- | otherwise = asyncWriteRawBufferPtr loc fd is_stream buf off len
-
--- ToDo: we don't have a non-blocking primitve read on Win32
-readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBufferNoBlock = readRawBuffer
-
--- Async versions of the read/write primitives, for the non-threaded RTS
-
-asyncReadRawBuffer loc fd is_stream buf off len = do
- (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0)
- (fromIntegral len) off buf
- if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
- else return (fromIntegral l)
-
-asyncReadRawBufferPtr loc fd is_stream buf off len = do
- (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0)
- (fromIntegral len) (buf `plusPtr` off)
- if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
- else return (fromIntegral l)
-
-asyncWriteRawBuffer loc fd is_stream buf off len = do
- (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0)
- (fromIntegral len) off buf
- if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
- else return (fromIntegral l)
-
-asyncWriteRawBufferPtr loc fd is_stream buf off len = do
- (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0)
- (fromIntegral len) (buf `plusPtr` off)
- if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
- else return (fromIntegral l)
-
--- Blocking versions of the read/write primitives, for the threaded RTS
-
-blockingReadRawBuffer loc fd True buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_recv_rawBuffer fd buf off len
-blockingReadRawBuffer loc fd False buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_read_rawBuffer fd buf off len
-
-blockingReadRawBufferPtr loc fd True buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_recv_off fd buf off len
-blockingReadRawBufferPtr loc fd False buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_read_off fd buf off len
-
-blockingWriteRawBuffer loc fd True buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_send_rawBuffer fd buf off len
-blockingWriteRawBuffer loc fd False buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_write_rawBuffer fd buf off len
-
-blockingWriteRawBufferPtr loc fd True buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_send_off fd buf off len
-blockingWriteRawBufferPtr loc fd False buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_write_off fd buf off len
-
--- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
--- These calls may block, but that's ok.
-
-foreign import ccall safe "__hscore_PrelHandle_recv"
- safe_recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_recv"
- safe_recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_send"
- safe_send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_send"
- safe_send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-
-#endif
-
-foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
-
-foreign import ccall safe "__hscore_PrelHandle_read"
- safe_read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_read"
- safe_read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_write"
- safe_write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_write"
- safe_write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-
--- ---------------------------------------------------------------------------
--- Standard Handles
-
--- Three handles are allocated during program initialisation. The first
--- two manage input or output from the Haskell program's standard input
--- or output channel respectively. The third manages output to the
--- standard error channel. These handles are initially open.
-
-fd_stdin = 0 :: FD
-fd_stdout = 1 :: FD
-fd_stderr = 2 :: FD
-
--- | A handle managing input from the Haskell program's standard input channel.
-stdin :: Handle
-stdin = unsafePerformIO $ do
- -- ToDo: acquire lock
- -- We don't set non-blocking mode on standard handles, because it may
- -- confuse other applications attached to the same TTY/pipe
- -- see Note [nonblock]
- (buf, bmode) <- getBuffer fd_stdin ReadBuffer
- mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
-
--- | A handle managing output to the Haskell program's standard output channel.
-stdout :: Handle
-stdout = unsafePerformIO $ do
- -- ToDo: acquire lock
- -- We don't set non-blocking mode on standard handles, because it may
- -- confuse other applications attached to the same TTY/pipe
- -- see Note [nonblock]
- (buf, bmode) <- getBuffer fd_stdout WriteBuffer
- mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
-
--- | A handle managing output to the Haskell program's standard error channel.
-stderr :: Handle
-stderr = unsafePerformIO $ do
- -- ToDo: acquire lock
- -- We don't set non-blocking mode on standard handles, because it may
- -- confuse other applications attached to the same TTY/pipe
- -- see Note [nonblock]
- buf <- mkUnBuffer
- mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
-
--- ---------------------------------------------------------------------------
--- Opening and Closing Files
-
-addFilePathToIOError fun fp (IOError h iot _ str _)
- = IOError h iot fun str (Just fp)
-
--- | Computation 'openFile' @file mode@ allocates and returns a new, open
--- handle to manage the file @file@. It manages input if @mode@
--- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
--- and both input and output if mode is 'ReadWriteMode'.
---
--- If the file does not exist and it is opened for output, it should be
--- created as a new file. If @mode@ is 'WriteMode' and the file
--- already exists, then it should be truncated to zero length.
--- Some operating systems delete empty files, so there is no guarantee
--- that the file will exist following an 'openFile' with @mode@
--- 'WriteMode' unless it is subsequently written to successfully.
--- The handle is positioned at the end of the file if @mode@ is
--- 'AppendMode', and otherwise at the beginning (in which case its
--- internal position is 0).
--- The initial buffer mode is implementation-dependent.
---
--- This operation may fail with:
---
--- * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
---
--- * 'isDoesNotExistError' if the file does not exist; or
---
--- * 'isPermissionError' if the user does not have permission to open the file.
---
--- Note: if you will be working with files containing binary data, you'll want to
--- be using 'openBinaryFile'.
-openFile :: FilePath -> IOMode -> IO Handle
-openFile fp im =
- catch
- (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
- (\e -> ioError (addFilePathToIOError "openFile" fp e))
-
--- | Like 'openFile', but open the file in binary mode.
--- On Windows, reading a file in text mode (which is the default)
--- will translate CRLF to LF, and writing will translate LF to CRLF.
--- This is usually what you want with text files. With binary files
--- this is undesirable; also, as usual under Microsoft operating systems,
--- text mode treats control-Z as EOF. Binary mode turns off all special
--- treatment of end-of-line and end-of-file characters.
--- (See also 'hSetBinaryMode'.)
-
-openBinaryFile :: FilePath -> IOMode -> IO Handle
-openBinaryFile fp m =
- catch
- (openFile' fp m True)
- (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
-
-openFile' filepath mode binary =
- withCString filepath $ \ f ->
-
- let
- oflags1 = case mode of
- ReadMode -> read_flags
-#ifdef mingw32_HOST_OS
- WriteMode -> write_flags .|. o_TRUNC
-#else
- WriteMode -> write_flags
-#endif
- ReadWriteMode -> rw_flags
- AppendMode -> append_flags
-
- binary_flags
- | binary = o_BINARY
- | otherwise = 0
-
- oflags = oflags1 .|. binary_flags
- in do
-
- -- the old implementation had a complicated series of three opens,
- -- which is perhaps because we have to be careful not to open
- -- directories. However, the man pages I've read say that open()
- -- always returns EISDIR if the file is a directory and was opened
- -- for writing, so I think we're ok with a single open() here...
- fd <- throwErrnoIfMinus1Retry "openFile"
- (c_open f (fromIntegral oflags) 0o666)
-
- fd_type <- fdType fd
-
- h <- openFd fd (Just fd_type) False filepath mode binary
- `catchException` \e -> do c_close fd; throw e
- -- NB. don't forget to close the FD if openFd fails, otherwise
- -- this FD leaks.
- -- ASSERT: if we just created the file, then openFd won't fail
- -- (so we don't need to worry about removing the newly created file
- -- in the event of an error).
-
-#ifndef mingw32_HOST_OS
- -- we want to truncate() if this is an open in WriteMode, but only
- -- if the target is a RegularFile. ftruncate() fails on special files
- -- like /dev/null.
- if mode == WriteMode && fd_type == RegularFile
- then throwErrnoIf (/=0) "openFile"
- (c_ftruncate fd 0)
- else return 0
-#endif
- return h
-
-
--- | The function creates a temporary file in ReadWrite mode.
--- The created file isn\'t deleted automatically, so you need to delete it manually.
-openTempFile :: FilePath -- ^ Directory in which to create the file
- -> String -- ^ File name template. If the template is \"foo.ext\" then
- -- the create file will be \"fooXXX.ext\" where XXX is some
- -- random number.
- -> IO (FilePath, Handle)
-openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template dEFAULT_OPEN_IN_BINARY_MODE
-
--- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
-openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
-openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True
-
-openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle)
-openTempFile' loc tmp_dir template binary = do
- pid <- c_getpid
- findTempName pid
- where
- (prefix,suffix) = break (=='.') template
-
- oflags1 = rw_flags .|. o_EXCL
-
- binary_flags
- | binary = o_BINARY
- | otherwise = 0
-
- oflags = oflags1 .|. binary_flags
-
- findTempName x = do
- fd <- withCString filepath $ \ f ->
- c_open f oflags 0o666
- if fd < 0
- then do
- errno <- getErrno
- if errno == eEXIST
- then findTempName (x+1)
- else ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
- else do
- h <- openFd fd Nothing False filepath ReadWriteMode True
- `catchException` \e -> do c_close fd; throw e
- return (filepath, h)
- where
- filename = prefix ++ show x ++ suffix
- filepath = tmp_dir `joinFileName` filename
-
-
-std_flags = o_NONBLOCK .|. o_NOCTTY
-output_flags = std_flags .|. o_CREAT
-read_flags = std_flags .|. o_RDONLY
-write_flags = output_flags .|. o_WRONLY
-rw_flags = output_flags .|. o_RDWR
-append_flags = write_flags .|. o_APPEND
-
--- ---------------------------------------------------------------------------
--- openFd
-
-openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> IO Handle
-openFd fd mb_fd_type is_socket filepath mode binary = do
- -- turn on non-blocking mode
- setNonBlockingFD fd
-
-#ifdef mingw32_HOST_OS
- -- On Windows, the is_stream flag indicates that the Handle is a socket
- let is_stream = is_socket
-#else
- -- On Unix, the is_stream flag indicates that the FD is non-blocking
- let is_stream = True
-#endif
-
- let (ha_type, write) =
- case mode of
- ReadMode -> ( ReadHandle, False )
- WriteMode -> ( WriteHandle, True )
- ReadWriteMode -> ( ReadWriteHandle, True )
- AppendMode -> ( AppendHandle, True )
-
- -- open() won't tell us if it was a directory if we only opened for
- -- reading, so check again.
- fd_type <-
- case mb_fd_type of
- Just x -> return x
- Nothing -> fdType fd
-
- case fd_type of
- Directory ->
- ioException (IOError Nothing InappropriateType "openFile"
- "is a directory" Nothing)
-
- -- regular files need to be locked
- RegularFile -> do
-#ifndef mingw32_HOST_OS
- r <- lockFile fd (fromBool write) 1{-exclusive-}
- when (r == -1) $
- ioException (IOError Nothing ResourceBusy "openFile"
- "file is locked" Nothing)
-#endif
- mkFileHandle fd is_stream filepath ha_type binary
-
- Stream
- -- only *Streams* can be DuplexHandles. Other read/write
- -- Handles must share a buffer.
- | ReadWriteHandle <- ha_type ->
- mkDuplexHandle fd is_stream filepath binary
- | otherwise ->
- mkFileHandle fd is_stream filepath ha_type binary
-
- RawDevice ->
- mkFileHandle fd is_stream filepath ha_type binary
-
-fdToHandle :: FD -> IO Handle
-fdToHandle fd = do
- mode <- fdGetMode fd
- let fd_str = "<file descriptor: " ++ show fd ++ ">"
- openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-}
-
-
-#ifndef mingw32_HOST_OS
-foreign import ccall unsafe "lockFile"
- lockFile :: CInt -> CInt -> CInt -> IO CInt
-
-foreign import ccall unsafe "unlockFile"
- unlockFile :: CInt -> IO CInt
-#endif
-
-mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
- -> IO Handle
-mkStdHandle fd filepath ha_type buf bmode = do
- spares <- newIORef BufferListNil
- newFileHandle filepath (stdHandleFinalizer filepath)
- (Handle__ { haFD = fd,
- haType = ha_type,
- haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
- haIsStream = False, -- means FD is blocking on Unix
- haBufferMode = bmode,
- haBuffer = buf,
- haBuffers = spares,
- haOtherSide = Nothing
- })
-
-mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
-mkFileHandle fd is_stream filepath ha_type binary = do
- (buf, bmode) <- getBuffer fd (initBufferState ha_type)
-
-#ifdef mingw32_HOST_OS
- -- On Windows, if this is a read/write handle and we are in text mode,
- -- turn off buffering. We don't correctly handle the case of switching
- -- from read mode to write mode on a buffered text-mode handle, see bug
- -- \#679.
- bmode <- case ha_type of
- ReadWriteHandle | not binary -> return NoBuffering
- _other -> return bmode
-#endif
-
- spares <- newIORef BufferListNil
- newFileHandle filepath (handleFinalizer filepath)
- (Handle__ { haFD = fd,
- haType = ha_type,
- haIsBin = binary,
- haIsStream = is_stream,
- haBufferMode = bmode,
- haBuffer = buf,
- haBuffers = spares,
- haOtherSide = Nothing
- })
-
-mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
-mkDuplexHandle fd is_stream filepath binary = do
- (w_buf, w_bmode) <- getBuffer fd WriteBuffer
- w_spares <- newIORef BufferListNil
- let w_handle_ =
- Handle__ { haFD = fd,
- haType = WriteHandle,
- haIsBin = binary,
- haIsStream = is_stream,
- haBufferMode = w_bmode,
- haBuffer = w_buf,
- haBuffers = w_spares,
- haOtherSide = Nothing
- }
- write_side <- newMVar w_handle_
-
- (r_buf, r_bmode) <- getBuffer fd ReadBuffer
- r_spares <- newIORef BufferListNil
- let r_handle_ =
- Handle__ { haFD = fd,
- haType = ReadHandle,
- haIsBin = binary,
- haIsStream = is_stream,
- haBufferMode = r_bmode,
- haBuffer = r_buf,
- haBuffers = r_spares,
- haOtherSide = Just write_side
- }
- read_side <- newMVar r_handle_
-
- addMVarFinalizer write_side (handleFinalizer filepath write_side)
- return (DuplexHandle filepath read_side write_side)
-
-
-initBufferState ReadHandle = ReadBuffer
-initBufferState _ = WriteBuffer
-
--- ---------------------------------------------------------------------------
--- Closing a handle
-
--- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the
--- computation finishes, if @hdl@ is writable its buffer is flushed as
--- for 'hFlush'.
--- Performing 'hClose' on a handle that has already been closed has no effect;
--- doing so not an error. All other operations on a closed handle will fail.
--- If 'hClose' fails for any reason, any further operations (apart from
--- 'hClose') on the handle will still fail as if @hdl@ had been successfully
--- closed.
-
-hClose :: Handle -> IO ()
-hClose h@(FileHandle _ m) = hClose' h m
-hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
-
-hClose' h m = withHandle__' "hClose" h m $ hClose_help
-
--- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
--- or an IO error occurs on a lazy stream. The semi-closed Handle is
--- then closed immediately. We have to be careful with DuplexHandles
--- though: we have to leave the closing to the finalizer in that case,
--- because the write side may still be in use.
-hClose_help :: Handle__ -> IO Handle__
-hClose_help handle_ =
- case haType handle_ of
- ClosedHandle -> return handle_
- _ -> do flushWriteBufferOnly handle_ -- interruptible
- hClose_handle_ handle_
-
-hClose_handle_ handle_ = do
- let fd = haFD handle_
-
- -- close the file descriptor, but not when this is the read
- -- side of a duplex handle.
- case haOtherSide handle_ of
- Nothing ->
- throwErrnoIfMinus1Retry_ "hClose"
-#ifdef mingw32_HOST_OS
- (closeFd (haIsStream handle_) fd)
-#else
- (c_close fd)
-#endif
- Just _ -> return ()
-
- -- free the spare buffers
- writeIORef (haBuffers handle_) BufferListNil
-
-#ifndef mingw32_HOST_OS
- -- unlock it
- unlockFile fd
-#endif
-
- -- we must set the fd to -1, because the finalizer is going
- -- to run eventually and try to close/unlock it.
- return (handle_{ haFD = -1,
- haType = ClosedHandle
- })
-
------------------------------------------------------------------------------
--- Detecting and changing the size of a file
-
--- | For a handle @hdl@ which attached to a physical file,
--- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
-
-hFileSize :: Handle -> IO Integer
-hFileSize handle =
- withHandle_ "hFileSize" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- _ -> do flushWriteBufferOnly handle_
- r <- fdFileSize (haFD handle_)
- if r /= -1
- then return r
- else ioException (IOError Nothing InappropriateType "hFileSize"
- "not a regular file" Nothing)
-
-
--- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
-
-hSetFileSize :: Handle -> Integer -> IO ()
-hSetFileSize handle size =
- withHandle_ "hSetFileSize" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- _ -> do flushWriteBufferOnly handle_
- throwErrnoIf (/=0) "hSetFileSize"
- (c_ftruncate (haFD handle_) (fromIntegral size))
- return ()
-
--- ---------------------------------------------------------------------------
--- Detecting the End of Input
-
--- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
--- 'True' if no further input can be taken from @hdl@ or for a
--- physical file, if the current I\/O position is equal to the length of
--- the file. Otherwise, it returns 'False'.
-
-hIsEOF :: Handle -> IO Bool
-hIsEOF handle =
- catch
- (do hLookAhead handle; return False)
- (\e -> if isEOFError e then return True else ioError e)
-
--- | The computation 'isEOF' is identical to 'hIsEOF',
--- except that it works only on 'stdin'.
-
-isEOF :: IO Bool
-isEOF = hIsEOF stdin
-
--- ---------------------------------------------------------------------------
--- Looking ahead
-
--- | Computation 'hLookAhead' returns the next character from the handle
--- without removing it from the input buffer, blocking until a character
--- is available.
---
--- This operation may fail with:
---
--- * 'isEOFError' if the end of file has been reached.
-
-hLookAhead :: Handle -> IO Char
-hLookAhead handle = do
- wantReadableHandle "hLookAhead" handle $ \handle_ -> do
- let ref = haBuffer handle_
- fd = haFD handle_
- is_line = haBufferMode handle_ == LineBuffering
- buf <- readIORef ref
-
- -- fill up the read buffer if necessary
- new_buf <- if bufferEmpty buf
- then fillReadBuffer fd True (haIsStream handle_) buf
- else return buf
-
- writeIORef ref new_buf
-
- (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
- return c
-
--- ---------------------------------------------------------------------------
--- Buffering Operations
-
--- Three kinds of buffering are supported: line-buffering,
--- block-buffering or no-buffering. See GHC.IOBase for definition and
--- further explanation of what the type represent.
-
--- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
--- handle @hdl@ on subsequent reads and writes.
---
--- If the buffer mode is changed from 'BlockBuffering' or
--- 'LineBuffering' to 'NoBuffering', then
---
--- * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
---
--- * if @hdl@ is not writable, the contents of the buffer is discarded.
---
--- This operation may fail with:
---
--- * 'isPermissionError' if the handle has already been used for reading
--- or writing and the implementation does not allow the buffering mode
--- to be changed.
-
-hSetBuffering :: Handle -> BufferMode -> IO ()
-hSetBuffering handle mode =
- withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- _ -> do
- {- Note:
- - we flush the old buffer regardless of whether
- the new buffer could fit the contents of the old buffer
- or not.
- - allow a handle's buffering to change even if IO has
- occurred (ANSI C spec. does not allow this, nor did
- the previous implementation of IO.hSetBuffering).
- - a non-standard extension is to allow the buffering
- of semi-closed handles to change [sof 6/98]
- -}
- flushBuffer handle_
-
- let state = initBufferState (haType handle_)
- new_buf <-
- case mode of
- -- we always have a 1-character read buffer for
- -- unbuffered handles: it's needed to
- -- support hLookAhead.
- NoBuffering -> allocateBuffer 1 ReadBuffer
- LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
- BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
- BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
- | otherwise -> allocateBuffer n state
- writeIORef (haBuffer handle_) new_buf
-
- -- for input terminals we need to put the terminal into
- -- cooked or raw mode depending on the type of buffering.
- is_tty <- fdIsTTY (haFD handle_)
- when (is_tty && isReadableHandleType (haType handle_)) $
- case mode of
-#ifndef mingw32_HOST_OS
- -- 'raw' mode under win32 is a bit too specialised (and troublesome
- -- for most common uses), so simply disable its use here.
- NoBuffering -> setCooked (haFD handle_) False
-#else
- NoBuffering -> return ()
-#endif
- _ -> setCooked (haFD handle_) True
-
- -- throw away spare buffers, they might be the wrong size
- writeIORef (haBuffers handle_) BufferListNil
-
- return (handle_{ haBufferMode = mode })
-
--- -----------------------------------------------------------------------------
--- hFlush
-
--- | The action 'hFlush' @hdl@ causes any items buffered for output
--- in handle @hdl@ to be sent immediately to the operating system.
---
--- This operation may fail with:
---
--- * 'isFullError' if the device is full;
---
--- * 'isPermissionError' if a system resource limit would be exceeded.
--- It is unspecified whether the characters in the buffer are discarded
--- or retained under these circumstances.
-
-hFlush :: Handle -> IO ()
-hFlush handle =
- wantWritableHandle "hFlush" handle $ \ handle_ -> do
- buf <- readIORef (haBuffer handle_)
- if bufferIsWritable buf && not (bufferEmpty buf)
- then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
- writeIORef (haBuffer handle_) flushed_buf
- else return ()
-
-
--- -----------------------------------------------------------------------------
--- Repositioning Handles
-
-data HandlePosn = HandlePosn Handle HandlePosition
-
-instance Eq HandlePosn where
- (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
-
-instance Show HandlePosn where
- showsPrec p (HandlePosn h pos) =
- showsPrec p h . showString " at position " . shows pos
-
- -- HandlePosition is the Haskell equivalent of POSIX' off_t.
- -- We represent it as an Integer on the Haskell side, but
- -- cheat slightly in that hGetPosn calls upon a C helper
- -- that reports the position back via (merely) an Int.
-type HandlePosition = Integer
-
--- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
--- @hdl@ as a value of the abstract type 'HandlePosn'.
-
-hGetPosn :: Handle -> IO HandlePosn
-hGetPosn handle = do
- posn <- hTell handle
- return (HandlePosn handle posn)
-
--- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
--- then computation 'hSetPosn' @p@ sets the position of @hdl@
--- to the position it held at the time of the call to 'hGetPosn'.
---
--- This operation may fail with:
---
--- * 'isPermissionError' if a system resource limit would be exceeded.
-
-hSetPosn :: HandlePosn -> IO ()
-hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
-
--- ---------------------------------------------------------------------------
--- hSeek
-
--- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
-data SeekMode
- = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@.
- | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@
- -- from the current position.
- | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@
- -- from the end of the file.
- deriving (Eq, Ord, Ix, Enum, Read, Show)
-
-{- Note:
- - when seeking using `SeekFromEnd', positive offsets (>=0) means
- seeking at or past EOF.
-
- - we possibly deviate from the report on the issue of seeking within
- the buffer and whether to flush it or not. The report isn't exactly
- clear here.
--}
-
--- | Computation 'hSeek' @hdl mode i@ sets the position of handle
--- @hdl@ depending on @mode@.
--- The offset @i@ is given in terms of 8-bit bytes.
---
--- If @hdl@ is block- or line-buffered, then seeking to a position which is not
--- in the current buffer will first cause any items in the output buffer to be
--- written to the device, and then cause the input buffer to be discarded.
--- Some handles may not be seekable (see 'hIsSeekable'), or only support a
--- subset of the possible positioning operations (for instance, it may only
--- be possible to seek to the end of a tape, or to a positive offset from
--- the beginning or current position).
--- It is not possible to set a negative I\/O position, or for
--- a physical file, an I\/O position beyond the current end-of-file.
---
--- This operation may fail with:
---
--- * 'isPermissionError' if a system resource limit would be exceeded.
-
-hSeek :: Handle -> SeekMode -> Integer -> IO ()
-hSeek handle mode offset =
- wantSeekableHandle "hSeek" handle $ \ handle_ -> do
-# ifdef DEBUG_DUMP
- puts ("hSeek " ++ show (mode,offset) ++ "\n")
-# endif
- let ref = haBuffer handle_
- buf <- readIORef ref
- let r = bufRPtr buf
- w = bufWPtr buf
- fd = haFD handle_
-
- let do_seek =
- throwErrnoIfMinus1Retry_ "hSeek"
- (c_lseek (haFD handle_) (fromIntegral offset) whence)
-
- whence :: CInt
- whence = case mode of
- AbsoluteSeek -> sEEK_SET
- RelativeSeek -> sEEK_CUR
- SeekFromEnd -> sEEK_END
-
- if bufferIsWritable buf
- then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
- writeIORef ref new_buf
- do_seek
- else do
-
- if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
- then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
- else do
-
- new_buf <- flushReadBuffer (haFD handle_) buf
- writeIORef ref new_buf
- do_seek
-
-
-hTell :: Handle -> IO Integer
-hTell handle =
- wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
-
-#if defined(mingw32_HOST_OS)
- -- urgh, on Windows we have to worry about \n -> \r\n translation,
- -- so we can't easily calculate the file position using the
- -- current buffer size. Just flush instead.
- flushBuffer handle_
-#endif
- let fd = haFD handle_
- posn <- fromIntegral `liftM`
- throwErrnoIfMinus1Retry "hGetPosn"
- (c_lseek fd 0 sEEK_CUR)
-
- let ref = haBuffer handle_
- buf <- readIORef ref
-
- let real_posn
- | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
- | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
-# ifdef DEBUG_DUMP
- puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
- puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
-# endif
- return real_posn
-
--- -----------------------------------------------------------------------------
--- Handle Properties
-
--- A number of operations return information about the properties of a
--- handle. Each of these operations returns `True' if the handle has
--- the specified property, and `False' otherwise.
-
-hIsOpen :: Handle -> IO Bool
-hIsOpen handle =
- withHandle_ "hIsOpen" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> return False
- SemiClosedHandle -> return False
- _ -> return True
-
-hIsClosed :: Handle -> IO Bool
-hIsClosed handle =
- withHandle_ "hIsClosed" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> return True
- _ -> return False
-
-{- not defined, nor exported, but mentioned
- here for documentation purposes:
-
- hSemiClosed :: Handle -> IO Bool
- hSemiClosed h = do
- ho <- hIsOpen h
- hc <- hIsClosed h
- return (not (ho || hc))
--}
-
-hIsReadable :: Handle -> IO Bool
-hIsReadable (DuplexHandle _ _ _) = return True
-hIsReadable handle =
- withHandle_ "hIsReadable" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- htype -> return (isReadableHandleType htype)
-
-hIsWritable :: Handle -> IO Bool
-hIsWritable (DuplexHandle _ _ _) = return True
-hIsWritable handle =
- withHandle_ "hIsWritable" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- htype -> return (isWritableHandleType htype)
-
--- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
--- for @hdl@.
-
-hGetBuffering :: Handle -> IO BufferMode
-hGetBuffering handle =
- withHandle_ "hGetBuffering" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- _ ->
- -- We're being non-standard here, and allow the buffering
- -- of a semi-closed handle to be queried. -- sof 6/98
- return (haBufferMode handle_) -- could be stricter..
-
-hIsSeekable :: Handle -> IO Bool
-hIsSeekable handle =
- withHandle_ "hIsSeekable" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- AppendHandle -> return False
- _ -> do t <- fdType (haFD handle_)
- return ((t == RegularFile || t == RawDevice)
- && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED))
-
--- -----------------------------------------------------------------------------
--- Changing echo status (Non-standard GHC extensions)
-
--- | Set the echoing status of a handle connected to a terminal.
-
-hSetEcho :: Handle -> Bool -> IO ()
-hSetEcho handle on = do
- isT <- hIsTerminalDevice handle
- if not isT
- then return ()
- else
- withHandle_ "hSetEcho" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- _ -> setEcho (haFD handle_) on
-
--- | Get the echoing status of a handle connected to a terminal.
-
-hGetEcho :: Handle -> IO Bool
-hGetEcho handle = do
- isT <- hIsTerminalDevice handle
- if not isT
- then return False
- else
- withHandle_ "hGetEcho" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- _ -> getEcho (haFD handle_)
-
--- | Is the handle connected to a terminal?
-
-hIsTerminalDevice :: Handle -> IO Bool
-hIsTerminalDevice handle = do
- withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- _ -> fdIsTTY (haFD handle_)
-
--- -----------------------------------------------------------------------------
--- hSetBinaryMode
-
--- | Select binary mode ('True') or text mode ('False') on a open handle.
--- (See also 'openBinaryFile'.)
-
-hSetBinaryMode :: Handle -> Bool -> IO ()
-hSetBinaryMode handle bin =
- withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
- do throwErrnoIfMinus1_ "hSetBinaryMode"
- (setmode (haFD handle_) bin)
- return handle_{haIsBin=bin}
-
-foreign import ccall unsafe "__hscore_setmode"
- setmode :: CInt -> Bool -> IO CInt
-
--- -----------------------------------------------------------------------------
--- Duplicating a Handle
-
--- | Returns a duplicate of the original handle, with its own buffer.
--- The two Handles will share a file pointer, however. The original
--- handle's buffer is flushed, including discarding any input data,
--- before the handle is duplicated.
-
-hDuplicate :: Handle -> IO Handle
-hDuplicate h@(FileHandle path m) = do
- new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing)
- newFileHandle path (handleFinalizer path) new_h_
-hDuplicate h@(DuplexHandle path r w) = do
- new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing)
- new_w <- newMVar new_w_
- new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w))
- new_r <- newMVar new_r_
- addMVarFinalizer new_w (handleFinalizer path new_w)
- return (DuplexHandle path new_r new_w)
-
-dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__
- -> IO (Handle__, Handle__)
-dupHandle h other_side h_ = do
- -- flush the buffer first, so we don't have to copy its contents
- flushBuffer h_
- new_fd <- case other_side of
- Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_)
- Just r -> withHandle_' "dupHandle" h r (return . haFD)
- dupHandle_ other_side h_ new_fd
-
-dupHandleTo other_side hto_ h_ = do
- flushBuffer h_
- -- Windows' dup2 does not return the new descriptor, unlike Unix
- throwErrnoIfMinus1 "dupHandleTo" $
- c_dup2 (haFD h_) (haFD hto_)
- dupHandle_ other_side h_ (haFD hto_)
-
-dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD
- -> IO (Handle__, Handle__)
-dupHandle_ other_side h_ new_fd = do
- buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
- ioref <- newIORef buffer
- ioref_buffers <- newIORef BufferListNil
-
- let new_handle_ = h_{ haFD = new_fd,
- haBuffer = ioref,
- haBuffers = ioref_buffers,
- haOtherSide = other_side }
- return (h_, new_handle_)
-
--- -----------------------------------------------------------------------------
--- Replacing a Handle
-
-{- |
-Makes the second handle a duplicate of the first handle. The second
-handle will be closed first, if it is not already.
-
-This can be used to retarget the standard Handles, for example:
-
-> do h <- openFile "mystdout" WriteMode
-> hDuplicateTo h stdout
--}
-
-hDuplicateTo :: Handle -> Handle -> IO ()
-hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do
- withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
- _ <- hClose_help h2_
- withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_)
-hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do
- withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
- _ <- hClose_help w2_
- withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_)
- withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
- _ <- hClose_help r2_
- withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)
-hDuplicateTo h1 _ =
- ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
- "handles are incompatible" Nothing)
-
--- ---------------------------------------------------------------------------
--- showing Handles.
---
--- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
--- than the (pure) instance of 'Show' for 'Handle'.
-
-hShow :: Handle -> IO String
-hShow h@(FileHandle path _) = showHandle' path False h
-hShow h@(DuplexHandle path _ _) = showHandle' path True h
-
-showHandle' filepath is_duplex h =
- withHandle_ "showHandle" h $ \hdl_ ->
- let
- showType | is_duplex = showString "duplex (read-write)"
- | otherwise = shows (haType hdl_)
- in
- return
- (( showChar '{' .
- showHdl (haType hdl_)
- (showString "loc=" . showString filepath . showChar ',' .
- showString "type=" . showType . showChar ',' .
- showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
- showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
- ) "")
- where
-
- showHdl :: HandleType -> ShowS -> ShowS
- showHdl ht cont =
- case ht of
- ClosedHandle -> shows ht . showString "}"
- _ -> cont
-
- showBufMode :: Buffer -> BufferMode -> ShowS
- showBufMode buf bmo =
- case bmo of
- NoBuffering -> showString "none"
- LineBuffering -> showString "line"
- BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
- BlockBuffering Nothing -> showString "block " . showParen True (shows def)
- where
- def :: Int
- def = bufSize buf
-
--- ---------------------------------------------------------------------------
--- debugging
-
-#if defined(DEBUG_DUMP)
-puts :: String -> IO ()
-puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))
- return ()
-#endif
-
--- -----------------------------------------------------------------------------
--- utils
-
-throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt
-throwErrnoIfMinus1RetryOnBlock loc f on_block =
- do
- res <- f
- if (res :: CInt) == -1
- then do
- err <- getErrno
- if err == eINTR
- then throwErrnoIfMinus1RetryOnBlock loc f on_block
- else if err == eWOULDBLOCK || err == eAGAIN
- then do on_block
- else throwErrno loc
- else return res
-
--- -----------------------------------------------------------------------------
--- wrappers to platform-specific constants:
-
-foreign import ccall unsafe "__hscore_supportsTextMode"
- tEXT_MODE_SEEK_ALLOWED :: Bool
-
-foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
-foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
-foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
-foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
-
-#undef DEBUG_DUMP
-
------------------------------------------------------------------------------
--- |
--- Module : GHC.IO
--- Copyright : (c) The University of Glasgow, 1992-2001
--- License : see libraries/base/LICENSE
---
--- Maintainer : libraries@haskell.org
--- Stability : internal
--- Portability : non-portable
---
--- String I\/O functions
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.IO (
- hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
- commitBuffer', -- hack, see below
- hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
- hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile,
- memcpy_ba_baoff,
- memcpy_ptr_baoff,
- memcpy_baoff_ba,
- memcpy_baoff_ptr,
- ) where
-
-import Foreign
-import Foreign.C
-
-import System.IO.Error
-import Data.Maybe
-import Control.Monad
-import System.Posix.Internals
-
-import GHC.Enum
-import GHC.Base
-import GHC.IOBase
-import GHC.Handle -- much of the real stuff is in here
-import GHC.Real
-import GHC.Num
-import GHC.Show
-import GHC.List
-import GHC.Exception ( ioError, catch )
-
-#ifdef mingw32_HOST_OS
-import GHC.Conc
-#endif
-
--- ---------------------------------------------------------------------------
--- Simple input operations
-
--- If hWaitForInput finds anything in the Handle's buffer, it
--- immediately returns. If not, it tries to read from the underlying
--- OS handle. Notice that for buffered Handles connected to terminals
--- this means waiting until a complete line is available.
-
--- | Computation 'hWaitForInput' @hdl t@
--- waits until input is available on handle @hdl@.
--- It returns 'True' as soon as input is available on @hdl@,
--- or 'False' if no input is available within @t@ milliseconds.
---
--- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
---
--- This operation may fail with:
---
--- * 'isEOFError' if the end of file has been reached.
---
--- NOTE for GHC users: unless you use the @-threaded@ flag,
--- @hWaitForInput t@ where @t >= 0@ will block all other Haskell
--- threads for the duration of the call. It behaves like a
--- @safe@ foreign call in this respect.
-
-hWaitForInput :: Handle -> Int -> IO Bool
-hWaitForInput h msecs = do
- wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
- let ref = haBuffer handle_
- buf <- readIORef ref
-
- if not (bufferEmpty buf)
- then return True
- else do
-
- if msecs < 0
- then do buf' <- fillReadBuffer (haFD handle_) True
- (haIsStream handle_) buf
- writeIORef ref buf'
- return True
- else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $
- fdReady (haFD handle_) 0 {- read -}
- (fromIntegral msecs)
- (fromIntegral $ fromEnum $ haIsStream handle_)
- return (r /= 0)
-
-foreign import ccall safe "fdReady"
- fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
-
--- ---------------------------------------------------------------------------
--- hGetChar
-
--- | Computation 'hGetChar' @hdl@ reads a character from the file or
--- channel managed by @hdl@, blocking until a character is available.
---
--- This operation may fail with:
---
--- * 'isEOFError' if the end of file has been reached.
-
-hGetChar :: Handle -> IO Char
-hGetChar handle =
- wantReadableHandle "hGetChar" handle $ \handle_ -> do
-
- let fd = haFD handle_
- ref = haBuffer handle_
-
- buf <- readIORef ref
- if not (bufferEmpty buf)
- then hGetcBuffered fd ref buf
- else do
-
- -- buffer is empty.
- case haBufferMode handle_ of
- LineBuffering -> do
- new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
- hGetcBuffered fd ref new_buf
- BlockBuffering _ -> do
- new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
- -- ^^^^
- -- don't wait for a completely full buffer.
- hGetcBuffered fd ref new_buf
- NoBuffering -> do
- -- make use of the minimal buffer we already have
- let raw = bufBuf buf
- r <- readRawBuffer "hGetChar" fd (haIsStream handle_) raw 0 1
- if r == 0
- then ioe_EOF
- else do (c,_) <- readCharFromBuffer raw 0
- return c
-
-hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
- = do (c,r) <- readCharFromBuffer b r
- let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
- | otherwise = buf{ bufRPtr=r }
- writeIORef ref new_buf
- return c
-
--- ---------------------------------------------------------------------------
--- hGetLine
-
--- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
--- the duration.
-
--- | Computation 'hGetLine' @hdl@ reads a line from the file or
--- channel managed by @hdl@.
---
--- This operation may fail with:
---
--- * 'isEOFError' if the end of file is encountered when reading
--- the /first/ character of the line.
---
--- If 'hGetLine' encounters end-of-file at any other point while reading
--- in a line, it is treated as a line terminator and the (partial)
--- line is returned.
-
-hGetLine :: Handle -> IO String
-hGetLine h = do
- m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
- case haBufferMode handle_ of
- NoBuffering -> return Nothing
- LineBuffering -> do
- l <- hGetLineBuffered handle_
- return (Just l)
- BlockBuffering _ -> do
- l <- hGetLineBuffered handle_
- return (Just l)
- case m of
- Nothing -> hGetLineUnBuffered h
- Just l -> return l
-
-hGetLineBuffered :: Handle__ -> IO String
-hGetLineBuffered handle_ = do
- let ref = haBuffer handle_
- buf <- readIORef ref
- hGetLineBufferedLoop handle_ ref buf []
-
-hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String]
- -> IO String
-hGetLineBufferedLoop handle_ ref
- buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
- let
- -- find the end-of-line character, if there is one
- loop raw r
- | r == w = return (False, w)
- | otherwise = do
- (c,r') <- readCharFromBuffer raw r
- if c == '\n'
- then return (True, r) -- NB. not r': don't include the '\n'
- else loop raw r'
- in do
- (eol, off) <- loop raw r
-
-#ifdef DEBUG_DUMP
- puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
-#endif
-
- xs <- unpack raw r off
-
- -- if eol == True, then off is the offset of the '\n'
- -- otherwise off == w and the buffer is now empty.
- if eol
- then do if (w == off + 1)
- then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
- else writeIORef ref buf{ bufRPtr = off + 1 }
- return (concat (reverse (xs:xss)))
- else do
- maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
- buf{ bufWPtr=0, bufRPtr=0 }
- case maybe_buf of
- -- Nothing indicates we caught an EOF, and we may have a
- -- partial line to return.
- Nothing -> do
- writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
- let str = concat (reverse (xs:xss))
- if not (null str)
- then return str
- else ioe_EOF
- Just new_buf ->
- hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
-
-
-maybeFillReadBuffer fd is_line is_stream buf
- = catch
- (do buf <- fillReadBuffer fd is_line is_stream buf
- return (Just buf)
- )
- (\e -> do if isEOFError e
- then return Nothing
- else ioError e)
-
-
-unpack :: RawBuffer -> Int -> Int -> IO [Char]
-unpack buf r 0 = return ""
-unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
- where
- unpack acc i s
- | i <# r = (# s, acc #)
- | otherwise =
- case readCharArray# buf i s of
- (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
-
-
-hGetLineUnBuffered :: Handle -> IO String
-hGetLineUnBuffered h = do
- c <- hGetChar h
- if c == '\n' then
- return ""
- else do
- l <- getRest
- return (c:l)
- where
- getRest = do
- c <-
- catch
- (hGetChar h)
- (\ err -> do
- if isEOFError err then
- return '\n'
- else
- ioError err)
- if c == '\n' then
- return ""
- else do
- s <- getRest
- return (c:s)
-
--- -----------------------------------------------------------------------------
--- hGetContents
-
--- hGetContents on a DuplexHandle only affects the read side: you can
--- carry on writing to it afterwards.
-
--- | Computation 'hGetContents' @hdl@ returns the list of characters
--- corresponding to the unread portion of the channel or file managed
--- by @hdl@, which is put into an intermediate state, /semi-closed/.
--- In this state, @hdl@ is effectively closed,
--- but items are read from @hdl@ on demand and accumulated in a special
--- list returned by 'hGetContents' @hdl@.
---
--- Any operation that fails because a handle is closed,
--- also fails if a handle is semi-closed. The only exception is 'hClose'.
--- A semi-closed handle becomes closed:
---
--- * if 'hClose' is applied to it;
---
--- * if an I\/O error occurs when reading an item from the handle;
---
--- * or once the entire contents of the handle has been read.
---
--- Once a semi-closed handle becomes closed, the contents of the
--- associated list becomes fixed. The contents of this final list is
--- only partially specified: it will contain at least all the items of
--- the stream that were evaluated prior to the handle becoming closed.
---
--- Any I\/O errors encountered while a handle is semi-closed are simply
--- discarded.
---
--- This operation may fail with:
---
--- * 'isEOFError' if the end of file has been reached.
-
-hGetContents :: Handle -> IO String
-hGetContents handle =
- withHandle "hGetContents" handle $ \handle_ ->
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- AppendHandle -> ioe_notReadable
- WriteHandle -> ioe_notReadable
- _ -> do xs <- lazyRead handle
- return (handle_{ haType=SemiClosedHandle}, xs )
-
--- Note that someone may close the semi-closed handle (or change its
--- buffering), so each time these lazy read functions are pulled on,
--- they have to check whether the handle has indeed been closed.
-
-lazyRead :: Handle -> IO String
-lazyRead handle =
- unsafeInterleaveIO $
- withHandle "lazyRead" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> return (handle_, "")
- SemiClosedHandle -> lazyRead' handle handle_
- _ -> ioException
- (IOError (Just handle) IllegalOperation "lazyRead"
- "illegal handle type" Nothing)
-
-lazyRead' h handle_ = do
- let ref = haBuffer handle_
- fd = haFD handle_
-
- -- even a NoBuffering handle can have a char in the buffer...
- -- (see hLookAhead)
- buf <- readIORef ref
- if not (bufferEmpty buf)
- then lazyReadHaveBuffer h handle_ fd ref buf
- else do
-
- case haBufferMode handle_ of
- NoBuffering -> do
- -- make use of the minimal buffer we already have
- let raw = bufBuf buf
- r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1
- if r == 0
- then do handle_ <- hClose_help handle_
- return (handle_, "")
- else do (c,_) <- readCharFromBuffer raw 0
- rest <- lazyRead h
- return (handle_, c : rest)
-
- LineBuffering -> lazyReadBuffered h handle_ fd ref buf
- BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
-
--- we never want to block during the read, so we call fillReadBuffer with
--- is_line==True, which tells it to "just read what there is".
-lazyReadBuffered h handle_ fd ref buf = do
- catch
- (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
- lazyReadHaveBuffer h handle_ fd ref buf
- )
- -- all I/O errors are discarded. Additionally, we close the handle.
- (\e -> do handle_ <- hClose_help handle_
- return (handle_, "")
- )
-
-lazyReadHaveBuffer h handle_ fd ref buf = do
- more <- lazyRead h
- writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
- s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
- return (handle_, s)
-
-
-unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
-unpackAcc buf r 0 acc = return acc
-unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
- where
- unpack acc i s
- | i <# r = (# s, acc #)
- | otherwise =
- case readCharArray# buf i s of
- (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
-
--- ---------------------------------------------------------------------------
--- hPutChar
-
--- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
--- file or channel managed by @hdl@. Characters may be buffered if
--- buffering is enabled for @hdl@.
---
--- This operation may fail with:
---
--- * 'isFullError' if the device is full; or
---
--- * 'isPermissionError' if another system resource limit would be exceeded.
-
-hPutChar :: Handle -> Char -> IO ()
-hPutChar handle c = do
- c `seq` return ()
- wantWritableHandle "hPutChar" handle $ \ handle_ -> do
- let fd = haFD handle_
- case haBufferMode handle_ of
- LineBuffering -> hPutcBuffered handle_ True c
- BlockBuffering _ -> hPutcBuffered handle_ False c
- NoBuffering ->
- with (castCharToCChar c) $ \buf -> do
- writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1
- return ()
-
-hPutcBuffered handle_ is_line c = do
- let ref = haBuffer handle_
- buf <- readIORef ref
- let w = bufWPtr buf
- w' <- writeCharIntoBuffer (bufBuf buf) w c
- let new_buf = buf{ bufWPtr = w' }
- if bufferFull new_buf || is_line && c == '\n'
- then do
- flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
- writeIORef ref flushed_buf
- else do
- writeIORef ref new_buf
-
-
-hPutChars :: Handle -> [Char] -> IO ()
-hPutChars handle [] = return ()
-hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
-
--- ---------------------------------------------------------------------------
--- hPutStr
-
--- We go to some trouble to avoid keeping the handle locked while we're
--- evaluating the string argument to hPutStr, in case doing so triggers another
--- I/O operation on the same handle which would lead to deadlock. The classic
--- case is
---
--- putStr (trace "hello" "world")
---
--- so the basic scheme is this:
---
--- * copy the string into a fresh buffer,
--- * "commit" the buffer to the handle.
---
--- Committing may involve simply copying the contents of the new
--- buffer into the handle's buffer, flushing one or both buffers, or
--- maybe just swapping the buffers over (if the handle's buffer was
--- empty). See commitBuffer below.
-
--- | Computation 'hPutStr' @hdl s@ writes the string
--- @s@ to the file or channel managed by @hdl@.
---
--- This operation may fail with:
---
--- * 'isFullError' if the device is full; or
---
--- * 'isPermissionError' if another system resource limit would be exceeded.
-
-hPutStr :: Handle -> String -> IO ()
-hPutStr handle str = do
- buffer_mode <- wantWritableHandle "hPutStr" handle
- (\ handle_ -> do getSpareBuffer handle_)
- case buffer_mode of
- (NoBuffering, _) -> do
- hPutChars handle str -- v. slow, but we don't care
- (LineBuffering, buf) -> do
- writeLines handle buf str
- (BlockBuffering _, buf) -> do
- writeBlocks handle buf str
-
-
-getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
-getSpareBuffer Handle__{haBuffer=ref,
- haBuffers=spare_ref,
- haBufferMode=mode}
- = do
- case mode of
- NoBuffering -> return (mode, error "no buffer!")
- _ -> do
- bufs <- readIORef spare_ref
- buf <- readIORef ref
- case bufs of
- BufferListCons b rest -> do
- writeIORef spare_ref rest
- return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
- BufferListNil -> do
- new_buf <- allocateBuffer (bufSize buf) WriteBuffer
- return (mode, new_buf)
-
-
-writeLines :: Handle -> Buffer -> String -> IO ()
-writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
- let
- shoveString :: Int -> [Char] -> IO ()
- -- check n == len first, to ensure that shoveString is strict in n.
- shoveString n cs | n == len = do
- new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
- writeLines hdl new_buf cs
- shoveString n [] = do
- commitBuffer hdl raw len n False{-no flush-} True{-release-}
- return ()
- shoveString n (c:cs) = do
- n' <- writeCharIntoBuffer raw n c
- if (c == '\n')
- then do
- new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
- writeLines hdl new_buf cs
- else
- shoveString n' cs
- in
- shoveString 0 s
-
-writeBlocks :: Handle -> Buffer -> String -> IO ()
-writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
- let
- shoveString :: Int -> [Char] -> IO ()
- -- check n == len first, to ensure that shoveString is strict in n.
- shoveString n cs | n == len = do
- new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
- writeBlocks hdl new_buf cs
- shoveString n [] = do
- commitBuffer hdl raw len n False{-no flush-} True{-release-}
- return ()
- shoveString n (c:cs) = do
- n' <- writeCharIntoBuffer raw n c
- shoveString n' cs
- in
- shoveString 0 s
-
--- -----------------------------------------------------------------------------
--- commitBuffer handle buf sz count flush release
---
--- Write the contents of the buffer 'buf' ('sz' bytes long, containing
--- 'count' bytes of data) to handle (handle must be block or line buffered).
---
--- Implementation:
---
--- for block/line buffering,
--- 1. If there isn't room in the handle buffer, flush the handle
--- buffer.
---
--- 2. If the handle buffer is empty,
--- if flush,
--- then write buf directly to the device.
--- else swap the handle buffer with buf.
---
--- 3. If the handle buffer is non-empty, copy buf into the
--- handle buffer. Then, if flush != 0, flush
--- the buffer.
-
-commitBuffer
- :: Handle -- handle to commit to
- -> RawBuffer -> Int -- address and size (in bytes) of buffer
- -> Int -- number of bytes of data in buffer
- -> Bool -- True <=> flush the handle afterward
- -> Bool -- release the buffer?
- -> IO Buffer
-
-commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
- wantWritableHandle "commitAndReleaseBuffer" hdl $
- commitBuffer' raw sz count flush release
-
--- Explicitly lambda-lift this function to subvert GHC's full laziness
--- optimisations, which otherwise tends to float out subexpressions
--- past the \handle, which is really a pessimisation in this case because
--- that lambda is a one-shot lambda.
---
--- Don't forget to export the function, to stop it being inlined too
--- (this appears to be better than NOINLINE, because the strictness
--- analyser still gets to worker-wrapper it).
---
--- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
---
-commitBuffer' raw sz@(I# _) count@(I# _) flush release
- handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
-
-#ifdef DEBUG_DUMP
- puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
- ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
-#endif
-
- old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
- <- readIORef ref
-
- buf_ret <-
- -- enough room in handle buffer?
- if (not flush && (size - w > count))
- -- The > is to be sure that we never exactly fill
- -- up the buffer, which would require a flush. So
- -- if copying the new data into the buffer would
- -- make the buffer full, we just flush the existing
- -- buffer and the new data immediately, rather than
- -- copying before flushing.
-
- -- not flushing, and there's enough room in the buffer:
- -- just copy the data in and update bufWPtr.
- then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count)
- writeIORef ref old_buf{ bufWPtr = w + count }
- return (newEmptyBuffer raw WriteBuffer sz)
-
- -- else, we have to flush
- else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
-
- let this_buf =
- Buffer{ bufBuf=raw, bufState=WriteBuffer,
- bufRPtr=0, bufWPtr=count, bufSize=sz }
-
- -- if: (a) we don't have to flush, and
- -- (b) size(new buffer) == size(old buffer), and
- -- (c) new buffer is not full,
- -- we can just just swap them over...
- if (not flush && sz == size && count /= sz)
- then do
- writeIORef ref this_buf
- return flushed_buf
-
- -- otherwise, we have to flush the new data too,
- -- and start with a fresh buffer
- else do
- flushWriteBuffer fd (haIsStream handle_) this_buf
- writeIORef ref flushed_buf
- -- if the sizes were different, then allocate
- -- a new buffer of the correct size.
- if sz == size
- then return (newEmptyBuffer raw WriteBuffer sz)
- else allocateBuffer size WriteBuffer
-
- -- release the buffer if necessary
- case buf_ret of
- Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
- if release && buf_ret_sz == size
- then do
- spare_bufs <- readIORef spare_buf_ref
- writeIORef spare_buf_ref
- (BufferListCons buf_ret_raw spare_bufs)
- return buf_ret
- else
- return buf_ret
-
--- ---------------------------------------------------------------------------
--- Reading/writing sequences of bytes.
-
--- ---------------------------------------------------------------------------
--- hPutBuf
-
--- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
--- buffer @buf@ to the handle @hdl@. It returns ().
---
--- This operation may fail with:
---
--- * 'ResourceVanished' if the handle is a pipe or socket, and the
--- reading end is closed. (If this is a POSIX system, and the program
--- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
--- instead, whose default action is to terminate the program).
-
-hPutBuf :: Handle -- handle to write to
- -> Ptr a -- address of buffer
- -> Int -- number of bytes of data in buffer
- -> IO ()
-hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
-
-hPutBufNonBlocking
- :: Handle -- handle to write to
- -> Ptr a -- address of buffer
- -> Int -- number of bytes of data in buffer
- -> IO Int -- returns: number of bytes written
-hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
-
-hPutBuf':: Handle -- handle to write to
- -> Ptr a -- address of buffer
- -> Int -- number of bytes of data in buffer
- -> Bool -- allow blocking?
- -> IO Int
-hPutBuf' handle ptr count can_block
- | count == 0 = return 0
- | count < 0 = illegalBufferSize handle "hPutBuf" count
- | otherwise =
- wantWritableHandle "hPutBuf" handle $
- \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
- bufWrite fd ref is_stream ptr count can_block
-
-bufWrite fd ref is_stream ptr count can_block =
- seq count $ seq fd $ do -- strictness hack
- old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
- <- readIORef ref
-
- -- enough room in handle buffer?
- if (size - w > count)
- -- There's enough room in the buffer:
- -- just copy the data in and update bufWPtr.
- then do memcpy_baoff_ptr old_raw (fromIntegral w) ptr (fromIntegral count)
- writeIORef ref old_buf{ bufWPtr = w + count }
- return count
-
- -- else, we have to flush
- else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
- -- TODO: we should do a non-blocking flush here
- writeIORef ref flushed_buf
- -- if we can fit in the buffer, then just loop
- if count < size
- then bufWrite fd ref is_stream ptr count can_block
- else if can_block
- then do writeChunk fd is_stream (castPtr ptr) count
- return count
- else writeChunkNonBlocking fd is_stream ptr count
-
-writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
-writeChunk fd is_stream ptr bytes = loop 0 bytes
- where
- loop :: Int -> Int -> IO ()
- loop _ bytes | bytes <= 0 = return ()
- loop off bytes = do
- r <- fromIntegral `liftM`
- writeRawBufferPtr "writeChunk" fd is_stream ptr
- off (fromIntegral bytes)
- -- write can't return 0
- loop (off + r) (bytes - r)
-
-writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
-writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
- where
- loop :: Int -> Int -> IO Int
- loop off bytes | bytes <= 0 = return off
- loop off bytes = do
-#ifndef mingw32_HOST_OS
- ssize <- c_write fd (ptr `plusPtr` off) (fromIntegral bytes)
- let r = fromIntegral ssize :: Int
- if (r == -1)
- then do errno <- getErrno
- if (errno == eAGAIN || errno == eWOULDBLOCK)
- then return off
- else throwErrno "writeChunk"
- else loop (off + r) (bytes - r)
-#else
- (ssize, rc) <- asyncWrite (fromIntegral fd)
- (fromIntegral $ fromEnum is_stream)
- (fromIntegral bytes)
- (ptr `plusPtr` off)
- let r = fromIntegral ssize :: Int
- if r == (-1)
- then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
- else loop (off + r) (bytes - r)
-#endif
-
--- ---------------------------------------------------------------------------
--- hGetBuf
-
--- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
--- into the buffer @buf@ until either EOF is reached or
--- @count@ 8-bit bytes have been read.
--- It returns the number of bytes actually read. This may be zero if
--- EOF was reached before any data was read (or if @count@ is zero).
---
--- 'hGetBuf' never raises an EOF exception, instead it returns a value
--- smaller than @count@.
---
--- If the handle is a pipe or socket, and the writing end
--- is closed, 'hGetBuf' will behave as if EOF was reached.
-
-hGetBuf :: Handle -> Ptr a -> Int -> IO Int
-hGetBuf h ptr count
- | count == 0 = return 0
- | count < 0 = illegalBufferSize h "hGetBuf" count
- | otherwise =
- wantReadableHandle "hGetBuf" h $
- \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
- bufRead fd ref is_stream ptr 0 count
-
--- small reads go through the buffer, large reads are satisfied by
--- taking data first from the buffer and then direct from the file
--- descriptor.
-bufRead fd ref is_stream ptr so_far count =
- seq fd $ seq so_far $ seq count $ do -- strictness hack
- buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
- if bufferEmpty buf
- then if count > sz -- small read?
- then do rest <- readChunk fd is_stream ptr count
- return (so_far + rest)
- else do mb_buf <- maybeFillReadBuffer fd True is_stream buf
- case mb_buf of
- Nothing -> return so_far -- got nothing, we're done
- Just buf' -> do
- writeIORef ref buf'
- bufRead fd ref is_stream ptr so_far count
- else do
- let avail = w - r
- if (count == avail)
- then do
- memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
- writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
- return (so_far + count)
- else do
- if (count < avail)
- then do
- memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
- writeIORef ref buf{ bufRPtr = r + count }
- return (so_far + count)
- else do
-
- memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)
- writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
- let remaining = count - avail
- so_far' = so_far + avail
- ptr' = ptr `plusPtr` avail
-
- if remaining < sz
- then bufRead fd ref is_stream ptr' so_far' remaining
- else do
-
- rest <- readChunk fd is_stream ptr' remaining
- return (so_far' + rest)
-
-readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
-readChunk fd is_stream ptr bytes = loop 0 bytes
- where
- loop :: Int -> Int -> IO Int
- loop off bytes | bytes <= 0 = return off
- loop off bytes = do
- r <- fromIntegral `liftM`
- readRawBufferPtr "readChunk" fd is_stream
- (castPtr ptr) off (fromIntegral bytes)
- if r == 0
- then return off
- else loop (off + r) (bytes - r)
-
-
--- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
--- into the buffer @buf@ until either EOF is reached, or
--- @count@ 8-bit bytes have been read, or there is no more data available
--- to read immediately.
---
--- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
--- never block waiting for data to become available, instead it returns
--- only whatever data is available. To wait for data to arrive before
--- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
---
--- If the handle is a pipe or socket, and the writing end
--- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
---
-hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
-hGetBufNonBlocking h ptr count
- | count == 0 = return 0
- | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
- | otherwise =
- wantReadableHandle "hGetBufNonBlocking" h $
- \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
- bufReadNonBlocking fd ref is_stream ptr 0 count
-
-bufReadNonBlocking fd ref is_stream ptr so_far count =
- seq fd $ seq so_far $ seq count $ do -- strictness hack
- buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
- if bufferEmpty buf
- then if count > sz -- large read?
- then do rest <- readChunkNonBlocking fd is_stream ptr count
- return (so_far + rest)
- else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf
- case buf' of { Buffer{ bufWPtr=w } ->
- if (w == 0)
- then return so_far
- else do writeIORef ref buf'
- bufReadNonBlocking fd ref is_stream ptr
- so_far (min count w)
- -- NOTE: new count is 'min count w'
- -- so we will just copy the contents of the
- -- buffer in the recursive call, and not
- -- loop again.
- }
- else do
- let avail = w - r
- if (count == avail)
- then do
- memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
- writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
- return (so_far + count)
- else do
- if (count < avail)
- then do
- memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
- writeIORef ref buf{ bufRPtr = r + count }
- return (so_far + count)
- else do
-
- memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)
- writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
- let remaining = count - avail
- so_far' = so_far + avail
- ptr' = ptr `plusPtr` avail
-
- -- we haven't attempted to read anything yet if we get to here.
- if remaining < sz
- then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining
- else do
-
- rest <- readChunkNonBlocking fd is_stream ptr' remaining
- return (so_far' + rest)
-
-
-readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
-readChunkNonBlocking fd is_stream ptr bytes = do
-#ifndef mingw32_HOST_OS
- ssize <- c_read fd (castPtr ptr) (fromIntegral bytes)
- let r = fromIntegral ssize :: Int
- if (r == -1)
- then do errno <- getErrno
- if (errno == eAGAIN || errno == eWOULDBLOCK)
- then return 0
- else throwErrno "readChunk"
- else return r
-#else
- fromIntegral `liftM`
- readRawBufferPtr "readChunkNonBlocking" fd is_stream
- (castPtr ptr) 0 (fromIntegral bytes)
-
- -- we don't have non-blocking read support on Windows, so just invoke
- -- the ordinary low-level read which will block until data is available,
- -- but won't wait for the whole buffer to fill.
-#endif
-
-slurpFile :: FilePath -> IO (Ptr (), Int)
-slurpFile fname = do
- handle <- openFile fname ReadMode
- sz <- hFileSize handle
- if sz > fromIntegral (maxBound::Int) then
- ioError (userError "slurpFile: file too big")
- else do
- let sz_i = fromIntegral sz
- if sz_i == 0 then return (nullPtr, 0) else do
- chunk <- mallocBytes sz_i
- r <- hGetBuf handle chunk sz_i
- hClose handle
- return (chunk, r)
-
--- ---------------------------------------------------------------------------
--- memcpy wrappers
-
-foreign import ccall unsafe "__hscore_memcpy_src_off"
- memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
-foreign import ccall unsafe "__hscore_memcpy_src_off"
- memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
-foreign import ccall unsafe "__hscore_memcpy_dst_off"
- memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ())
-foreign import ccall unsafe "__hscore_memcpy_dst_off"
- memcpy_baoff_ptr :: RawBuffer -> CInt -> Ptr a -> CSize -> IO (Ptr ())
-
------------------------------------------------------------------------------
--- Internal Utils
-
-illegalBufferSize :: Handle -> String -> Int -> IO a
-illegalBufferSize handle fn (sz :: Int) =
- ioException (IOError (Just handle)
- InvalidArgument fn
- ("illegal buffer size " ++ showsPrec 9 sz [])
- Nothing)
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.IOBase
--- Copyright : (c) The University of Glasgow 1994-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- Definitions for the 'IO' monad and its friends.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.IOBase(
- IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO,
- unsafePerformIO, unsafeInterleaveIO,
- unsafeDupablePerformIO, unsafeDupableInterleaveIO,
- noDuplicate,
-
- -- To and from from ST
- stToIO, ioToST, unsafeIOToST, unsafeSTToIO,
-
- -- References
- IORef(..), newIORef, readIORef, writeIORef,
- IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray,
- MVar(..),
-
- -- Handles, file descriptors,
- FilePath,
- Handle(..), Handle__(..), HandleType(..), IOMode(..), FD,
- isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle,
-
- -- Buffers
- Buffer(..), RawBuffer, BufferState(..), BufferList(..), BufferMode(..),
- bufferIsWritable, bufferEmpty, bufferFull,
-
- -- Exceptions
- Exception(..), ArithException(..), AsyncException(..), ArrayException(..),
- stackOverflow, heapOverflow, throw, throwIO, ioException,
- IOError, IOException(..), IOErrorType(..), ioError, userError,
- ExitCode(..)
- ) where
-
-import GHC.ST
-import GHC.Arr -- to derive Ix class
-import GHC.Enum -- to derive Enum class
-import GHC.STRef
-import GHC.Base
--- import GHC.Num -- To get fromInteger etc, needed because of -fno-implicit-prelude
-import Data.Maybe ( Maybe(..) )
-import GHC.Show
-import GHC.List
-import GHC.Read
-import Foreign.C.Types (CInt)
-
-#ifndef __HADDOCK__
-import {-# SOURCE #-} Data.Typeable ( showsTypeRep )
-import {-# SOURCE #-} Data.Dynamic ( Dynamic, dynTypeRep )
-#endif
-
--- ---------------------------------------------------------------------------
--- The IO Monad
-
-{-
-The IO Monad is just an instance of the ST monad, where the state is
-the real world. We use the exception mechanism (in GHC.Exception) to
-implement IO exceptions.
-
-NOTE: The IO representation is deeply wired in to various parts of the
-system. The following list may or may not be exhaustive:
-
-Compiler - types of various primitives in PrimOp.lhs
-
-RTS - forceIO (StgMiscClosures.hc)
- - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
- (Exceptions.hc)
- - raiseAsync (Schedule.c)
-
-Prelude - GHC.IOBase.lhs, and several other places including
- GHC.Exception.lhs.
-
-Libraries - parts of hslibs/lang.
-
---SDM
--}
-
-{-|
-A value of type @'IO' a@ is a computation which, when performed,
-does some I\/O before returning a value of type @a@.
-
-There is really only one way to \"perform\" an I\/O action: bind it to
-@Main.main@ in your program. When your program is run, the I\/O will
-be performed. It isn't possible to perform I\/O from an arbitrary
-function, unless that function is itself in the 'IO' monad and called
-at some point, directly or indirectly, from @Main.main@.
-
-'IO' is a monad, so 'IO' actions can be combined using either the do-notation
-or the '>>' and '>>=' operations from the 'Monad' class.
--}
-newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
-
-unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
-unIO (IO a) = a
-
-instance Functor IO where
- fmap f x = x >>= (return . f)
-
-instance Monad IO where
- {-# INLINE return #-}
- {-# INLINE (>>) #-}
- {-# INLINE (>>=) #-}
- m >> k = m >>= \ _ -> k
- return x = returnIO x
-
- m >>= k = bindIO m k
- fail s = failIO s
-
-failIO :: String -> IO a
-failIO s = ioError (userError s)
-
-liftIO :: IO a -> State# RealWorld -> STret RealWorld a
-liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
-
-bindIO :: IO a -> (a -> IO b) -> IO b
-bindIO (IO m) k = IO ( \ s ->
- case m s of
- (# new_s, a #) -> unIO (k a) new_s
- )
-
-thenIO :: IO a -> IO b -> IO b
-thenIO (IO m) k = IO ( \ s ->
- case m s of
- (# new_s, a #) -> unIO k new_s
- )
-
-returnIO :: a -> IO a
-returnIO x = IO (\ s -> (# s, x #))
-
--- ---------------------------------------------------------------------------
--- Coercions between IO and ST
-
--- | A monad transformer embedding strict state transformers in the 'IO'
--- monad. The 'RealWorld' parameter indicates that the internal state
--- used by the 'ST' computation is a special one supplied by the 'IO'
--- monad, and thus distinct from those used by invocations of 'runST'.
-stToIO :: ST RealWorld a -> IO a
-stToIO (ST m) = IO m
-
-ioToST :: IO a -> ST RealWorld a
-ioToST (IO m) = (ST m)
-
--- This relies on IO and ST having the same representation modulo the
--- constraint on the type of the state
---
-unsafeIOToST :: IO a -> ST s a
-unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s
-
-unsafeSTToIO :: ST s a -> IO a
-unsafeSTToIO (ST m) = IO (unsafeCoerce# m)
-
--- ---------------------------------------------------------------------------
--- Unsafe IO operations
-
-{-|
-This is the \"back door\" into the 'IO' monad, allowing
-'IO' computation to be performed at any time. For
-this to be safe, the 'IO' computation should be
-free of side effects and independent of its environment.
-
-If the I\/O computation wrapped in 'unsafePerformIO'
-performs side effects, then the relative order in which those side
-effects take place (relative to the main I\/O trunk, or other calls to
-'unsafePerformIO') is indeterminate. You have to be careful when
-writing and compiling modules that use 'unsafePerformIO':
-
- * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@
- that calls 'unsafePerformIO'. If the call is inlined,
- the I\/O may be performed more than once.
-
- * Use the compiler flag @-fno-cse@ to prevent common sub-expression
- elimination being performed on the module, which might combine
- two side effects that were meant to be separate. A good example
- is using multiple global variables (like @test@ in the example below).
-
- * Make sure that the either you switch off let-floating, or that the
- call to 'unsafePerformIO' cannot float outside a lambda. For example,
- if you say:
- @
- f x = unsafePerformIO (newIORef [])
- @
- you may get only one reference cell shared between all calls to @f@.
- Better would be
- @
- f x = unsafePerformIO (newIORef [x])
- @
- because now it can't float outside the lambda.
-
-It is less well known that
-'unsafePerformIO' is not type safe. For example:
-
-> test :: IORef [a]
-> test = unsafePerformIO $ newIORef []
->
-> main = do
-> writeIORef test [42]
-> bang <- readIORef test
-> print (bang :: [Char])
-
-This program will core dump. This problem with polymorphic references
-is well known in the ML community, and does not arise with normal
-monadic use of references. There is no easy way to make it impossible
-once you use 'unsafePerformIO'. Indeed, it is
-possible to write @coerce :: a -> b@ with the
-help of 'unsafePerformIO'. So be careful!
--}
-unsafePerformIO :: IO a -> a
-unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m)
-
-{-|
-This version of 'unsafePerformIO' is slightly more efficient,
-because it omits the check that the IO is only being performed by a
-single thread. Hence, when you write 'unsafeDupablePerformIO',
-there is a possibility that the IO action may be performed multiple
-times (on a multiprocessor), and you should therefore ensure that
-it gives the same results each time.
--}
-{-# NOINLINE unsafeDupablePerformIO #-}
-unsafeDupablePerformIO :: IO a -> a
-unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
-
--- Why do we NOINLINE unsafeDupablePerformIO? See the comment with
--- GHC.ST.runST. Essentially the issue is that the IO computation
--- inside unsafePerformIO must be atomic: it must either all run, or
--- not at all. If we let the compiler see the application of the IO
--- to realWorld#, it might float out part of the IO.
-
--- Why is there a call to 'lazy' in unsafeDupablePerformIO?
--- If we don't have it, the demand analyser discovers the following strictness
--- for unsafeDupablePerformIO: C(U(AV))
--- But then consider
--- unsafeDupablePerformIO (\s -> let r = f x in
--- case writeIORef v r s of (# s1, _ #) ->
--- (# s1, r #)
--- The strictness analyser will find that the binding for r is strict,
--- (becuase of uPIO's strictness sig), and so it'll evaluate it before
--- doing the writeIORef. This actually makes tests/lib/should_run/memo002
--- get a deadlock!
---
--- Solution: don't expose the strictness of unsafeDupablePerformIO,
--- by hiding it with 'lazy'
-
-{-|
-'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily.
-When passed a value of type @IO a@, the 'IO' will only be performed
-when the value of the @a@ is demanded. This is used to implement lazy
-file reading, see 'System.IO.hGetContents'.
--}
-{-# INLINE unsafeInterleaveIO #-}
-unsafeInterleaveIO :: IO a -> IO a
-unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m)
-
--- We believe that INLINE on unsafeInterleaveIO is safe, because the
--- state from this IO thread is passed explicitly to the interleaved
--- IO, so it cannot be floated out and shared.
-
-{-# INLINE unsafeDupableInterleaveIO #-}
-unsafeDupableInterleaveIO :: IO a -> IO a
-unsafeDupableInterleaveIO (IO m)
- = IO ( \ s -> let
- r = case m s of (# _, res #) -> res
- in
- (# s, r #))
-
-{-|
-Ensures that the suspensions under evaluation by the current thread
-are unique; that is, the current thread is not evaluating anything
-that is also under evaluation by another thread that has also executed
-'noDuplicate'.
-
-This operation is used in the definition of 'unsafePerformIO' to
-prevent the IO action from being executed multiple times, which is usually
-undesirable.
--}
-noDuplicate :: IO ()
-noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #)
-
--- ---------------------------------------------------------------------------
--- Handle type
-
-data MVar a = MVar (MVar# RealWorld a)
-{- ^
-An 'MVar' (pronounced \"em-var\") is a synchronising variable, used
-for communication between concurrent threads. It can be thought of
-as a a box, which may be empty or full.
--}
-
--- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module
-instance Eq (MVar a) where
- (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
-
--- A Handle is represented by (a reference to) a record
--- containing the state of the I/O port/device. We record
--- the following pieces of info:
-
--- * type (read,write,closed etc.)
--- * the underlying file descriptor
--- * buffering mode
--- * buffer, and spare buffers
--- * user-friendly name (usually the
--- FilePath used when IO.openFile was called)
-
--- Note: when a Handle is garbage collected, we want to flush its buffer
--- and close the OS file handle, so as to free up a (precious) resource.
-
--- | Haskell defines operations to read and write characters from and to files,
--- represented by values of type @Handle@. Each value of this type is a
--- /handle/: a record used by the Haskell run-time system to /manage/ I\/O
--- with file system objects. A handle has at least the following properties:
---
--- * whether it manages input or output or both;
---
--- * whether it is /open/, /closed/ or /semi-closed/;
---
--- * whether the object is seekable;
---
--- * whether buffering is disabled, or enabled on a line or block basis;
---
--- * a buffer (whose length may be zero).
---
--- Most handles will also have a current I\/O position indicating where the next
--- input or output operation will occur. A handle is /readable/ if it
--- manages only input or both input and output; likewise, it is /writable/ if
--- it manages only output or both input and output. A handle is /open/ when
--- first allocated.
--- Once it is closed it can no longer be used for either input or output,
--- though an implementation cannot re-use its storage while references
--- remain to it. Handles are in the 'Show' and 'Eq' classes. The string
--- produced by showing a handle is system dependent; it should include
--- enough information to identify the handle for debugging. A handle is
--- equal according to '==' only to itself; no attempt
--- is made to compare the internal state of different handles for equality.
---
--- GHC note: a 'Handle' will be automatically closed when the garbage
--- collector detects that it has become unreferenced by the program.
--- However, relying on this behaviour is not generally recommended:
--- the garbage collector is unpredictable. If possible, use explicit
--- an explicit 'hClose' to close 'Handle's when they are no longer
--- required. GHC does not currently attempt to free up file
--- descriptors when they have run out, it is your responsibility to
--- ensure that this doesn't happen.
-
-data Handle
- = FileHandle -- A normal handle to a file
- FilePath -- the file (invariant)
- !(MVar Handle__)
-
- | DuplexHandle -- A handle to a read/write stream
- FilePath -- file for a FIFO, otherwise some
- -- descriptive string.
- !(MVar Handle__) -- The read side
- !(MVar Handle__) -- The write side
-
--- NOTES:
--- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be
--- seekable.
-
-instance Eq Handle where
- (FileHandle _ h1) == (FileHandle _ h2) = h1 == h2
- (DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2
- _ == _ = False
-
-type FD = CInt
-
-data Handle__
- = Handle__ {
- haFD :: !FD, -- file descriptor
- haType :: HandleType, -- type (read/write/append etc.)
- haIsBin :: Bool, -- binary mode?
- haIsStream :: Bool, -- Windows : is this a socket?
- -- Unix : is O_NONBLOCK set?
- haBufferMode :: BufferMode, -- buffer contains read/write data?
- haBuffer :: !(IORef Buffer), -- the current buffer
- haBuffers :: !(IORef BufferList), -- spare buffers
- haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a
- -- duplex handle.
- }
-
--- ---------------------------------------------------------------------------
--- Buffers
-
--- The buffer is represented by a mutable variable containing a
--- record, where the record contains the raw buffer and the start/end
--- points of the filled portion. We use a mutable variable so that
--- the common operation of writing (or reading) some data from (to)
--- the buffer doesn't need to modify, and hence copy, the handle
--- itself, it just updates the buffer.
-
--- There will be some allocation involved in a simple hPutChar in
--- order to create the new Buffer structure (below), but this is
--- relatively small, and this only has to be done once per write
--- operation.
-
--- The buffer contains its size - we could also get the size by
--- calling sizeOfMutableByteArray# on the raw buffer, but that tends
--- to be rounded up to the nearest Word.
-
-type RawBuffer = MutableByteArray# RealWorld
-
--- INVARIANTS on a Buffer:
---
--- * A handle *always* has a buffer, even if it is only 1 character long
--- (an unbuffered handle needs a 1 character buffer in order to support
--- hLookAhead and hIsEOF).
--- * r <= w
--- * if r == w, then r == 0 && w == 0
--- * if state == WriteBuffer, then r == 0
--- * a write buffer is never full. If an operation
--- fills up the buffer, it will always flush it before
--- returning.
--- * a read buffer may be full as a result of hLookAhead. In normal
--- operation, a read buffer always has at least one character of space.
-
-data Buffer
- = Buffer {
- bufBuf :: RawBuffer,
- bufRPtr :: !Int,
- bufWPtr :: !Int,
- bufSize :: !Int,
- bufState :: BufferState
- }
-
-data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
-
--- we keep a few spare buffers around in a handle to avoid allocating
--- a new one for each hPutStr. These buffers are *guaranteed* to be the
--- same size as the main buffer.
-data BufferList
- = BufferListNil
- | BufferListCons RawBuffer BufferList
-
-
-bufferIsWritable :: Buffer -> Bool
-bufferIsWritable Buffer{ bufState=WriteBuffer } = True
-bufferIsWritable _other = False
-
-bufferEmpty :: Buffer -> Bool
-bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } = r == w
-
--- only makes sense for a write buffer
-bufferFull :: Buffer -> Bool
-bufferFull b@Buffer{ bufWPtr=w } = w >= bufSize b
-
--- Internally, we classify handles as being one
--- of the following:
-
-data HandleType
- = ClosedHandle
- | SemiClosedHandle
- | ReadHandle
- | WriteHandle
- | AppendHandle
- | ReadWriteHandle
-
-isReadableHandleType ReadHandle = True
-isReadableHandleType ReadWriteHandle = True
-isReadableHandleType _ = False
-
-isWritableHandleType AppendHandle = True
-isWritableHandleType WriteHandle = True
-isWritableHandleType ReadWriteHandle = True
-isWritableHandleType _ = False
-
-isReadWriteHandleType ReadWriteHandle{} = True
-isReadWriteHandleType _ = False
-
--- | File and directory names are values of type 'String', whose precise
--- meaning is operating system dependent. Files can be opened, yielding a
--- handle which can then be used to operate on the contents of that file.
-
-type FilePath = String
-
--- ---------------------------------------------------------------------------
--- Buffering modes
-
--- | Three kinds of buffering are supported: line-buffering,
--- block-buffering or no-buffering. These modes have the following
--- effects. For output, items are written out, or /flushed/,
--- from the internal buffer according to the buffer mode:
---
--- * /line-buffering/: the entire output buffer is flushed
--- whenever a newline is output, the buffer overflows,
--- a 'System.IO.hFlush' is issued, or the handle is closed.
---
--- * /block-buffering/: the entire buffer is written out whenever it
--- overflows, a 'System.IO.hFlush' is issued, or the handle is closed.
---
--- * /no-buffering/: output is written immediately, and never stored
--- in the buffer.
---
--- An implementation is free to flush the buffer more frequently,
--- but not less frequently, than specified above.
--- The output buffer is emptied as soon as it has been written out.
---
--- Similarly, input occurs according to the buffer mode for the handle:
---
--- * /line-buffering/: when the buffer for the handle is not empty,
--- the next item is obtained from the buffer; otherwise, when the
--- buffer is empty, characters up to and including the next newline
--- character are read into the buffer. No characters are available
--- until the newline character is available or the buffer is full.
---
--- * /block-buffering/: when the buffer for the handle becomes empty,
--- the next block of data is read into the buffer.
---
--- * /no-buffering/: the next input item is read and returned.
--- The 'System.IO.hLookAhead' operation implies that even a no-buffered
--- handle may require a one-character buffer.
---
--- The default buffering mode when a handle is opened is
--- implementation-dependent and may depend on the file system object
--- which is attached to that handle.
--- For most implementations, physical files will normally be block-buffered
--- and terminals will normally be line-buffered.
-
-data BufferMode
- = NoBuffering -- ^ buffering is disabled if possible.
- | LineBuffering
- -- ^ line-buffering should be enabled if possible.
- | BlockBuffering (Maybe Int)
- -- ^ block-buffering should be enabled if possible.
- -- The size of the buffer is @n@ items if the argument
- -- is 'Just' @n@ and is otherwise implementation-dependent.
- deriving (Eq, Ord, Read, Show)
-
--- ---------------------------------------------------------------------------
--- IORefs
-
--- |A mutable variable in the 'IO' monad
-newtype IORef a = IORef (STRef RealWorld a)
-
--- explicit instance because Haddock can't figure out a derived one
-instance Eq (IORef a) where
- IORef x == IORef y = x == y
-
--- |Build a new 'IORef'
-newIORef :: a -> IO (IORef a)
-newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var)
-
--- |Read the value of an 'IORef'
-readIORef :: IORef a -> IO a
-readIORef (IORef var) = stToIO (readSTRef var)
-
--- |Write a new value into an 'IORef'
-writeIORef :: IORef a -> a -> IO ()
-writeIORef (IORef var) v = stToIO (writeSTRef var v)
-
--- ---------------------------------------------------------------------------
--- | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad.
--- The type arguments are as follows:
---
--- * @i@: the index type of the array (should be an instance of 'Ix')
---
--- * @e@: the element type of the array.
---
---
-
-newtype IOArray i e = IOArray (STArray RealWorld i e)
-
--- explicit instance because Haddock can't figure out a derived one
-instance Eq (IOArray i e) where
- IOArray x == IOArray y = x == y
-
--- |Build a new 'IOArray'
-newIOArray :: Ix i => (i,i) -> e -> IO (IOArray i e)
-{-# INLINE newIOArray #-}
-newIOArray lu init = stToIO $ do {marr <- newSTArray lu init; return (IOArray marr)}
-
--- | Read a value from an 'IOArray'
-unsafeReadIOArray :: Ix i => IOArray i e -> Int -> IO e
-{-# INLINE unsafeReadIOArray #-}
-unsafeReadIOArray (IOArray marr) i = stToIO (unsafeReadSTArray marr i)
-
--- | Write a new value into an 'IOArray'
-unsafeWriteIOArray :: Ix i => IOArray i e -> Int -> e -> IO ()
-{-# INLINE unsafeWriteIOArray #-}
-unsafeWriteIOArray (IOArray marr) i e = stToIO (unsafeWriteSTArray marr i e)
-
--- | Read a value from an 'IOArray'
-readIOArray :: Ix i => IOArray i e -> i -> IO e
-readIOArray (IOArray marr) i = stToIO (readSTArray marr i)
-
--- | Write a new value into an 'IOArray'
-writeIOArray :: Ix i => IOArray i e -> i -> e -> IO ()
-writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e)
-
-
--- ---------------------------------------------------------------------------
--- Show instance for Handles
-
--- handle types are 'show'n when printing error msgs, so
--- we provide a more user-friendly Show instance for it
--- than the derived one.
-
-instance Show HandleType where
- showsPrec p t =
- case t of
- ClosedHandle -> showString "closed"
- SemiClosedHandle -> showString "semi-closed"
- ReadHandle -> showString "readable"
- WriteHandle -> showString "writable"
- AppendHandle -> showString "writable (append)"
- ReadWriteHandle -> showString "read-writable"
-
-instance Show Handle where
- showsPrec p (FileHandle file _) = showHandle file
- showsPrec p (DuplexHandle file _ _) = showHandle file
-
-showHandle file = showString "{handle: " . showString file . showString "}"
-
--- ------------------------------------------------------------------------
--- Exception datatype and operations
-
--- |The type of exceptions. Every kind of system-generated exception
--- has a constructor in the 'Exception' type, and values of other
--- types may be injected into 'Exception' by coercing them to
--- 'Data.Dynamic.Dynamic' (see the section on Dynamic Exceptions:
--- "Control.Exception\#DynamicExceptions").
-data Exception
- = ArithException ArithException
- -- ^Exceptions raised by arithmetic
- -- operations. (NOTE: GHC currently does not throw
- -- 'ArithException's except for 'DivideByZero').
- | ArrayException ArrayException
- -- ^Exceptions raised by array-related
- -- operations. (NOTE: GHC currently does not throw
- -- 'ArrayException's).
- | AssertionFailed String
- -- ^This exception is thrown by the
- -- 'assert' operation when the condition
- -- fails. The 'String' argument contains the
- -- location of the assertion in the source program.
- | AsyncException AsyncException
- -- ^Asynchronous exceptions (see section on Asynchronous Exceptions: "Control.Exception\#AsynchronousExceptions").
- | BlockedOnDeadMVar
- -- ^The current thread was executing a call to
- -- 'Control.Concurrent.MVar.takeMVar' that could never return,
- -- because there are no other references to this 'MVar'.
- | BlockedIndefinitely
- -- ^The current thread was waiting to retry an atomic memory transaction
- -- that could never become possible to complete because there are no other
- -- threads referring to any of teh TVars involved.
- | NestedAtomically
- -- ^The runtime detected an attempt to nest one STM transaction
- -- inside another one, presumably due to the use of
- -- 'unsafePeformIO' with 'atomically'.
- | Deadlock
- -- ^There are no runnable threads, so the program is
- -- deadlocked. The 'Deadlock' exception is
- -- raised in the main thread only (see also: "Control.Concurrent").
- | DynException Dynamic
- -- ^Dynamically typed exceptions (see section on Dynamic Exceptions: "Control.Exception\#DynamicExceptions").
- | ErrorCall String
- -- ^The 'ErrorCall' exception is thrown by 'error'. The 'String'
- -- argument of 'ErrorCall' is the string passed to 'error' when it was
- -- called.
- | ExitException ExitCode
- -- ^The 'ExitException' exception is thrown by 'System.Exit.exitWith' (and
- -- 'System.Exit.exitFailure'). The 'ExitCode' argument is the value passed
- -- to 'System.Exit.exitWith'. An unhandled 'ExitException' exception in the
- -- main thread will cause the program to be terminated with the given
- -- exit code.
- | IOException IOException
- -- ^These are the standard IO exceptions generated by
- -- Haskell\'s @IO@ operations. See also "System.IO.Error".
- | NoMethodError String
- -- ^An attempt was made to invoke a class method which has
- -- no definition in this instance, and there was no default
- -- definition given in the class declaration. GHC issues a
- -- warning when you compile an instance which has missing
- -- methods.
- | NonTermination
- -- ^The current thread is stuck in an infinite loop. This
- -- exception may or may not be thrown when the program is
- -- non-terminating.
- | PatternMatchFail String
- -- ^A pattern matching failure. The 'String' argument should contain a
- -- descriptive message including the function name, source file
- -- and line number.
- | RecConError String
- -- ^An attempt was made to evaluate a field of a record
- -- for which no value was given at construction time. The
- -- 'String' argument gives the location of the
- -- record construction in the source program.
- | RecSelError String
- -- ^A field selection was attempted on a constructor that
- -- doesn\'t have the requested field. This can happen with
- -- multi-constructor records when one or more fields are
- -- missing from some of the constructors. The
- -- 'String' argument gives the location of the
- -- record selection in the source program.
- | RecUpdError String
- -- ^An attempt was made to update a field in a record,
- -- where the record doesn\'t have the requested field. This can
- -- only occur with multi-constructor records, when one or more
- -- fields are missing from some of the constructors. The
- -- 'String' argument gives the location of the
- -- record update in the source program.
-
--- |The type of arithmetic exceptions
-data ArithException
- = Overflow
- | Underflow
- | LossOfPrecision
- | DivideByZero
- | Denormal
- deriving (Eq, Ord)
-
-
--- |Asynchronous exceptions
-data AsyncException
- = StackOverflow
- -- ^The current thread\'s stack exceeded its limit.
- -- Since an exception has been raised, the thread\'s stack
- -- will certainly be below its limit again, but the
- -- programmer should take remedial action
- -- immediately.
- | HeapOverflow
- -- ^The program\'s heap is reaching its limit, and
- -- the program should take action to reduce the amount of
- -- live data it has. Notes:
- --
- -- * It is undefined which thread receives this exception.
- --
- -- * GHC currently does not throw 'HeapOverflow' exceptions.
- | ThreadKilled
- -- ^This exception is raised by another thread
- -- calling 'Control.Concurrent.killThread', or by the system
- -- if it needs to terminate the thread for some
- -- reason.
- deriving (Eq, Ord)
-
--- | Exceptions generated by array operations
-data ArrayException
- = IndexOutOfBounds String
- -- ^An attempt was made to index an array outside
- -- its declared bounds.
- | UndefinedElement String
- -- ^An attempt was made to evaluate an element of an
- -- array that had not been initialized.
- deriving (Eq, Ord)
-
-stackOverflow, heapOverflow :: Exception -- for the RTS
-stackOverflow = AsyncException StackOverflow
-heapOverflow = AsyncException HeapOverflow
-
-instance Show ArithException where
- showsPrec _ Overflow = showString "arithmetic overflow"
- showsPrec _ Underflow = showString "arithmetic underflow"
- showsPrec _ LossOfPrecision = showString "loss of precision"
- showsPrec _ DivideByZero = showString "divide by zero"
- showsPrec _ Denormal = showString "denormal"
-
-instance Show AsyncException where
- showsPrec _ StackOverflow = showString "stack overflow"
- showsPrec _ HeapOverflow = showString "heap overflow"
- showsPrec _ ThreadKilled = showString "thread killed"
-
-instance Show ArrayException where
- showsPrec _ (IndexOutOfBounds s)
- = showString "array index out of range"
- . (if not (null s) then showString ": " . showString s
- else id)
- showsPrec _ (UndefinedElement s)
- = showString "undefined array element"
- . (if not (null s) then showString ": " . showString s
- else id)
-
-instance Show Exception where
- showsPrec _ (IOException err) = shows err
- showsPrec _ (ArithException err) = shows err
- showsPrec _ (ArrayException err) = shows err
- showsPrec _ (ErrorCall err) = showString err
- showsPrec _ (ExitException err) = showString "exit: " . shows err
- showsPrec _ (NoMethodError err) = showString err
- showsPrec _ (PatternMatchFail err) = showString err
- showsPrec _ (RecSelError err) = showString err
- showsPrec _ (RecConError err) = showString err
- showsPrec _ (RecUpdError err) = showString err
- showsPrec _ (AssertionFailed err) = showString err
- showsPrec _ (DynException err) = showString "exception :: " . showsTypeRep (dynTypeRep err)
- showsPrec _ (AsyncException e) = shows e
- showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
- showsPrec _ (BlockedIndefinitely) = showString "thread blocked indefinitely"
- showsPrec _ (NestedAtomically) = showString "Control.Concurrent.STM.atomically was nested"
- showsPrec _ (NonTermination) = showString "<<loop>>"
- showsPrec _ (Deadlock) = showString "<<deadlock>>"
-
-instance Eq Exception where
- IOException e1 == IOException e2 = e1 == e2
- ArithException e1 == ArithException e2 = e1 == e2
- ArrayException e1 == ArrayException e2 = e1 == e2
- ErrorCall e1 == ErrorCall e2 = e1 == e2
- ExitException e1 == ExitException e2 = e1 == e2
- NoMethodError e1 == NoMethodError e2 = e1 == e2
- PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2
- RecSelError e1 == RecSelError e2 = e1 == e2
- RecConError e1 == RecConError e2 = e1 == e2
- RecUpdError e1 == RecUpdError e2 = e1 == e2
- AssertionFailed e1 == AssertionFailed e2 = e1 == e2
- DynException _ == DynException _ = False -- incomparable
- AsyncException e1 == AsyncException e2 = e1 == e2
- BlockedOnDeadMVar == BlockedOnDeadMVar = True
- NonTermination == NonTermination = True
- NestedAtomically == NestedAtomically = True
- Deadlock == Deadlock = True
- _ == _ = False
-
--- -----------------------------------------------------------------------------
--- The ExitCode type
-
--- We need it here because it is used in ExitException in the
--- Exception datatype (above).
-
-data ExitCode
- = ExitSuccess -- ^ indicates successful termination;
- | ExitFailure Int
- -- ^ indicates program failure with an exit code.
- -- The exact interpretation of the code is
- -- operating-system dependent. In particular, some values
- -- may be prohibited (e.g. 0 on a POSIX-compliant system).
- deriving (Eq, Ord, Read, Show)
-
--- --------------------------------------------------------------------------
--- Primitive throw
-
--- | Throw an exception. Exceptions may be thrown from purely
--- functional code, but may only be caught within the 'IO' monad.
-throw :: Exception -> a
-throw exception = raise# exception
-
--- | A variant of 'throw' that can be used within the 'IO' monad.
---
--- Although 'throwIO' has a type that is an instance of the type of 'throw', the
--- two functions are subtly different:
---
--- > throw e `seq` x ===> throw e
--- > throwIO e `seq` x ===> x
---
--- The first example will cause the exception @e@ to be raised,
--- whereas the second one won\'t. In fact, 'throwIO' will only cause
--- an exception to be raised when it is used within the 'IO' monad.
--- The 'throwIO' variant should be used in preference to 'throw' to
--- raise an exception within the 'IO' monad because it guarantees
--- ordering with respect to other 'IO' operations, whereas 'throw'
--- does not.
-throwIO :: Exception -> IO a
-throwIO err = IO $ raiseIO# err
-
-ioException :: IOException -> IO a
-ioException err = IO $ raiseIO# (IOException err)
-
--- | Raise an 'IOError' in the 'IO' monad.
-ioError :: IOError -> IO a
-ioError = ioException
-
--- ---------------------------------------------------------------------------
--- IOError type
-
--- | The Haskell 98 type for exceptions in the 'IO' monad.
--- Any I\/O operation may raise an 'IOError' instead of returning a result.
--- For a more general type of exception, including also those that arise
--- in pure code, see 'Control.Exception.Exception'.
---
--- In Haskell 98, this is an opaque type.
-type IOError = IOException
-
--- |Exceptions that occur in the @IO@ monad.
--- An @IOException@ records a more specific error type, a descriptive
--- string and maybe the handle that was used when the error was
--- flagged.
-data IOException
- = IOError {
- ioe_handle :: Maybe Handle, -- the handle used by the action flagging
- -- the error.
- ioe_type :: IOErrorType, -- what it was.
- ioe_location :: String, -- location.
- ioe_description :: String, -- error type specific information.
- ioe_filename :: Maybe FilePath -- filename the error is related to.
- }
-
-instance Eq IOException where
- (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) =
- e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2
-
--- | An abstract type that contains a value for each variant of 'IOError'.
-data IOErrorType
- -- Haskell 98:
- = AlreadyExists
- | NoSuchThing
- | ResourceBusy
- | ResourceExhausted
- | EOF
- | IllegalOperation
- | PermissionDenied
- | UserError
- -- GHC only:
- | UnsatisfiedConstraints
- | SystemError
- | ProtocolError
- | OtherError
- | InvalidArgument
- | InappropriateType
- | HardwareFault
- | UnsupportedOperation
- | TimeExpired
- | ResourceVanished
- | Interrupted
- | DynIOError Dynamic -- cheap&cheerful extensible IO error type.
-
-instance Eq IOErrorType where
- x == y =
- case x of
- DynIOError{} -> False -- from a strictness POV, compatible with a derived Eq inst?
- _ -> getTag x ==# getTag y
-
-instance Show IOErrorType where
- showsPrec _ e =
- showString $
- case e of
- AlreadyExists -> "already exists"
- NoSuchThing -> "does not exist"
- ResourceBusy -> "resource busy"
- ResourceExhausted -> "resource exhausted"
- EOF -> "end of file"
- IllegalOperation -> "illegal operation"
- PermissionDenied -> "permission denied"
- UserError -> "user error"
- HardwareFault -> "hardware fault"
- InappropriateType -> "inappropriate type"
- Interrupted -> "interrupted"
- InvalidArgument -> "invalid argument"
- OtherError -> "failed"
- ProtocolError -> "protocol error"
- ResourceVanished -> "resource vanished"
- SystemError -> "system error"
- TimeExpired -> "timeout"
- UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
- UnsupportedOperation -> "unsupported operation"
- DynIOError{} -> "unknown IO error"
-
--- | Construct an 'IOError' value with a string describing the error.
--- The 'fail' method of the 'IO' instance of the 'Monad' class raises a
--- 'userError', thus:
---
--- > instance Monad IO where
--- > ...
--- > fail s = ioError (userError s)
---
-userError :: String -> IOError
-userError str = IOError Nothing UserError "" str Nothing
-
--- ---------------------------------------------------------------------------
--- Showing IOErrors
-
-instance Show IOException where
- showsPrec p (IOError hdl iot loc s fn) =
- (case fn of
- Nothing -> case hdl of
- Nothing -> id
- Just h -> showsPrec p h . showString ": "
- Just name -> showString name . showString ": ") .
- (case loc of
- "" -> id
- _ -> showString loc . showString ": ") .
- showsPrec p iot .
- (case s of
- "" -> id
- _ -> showString " (" . showString s . showString ")")
-
--- -----------------------------------------------------------------------------
--- IOMode type
-
-data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
- deriving (Eq, Ord, Ix, Enum, Read, Show)
-\end{code}
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Int
--- Copyright : (c) The University of Glasgow 1997-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- The sized integral datatypes, 'Int8', 'Int16', 'Int32', and 'Int64'.
---
------------------------------------------------------------------------------
-
-#include "MachDeps.h"
-
--- #hide
-module GHC.Int (
- Int8(..), Int16(..), Int32(..), Int64(..))
- where
-
-import Data.Bits
-
-import {-# SOURCE #-} GHC.Err
-import GHC.Base
-import GHC.Enum
-import GHC.Num
-import GHC.Real
-import GHC.Read
-import GHC.Arr
-import GHC.Word
-import GHC.Show
-
-------------------------------------------------------------------------
--- type Int8
-------------------------------------------------------------------------
-
--- Int8 is represented in the same way as Int. Operations may assume
--- and must ensure that it holds only values from its logical range.
-
-data Int8 = I8# Int# deriving (Eq, Ord)
--- ^ 8-bit signed integer type
-
-instance Show Int8 where
- showsPrec p x = showsPrec p (fromIntegral x :: Int)
-
-instance Num Int8 where
- (I8# x#) + (I8# y#) = I8# (narrow8Int# (x# +# y#))
- (I8# x#) - (I8# y#) = I8# (narrow8Int# (x# -# y#))
- (I8# x#) * (I8# y#) = I8# (narrow8Int# (x# *# y#))
- negate (I8# x#) = I8# (narrow8Int# (negateInt# x#))
- abs x | x >= 0 = x
- | otherwise = negate x
- signum x | x > 0 = 1
- signum 0 = 0
- signum _ = -1
- fromInteger (S# i#) = I8# (narrow8Int# i#)
- fromInteger (J# s# d#) = I8# (narrow8Int# (integer2Int# s# d#))
-
-instance Real Int8 where
- toRational x = toInteger x % 1
-
-instance Enum Int8 where
- succ x
- | x /= maxBound = x + 1
- | otherwise = succError "Int8"
- pred x
- | x /= minBound = x - 1
- | otherwise = predError "Int8"
- toEnum i@(I# i#)
- | i >= fromIntegral (minBound::Int8) && i <= fromIntegral (maxBound::Int8)
- = I8# i#
- | otherwise = toEnumError "Int8" i (minBound::Int8, maxBound::Int8)
- fromEnum (I8# x#) = I# x#
- enumFrom = boundedEnumFrom
- enumFromThen = boundedEnumFromThen
-
-instance Integral Int8 where
- quot x@(I8# x#) y@(I8# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I8# (narrow8Int# (x# `quotInt#` y#))
- rem x@(I8# x#) y@(I8# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I8# (narrow8Int# (x# `remInt#` y#))
- div x@(I8# x#) y@(I8# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I8# (narrow8Int# (x# `divInt#` y#))
- mod x@(I8# x#) y@(I8# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I8# (narrow8Int# (x# `modInt#` y#))
- quotRem x@(I8# x#) y@(I8# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = (I8# (narrow8Int# (x# `quotInt#` y#)),
- I8# (narrow8Int# (x# `remInt#` y#)))
- divMod x@(I8# x#) y@(I8# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = (I8# (narrow8Int# (x# `divInt#` y#)),
- I8# (narrow8Int# (x# `modInt#` y#)))
- toInteger (I8# x#) = S# x#
-
-instance Bounded Int8 where
- minBound = -0x80
- maxBound = 0x7F
-
-instance Ix Int8 where
- range (m,n) = [m..n]
- unsafeIndex b@(m,_) i = fromIntegral i - fromIntegral m
- inRange (m,n) i = m <= i && i <= n
-
-instance Read Int8 where
- readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]
-
-instance Bits Int8 where
- {-# INLINE shift #-}
-
- (I8# x#) .&. (I8# y#) = I8# (word2Int# (int2Word# x# `and#` int2Word# y#))
- (I8# x#) .|. (I8# y#) = I8# (word2Int# (int2Word# x# `or#` int2Word# y#))
- (I8# x#) `xor` (I8# y#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# y#))
- complement (I8# x#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))
- (I8# x#) `shift` (I# i#)
- | i# >=# 0# = I8# (narrow8Int# (x# `iShiftL#` i#))
- | otherwise = I8# (x# `iShiftRA#` negateInt# i#)
- (I8# x#) `rotate` (I# i#)
- | i'# ==# 0#
- = I8# x#
- | otherwise
- = I8# (narrow8Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`
- (x'# `uncheckedShiftRL#` (8# -# i'#)))))
- where
- x'# = narrow8Word# (int2Word# x#)
- i'# = word2Int# (int2Word# i# `and#` int2Word# 7#)
- bitSize _ = 8
- isSigned _ = True
-
-{-# RULES
-"fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8
-"fromIntegral/a->Int8" fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (narrow8Int# x#)
-"fromIntegral/Int8->a" fromIntegral = \(I8# x#) -> fromIntegral (I# x#)
- #-}
-
-------------------------------------------------------------------------
--- type Int16
-------------------------------------------------------------------------
-
--- Int16 is represented in the same way as Int. Operations may assume
--- and must ensure that it holds only values from its logical range.
-
-data Int16 = I16# Int# deriving (Eq, Ord)
--- ^ 16-bit signed integer type
-
-instance Show Int16 where
- showsPrec p x = showsPrec p (fromIntegral x :: Int)
-
-instance Num Int16 where
- (I16# x#) + (I16# y#) = I16# (narrow16Int# (x# +# y#))
- (I16# x#) - (I16# y#) = I16# (narrow16Int# (x# -# y#))
- (I16# x#) * (I16# y#) = I16# (narrow16Int# (x# *# y#))
- negate (I16# x#) = I16# (narrow16Int# (negateInt# x#))
- abs x | x >= 0 = x
- | otherwise = negate x
- signum x | x > 0 = 1
- signum 0 = 0
- signum _ = -1
- fromInteger (S# i#) = I16# (narrow16Int# i#)
- fromInteger (J# s# d#) = I16# (narrow16Int# (integer2Int# s# d#))
-
-instance Real Int16 where
- toRational x = toInteger x % 1
-
-instance Enum Int16 where
- succ x
- | x /= maxBound = x + 1
- | otherwise = succError "Int16"
- pred x
- | x /= minBound = x - 1
- | otherwise = predError "Int16"
- toEnum i@(I# i#)
- | i >= fromIntegral (minBound::Int16) && i <= fromIntegral (maxBound::Int16)
- = I16# i#
- | otherwise = toEnumError "Int16" i (minBound::Int16, maxBound::Int16)
- fromEnum (I16# x#) = I# x#
- enumFrom = boundedEnumFrom
- enumFromThen = boundedEnumFromThen
-
-instance Integral Int16 where
- quot x@(I16# x#) y@(I16# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I16# (narrow16Int# (x# `quotInt#` y#))
- rem x@(I16# x#) y@(I16# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I16# (narrow16Int# (x# `remInt#` y#))
- div x@(I16# x#) y@(I16# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I16# (narrow16Int# (x# `divInt#` y#))
- mod x@(I16# x#) y@(I16# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I16# (narrow16Int# (x# `modInt#` y#))
- quotRem x@(I16# x#) y@(I16# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = (I16# (narrow16Int# (x# `quotInt#` y#)),
- I16# (narrow16Int# (x# `remInt#` y#)))
- divMod x@(I16# x#) y@(I16# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = (I16# (narrow16Int# (x# `divInt#` y#)),
- I16# (narrow16Int# (x# `modInt#` y#)))
- toInteger (I16# x#) = S# x#
-
-instance Bounded Int16 where
- minBound = -0x8000
- maxBound = 0x7FFF
-
-instance Ix Int16 where
- range (m,n) = [m..n]
- unsafeIndex b@(m,_) i = fromIntegral i - fromIntegral m
- inRange (m,n) i = m <= i && i <= n
-
-instance Read Int16 where
- readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]
-
-instance Bits Int16 where
- {-# INLINE shift #-}
-
- (I16# x#) .&. (I16# y#) = I16# (word2Int# (int2Word# x# `and#` int2Word# y#))
- (I16# x#) .|. (I16# y#) = I16# (word2Int# (int2Word# x# `or#` int2Word# y#))
- (I16# x#) `xor` (I16# y#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# y#))
- complement (I16# x#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))
- (I16# x#) `shift` (I# i#)
- | i# >=# 0# = I16# (narrow16Int# (x# `iShiftL#` i#))
- | otherwise = I16# (x# `iShiftRA#` negateInt# i#)
- (I16# x#) `rotate` (I# i#)
- | i'# ==# 0#
- = I16# x#
- | otherwise
- = I16# (narrow16Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`
- (x'# `uncheckedShiftRL#` (16# -# i'#)))))
- where
- x'# = narrow16Word# (int2Word# x#)
- i'# = word2Int# (int2Word# i# `and#` int2Word# 15#)
- bitSize _ = 16
- isSigned _ = True
-
-{-# RULES
-"fromIntegral/Word8->Int16" fromIntegral = \(W8# x#) -> I16# (word2Int# x#)
-"fromIntegral/Int8->Int16" fromIntegral = \(I8# x#) -> I16# x#
-"fromIntegral/Int16->Int16" fromIntegral = id :: Int16 -> Int16
-"fromIntegral/a->Int16" fromIntegral = \x -> case fromIntegral x of I# x# -> I16# (narrow16Int# x#)
-"fromIntegral/Int16->a" fromIntegral = \(I16# x#) -> fromIntegral (I# x#)
- #-}
-
-------------------------------------------------------------------------
--- type Int32
-------------------------------------------------------------------------
-
-#if WORD_SIZE_IN_BITS < 32
-
-data Int32 = I32# Int32#
--- ^ 32-bit signed integer type
-
-instance Eq Int32 where
- (I32# x#) == (I32# y#) = x# `eqInt32#` y#
- (I32# x#) /= (I32# y#) = x# `neInt32#` y#
-
-instance Ord Int32 where
- (I32# x#) < (I32# y#) = x# `ltInt32#` y#
- (I32# x#) <= (I32# y#) = x# `leInt32#` y#
- (I32# x#) > (I32# y#) = x# `gtInt32#` y#
- (I32# x#) >= (I32# y#) = x# `geInt32#` y#
-
-instance Show Int32 where
- showsPrec p x = showsPrec p (toInteger x)
-
-instance Num Int32 where
- (I32# x#) + (I32# y#) = I32# (x# `plusInt32#` y#)
- (I32# x#) - (I32# y#) = I32# (x# `minusInt32#` y#)
- (I32# x#) * (I32# y#) = I32# (x# `timesInt32#` y#)
- negate (I32# x#) = I32# (negateInt32# x#)
- abs x | x >= 0 = x
- | otherwise = negate x
- signum x | x > 0 = 1
- signum 0 = 0
- signum _ = -1
- fromInteger (S# i#) = I32# (intToInt32# i#)
- fromInteger (J# s# d#) = I32# (integerToInt32# s# d#)
-
-instance Enum Int32 where
- succ x
- | x /= maxBound = x + 1
- | otherwise = succError "Int32"
- pred x
- | x /= minBound = x - 1
- | otherwise = predError "Int32"
- toEnum (I# i#) = I32# (intToInt32# i#)
- fromEnum x@(I32# x#)
- | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int)
- = I# (int32ToInt# x#)
- | otherwise = fromEnumError "Int32" x
- enumFrom = integralEnumFrom
- enumFromThen = integralEnumFromThen
- enumFromTo = integralEnumFromTo
- enumFromThenTo = integralEnumFromThenTo
-
-instance Integral Int32 where
- quot x@(I32# x#) y@(I32# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I32# (x# `quotInt32#` y#)
- rem x@(I32# x#) y@(I32# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I32# (x# `remInt32#` y#)
- div x@(I32# x#) y@(I32# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I32# (x# `divInt32#` y#)
- mod x@(I32# x#) y@(I32# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I32# (x# `modInt32#` y#)
- quotRem x@(I32# x#) y@(I32# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = (I32# (x# `quotInt32#` y#),
- I32# (x# `remInt32#` y#))
- divMod x@(I32# x#) y@(I32# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = (I32# (x# `divInt32#` y#),
- I32# (x# `modInt32#` y#))
- toInteger x@(I32# x#)
- | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int)
- = S# (int32ToInt# x#)
- | otherwise = case int32ToInteger# x# of (# s, d #) -> J# s d
-
-divInt32#, modInt32# :: Int32# -> Int32# -> Int32#
-x# `divInt32#` y#
- | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#)
- = ((x# `minusInt32#` y#) `minusInt32#` intToInt32# 1#) `quotInt32#` y#
- | (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#)
- = ((x# `minusInt32#` y#) `plusInt32#` intToInt32# 1#) `quotInt32#` y#
- | otherwise = x# `quotInt32#` y#
-x# `modInt32#` y#
- | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#) ||
- (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#)
- = if r# `neInt32#` intToInt32# 0# then r# `plusInt32#` y# else intToInt32# 0#
- | otherwise = r#
- where
- r# = x# `remInt32#` y#
-
-instance Read Int32 where
- readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]
-
-instance Bits Int32 where
- {-# INLINE shift #-}
-
- (I32# x#) .&. (I32# y#) = I32# (word32ToInt32# (int32ToWord32# x# `and32#` int32ToWord32# y#))
- (I32# x#) .|. (I32# y#) = I32# (word32ToInt32# (int32ToWord32# x# `or32#` int32ToWord32# y#))
- (I32# x#) `xor` (I32# y#) = I32# (word32ToInt32# (int32ToWord32# x# `xor32#` int32ToWord32# y#))
- complement (I32# x#) = I32# (word32ToInt32# (not32# (int32ToWord32# x#)))
- (I32# x#) `shift` (I# i#)
- | i# >=# 0# = I32# (x# `iShiftL32#` i#)
- | otherwise = I32# (x# `iShiftRA32#` negateInt# i#)
- (I32# x#) `rotate` (I# i#)
- | i'# ==# 0#
- = I32# x#
- | otherwise
- = I32# (word32ToInt32# ((x'# `shiftL32#` i'#) `or32#`
- (x'# `shiftRL32#` (32# -# i'#))))
- where
- x'# = int32ToWord32# x#
- i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)
- bitSize _ = 32
- isSigned _ = True
-
-foreign import "stg_eqInt32" unsafe eqInt32# :: Int32# -> Int32# -> Bool
-foreign import "stg_neInt32" unsafe neInt32# :: Int32# -> Int32# -> Bool
-foreign import "stg_ltInt32" unsafe ltInt32# :: Int32# -> Int32# -> Bool
-foreign import "stg_leInt32" unsafe leInt32# :: Int32# -> Int32# -> Bool
-foreign import "stg_gtInt32" unsafe gtInt32# :: Int32# -> Int32# -> Bool
-foreign import "stg_geInt32" unsafe geInt32# :: Int32# -> Int32# -> Bool
-foreign import "stg_plusInt32" unsafe plusInt32# :: Int32# -> Int32# -> Int32#
-foreign import "stg_minusInt32" unsafe minusInt32# :: Int32# -> Int32# -> Int32#
-foreign import "stg_timesInt32" unsafe timesInt32# :: Int32# -> Int32# -> Int32#
-foreign import "stg_negateInt32" unsafe negateInt32# :: Int32# -> Int32#
-foreign import "stg_quotInt32" unsafe quotInt32# :: Int32# -> Int32# -> Int32#
-foreign import "stg_remInt32" unsafe remInt32# :: Int32# -> Int32# -> Int32#
-foreign import "stg_intToInt32" unsafe intToInt32# :: Int# -> Int32#
-foreign import "stg_int32ToInt" unsafe int32ToInt# :: Int32# -> Int#
-foreign import "stg_wordToWord32" unsafe wordToWord32# :: Word# -> Word32#
-foreign import "stg_int32ToWord32" unsafe int32ToWord32# :: Int32# -> Word32#
-foreign import "stg_word32ToInt32" unsafe word32ToInt32# :: Word32# -> Int32#
-foreign import "stg_and32" unsafe and32# :: Word32# -> Word32# -> Word32#
-foreign import "stg_or32" unsafe or32# :: Word32# -> Word32# -> Word32#
-foreign import "stg_xor32" unsafe xor32# :: Word32# -> Word32# -> Word32#
-foreign import "stg_not32" unsafe not32# :: Word32# -> Word32#
-foreign import "stg_iShiftL32" unsafe iShiftL32# :: Int32# -> Int# -> Int32#
-foreign import "stg_iShiftRA32" unsafe iShiftRA32# :: Int32# -> Int# -> Int32#
-foreign import "stg_shiftL32" unsafe shiftL32# :: Word32# -> Int# -> Word32#
-foreign import "stg_shiftRL32" unsafe shiftRL32# :: Word32# -> Int# -> Word32#
-
-{-# RULES
-"fromIntegral/Int->Int32" fromIntegral = \(I# x#) -> I32# (intToInt32# x#)
-"fromIntegral/Word->Int32" fromIntegral = \(W# x#) -> I32# (word32ToInt32# (wordToWord32# x#))
-"fromIntegral/Word32->Int32" fromIntegral = \(W32# x#) -> I32# (word32ToInt32# x#)
-"fromIntegral/Int32->Int" fromIntegral = \(I32# x#) -> I# (int32ToInt# x#)
-"fromIntegral/Int32->Word" fromIntegral = \(I32# x#) -> W# (int2Word# (int32ToInt# x#))
-"fromIntegral/Int32->Word32" fromIntegral = \(I32# x#) -> W32# (int32ToWord32# x#)
-"fromIntegral/Int32->Int32" fromIntegral = id :: Int32 -> Int32
- #-}
-
-#else
-
--- Int32 is represented in the same way as Int.
-#if WORD_SIZE_IN_BITS > 32
--- Operations may assume and must ensure that it holds only values
--- from its logical range.
-#endif
-
-data Int32 = I32# Int# deriving (Eq, Ord)
--- ^ 32-bit signed integer type
-
-instance Show Int32 where
- showsPrec p x = showsPrec p (fromIntegral x :: Int)
-
-instance Num Int32 where
- (I32# x#) + (I32# y#) = I32# (narrow32Int# (x# +# y#))
- (I32# x#) - (I32# y#) = I32# (narrow32Int# (x# -# y#))
- (I32# x#) * (I32# y#) = I32# (narrow32Int# (x# *# y#))
- negate (I32# x#) = I32# (narrow32Int# (negateInt# x#))
- abs x | x >= 0 = x
- | otherwise = negate x
- signum x | x > 0 = 1
- signum 0 = 0
- signum _ = -1
- fromInteger (S# i#) = I32# (narrow32Int# i#)
- fromInteger (J# s# d#) = I32# (narrow32Int# (integer2Int# s# d#))
-
-instance Enum Int32 where
- succ x
- | x /= maxBound = x + 1
- | otherwise = succError "Int32"
- pred x
- | x /= minBound = x - 1
- | otherwise = predError "Int32"
-#if WORD_SIZE_IN_BITS == 32
- toEnum (I# i#) = I32# i#
-#else
- toEnum i@(I# i#)
- | i >= fromIntegral (minBound::Int32) && i <= fromIntegral (maxBound::Int32)
- = I32# i#
- | otherwise = toEnumError "Int32" i (minBound::Int32, maxBound::Int32)
-#endif
- fromEnum (I32# x#) = I# x#
- enumFrom = boundedEnumFrom
- enumFromThen = boundedEnumFromThen
-
-instance Integral Int32 where
- quot x@(I32# x#) y@(I32# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I32# (narrow32Int# (x# `quotInt#` y#))
- rem x@(I32# x#) y@(I32# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I32# (narrow32Int# (x# `remInt#` y#))
- div x@(I32# x#) y@(I32# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I32# (narrow32Int# (x# `divInt#` y#))
- mod x@(I32# x#) y@(I32# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I32# (narrow32Int# (x# `modInt#` y#))
- quotRem x@(I32# x#) y@(I32# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = (I32# (narrow32Int# (x# `quotInt#` y#)),
- I32# (narrow32Int# (x# `remInt#` y#)))
- divMod x@(I32# x#) y@(I32# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = (I32# (narrow32Int# (x# `divInt#` y#)),
- I32# (narrow32Int# (x# `modInt#` y#)))
- toInteger (I32# x#) = S# x#
-
-instance Read Int32 where
- readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]
-
-instance Bits Int32 where
- {-# INLINE shift #-}
-
- (I32# x#) .&. (I32# y#) = I32# (word2Int# (int2Word# x# `and#` int2Word# y#))
- (I32# x#) .|. (I32# y#) = I32# (word2Int# (int2Word# x# `or#` int2Word# y#))
- (I32# x#) `xor` (I32# y#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# y#))
- complement (I32# x#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))
- (I32# x#) `shift` (I# i#)
- | i# >=# 0# = I32# (narrow32Int# (x# `iShiftL#` i#))
- | otherwise = I32# (x# `iShiftRA#` negateInt# i#)
- (I32# x#) `rotate` (I# i#)
- | i'# ==# 0#
- = I32# x#
- | otherwise
- = I32# (narrow32Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`
- (x'# `uncheckedShiftRL#` (32# -# i'#)))))
- where
- x'# = narrow32Word# (int2Word# x#)
- i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)
- bitSize _ = 32
- isSigned _ = True
-
-{-# RULES
-"fromIntegral/Word8->Int32" fromIntegral = \(W8# x#) -> I32# (word2Int# x#)
-"fromIntegral/Word16->Int32" fromIntegral = \(W16# x#) -> I32# (word2Int# x#)
-"fromIntegral/Int8->Int32" fromIntegral = \(I8# x#) -> I32# x#
-"fromIntegral/Int16->Int32" fromIntegral = \(I16# x#) -> I32# x#
-"fromIntegral/Int32->Int32" fromIntegral = id :: Int32 -> Int32
-"fromIntegral/a->Int32" fromIntegral = \x -> case fromIntegral x of I# x# -> I32# (narrow32Int# x#)
-"fromIntegral/Int32->a" fromIntegral = \(I32# x#) -> fromIntegral (I# x#)
- #-}
-
-#endif
-
-instance Real Int32 where
- toRational x = toInteger x % 1
-
-instance Bounded Int32 where
- minBound = -0x80000000
- maxBound = 0x7FFFFFFF
-
-instance Ix Int32 where
- range (m,n) = [m..n]
- unsafeIndex b@(m,_) i = fromIntegral i - fromIntegral m
- inRange (m,n) i = m <= i && i <= n
-
-------------------------------------------------------------------------
--- type Int64
-------------------------------------------------------------------------
-
-#if WORD_SIZE_IN_BITS < 64
-
-data Int64 = I64# Int64#
--- ^ 64-bit signed integer type
-
-instance Eq Int64 where
- (I64# x#) == (I64# y#) = x# `eqInt64#` y#
- (I64# x#) /= (I64# y#) = x# `neInt64#` y#
-
-instance Ord Int64 where
- (I64# x#) < (I64# y#) = x# `ltInt64#` y#
- (I64# x#) <= (I64# y#) = x# `leInt64#` y#
- (I64# x#) > (I64# y#) = x# `gtInt64#` y#
- (I64# x#) >= (I64# y#) = x# `geInt64#` y#
-
-instance Show Int64 where
- showsPrec p x = showsPrec p (toInteger x)
-
-instance Num Int64 where
- (I64# x#) + (I64# y#) = I64# (x# `plusInt64#` y#)
- (I64# x#) - (I64# y#) = I64# (x# `minusInt64#` y#)
- (I64# x#) * (I64# y#) = I64# (x# `timesInt64#` y#)
- negate (I64# x#) = I64# (negateInt64# x#)
- abs x | x >= 0 = x
- | otherwise = negate x
- signum x | x > 0 = 1
- signum 0 = 0
- signum _ = -1
- fromInteger (S# i#) = I64# (intToInt64# i#)
- fromInteger (J# s# d#) = I64# (integerToInt64# s# d#)
-
-instance Enum Int64 where
- succ x
- | x /= maxBound = x + 1
- | otherwise = succError "Int64"
- pred x
- | x /= minBound = x - 1
- | otherwise = predError "Int64"
- toEnum (I# i#) = I64# (intToInt64# i#)
- fromEnum x@(I64# x#)
- | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int)
- = I# (int64ToInt# x#)
- | otherwise = fromEnumError "Int64" x
- enumFrom = integralEnumFrom
- enumFromThen = integralEnumFromThen
- enumFromTo = integralEnumFromTo
- enumFromThenTo = integralEnumFromThenTo
-
-instance Integral Int64 where
- quot x@(I64# x#) y@(I64# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I64# (x# `quotInt64#` y#)
- rem x@(I64# x#) y@(I64# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I64# (x# `remInt64#` y#)
- div x@(I64# x#) y@(I64# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I64# (x# `divInt64#` y#)
- mod x@(I64# x#) y@(I64# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I64# (x# `modInt64#` y#)
- quotRem x@(I64# x#) y@(I64# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = (I64# (x# `quotInt64#` y#),
- I64# (x# `remInt64#` y#))
- divMod x@(I64# x#) y@(I64# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = (I64# (x# `divInt64#` y#),
- I64# (x# `modInt64#` y#))
- toInteger x@(I64# x#)
- | x >= fromIntegral (minBound::Int) &&
- x <= fromIntegral (maxBound::Int)
- = S# (int64ToInt# x#)
- | otherwise = case int64ToInteger# x# of
- (# s, d #) -> J# s d
-
-
-divInt64#, modInt64# :: Int64# -> Int64# -> Int64#
-x# `divInt64#` y#
- | (x# `gtInt64#` intToInt64# 0#) && (y# `ltInt64#` intToInt64# 0#)
- = ((x# `minusInt64#` y#) `minusInt64#` intToInt64# 1#) `quotInt64#` y#
- | (x# `ltInt64#` intToInt64# 0#) && (y# `gtInt64#` intToInt64# 0#)
- = ((x# `minusInt64#` y#) `plusInt64#` intToInt64# 1#) `quotInt64#` y#
- | otherwise = x# `quotInt64#` y#
-x# `modInt64#` y#
- | (x# `gtInt64#` intToInt64# 0#) && (y# `ltInt64#` intToInt64# 0#) ||
- (x# `ltInt64#` intToInt64# 0#) && (y# `gtInt64#` intToInt64# 0#)
- = if r# `neInt64#` intToInt64# 0# then r# `plusInt64#` y# else intToInt64# 0#
- | otherwise = r#
- where
- r# = x# `remInt64#` y#
-
-instance Read Int64 where
- readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]
-
-instance Bits Int64 where
- {-# INLINE shift #-}
-
- (I64# x#) .&. (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `and64#` int64ToWord64# y#))
- (I64# x#) .|. (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `or64#` int64ToWord64# y#))
- (I64# x#) `xor` (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `xor64#` int64ToWord64# y#))
- complement (I64# x#) = I64# (word64ToInt64# (not64# (int64ToWord64# x#)))
- (I64# x#) `shift` (I# i#)
- | i# >=# 0# = I64# (x# `iShiftL64#` i#)
- | otherwise = I64# (x# `iShiftRA64#` negateInt# i#)
- (I64# x#) `rotate` (I# i#)
- | i'# ==# 0#
- = I64# x#
- | otherwise
- = I64# (word64ToInt64# ((x'# `uncheckedShiftL64#` i'#) `or64#`
- (x'# `uncheckedShiftRL64#` (64# -# i'#))))
- where
- x'# = int64ToWord64# x#
- i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)
- bitSize _ = 64
- isSigned _ = True
-
-
--- give the 64-bit shift operations the same treatment as the 32-bit
--- ones (see GHC.Base), namely we wrap them in tests to catch the
--- cases when we're shifting more than 64 bits to avoid unspecified
--- behaviour in the C shift operations.
-
-iShiftL64#, iShiftRA64# :: Int64# -> Int# -> Int64#
-
-a `iShiftL64#` b | b >=# 64# = intToInt64# 0#
- | otherwise = a `uncheckedIShiftL64#` b
-
-a `iShiftRA64#` b | b >=# 64# = if a `ltInt64#` (intToInt64# 0#)
- then intToInt64# (-1#)
- else intToInt64# 0#
- | otherwise = a `uncheckedIShiftRA64#` b
-
-
-foreign import ccall unsafe "hs_eqInt64" eqInt64# :: Int64# -> Int64# -> Bool
-foreign import ccall unsafe "hs_neInt64" neInt64# :: Int64# -> Int64# -> Bool
-foreign import ccall unsafe "hs_ltInt64" ltInt64# :: Int64# -> Int64# -> Bool
-foreign import ccall unsafe "hs_leInt64" leInt64# :: Int64# -> Int64# -> Bool
-foreign import ccall unsafe "hs_gtInt64" gtInt64# :: Int64# -> Int64# -> Bool
-foreign import ccall unsafe "hs_geInt64" geInt64# :: Int64# -> Int64# -> Bool
-foreign import ccall unsafe "hs_plusInt64" plusInt64# :: Int64# -> Int64# -> Int64#
-foreign import ccall unsafe "hs_minusInt64" minusInt64# :: Int64# -> Int64# -> Int64#
-foreign import ccall unsafe "hs_timesInt64" timesInt64# :: Int64# -> Int64# -> Int64#
-foreign import ccall unsafe "hs_negateInt64" negateInt64# :: Int64# -> Int64#
-foreign import ccall unsafe "hs_quotInt64" quotInt64# :: Int64# -> Int64# -> Int64#
-foreign import ccall unsafe "hs_remInt64" remInt64# :: Int64# -> Int64# -> Int64#
-foreign import ccall unsafe "hs_intToInt64" intToInt64# :: Int# -> Int64#
-foreign import ccall unsafe "hs_int64ToInt" int64ToInt# :: Int64# -> Int#
-foreign import ccall unsafe "hs_wordToWord64" wordToWord64# :: Word# -> Word64#
-foreign import ccall unsafe "hs_int64ToWord64" int64ToWord64# :: Int64# -> Word64#
-foreign import ccall unsafe "hs_word64ToInt64" word64ToInt64# :: Word64# -> Int64#
-foreign import ccall unsafe "hs_and64" and64# :: Word64# -> Word64# -> Word64#
-foreign import ccall unsafe "hs_or64" or64# :: Word64# -> Word64# -> Word64#
-foreign import ccall unsafe "hs_xor64" xor64# :: Word64# -> Word64# -> Word64#
-foreign import ccall unsafe "hs_not64" not64# :: Word64# -> Word64#
-foreign import ccall unsafe "hs_uncheckedShiftL64" uncheckedShiftL64# :: Word64# -> Int# -> Word64#
-foreign import ccall unsafe "hs_uncheckedShiftRL64" uncheckedShiftRL64# :: Word64# -> Int# -> Word64#
-foreign import ccall unsafe "hs_uncheckedIShiftL64" uncheckedIShiftL64# :: Int64# -> Int# -> Int64#
-foreign import ccall unsafe "hs_uncheckedIShiftRA64" uncheckedIShiftRA64# :: Int64# -> Int# -> Int64#
-
-foreign import ccall unsafe "hs_integerToInt64" integerToInt64# :: Int# -> ByteArray# -> Int64#
-
-{-# RULES
-"fromIntegral/Int->Int64" fromIntegral = \(I# x#) -> I64# (intToInt64# x#)
-"fromIntegral/Word->Int64" fromIntegral = \(W# x#) -> I64# (word64ToInt64# (wordToWord64# x#))
-"fromIntegral/Word64->Int64" fromIntegral = \(W64# x#) -> I64# (word64ToInt64# x#)
-"fromIntegral/Int64->Int" fromIntegral = \(I64# x#) -> I# (int64ToInt# x#)
-"fromIntegral/Int64->Word" fromIntegral = \(I64# x#) -> W# (int2Word# (int64ToInt# x#))
-"fromIntegral/Int64->Word64" fromIntegral = \(I64# x#) -> W64# (int64ToWord64# x#)
-"fromIntegral/Int64->Int64" fromIntegral = id :: Int64 -> Int64
- #-}
-
-#else
-
--- Int64 is represented in the same way as Int.
--- Operations may assume and must ensure that it holds only values
--- from its logical range.
-
-data Int64 = I64# Int# deriving (Eq, Ord)
--- ^ 64-bit signed integer type
-
-instance Show Int64 where
- showsPrec p x = showsPrec p (fromIntegral x :: Int)
-
-instance Num Int64 where
- (I64# x#) + (I64# y#) = I64# (x# +# y#)
- (I64# x#) - (I64# y#) = I64# (x# -# y#)
- (I64# x#) * (I64# y#) = I64# (x# *# y#)
- negate (I64# x#) = I64# (negateInt# x#)
- abs x | x >= 0 = x
- | otherwise = negate x
- signum x | x > 0 = 1
- signum 0 = 0
- signum _ = -1
- fromInteger (S# i#) = I64# i#
- fromInteger (J# s# d#) = I64# (integer2Int# s# d#)
-
-instance Enum Int64 where
- succ x
- | x /= maxBound = x + 1
- | otherwise = succError "Int64"
- pred x
- | x /= minBound = x - 1
- | otherwise = predError "Int64"
- toEnum (I# i#) = I64# i#
- fromEnum (I64# x#) = I# x#
- enumFrom = boundedEnumFrom
- enumFromThen = boundedEnumFromThen
-
-instance Integral Int64 where
- quot x@(I64# x#) y@(I64# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I64# (x# `quotInt#` y#)
- rem x@(I64# x#) y@(I64# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I64# (x# `remInt#` y#)
- div x@(I64# x#) y@(I64# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I64# (x# `divInt#` y#)
- mod x@(I64# x#) y@(I64# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = I64# (x# `modInt#` y#)
- quotRem x@(I64# x#) y@(I64# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = (I64# (x# `quotInt#` y#), I64# (x# `remInt#` y#))
- divMod x@(I64# x#) y@(I64# y#)
- | y == 0 = divZeroError
- | x == minBound && y == (-1) = overflowError
- | otherwise = (I64# (x# `divInt#` y#), I64# (x# `modInt#` y#))
- toInteger (I64# x#) = S# x#
-
-instance Read Int64 where
- readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]
-
-instance Bits Int64 where
- {-# INLINE shift #-}
-
- (I64# x#) .&. (I64# y#) = I64# (word2Int# (int2Word# x# `and#` int2Word# y#))
- (I64# x#) .|. (I64# y#) = I64# (word2Int# (int2Word# x# `or#` int2Word# y#))
- (I64# x#) `xor` (I64# y#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# y#))
- complement (I64# x#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))
- (I64# x#) `shift` (I# i#)
- | i# >=# 0# = I64# (x# `iShiftL#` i#)
- | otherwise = I64# (x# `iShiftRA#` negateInt# i#)
- (I64# x#) `rotate` (I# i#)
- | i'# ==# 0#
- = I64# x#
- | otherwise
- = I64# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`
- (x'# `uncheckedShiftRL#` (64# -# i'#))))
- where
- x'# = int2Word# x#
- i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)
- bitSize _ = 64
- isSigned _ = True
-
-{-# RULES
-"fromIntegral/a->Int64" fromIntegral = \x -> case fromIntegral x of I# x# -> I64# x#
-"fromIntegral/Int64->a" fromIntegral = \(I64# x#) -> fromIntegral (I# x#)
- #-}
-
-#endif
-
-instance Real Int64 where
- toRational x = toInteger x % 1
-
-instance Bounded Int64 where
- minBound = -0x8000000000000000
- maxBound = 0x7FFFFFFFFFFFFFFF
-
-instance Ix Int64 where
- range (m,n) = [m..n]
- unsafeIndex b@(m,_) i = fromIntegral i - fromIntegral m
- inRange (m,n) i = m <= i && i <= n
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.List
--- Copyright : (c) The University of Glasgow 1994-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- The List data type and its operations
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.List (
- -- [] (..), -- Not Haskell 98; built in syntax
-
- map, (++), filter, concat,
- head, last, tail, init, null, length, (!!),
- foldl, scanl, scanl1, foldr, foldr1, scanr, scanr1,
- iterate, repeat, replicate, cycle,
- take, drop, splitAt, takeWhile, dropWhile, span, break,
- reverse, and, or,
- any, all, elem, notElem, lookup,
- concatMap,
- zip, zip3, zipWith, zipWith3, unzip, unzip3,
- errorEmptyList,
-
-#ifndef USE_REPORT_PRELUDE
- -- non-standard, but hidden when creating the Prelude
- -- export list.
- takeUInt_append
-#endif
-
- ) where
-
-import {-# SOURCE #-} GHC.Err ( error )
-import Data.Tuple() -- Instances
-import Data.Maybe
-import GHC.Base
-
-infixl 9 !!
-infix 4 `elem`, `notElem`
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{List-manipulation functions}
-%* *
-%*********************************************************
-
-\begin{code}
--- | Extract the first element of a list, which must be non-empty.
-head :: [a] -> a
-head (x:_) = x
-head [] = badHead
-
-badHead = errorEmptyList "head"
-
--- This rule is useful in cases like
--- head [y | (x,y) <- ps, x==t]
-{-# RULES
-"head/build" forall (g::forall b.(a->b->b)->b->b) .
- head (build g) = g (\x _ -> x) badHead
-"head/augment" forall xs (g::forall b. (a->b->b) -> b -> b) .
- head (augment g xs) = g (\x _ -> x) (head xs)
- #-}
-
--- | Extract the elements after the head of a list, which must be non-empty.
-tail :: [a] -> [a]
-tail (_:xs) = xs
-tail [] = errorEmptyList "tail"
-
--- | Extract the last element of a list, which must be finite and non-empty.
-last :: [a] -> a
-#ifdef USE_REPORT_PRELUDE
-last [x] = x
-last (_:xs) = last xs
-last [] = errorEmptyList "last"
-#else
--- eliminate repeated cases
-last [] = errorEmptyList "last"
-last (x:xs) = last' x xs
- where last' y [] = y
- last' _ (y:ys) = last' y ys
-#endif
-
--- | Return all the elements of a list except the last one.
--- The list must be finite and non-empty.
-init :: [a] -> [a]
-#ifdef USE_REPORT_PRELUDE
-init [x] = []
-init (x:xs) = x : init xs
-init [] = errorEmptyList "init"
-#else
--- eliminate repeated cases
-init [] = errorEmptyList "init"
-init (x:xs) = init' x xs
- where init' _ [] = []
- init' y (z:zs) = y : init' z zs
-#endif
-
--- | Test whether a list is empty.
-null :: [a] -> Bool
-null [] = True
-null (_:_) = False
-
--- | 'length' returns the length of a finite list as an 'Int'.
--- It is an instance of the more general 'Data.List.genericLength',
--- the result type of which may be any kind of number.
-length :: [a] -> Int
-length l = len l 0#
- where
- len :: [a] -> Int# -> Int
- len [] a# = I# a#
- len (_:xs) a# = len xs (a# +# 1#)
-
--- | 'filter', applied to a predicate and a list, returns the list of
--- those elements that satisfy the predicate; i.e.,
---
--- > filter p xs = [ x | x <- xs, p x]
-
-filter :: (a -> Bool) -> [a] -> [a]
-filter _pred [] = []
-filter pred (x:xs)
- | pred x = x : filter pred xs
- | otherwise = filter pred xs
-
-{-# NOINLINE [0] filterFB #-}
-filterFB c p x r | p x = x `c` r
- | otherwise = r
-
-{-# RULES
-"filter" [~1] forall p xs. filter p xs = build (\c n -> foldr (filterFB c p) n xs)
-"filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p
-"filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x)
- #-}
-
--- Note the filterFB rule, which has p and q the "wrong way round" in the RHS.
--- filterFB (filterFB c p) q a b
--- = if q a then filterFB c p a b else b
--- = if q a then (if p a then c a b else b) else b
--- = if q a && p a then c a b else b
--- = filterFB c (\x -> q x && p x) a b
--- I originally wrote (\x -> p x && q x), which is wrong, and actually
--- gave rise to a live bug report. SLPJ.
-
-
--- | 'foldl', applied to a binary operator, a starting value (typically
--- the left-identity of the operator), and a list, reduces the list
--- using the binary operator, from left to right:
---
--- > foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
---
--- The list must be finite.
-
--- We write foldl as a non-recursive thing, so that it
--- can be inlined, and then (often) strictness-analysed,
--- and hence the classic space leak on foldl (+) 0 xs
-
-foldl :: (a -> b -> a) -> a -> [b] -> a
-foldl f z xs = lgo z xs
- where
- lgo z [] = z
- lgo z (x:xs) = lgo (f z x) xs
-
--- | 'scanl' is similar to 'foldl', but returns a list of successive
--- reduced values from the left:
---
--- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
---
--- Note that
---
--- > last (scanl f z xs) == foldl f z xs.
-
-scanl :: (a -> b -> a) -> a -> [b] -> [a]
-scanl f q ls = q : (case ls of
- [] -> []
- x:xs -> scanl f (f q x) xs)
-
--- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
---
--- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
-
-scanl1 :: (a -> a -> a) -> [a] -> [a]
-scanl1 f (x:xs) = scanl f x xs
-scanl1 _ [] = []
-
--- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
--- above functions.
-
--- | 'foldr1' is a variant of 'foldr' that has no starting value argument,
--- and thus must be applied to non-empty lists.
-
-foldr1 :: (a -> a -> a) -> [a] -> a
-foldr1 _ [x] = x
-foldr1 f (x:xs) = f x (foldr1 f xs)
-foldr1 _ [] = errorEmptyList "foldr1"
-
--- | 'scanr' is the right-to-left dual of 'scanl'.
--- Note that
---
--- > head (scanr f z xs) == foldr f z xs.
-
-scanr :: (a -> b -> b) -> b -> [a] -> [b]
-scanr _ q0 [] = [q0]
-scanr f q0 (x:xs) = f x q : qs
- where qs@(q:_) = scanr f q0 xs
-
--- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
-
-scanr1 :: (a -> a -> a) -> [a] -> [a]
-scanr1 f [] = []
-scanr1 f [x] = [x]
-scanr1 f (x:xs) = f x q : qs
- where qs@(q:_) = scanr1 f xs
-
--- | 'iterate' @f x@ returns an infinite list of repeated applications
--- of @f@ to @x@:
---
--- > iterate f x == [x, f x, f (f x), ...]
-
-iterate :: (a -> a) -> a -> [a]
-iterate f x = x : iterate f (f x)
-
-iterateFB c f x = x `c` iterateFB c f (f x)
-
-
-{-# RULES
-"iterate" [~1] forall f x. iterate f x = build (\c _n -> iterateFB c f x)
-"iterateFB" [1] iterateFB (:) = iterate
- #-}
-
-
--- | 'repeat' @x@ is an infinite list, with @x@ the value of every element.
-repeat :: a -> [a]
-{-# INLINE [0] repeat #-}
--- The pragma just gives the rules more chance to fire
-repeat x = xs where xs = x : xs
-
-{-# INLINE [0] repeatFB #-} -- ditto
-repeatFB c x = xs where xs = x `c` xs
-
-
-{-# RULES
-"repeat" [~1] forall x. repeat x = build (\c _n -> repeatFB c x)
-"repeatFB" [1] repeatFB (:) = repeat
- #-}
-
--- | 'replicate' @n x@ is a list of length @n@ with @x@ the value of
--- every element.
--- It is an instance of the more general 'Data.List.genericReplicate',
--- in which @n@ may be of any integral type.
-{-# INLINE replicate #-}
-replicate :: Int -> a -> [a]
-replicate n x = take n (repeat x)
-
--- | 'cycle' ties a finite list into a circular one, or equivalently,
--- the infinite repetition of the original list. It is the identity
--- on infinite lists.
-
-cycle :: [a] -> [a]
-cycle [] = error "Prelude.cycle: empty list"
-cycle xs = xs' where xs' = xs ++ xs'
-
--- | 'takeWhile', applied to a predicate @p@ and a list @xs@, returns the
--- longest prefix (possibly empty) of @xs@ of elements that satisfy @p@:
---
--- > takeWhile (< 3) [1,2,3,4,1,2,3,4] == [1,2]
--- > takeWhile (< 9) [1,2,3] == [1,2,3]
--- > takeWhile (< 0) [1,2,3] == []
---
-
-takeWhile :: (a -> Bool) -> [a] -> [a]
-takeWhile _ [] = []
-takeWhile p (x:xs)
- | p x = x : takeWhile p xs
- | otherwise = []
-
--- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@:
---
--- > dropWhile (< 3) [1,2,3,4,5,1,2,3] == [3,4,5,1,2,3]
--- > dropWhile (< 9) [1,2,3] == []
--- > dropWhile (< 0) [1,2,3] == [1,2,3]
---
-
-dropWhile :: (a -> Bool) -> [a] -> [a]
-dropWhile _ [] = []
-dropWhile p xs@(x:xs')
- | p x = dropWhile p xs'
- | otherwise = xs
-
--- | 'take' @n@, applied to a list @xs@, returns the prefix of @xs@
--- of length @n@, or @xs@ itself if @n > 'length' xs@:
---
--- > take 5 "Hello World!" == "Hello"
--- > take 3 [1,2,3,4,5] == [1,2,3]
--- > take 3 [1,2] == [1,2]
--- > take 3 [] == []
--- > take (-1) [1,2] == []
--- > take 0 [1,2] == []
---
--- It is an instance of the more general 'Data.List.genericTake',
--- in which @n@ may be of any integral type.
-take :: Int -> [a] -> [a]
-
--- | 'drop' @n xs@ returns the suffix of @xs@
--- after the first @n@ elements, or @[]@ if @n > 'length' xs@:
---
--- > drop 6 "Hello World!" == "World!"
--- > drop 3 [1,2,3,4,5] == [4,5]
--- > drop 3 [1,2] == []
--- > drop 3 [] == []
--- > drop (-1) [1,2] == [1,2]
--- > drop 0 [1,2] == [1,2]
---
--- It is an instance of the more general 'Data.List.genericDrop',
--- in which @n@ may be of any integral type.
-drop :: Int -> [a] -> [a]
-
--- | 'splitAt' @n xs@ returns a tuple where first element is @xs@ prefix of
--- length @n@ and second element is the remainder of the list:
---
--- > splitAt 6 "Hello World!" == ("Hello ","World!")
--- > splitAt 3 [1,2,3,4,5] == ([1,2,3],[4,5])
--- > splitAt 1 [1,2,3] == ([1],[2,3])
--- > splitAt 3 [1,2,3] == ([1,2,3],[])
--- > splitAt 4 [1,2,3] == ([1,2,3],[])
--- > splitAt 0 [1,2,3] == ([],[1,2,3])
--- > splitAt (-1) [1,2,3] == ([],[1,2,3])
---
--- It is equivalent to @('take' n xs, 'drop' n xs)@.
--- 'splitAt' is an instance of the more general 'Data.List.genericSplitAt',
--- in which @n@ may be of any integral type.
-splitAt :: Int -> [a] -> ([a],[a])
-
-#ifdef USE_REPORT_PRELUDE
-take n _ | n <= 0 = []
-take _ [] = []
-take n (x:xs) = x : take (n-1) xs
-
-drop n xs | n <= 0 = xs
-drop _ [] = []
-drop n (_:xs) = drop (n-1) xs
-
-splitAt n xs = (take n xs, drop n xs)
-
-#else /* hack away */
-{-# RULES
-"take" [~1] forall n xs . take n xs = takeFoldr n xs
-"takeList" [1] forall n xs . foldr (takeFB (:) []) (takeConst []) xs n = takeUInt n xs
- #-}
-
-{-# INLINE takeFoldr #-}
-takeFoldr :: Int -> [a] -> [a]
-takeFoldr (I# n#) xs
- = build (\c nil -> if n# <=# 0# then nil else
- foldr (takeFB c nil) (takeConst nil) xs n#)
-
-{-# NOINLINE [0] takeConst #-}
--- just a version of const that doesn't get inlined too early, so we
--- can spot it in rules. Also we need a type sig due to the unboxed Int#.
-takeConst :: a -> Int# -> a
-takeConst x _ = x
-
-{-# NOINLINE [0] takeFB #-}
-takeFB :: (a -> b -> b) -> b -> a -> (Int# -> b) -> Int# -> b
-takeFB c n x xs m | m <=# 1# = x `c` n
- | otherwise = x `c` xs (m -# 1#)
-
-{-# INLINE [0] take #-}
-take (I# n#) xs = takeUInt n# xs
-
--- The general code for take, below, checks n <= maxInt
--- No need to check for maxInt overflow when specialised
--- at type Int or Int# since the Int must be <= maxInt
-
-takeUInt :: Int# -> [b] -> [b]
-takeUInt n xs
- | n >=# 0# = take_unsafe_UInt n xs
- | otherwise = []
-
-take_unsafe_UInt :: Int# -> [b] -> [b]
-take_unsafe_UInt 0# _ = []
-take_unsafe_UInt m ls =
- case ls of
- [] -> []
- (x:xs) -> x : take_unsafe_UInt (m -# 1#) xs
-
-takeUInt_append :: Int# -> [b] -> [b] -> [b]
-takeUInt_append n xs rs
- | n >=# 0# = take_unsafe_UInt_append n xs rs
- | otherwise = []
-
-take_unsafe_UInt_append :: Int# -> [b] -> [b] -> [b]
-take_unsafe_UInt_append 0# _ rs = rs
-take_unsafe_UInt_append m ls rs =
- case ls of
- [] -> rs
- (x:xs) -> x : take_unsafe_UInt_append (m -# 1#) xs rs
-
-drop (I# n#) ls
- | n# <# 0# = ls
- | otherwise = drop# n# ls
- where
- drop# :: Int# -> [a] -> [a]
- drop# 0# xs = xs
- drop# _ xs@[] = xs
- drop# m# (_:xs) = drop# (m# -# 1#) xs
-
-splitAt (I# n#) ls
- | n# <# 0# = ([], ls)
- | otherwise = splitAt# n# ls
- where
- splitAt# :: Int# -> [a] -> ([a], [a])
- splitAt# 0# xs = ([], xs)
- splitAt# _ xs@[] = (xs, xs)
- splitAt# m# (x:xs) = (x:xs', xs'')
- where
- (xs', xs'') = splitAt# (m# -# 1#) xs
-
-#endif /* USE_REPORT_PRELUDE */
-
--- | 'span', applied to a predicate @p@ and a list @xs@, returns a tuple where
--- first element is longest prefix (possibly empty) of @xs@ of elements that
--- satisfy @p@ and second element is the remainder of the list:
---
--- > span (< 3) [1,2,3,4,1,2,3,4] == ([1,2],[3,4,1,2,3,4])
--- > span (< 9) [1,2,3] == ([1,2,3],[])
--- > span (< 0) [1,2,3] == ([],[1,2,3])
---
--- 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@
-
-span :: (a -> Bool) -> [a] -> ([a],[a])
-span _ xs@[] = (xs, xs)
-span p xs@(x:xs')
- | p x = let (ys,zs) = span p xs' in (x:ys,zs)
- | otherwise = ([],xs)
-
--- | 'break', applied to a predicate @p@ and a list @xs@, returns a tuple where
--- first element is longest prefix (possibly empty) of @xs@ of elements that
--- /do not satisfy/ @p@ and second element is the remainder of the list:
---
--- > break (> 3) [1,2,3,4,1,2,3,4] == ([1,2,3],[4,1,2,3,4])
--- > break (< 9) [1,2,3] == ([],[1,2,3])
--- > break (> 9) [1,2,3] == ([1,2,3],[])
---
--- 'break' @p@ is equivalent to @'span' ('not' . p)@.
-
-break :: (a -> Bool) -> [a] -> ([a],[a])
-#ifdef USE_REPORT_PRELUDE
-break p = span (not . p)
-#else
--- HBC version (stolen)
-break _ xs@[] = (xs, xs)
-break p xs@(x:xs')
- | p x = ([],xs)
- | otherwise = let (ys,zs) = break p xs' in (x:ys,zs)
-#endif
-
--- | 'reverse' @xs@ returns the elements of @xs@ in reverse order.
--- @xs@ must be finite.
-reverse :: [a] -> [a]
-#ifdef USE_REPORT_PRELUDE
-reverse = foldl (flip (:)) []
-#else
-reverse l = rev l []
- where
- rev [] a = a
- rev (x:xs) a = rev xs (x:a)
-#endif
-
--- | 'and' returns the conjunction of a Boolean list. For the result to be
--- 'True', the list must be finite; 'False', however, results from a 'False'
--- value at a finite index of a finite or infinite list.
-and :: [Bool] -> Bool
-
--- | 'or' returns the disjunction of a Boolean list. For the result to be
--- 'False', the list must be finite; 'True', however, results from a 'True'
--- value at a finite index of a finite or infinite list.
-or :: [Bool] -> Bool
-#ifdef USE_REPORT_PRELUDE
-and = foldr (&&) True
-or = foldr (||) False
-#else
-and [] = True
-and (x:xs) = x && and xs
-or [] = False
-or (x:xs) = x || or xs
-
-{-# RULES
-"and/build" forall (g::forall b.(Bool->b->b)->b->b) .
- and (build g) = g (&&) True
-"or/build" forall (g::forall b.(Bool->b->b)->b->b) .
- or (build g) = g (||) False
- #-}
-#endif
-
--- | Applied to a predicate and a list, 'any' determines if any element
--- of the list satisfies the predicate.
-any :: (a -> Bool) -> [a] -> Bool
-
--- | Applied to a predicate and a list, 'all' determines if all elements
--- of the list satisfy the predicate.
-all :: (a -> Bool) -> [a] -> Bool
-#ifdef USE_REPORT_PRELUDE
-any p = or . map p
-all p = and . map p
-#else
-any _ [] = False
-any p (x:xs) = p x || any p xs
-
-all _ [] = True
-all p (x:xs) = p x && all p xs
-{-# RULES
-"any/build" forall p (g::forall b.(a->b->b)->b->b) .
- any p (build g) = g ((||) . p) False
-"all/build" forall p (g::forall b.(a->b->b)->b->b) .
- all p (build g) = g ((&&) . p) True
- #-}
-#endif
-
--- | 'elem' is the list membership predicate, usually written in infix form,
--- e.g., @x `elem` xs@.
-elem :: (Eq a) => a -> [a] -> Bool
-
--- | 'notElem' is the negation of 'elem'.
-notElem :: (Eq a) => a -> [a] -> Bool
-#ifdef USE_REPORT_PRELUDE
-elem x = any (== x)
-notElem x = all (/= x)
-#else
-elem _ [] = False
-elem x (y:ys) = x==y || elem x ys
-
-notElem _ [] = True
-notElem x (y:ys)= x /= y && notElem x ys
-#endif
-
--- | 'lookup' @key assocs@ looks up a key in an association list.
-lookup :: (Eq a) => a -> [(a,b)] -> Maybe b
-lookup _key [] = Nothing
-lookup key ((x,y):xys)
- | key == x = Just y
- | otherwise = lookup key xys
-
--- | Map a function over a list and concatenate the results.
-concatMap :: (a -> [b]) -> [a] -> [b]
-concatMap f = foldr ((++) . f) []
-
--- | Concatenate a list of lists.
-concat :: [[a]] -> [a]
-concat = foldr (++) []
-
-{-# RULES
- "concat" forall xs. concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs)
--- We don't bother to turn non-fusible applications of concat back into concat
- #-}
-
-\end{code}
-
-
-\begin{code}
--- | List index (subscript) operator, starting from 0.
--- It is an instance of the more general 'Data.List.genericIndex',
--- which takes an index of any integral type.
-(!!) :: [a] -> Int -> a
-#ifdef USE_REPORT_PRELUDE
-xs !! n | n < 0 = error "Prelude.!!: negative index"
-[] !! _ = error "Prelude.!!: index too large"
-(x:_) !! 0 = x
-(_:xs) !! n = xs !! (n-1)
-#else
--- HBC version (stolen), then unboxified
--- The semantics is not quite the same for error conditions
--- in the more efficient version.
---
-xs !! (I# n) | n <# 0# = error "Prelude.(!!): negative index\n"
- | otherwise = sub xs n
- where
- sub :: [a] -> Int# -> a
- sub [] _ = error "Prelude.(!!): index too large\n"
- sub (y:ys) n = if n ==# 0#
- then y
- else sub ys (n -# 1#)
-#endif
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{The zip family}
-%* *
-%*********************************************************
-
-\begin{code}
-foldr2 _k z [] _ys = z
-foldr2 _k z _xs [] = z
-foldr2 k z (x:xs) (y:ys) = k x y (foldr2 k z xs ys)
-
-foldr2_left _k z _x _r [] = z
-foldr2_left k _z x r (y:ys) = k x y (r ys)
-
-foldr2_right _k z _y _r [] = z
-foldr2_right k _z y r (x:xs) = k x y (r xs)
-
--- foldr2 k z xs ys = foldr (foldr2_left k z) (\_ -> z) xs ys
--- foldr2 k z xs ys = foldr (foldr2_right k z) (\_ -> z) ys xs
-{-# RULES
-"foldr2/left" forall k z ys (g::forall b.(a->b->b)->b->b) .
- foldr2 k z (build g) ys = g (foldr2_left k z) (\_ -> z) ys
-
-"foldr2/right" forall k z xs (g::forall b.(a->b->b)->b->b) .
- foldr2 k z xs (build g) = g (foldr2_right k z) (\_ -> z) xs
- #-}
-\end{code}
-
-The foldr2/right rule isn't exactly right, because it changes
-the strictness of foldr2 (and thereby zip)
-
-E.g. main = print (null (zip nonobviousNil (build undefined)))
- where nonobviousNil = f 3
- f n = if n == 0 then [] else f (n-1)
-
-I'm going to leave it though.
-
-
-Zips for larger tuples are in the List module.
-
-\begin{code}
-----------------------------------------------
--- | 'zip' takes two lists and returns a list of corresponding pairs.
--- If one input list is short, excess elements of the longer list are
--- discarded.
-zip :: [a] -> [b] -> [(a,b)]
-zip (a:as) (b:bs) = (a,b) : zip as bs
-zip _ _ = []
-
-{-# INLINE [0] zipFB #-}
-zipFB c x y r = (x,y) `c` r
-
-{-# RULES
-"zip" [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys)
-"zipList" [1] foldr2 (zipFB (:)) [] = zip
- #-}
-\end{code}
-
-\begin{code}
-----------------------------------------------
--- | 'zip3' takes three lists and returns a list of triples, analogous to
--- 'zip'.
-zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
--- Specification
--- zip3 = zipWith3 (,,)
-zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs
-zip3 _ _ _ = []
-\end{code}
-
-
--- The zipWith family generalises the zip family by zipping with the
--- function given as the first argument, instead of a tupling function.
-
-\begin{code}
-----------------------------------------------
--- | 'zipWith' generalises 'zip' by zipping with the function given
--- as the first argument, instead of a tupling function.
--- For example, @'zipWith' (+)@ is applied to two lists to produce the
--- list of corresponding sums.
-zipWith :: (a->b->c) -> [a]->[b]->[c]
-zipWith f (a:as) (b:bs) = f a b : zipWith f as bs
-zipWith _ _ _ = []
-
-{-# INLINE [0] zipWithFB #-}
-zipWithFB c f x y r = (x `f` y) `c` r
-
-{-# RULES
-"zipWith" [~1] forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys)
-"zipWithList" [1] forall f. foldr2 (zipWithFB (:) f) [] = zipWith f
- #-}
-\end{code}
-
-\begin{code}
--- | The 'zipWith3' function takes a function which combines three
--- elements, as well as three lists and returns a list of their point-wise
--- combination, analogous to 'zipWith'.
-zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
-zipWith3 z (a:as) (b:bs) (c:cs)
- = z a b c : zipWith3 z as bs cs
-zipWith3 _ _ _ _ = []
-
--- | 'unzip' transforms a list of pairs into a list of first components
--- and a list of second components.
-unzip :: [(a,b)] -> ([a],[b])
-{-# INLINE unzip #-}
-unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
-
--- | The 'unzip3' function takes a list of triples and returns three
--- lists, analogous to 'unzip'.
-unzip3 :: [(a,b,c)] -> ([a],[b],[c])
-{-# INLINE unzip3 #-}
-unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
- ([],[],[])
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Error code}
-%* *
-%*********************************************************
-
-Common up near identical calls to `error' to reduce the number
-constant strings created when compiled:
-
-\begin{code}
-errorEmptyList :: String -> a
-errorEmptyList fun =
- error (prel_list_str ++ fun ++ ": empty list")
-
-prel_list_str :: String
-prel_list_str = "Prelude."
-\end{code}
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Num
--- Copyright : (c) The University of Glasgow 1994-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- The 'Num' class and the 'Integer' type.
---
------------------------------------------------------------------------------
-
-#include "MachDeps.h"
-#if SIZEOF_HSWORD == 4
-#define LEFTMOST_BIT 2147483648
-#define DIGITS 9
-#define BASE 1000000000
-#elif SIZEOF_HSWORD == 8
-#define LEFTMOST_BIT 9223372036854775808
-#define DIGITS 18
-#define BASE 1000000000000000000
-#else
-#error Please define LEFTMOST_BIT to be 2^(SIZEOF_HSWORD*8-1)
--- DIGITS should be the largest integer such that 10^DIGITS < LEFTMOST_BIT
--- BASE should be 10^DIGITS. Note that ^ is not available yet.
-#endif
-
--- #hide
-module GHC.Num where
-
-import {-# SOURCE #-} GHC.Err
-import GHC.Base
-import GHC.Enum
-import GHC.Show
-
-infixl 7 *
-infixl 6 +, -
-
-default () -- Double isn't available yet,
- -- and we shouldn't be using defaults anyway
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Standard numeric class}
-%* *
-%*********************************************************
-
-\begin{code}
--- | Basic numeric class.
---
--- Minimal complete definition: all except 'negate' or @(-)@
-class (Eq a, Show a) => Num a where
- (+), (-), (*) :: a -> a -> a
- -- | Unary negation.
- negate :: a -> a
- -- | Absolute value.
- abs :: a -> a
- -- | Sign of a number.
- -- The functions 'abs' and 'signum' should satisfy the law:
- --
- -- > abs x * signum x == x
- --
- -- For real numbers, the 'signum' is either @-1@ (negative), @0@ (zero)
- -- or @1@ (positive).
- signum :: a -> a
- -- | Conversion from an 'Integer'.
- -- An integer literal represents the application of the function
- -- 'fromInteger' to the appropriate value of type 'Integer',
- -- so such literals have type @('Num' a) => a@.
- fromInteger :: Integer -> a
-
- x - y = x + negate y
- negate x = 0 - x
-
--- | the same as @'flip' ('-')@.
---
--- Because @-@ is treated specially in the Haskell grammar,
--- @(-@ /e/@)@ is not a section, but an application of prefix negation.
--- However, @('subtract'@ /exp/@)@ is equivalent to the disallowed section.
-{-# INLINE subtract #-}
-subtract :: (Num a) => a -> a -> a
-subtract x y = y - x
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Instances for @Int@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Num Int where
- (+) = plusInt
- (-) = minusInt
- negate = negateInt
- (*) = timesInt
- abs n = if n `geInt` 0 then n else negateInt n
-
- signum n | n `ltInt` 0 = negateInt 1
- | n `eqInt` 0 = 0
- | otherwise = 1
-
- fromInteger = integer2Int
-
-quotRemInt :: Int -> Int -> (Int, Int)
-quotRemInt a@(I# _) b@(I# _) = (a `quotInt` b, a `remInt` b)
- -- OK, so I made it a little stricter. Shoot me. (WDP 94/10)
-
-divModInt :: Int -> Int -> (Int, Int)
-divModInt x@(I# _) y@(I# _) = (x `divInt` y, x `modInt` y)
- -- Stricter. Sorry if you don't like it. (WDP 94/10)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{The @Integer@ type}
-%* *
-%*********************************************************
-
-\begin{code}
--- | Arbitrary-precision integers.
-data Integer
- = S# Int# -- small integers
-#ifndef ILX
- | J# Int# ByteArray# -- large integers
-#else
- | J# Void BigInteger -- .NET big ints
-
-foreign type dotnet "BigInteger" BigInteger
-#endif
-\end{code}
-
-Convenient boxed Integer PrimOps.
-
-\begin{code}
-zeroInteger :: Integer
-zeroInteger = S# 0#
-
-int2Integer :: Int -> Integer
-{-# INLINE int2Integer #-}
-int2Integer (I# i) = S# i
-
-integer2Int :: Integer -> Int
-integer2Int (S# i) = I# i
-integer2Int (J# s d) = case (integer2Int# s d) of { n# -> I# n# }
-
-toBig (S# i) = case int2Integer# i of { (# s, d #) -> J# s d }
-toBig i@(J# _ _) = i
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Dividing @Integers@}
-%* *
-%*********************************************************
-
-\begin{code}
-quotRemInteger :: Integer -> Integer -> (Integer, Integer)
-quotRemInteger a@(S# (-LEFTMOST_BIT#)) b = quotRemInteger (toBig a) b
-quotRemInteger (S# i) (S# j)
- = case quotRemInt (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j )
-quotRemInteger i1@(J# _ _) i2@(S# _) = quotRemInteger i1 (toBig i2)
-quotRemInteger i1@(S# _) i2@(J# _ _) = quotRemInteger (toBig i1) i2
-quotRemInteger (J# s1 d1) (J# s2 d2)
- = case (quotRemInteger# s1 d1 s2 d2) of
- (# s3, d3, s4, d4 #)
- -> (J# s3 d3, J# s4 d4)
-
-divModInteger a@(S# (-LEFTMOST_BIT#)) b = divModInteger (toBig a) b
-divModInteger (S# i) (S# j)
- = case divModInt (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j)
-divModInteger i1@(J# _ _) i2@(S# _) = divModInteger i1 (toBig i2)
-divModInteger i1@(S# _) i2@(J# _ _) = divModInteger (toBig i1) i2
-divModInteger (J# s1 d1) (J# s2 d2)
- = case (divModInteger# s1 d1 s2 d2) of
- (# s3, d3, s4, d4 #)
- -> (J# s3 d3, J# s4 d4)
-
-remInteger :: Integer -> Integer -> Integer
-remInteger ia ib
- | ib == 0 = error "Prelude.Integral.rem{Integer}: divide by 0"
-remInteger a@(S# (-LEFTMOST_BIT#)) b = remInteger (toBig a) b
-remInteger (S# a) (S# b) = S# (remInt# a b)
-{- Special case doesn't work, because a 1-element J# has the range
- -(2^32-1) -- 2^32-1, whereas S# has the range -2^31 -- (2^31-1)
-remInteger ia@(S# a) (J# sb b)
- | sb ==# 1# = S# (remInt# a (word2Int# (integer2Word# sb b)))
- | sb ==# -1# = S# (remInt# a (0# -# (word2Int# (integer2Word# sb b))))
- | 0# <# sb = ia
- | otherwise = S# (0# -# a)
--}
-remInteger ia@(S# _) ib@(J# _ _) = remInteger (toBig ia) ib
-remInteger (J# sa a) (S# b)
- = case int2Integer# b of { (# sb, b #) ->
- case remInteger# sa a sb b of { (# sr, r #) ->
- S# (integer2Int# sr r) }}
-remInteger (J# sa a) (J# sb b)
- = case remInteger# sa a sb b of (# sr, r #) -> J# sr r
-
-quotInteger :: Integer -> Integer -> Integer
-quotInteger ia ib
- | ib == 0 = error "Prelude.Integral.quot{Integer}: divide by 0"
-quotInteger a@(S# (-LEFTMOST_BIT#)) b = quotInteger (toBig a) b
-quotInteger (S# a) (S# b) = S# (quotInt# a b)
-{- Special case disabled, see remInteger above
-quotInteger (S# a) (J# sb b)
- | sb ==# 1# = S# (quotInt# a (word2Int# (integer2Word# sb b)))
- | sb ==# -1# = S# (quotInt# a (0# -# (word2Int# (integer2Word# sb b))))
- | otherwise = zeroInteger
--}
-quotInteger ia@(S# _) ib@(J# _ _) = quotInteger (toBig ia) ib
-quotInteger (J# sa a) (S# b)
- = case int2Integer# b of { (# sb, b #) ->
- case quotInteger# sa a sb b of (# sq, q #) -> J# sq q }
-quotInteger (J# sa a) (J# sb b)
- = case quotInteger# sa a sb b of (# sg, g #) -> J# sg g
-\end{code}
-
-
-
-\begin{code}
-gcdInteger :: Integer -> Integer -> Integer
--- SUP: Do we really need the first two cases?
-gcdInteger a@(S# (-LEFTMOST_BIT#)) b = gcdInteger (toBig a) b
-gcdInteger a b@(S# (-LEFTMOST_BIT#)) = gcdInteger a (toBig b)
-gcdInteger (S# a) (S# b) = case gcdInt (I# a) (I# b) of { I# c -> S# c }
-gcdInteger ia@(S# 0#) ib@(J# 0# _) = error "GHC.Num.gcdInteger: gcd 0 0 is undefined"
-gcdInteger ia@(S# a) ib@(J# sb b)
- | a ==# 0# = abs ib
- | sb ==# 0# = abs ia
- | otherwise = S# (gcdIntegerInt# absSb b absA)
- where absA = if a <# 0# then negateInt# a else a
- absSb = if sb <# 0# then negateInt# sb else sb
-gcdInteger ia@(J# _ _) ib@(S# _) = gcdInteger ib ia
-gcdInteger (J# 0# _) (J# 0# _) = error "GHC.Num.gcdInteger: gcd 0 0 is undefined"
-gcdInteger (J# sa a) (J# sb b)
- = case gcdInteger# sa a sb b of (# sg, g #) -> J# sg g
-
-lcmInteger :: Integer -> Integer -> Integer
-lcmInteger a 0
- = zeroInteger
-lcmInteger 0 b
- = zeroInteger
-lcmInteger a b
- = (divExact aa (gcdInteger aa ab)) * ab
- where aa = abs a
- ab = abs b
-
-divExact :: Integer -> Integer -> Integer
-divExact a@(S# (-LEFTMOST_BIT#)) b = divExact (toBig a) b
-divExact (S# a) (S# b) = S# (quotInt# a b)
-divExact (S# a) (J# sb b)
- = S# (quotInt# a (integer2Int# sb b))
-divExact (J# sa a) (S# b)
- = case int2Integer# b of
- (# sb, b #) -> case divExactInteger# sa a sb b of (# sd, d #) -> J# sd d
-divExact (J# sa a) (J# sb b)
- = case divExactInteger# sa a sb b of (# sd, d #) -> J# sd d
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{The @Integer@ instances for @Eq@, @Ord@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Eq Integer where
- (S# i) == (S# j) = i ==# j
- (S# i) == (J# s d) = cmpIntegerInt# s d i ==# 0#
- (J# s d) == (S# i) = cmpIntegerInt# s d i ==# 0#
- (J# s1 d1) == (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ==# 0#
-
- (S# i) /= (S# j) = i /=# j
- (S# i) /= (J# s d) = cmpIntegerInt# s d i /=# 0#
- (J# s d) /= (S# i) = cmpIntegerInt# s d i /=# 0#
- (J# s1 d1) /= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) /=# 0#
-
-------------------------------------------------------------------------
-instance Ord Integer where
- (S# i) <= (S# j) = i <=# j
- (J# s d) <= (S# i) = cmpIntegerInt# s d i <=# 0#
- (S# i) <= (J# s d) = cmpIntegerInt# s d i >=# 0#
- (J# s1 d1) <= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <=# 0#
-
- (S# i) > (S# j) = i ># j
- (J# s d) > (S# i) = cmpIntegerInt# s d i ># 0#
- (S# i) > (J# s d) = cmpIntegerInt# s d i <# 0#
- (J# s1 d1) > (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ># 0#
-
- (S# i) < (S# j) = i <# j
- (J# s d) < (S# i) = cmpIntegerInt# s d i <# 0#
- (S# i) < (J# s d) = cmpIntegerInt# s d i ># 0#
- (J# s1 d1) < (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <# 0#
-
- (S# i) >= (S# j) = i >=# j
- (J# s d) >= (S# i) = cmpIntegerInt# s d i >=# 0#
- (S# i) >= (J# s d) = cmpIntegerInt# s d i <=# 0#
- (J# s1 d1) >= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) >=# 0#
-
- compare (S# i) (S# j)
- | i ==# j = EQ
- | i <=# j = LT
- | otherwise = GT
- compare (J# s d) (S# i)
- = case cmpIntegerInt# s d i of { res# ->
- if res# <# 0# then LT else
- if res# ># 0# then GT else EQ
- }
- compare (S# i) (J# s d)
- = case cmpIntegerInt# s d i of { res# ->
- if res# ># 0# then LT else
- if res# <# 0# then GT else EQ
- }
- compare (J# s1 d1) (J# s2 d2)
- = case cmpInteger# s1 d1 s2 d2 of { res# ->
- if res# <# 0# then LT else
- if res# ># 0# then GT else EQ
- }
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{The @Integer@ instances for @Num@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Num Integer where
- (+) = plusInteger
- (-) = minusInteger
- (*) = timesInteger
- negate = negateInteger
- fromInteger x = x
-
- -- ORIG: abs n = if n >= 0 then n else -n
- abs (S# (-LEFTMOST_BIT#)) = LEFTMOST_BIT
- abs (S# i) = case abs (I# i) of I# j -> S# j
- abs n@(J# s d) = if (s >=# 0#) then n else J# (negateInt# s) d
-
- signum (S# i) = case signum (I# i) of I# j -> S# j
- signum (J# s d)
- = let
- cmp = cmpIntegerInt# s d 0#
- in
- if cmp ># 0# then S# 1#
- else if cmp ==# 0# then S# 0#
- else S# (negateInt# 1#)
-
-plusInteger i1@(S# i) i2@(S# j) = case addIntC# i j of { (# r, c #) ->
- if c ==# 0# then S# r
- else toBig i1 + toBig i2 }
-plusInteger i1@(J# _ _) i2@(S# _) = i1 + toBig i2
-plusInteger i1@(S# _) i2@(J# _ _) = toBig i1 + i2
-plusInteger (J# s1 d1) (J# s2 d2) = case plusInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d
-
-minusInteger i1@(S# i) i2@(S# j) = case subIntC# i j of { (# r, c #) ->
- if c ==# 0# then S# r
- else toBig i1 - toBig i2 }
-minusInteger i1@(J# _ _) i2@(S# _) = i1 - toBig i2
-minusInteger i1@(S# _) i2@(J# _ _) = toBig i1 - i2
-minusInteger (J# s1 d1) (J# s2 d2) = case minusInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d
-
-timesInteger i1@(S# i) i2@(S# j) = if mulIntMayOflo# i j ==# 0#
- then S# (i *# j)
- else toBig i1 * toBig i2
-timesInteger i1@(J# _ _) i2@(S# _) = i1 * toBig i2
-timesInteger i1@(S# _) i2@(J# _ _) = toBig i1 * i2
-timesInteger (J# s1 d1) (J# s2 d2) = case timesInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d
-
-negateInteger (S# (-LEFTMOST_BIT#)) = LEFTMOST_BIT
-negateInteger (S# i) = S# (negateInt# i)
-negateInteger (J# s d) = J# (negateInt# s) d
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{The @Integer@ instance for @Enum@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Enum Integer where
- succ x = x + 1
- pred x = x - 1
- toEnum n = int2Integer n
- fromEnum n = integer2Int n
-
- {-# INLINE enumFrom #-}
- {-# INLINE enumFromThen #-}
- {-# INLINE enumFromTo #-}
- {-# INLINE enumFromThenTo #-}
- enumFrom x = enumDeltaInteger x 1
- enumFromThen x y = enumDeltaInteger x (y-x)
- enumFromTo x lim = enumDeltaToInteger x 1 lim
- enumFromThenTo x y lim = enumDeltaToInteger x (y-x) lim
-
-{-# RULES
-"enumDeltaInteger" [~1] forall x y. enumDeltaInteger x y = build (\c _ -> enumDeltaIntegerFB c x y)
-"efdtInteger" [~1] forall x y l.enumDeltaToInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l)
-"enumDeltaInteger" [1] enumDeltaIntegerFB (:) = enumDeltaInteger
-"enumDeltaToInteger" [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger
- #-}
-
-enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b
-enumDeltaIntegerFB c x d = x `c` enumDeltaIntegerFB c (x+d) d
-
-enumDeltaInteger :: Integer -> Integer -> [Integer]
-enumDeltaInteger x d = x : enumDeltaInteger (x+d) d
-
-enumDeltaToIntegerFB c n x delta lim
- | delta >= 0 = up_fb c n x delta lim
- | otherwise = dn_fb c n x delta lim
-
-enumDeltaToInteger x delta lim
- | delta >= 0 = up_list x delta lim
- | otherwise = dn_list x delta lim
-
-up_fb c n x delta lim = go (x::Integer)
- where
- go x | x > lim = n
- | otherwise = x `c` go (x+delta)
-dn_fb c n x delta lim = go (x::Integer)
- where
- go x | x < lim = n
- | otherwise = x `c` go (x+delta)
-
-up_list x delta lim = go (x::Integer)
- where
- go x | x > lim = []
- | otherwise = x : go (x+delta)
-dn_list x delta lim = go (x::Integer)
- where
- go x | x < lim = []
- | otherwise = x : go (x+delta)
-
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{The @Integer@ instances for @Show@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Show Integer where
- showsPrec p n r
- | p > 6 && n < 0 = '(' : jtos n (')' : r)
- -- Minor point: testing p first gives better code
- -- in the not-uncommon case where the p argument
- -- is a constant
- | otherwise = jtos n r
- showList = showList__ (showsPrec 0)
-
--- Divide an conquer implementation of string conversion
-jtos :: Integer -> String -> String
-jtos n cs
- | n < 0 = '-' : jtos' (-n) cs
- | otherwise = jtos' n cs
- where
- jtos' :: Integer -> String -> String
- jtos' n cs
- | n < BASE = jhead (fromInteger n) cs
- | otherwise = jprinth (jsplitf (BASE*BASE) n) cs
-
- -- Split n into digits in base p. We first split n into digits
- -- in base p*p and then split each of these digits into two.
- -- Note that the first 'digit' modulo p*p may have a leading zero
- -- in base p that we need to drop - this is what jsplith takes care of.
- -- jsplitb the handles the remaining digits.
- jsplitf :: Integer -> Integer -> [Integer]
- jsplitf p n
- | p > n = [n]
- | otherwise = jsplith p (jsplitf (p*p) n)
-
- jsplith :: Integer -> [Integer] -> [Integer]
- jsplith p (n:ns) =
- if q > 0 then fromInteger q : fromInteger r : jsplitb p ns
- else fromInteger r : jsplitb p ns
- where
- (q, r) = n `quotRemInteger` p
-
- jsplitb :: Integer -> [Integer] -> [Integer]
- jsplitb p [] = []
- jsplitb p (n:ns) = q : r : jsplitb p ns
- where
- (q, r) = n `quotRemInteger` p
-
- -- Convert a number that has been split into digits in base BASE^2
- -- this includes a last splitting step and then conversion of digits
- -- that all fit into a machine word.
- jprinth :: [Integer] -> String -> String
- jprinth (n:ns) cs =
- if q > 0 then jhead q $ jblock r $ jprintb ns cs
- else jhead r $ jprintb ns cs
- where
- (q', r') = n `quotRemInteger` BASE
- q = fromInteger q'
- r = fromInteger r'
-
- jprintb :: [Integer] -> String -> String
- jprintb [] cs = cs
- jprintb (n:ns) cs = jblock q $ jblock r $ jprintb ns cs
- where
- (q', r') = n `quotRemInteger` BASE
- q = fromInteger q'
- r = fromInteger r'
-
- -- Convert an integer that fits into a machine word. Again, we have two
- -- functions, one that drops leading zeros (jhead) and one that doesn't
- -- (jblock)
- jhead :: Int -> String -> String
- jhead n cs
- | n < 10 = case unsafeChr (ord '0' + n) of
- c@(C# _) -> c : cs
- | otherwise = case unsafeChr (ord '0' + r) of
- c@(C# _) -> jhead q (c : cs)
- where
- (q, r) = n `quotRemInt` 10
-
- jblock = jblock' {- ' -} DIGITS
-
- jblock' :: Int -> Int -> String -> String
- jblock' d n cs
- | d == 1 = case unsafeChr (ord '0' + n) of
- c@(C# _) -> c : cs
- | otherwise = case unsafeChr (ord '0' + r) of
- c@(C# _) -> jblock' (d - 1) q (c : cs)
- where
- (q, r) = n `quotRemInt` 10
-
-\end{code}
+++ /dev/null
-{-# OPTIONS_GHC -fparr -funbox-strict-fields #-}
-
------------------------------------------------------------------------------
--- |
--- Module : GHC.PArr
--- Copyright : (c) 2001-2002 Manuel M T Chakravarty & Gabriele Keller
--- License : see libraries/base/LICENSE
---
--- Maintainer : Manuel M. T. Chakravarty <chak@cse.unsw.edu.au>
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- Basic implementation of Parallel Arrays.
---
--- This module has two functions: (1) It defines the interface to the
--- parallel array extension of the Prelude and (2) it provides a vanilla
--- implementation of parallel arrays that does not require to flatten the
--- array code. The implementation is not very optimised.
---
---- DOCU ----------------------------------------------------------------------
---
--- Language: Haskell 98 plus unboxed values and parallel arrays
---
--- The semantic difference between standard Haskell arrays (aka "lazy
--- arrays") and parallel arrays (aka "strict arrays") is that the evaluation
--- of two different elements of a lazy array is independent, whereas in a
--- strict array either non or all elements are evaluated. In other words,
--- when a parallel array is evaluated to WHNF, all its elements will be
--- evaluated to WHNF. The name parallel array indicates that all array
--- elements may, in general, be evaluated to WHNF in parallel without any
--- need to resort to speculative evaluation. This parallel evaluation
--- semantics is also beneficial in the sequential case, as it facilitates
--- loop-based array processing as known from classic array-based languages,
--- such as Fortran.
---
--- The interface of this module is essentially a variant of the list
--- component of the Prelude, but also includes some functions (such as
--- permutations) that are not provided for lists. The following list
--- operations are not supported on parallel arrays, as they would require the
--- availability of infinite parallel arrays: `iterate', `repeat', and `cycle'.
---
--- The current implementation is quite simple and entirely based on boxed
--- arrays. One disadvantage of boxed arrays is that they require to
--- immediately initialise all newly allocated arrays with an error thunk to
--- keep the garbage collector happy, even if it is guaranteed that the array
--- is fully initialised with different values before passing over the
--- user-visible interface boundary. Currently, no effort is made to use
--- raw memory copy operations to speed things up.
---
---- TODO ----------------------------------------------------------------------
---
--- * We probably want a standard library `PArray' in addition to the prelude
--- extension in the same way as the standard library `List' complements the
--- list functions from the prelude.
---
--- * Currently, functions that emphasis the constructor-based definition of
--- lists (such as, head, last, tail, and init) are not supported.
---
--- Is it worthwhile to support the string processing functions lines,
--- words, unlines, and unwords? (Currently, they are not implemented.)
---
--- It can, however, be argued that it would be worthwhile to include them
--- for completeness' sake; maybe only in the standard library `PArray'.
---
--- * Prescans are often more useful for array programming than scans. Shall
--- we include them into the Prelude or the library?
---
--- * Due to the use of the iterator `loop', we could define some fusion rules
--- in this module.
---
--- * We might want to add bounds checks that can be deactivated.
---
-
-module GHC.PArr (
- -- [::], -- Built-in syntax
-
- mapP, -- :: (a -> b) -> [:a:] -> [:b:]
- (+:+), -- :: [:a:] -> [:a:] -> [:a:]
- filterP, -- :: (a -> Bool) -> [:a:] -> [:a:]
- concatP, -- :: [:[:a:]:] -> [:a:]
- concatMapP, -- :: (a -> [:b:]) -> [:a:] -> [:b:]
--- head, last, tail, init, -- it's not wise to use them on arrays
- nullP, -- :: [:a:] -> Bool
- lengthP, -- :: [:a:] -> Int
- (!:), -- :: [:a:] -> Int -> a
- foldlP, -- :: (a -> b -> a) -> a -> [:b:] -> a
- foldl1P, -- :: (a -> a -> a) -> [:a:] -> a
- scanlP, -- :: (a -> b -> a) -> a -> [:b:] -> [:a:]
- scanl1P, -- :: (a -> a -> a) -> [:a:] -> [:a:]
- foldrP, -- :: (a -> b -> b) -> b -> [:a:] -> b
- foldr1P, -- :: (a -> a -> a) -> [:a:] -> a
- scanrP, -- :: (a -> b -> b) -> b -> [:a:] -> [:b:]
- scanr1P, -- :: (a -> a -> a) -> [:a:] -> [:a:]
--- iterate, repeat, -- parallel arrays must be finite
- replicateP, -- :: Int -> a -> [:a:]
--- cycle, -- parallel arrays must be finite
- takeP, -- :: Int -> [:a:] -> [:a:]
- dropP, -- :: Int -> [:a:] -> [:a:]
- splitAtP, -- :: Int -> [:a:] -> ([:a:],[:a:])
- takeWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:]
- dropWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:]
- spanP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
- breakP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
--- lines, words, unlines, unwords, -- is string processing really needed
- reverseP, -- :: [:a:] -> [:a:]
- andP, -- :: [:Bool:] -> Bool
- orP, -- :: [:Bool:] -> Bool
- anyP, -- :: (a -> Bool) -> [:a:] -> Bool
- allP, -- :: (a -> Bool) -> [:a:] -> Bool
- elemP, -- :: (Eq a) => a -> [:a:] -> Bool
- notElemP, -- :: (Eq a) => a -> [:a:] -> Bool
- lookupP, -- :: (Eq a) => a -> [:(a, b):] -> Maybe b
- sumP, -- :: (Num a) => [:a:] -> a
- productP, -- :: (Num a) => [:a:] -> a
- maximumP, -- :: (Ord a) => [:a:] -> a
- minimumP, -- :: (Ord a) => [:a:] -> a
- zipP, -- :: [:a:] -> [:b:] -> [:(a, b) :]
- zip3P, -- :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):]
- zipWithP, -- :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:]
- zipWith3P, -- :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:]
- unzipP, -- :: [:(a, b) :] -> ([:a:], [:b:])
- unzip3P, -- :: [:(a, b, c):] -> ([:a:], [:b:], [:c:])
-
- -- overloaded functions
- --
- enumFromToP, -- :: Enum a => a -> a -> [:a:]
- enumFromThenToP, -- :: Enum a => a -> a -> a -> [:a:]
-
- -- the following functions are not available on lists
- --
- toP, -- :: [a] -> [:a:]
- fromP, -- :: [:a:] -> [a]
- sliceP, -- :: Int -> Int -> [:e:] -> [:e:]
- foldP, -- :: (e -> e -> e) -> e -> [:e:] -> e
- fold1P, -- :: (e -> e -> e) -> [:e:] -> e
- permuteP, -- :: [:Int:] -> [:e:] -> [:e:]
- bpermuteP, -- :: [:Int:] -> [:e:] -> [:e:]
- dpermuteP, -- :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
- crossP, -- :: [:a:] -> [:b:] -> [:(a, b):]
- crossMapP, -- :: [:a:] -> (a -> [:b:]) -> [:(a, b):]
- indexOfP -- :: (a -> Bool) -> [:a:] -> [:Int:]
-) where
-
-#ifndef __HADDOCK__
-
-import Prelude
-
-import GHC.ST ( ST(..), STRep, runST )
-import GHC.Exts ( Int#, Array#, Int(I#), MutableArray#, newArray#,
- unsafeFreezeArray#, indexArray#, writeArray#, (<#), (>=#) )
-
-infixl 9 !:
-infixr 5 +:+
-infix 4 `elemP`, `notElemP`
-
-
--- representation of parallel arrays
--- ---------------------------------
-
--- this rather straight forward implementation maps parallel arrays to the
--- internal representation used for standard Haskell arrays in GHC's Prelude
--- (EXPORTED ABSTRACTLY)
---
--- * This definition *must* be kept in sync with `TysWiredIn.parrTyCon'!
---
-data [::] e = PArr Int# (Array# e)
-
-
--- exported operations on parallel arrays
--- --------------------------------------
-
--- operations corresponding to list operations
---
-
-mapP :: (a -> b) -> [:a:] -> [:b:]
-mapP f = fst . loop (mapEFL f) noAL
-
-(+:+) :: [:a:] -> [:a:] -> [:a:]
-a1 +:+ a2 = fst $ loop (mapEFL sel) noAL (enumFromToP 0 (len1 + len2 - 1))
- -- we can't use the [:x..y:] form here for tedious
- -- reasons to do with the typechecker and the fact that
- -- `enumFromToP' is defined in the same module
- where
- len1 = lengthP a1
- len2 = lengthP a2
- --
- sel i | i < len1 = a1!:i
- | otherwise = a2!:(i - len1)
-
-filterP :: (a -> Bool) -> [:a:] -> [:a:]
-filterP p = fst . loop (filterEFL p) noAL
-
-concatP :: [:[:a:]:] -> [:a:]
-concatP xss = foldlP (+:+) [::] xss
-
-concatMapP :: (a -> [:b:]) -> [:a:] -> [:b:]
-concatMapP f = concatP . mapP f
-
--- head, last, tail, init, -- it's not wise to use them on arrays
-
-nullP :: [:a:] -> Bool
-nullP [::] = True
-nullP _ = False
-
-lengthP :: [:a:] -> Int
-lengthP (PArr n# _) = I# n#
-
-(!:) :: [:a:] -> Int -> a
-(!:) = indexPArr
-
-foldlP :: (a -> b -> a) -> a -> [:b:] -> a
-foldlP f z = snd . loop (foldEFL (flip f)) z
-
-foldl1P :: (a -> a -> a) -> [:a:] -> a
-foldl1P f [::] = error "Prelude.foldl1P: empty array"
-foldl1P f a = snd $ loopFromTo 1 (lengthP a - 1) (foldEFL f) (a!:0) a
-
-scanlP :: (a -> b -> a) -> a -> [:b:] -> [:a:]
-scanlP f z = fst . loop (scanEFL (flip f)) z
-
-scanl1P :: (a -> a -> a) -> [:a:] -> [:a:]
-scanl1P f [::] = error "Prelude.scanl1P: empty array"
-scanl1P f a = fst $ loopFromTo 1 (lengthP a - 1) (scanEFL f) (a!:0) a
-
-foldrP :: (a -> b -> b) -> b -> [:a:] -> b
-foldrP = error "Prelude.foldrP: not implemented yet" -- FIXME
-
-foldr1P :: (a -> a -> a) -> [:a:] -> a
-foldr1P = error "Prelude.foldr1P: not implemented yet" -- FIXME
-
-scanrP :: (a -> b -> b) -> b -> [:a:] -> [:b:]
-scanrP = error "Prelude.scanrP: not implemented yet" -- FIXME
-
-scanr1P :: (a -> a -> a) -> [:a:] -> [:a:]
-scanr1P = error "Prelude.scanr1P: not implemented yet" -- FIXME
-
--- iterate, repeat -- parallel arrays must be finite
-
-replicateP :: Int -> a -> [:a:]
-{-# INLINE replicateP #-}
-replicateP n e = runST (do
- marr# <- newArray n e
- mkPArr n marr#)
-
--- cycle -- parallel arrays must be finite
-
-takeP :: Int -> [:a:] -> [:a:]
-takeP n = sliceP 0 (n - 1)
-
-dropP :: Int -> [:a:] -> [:a:]
-dropP n a = sliceP n (lengthP a - 1) a
-
-splitAtP :: Int -> [:a:] -> ([:a:],[:a:])
-splitAtP n xs = (takeP n xs, dropP n xs)
-
-takeWhileP :: (a -> Bool) -> [:a:] -> [:a:]
-takeWhileP = error "Prelude.takeWhileP: not implemented yet" -- FIXME
-
-dropWhileP :: (a -> Bool) -> [:a:] -> [:a:]
-dropWhileP = error "Prelude.dropWhileP: not implemented yet" -- FIXME
-
-spanP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
-spanP = error "Prelude.spanP: not implemented yet" -- FIXME
-
-breakP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
-breakP p = spanP (not . p)
-
--- lines, words, unlines, unwords, -- is string processing really needed
-
-reverseP :: [:a:] -> [:a:]
-reverseP a = permuteP (enumFromThenToP (len - 1) (len - 2) 0) a
- -- we can't use the [:x, y..z:] form here for tedious
- -- reasons to do with the typechecker and the fact that
- -- `enumFromThenToP' is defined in the same module
- where
- len = lengthP a
-
-andP :: [:Bool:] -> Bool
-andP = foldP (&&) True
-
-orP :: [:Bool:] -> Bool
-orP = foldP (||) True
-
-anyP :: (a -> Bool) -> [:a:] -> Bool
-anyP p = orP . mapP p
-
-allP :: (a -> Bool) -> [:a:] -> Bool
-allP p = andP . mapP p
-
-elemP :: (Eq a) => a -> [:a:] -> Bool
-elemP x = anyP (== x)
-
-notElemP :: (Eq a) => a -> [:a:] -> Bool
-notElemP x = allP (/= x)
-
-lookupP :: (Eq a) => a -> [:(a, b):] -> Maybe b
-lookupP = error "Prelude.lookupP: not implemented yet" -- FIXME
-
-sumP :: (Num a) => [:a:] -> a
-sumP = foldP (+) 0
-
-productP :: (Num a) => [:a:] -> a
-productP = foldP (*) 1
-
-maximumP :: (Ord a) => [:a:] -> a
-maximumP [::] = error "Prelude.maximumP: empty parallel array"
-maximumP xs = fold1P max xs
-
-minimumP :: (Ord a) => [:a:] -> a
-minimumP [::] = error "Prelude.minimumP: empty parallel array"
-minimumP xs = fold1P min xs
-
-zipP :: [:a:] -> [:b:] -> [:(a, b):]
-zipP = zipWithP (,)
-
-zip3P :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):]
-zip3P = zipWith3P (,,)
-
-zipWithP :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:]
-zipWithP f a1 a2 = let
- len1 = lengthP a1
- len2 = lengthP a2
- len = len1 `min` len2
- in
- fst $ loopFromTo 0 (len - 1) combine 0 a1
- where
- combine e1 i = (Just $ f e1 (a2!:i), i + 1)
-
-zipWith3P :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:]
-zipWith3P f a1 a2 a3 = let
- len1 = lengthP a1
- len2 = lengthP a2
- len3 = lengthP a3
- len = len1 `min` len2 `min` len3
- in
- fst $ loopFromTo 0 (len - 1) combine 0 a1
- where
- combine e1 i = (Just $ f e1 (a2!:i) (a3!:i), i + 1)
-
-unzipP :: [:(a, b):] -> ([:a:], [:b:])
-unzipP a = (fst $ loop (mapEFL fst) noAL a, fst $ loop (mapEFL snd) noAL a)
--- FIXME: these two functions should be optimised using a tupled custom loop
-unzip3P :: [:(a, b, c):] -> ([:a:], [:b:], [:c:])
-unzip3P a = (fst $ loop (mapEFL fst3) noAL a,
- fst $ loop (mapEFL snd3) noAL a,
- fst $ loop (mapEFL trd3) noAL a)
- where
- fst3 (a, _, _) = a
- snd3 (_, b, _) = b
- trd3 (_, _, c) = c
-
--- instances
---
-
-instance Eq a => Eq [:a:] where
- a1 == a2 | lengthP a1 == lengthP a2 = andP (zipWithP (==) a1 a2)
- | otherwise = False
-
-instance Ord a => Ord [:a:] where
- compare a1 a2 = case foldlP combineOrdering EQ (zipWithP compare a1 a2) of
- EQ | lengthP a1 == lengthP a2 -> EQ
- | lengthP a1 < lengthP a2 -> LT
- | otherwise -> GT
- where
- combineOrdering EQ EQ = EQ
- combineOrdering EQ other = other
- combineOrdering other _ = other
-
-instance Functor [::] where
- fmap = mapP
-
-instance Monad [::] where
- m >>= k = foldrP ((+:+) . k ) [::] m
- m >> k = foldrP ((+:+) . const k) [::] m
- return x = [:x:]
- fail _ = [::]
-
-instance Show a => Show [:a:] where
- showsPrec _ = showPArr . fromP
- where
- showPArr [] s = "[::]" ++ s
- showPArr (x:xs) s = "[:" ++ shows x (showPArr' xs s)
-
- showPArr' [] s = ":]" ++ s
- showPArr' (y:ys) s = ',' : shows y (showPArr' ys s)
-
-instance Read a => Read [:a:] where
- readsPrec _ a = [(toP v, rest) | (v, rest) <- readPArr a]
- where
- readPArr = readParen False (\r -> do
- ("[:",s) <- lex r
- readPArr1 s)
- readPArr1 s =
- (do { (":]", t) <- lex s; return ([], t) }) ++
- (do { (x, t) <- reads s; (xs, u) <- readPArr2 t; return (x:xs, u) })
-
- readPArr2 s =
- (do { (":]", t) <- lex s; return ([], t) }) ++
- (do { (",", t) <- lex s; (x, u) <- reads t; (xs, v) <- readPArr2 u;
- return (x:xs, v) })
-
--- overloaded functions
---
-
--- Ideally, we would like `enumFromToP' and `enumFromThenToP' to be members of
--- `Enum'. On the other hand, we really do not want to change `Enum'. Thus,
--- for the moment, we hope that the compiler is sufficiently clever to
--- properly fuse the following definitions.
-
-enumFromToP :: Enum a => a -> a -> [:a:]
-enumFromToP x y = mapP toEnum (eftInt (fromEnum x) (fromEnum y))
- where
- eftInt x y = scanlP (+) x $ replicateP (y - x + 1) 1
-
-enumFromThenToP :: Enum a => a -> a -> a -> [:a:]
-enumFromThenToP x y z =
- mapP toEnum (efttInt (fromEnum x) (fromEnum y) (fromEnum z))
- where
- efttInt x y z = scanlP (+) x $
- replicateP (abs (z - x) `div` abs delta + 1) delta
- where
- delta = y - x
-
--- the following functions are not available on lists
---
-
--- create an array from a list (EXPORTED)
---
-toP :: [a] -> [:a:]
-toP l = fst $ loop store l (replicateP (length l) ())
- where
- store _ (x:xs) = (Just x, xs)
-
--- convert an array to a list (EXPORTED)
---
-fromP :: [:a:] -> [a]
-fromP a = [a!:i | i <- [0..lengthP a - 1]]
-
--- cut a subarray out of an array (EXPORTED)
---
-sliceP :: Int -> Int -> [:e:] -> [:e:]
-sliceP from to a =
- fst $ loopFromTo (0 `max` from) (to `min` (lengthP a - 1)) (mapEFL id) noAL a
-
--- parallel folding (EXPORTED)
---
--- * the first argument must be associative; otherwise, the result is undefined
---
-foldP :: (e -> e -> e) -> e -> [:e:] -> e
-foldP = foldlP
-
--- parallel folding without explicit neutral (EXPORTED)
---
--- * the first argument must be associative; otherwise, the result is undefined
---
-fold1P :: (e -> e -> e) -> [:e:] -> e
-fold1P = foldl1P
-
--- permute an array according to the permutation vector in the first argument
--- (EXPORTED)
---
-permuteP :: [:Int:] -> [:e:] -> [:e:]
-permuteP is es
- | isLen /= esLen = error "GHC.PArr: arguments must be of the same length"
- | otherwise = runST (do
- marr <- newArray isLen noElem
- permute marr is es
- mkPArr isLen marr)
- where
- noElem = error "GHC.PArr.permuteP: I do not exist!"
- -- unlike standard Haskell arrays, this value represents an
- -- internal error
- isLen = lengthP is
- esLen = lengthP es
-
--- permute an array according to the back-permutation vector in the first
--- argument (EXPORTED)
---
--- * the permutation vector must represent a surjective function; otherwise,
--- the result is undefined
---
-bpermuteP :: [:Int:] -> [:e:] -> [:e:]
-bpermuteP is es = fst $ loop (mapEFL (es!:)) noAL is
-
--- permute an array according to the permutation vector in the first
--- argument, which need not be surjective (EXPORTED)
---
--- * any elements in the result that are not covered by the permutation
--- vector assume the value of the corresponding position of the third
--- argument
---
-dpermuteP :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
-dpermuteP is es dft
- | isLen /= esLen = error "GHC.PArr: arguments must be of the same length"
- | otherwise = runST (do
- marr <- newArray dftLen noElem
- trans 0 (isLen - 1) marr dft copyOne noAL
- permute marr is es
- mkPArr dftLen marr)
- where
- noElem = error "GHC.PArr.permuteP: I do not exist!"
- -- unlike standard Haskell arrays, this value represents an
- -- internal error
- isLen = lengthP is
- esLen = lengthP es
- dftLen = lengthP dft
-
- copyOne e _ = (Just e, noAL)
-
--- computes the cross combination of two arrays (EXPORTED)
---
-crossP :: [:a:] -> [:b:] -> [:(a, b):]
-crossP a1 a2 = fst $ loop combine (0, 0) $ replicateP len ()
- where
- len1 = lengthP a1
- len2 = lengthP a2
- len = len1 * len2
- --
- combine _ (i, j) = (Just $ (a1!:i, a2!:j), next)
- where
- next | (i + 1) == len1 = (0 , j + 1)
- | otherwise = (i + 1, j)
-
-{- An alternative implementation
- * The one above is certainly better for flattened code, but here where we
- are handling boxed arrays, the trade off is less clear. However, I
- think, the above one is still better.
-
-crossP a1 a2 = let
- len1 = lengthP a1
- len2 = lengthP a2
- x1 = concatP $ mapP (replicateP len2) a1
- x2 = concatP $ replicateP len1 a2
- in
- zipP x1 x2
- -}
-
--- |Compute a cross of an array and the arrays produced by the given function
--- for the elements of the first array.
---
-crossMapP :: [:a:] -> (a -> [:b:]) -> [:(a, b):]
-crossMapP a f = let
- bs = mapP f a
- segd = mapP lengthP bs
- as = zipWithP replicateP segd a
- in
- zipP (concatP as) (concatP bs)
-
-{- The following may seem more straight forward, but the above is very cheap
- with segmented arrays, as `mapP lengthP', `zipP', and `concatP' are
- constant time, and `map f' uses the lifted version of `f'.
-
-crossMapP a f = concatP $ mapP (\x -> mapP ((,) x) (f x)) a
-
- -}
-
--- computes an index array for all elements of the second argument for which
--- the predicate yields `True' (EXPORTED)
---
-indexOfP :: (a -> Bool) -> [:a:] -> [:Int:]
-indexOfP p a = fst $ loop calcIdx 0 a
- where
- calcIdx e idx | p e = (Just idx, idx + 1)
- | otherwise = (Nothing , idx )
-
-
--- auxiliary functions
--- -------------------
-
--- internally used mutable boxed arrays
---
-data MPArr s e = MPArr Int# (MutableArray# s e)
-
--- allocate a new mutable array that is pre-initialised with a given value
---
-newArray :: Int -> e -> ST s (MPArr s e)
-{-# INLINE newArray #-}
-newArray (I# n#) e = ST $ \s1# ->
- case newArray# n# e s1# of { (# s2#, marr# #) ->
- (# s2#, MPArr n# marr# #)}
-
--- convert a mutable array into the external parallel array representation
---
-mkPArr :: Int -> MPArr s e -> ST s [:e:]
-{-# INLINE mkPArr #-}
-mkPArr (I# n#) (MPArr _ marr#) = ST $ \s1# ->
- case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) ->
- (# s2#, PArr n# arr# #) }
-
--- general array iterator
---
--- * corresponds to `loopA' from ``Functional Array Fusion'', Chakravarty &
--- Keller, ICFP 2001
---
-loop :: (e -> acc -> (Maybe e', acc)) -- mapping & folding, once per element
- -> acc -- initial acc value
- -> [:e:] -- input array
- -> ([:e':], acc)
-{-# INLINE loop #-}
-loop mf acc arr = loopFromTo 0 (lengthP arr - 1) mf acc arr
-
--- general array iterator with bounds
---
-loopFromTo :: Int -- from index
- -> Int -- to index
- -> (e -> acc -> (Maybe e', acc))
- -> acc
- -> [:e:]
- -> ([:e':], acc)
-{-# INLINE loopFromTo #-}
-loopFromTo from to mf start arr = runST (do
- marr <- newArray (to - from + 1) noElem
- (n', acc) <- trans from to marr arr mf start
- arr <- mkPArr n' marr
- return (arr, acc))
- where
- noElem = error "GHC.PArr.loopFromTo: I do not exist!"
- -- unlike standard Haskell arrays, this value represents an
- -- internal error
-
--- actual loop body of `loop'
---
--- * for this to be really efficient, it has to be translated with the
--- constructor specialisation phase "SpecConstr" switched on; as of GHC 5.03
--- this requires an optimisation level of at least -O2
---
-trans :: Int -- index of first elem to process
- -> Int -- index of last elem to process
- -> MPArr s e' -- destination array
- -> [:e:] -- source array
- -> (e -> acc -> (Maybe e', acc)) -- mutator
- -> acc -- initial accumulator
- -> ST s (Int, acc) -- final destination length/final acc
-{-# INLINE trans #-}
-trans from to marr arr mf start = trans' from 0 start
- where
- trans' arrOff marrOff acc
- | arrOff > to = return (marrOff, acc)
- | otherwise = do
- let (oe', acc') = mf (arr `indexPArr` arrOff) acc
- marrOff' <- case oe' of
- Nothing -> return marrOff
- Just e' -> do
- writeMPArr marr marrOff e'
- return $ marrOff + 1
- trans' (arrOff + 1) marrOff' acc'
-
--- Permute the given elements into the mutable array.
---
-permute :: MPArr s e -> [:Int:] -> [:e:] -> ST s ()
-permute marr is es = perm 0
- where
- perm i
- | i == n = return ()
- | otherwise = writeMPArr marr (is!:i) (es!:i) >> perm (i + 1)
- where
- n = lengthP is
-
-
--- common patterns for using `loop'
---
-
--- initial value for the accumulator when the accumulator is not needed
---
-noAL :: ()
-noAL = ()
-
--- `loop' mutator maps a function over array elements
---
-mapEFL :: (e -> e') -> (e -> () -> (Maybe e', ()))
-{-# INLINE mapEFL #-}
-mapEFL f = \e a -> (Just $ f e, ())
-
--- `loop' mutator that filter elements according to a predicate
---
-filterEFL :: (e -> Bool) -> (e -> () -> (Maybe e, ()))
-{-# INLINE filterEFL #-}
-filterEFL p = \e a -> if p e then (Just e, ()) else (Nothing, ())
-
--- `loop' mutator for array folding
---
-foldEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe (), acc))
-{-# INLINE foldEFL #-}
-foldEFL f = \e a -> (Nothing, f e a)
-
--- `loop' mutator for array scanning
---
-scanEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe acc, acc))
-{-# INLINE scanEFL #-}
-scanEFL f = \e a -> (Just a, f e a)
-
--- elementary array operations
---
-
--- unlifted array indexing
---
-indexPArr :: [:e:] -> Int -> e
-{-# INLINE indexPArr #-}
-indexPArr (PArr n# arr#) (I# i#)
- | i# >=# 0# && i# <# n# =
- case indexArray# arr# i# of (# e #) -> e
- | otherwise = error $ "indexPArr: out of bounds parallel array index; " ++
- "idx = " ++ show (I# i#) ++ ", arr len = "
- ++ show (I# n#)
-
--- encapsulate writing into a mutable array into the `ST' monad
---
-writeMPArr :: MPArr s e -> Int -> e -> ST s ()
-{-# INLINE writeMPArr #-}
-writeMPArr (MPArr n# marr#) (I# i#) e
- | i# >=# 0# && i# <# n# =
- ST $ \s# ->
- case writeArray# marr# i# e s# of s'# -> (# s'#, () #)
- | otherwise = error $ "writeMPArr: out of bounds parallel array index; " ++
- "idx = " ++ show (I# i#) ++ ", arr len = "
- ++ show (I# n#)
-
-#endif /* __HADDOCK__ */
-
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Pack
--- Copyright : (c) The University of Glasgow 1997-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- This module provides a small set of low-level functions for packing
--- and unpacking a chunk of bytes. Used by code emitted by the compiler
--- plus the prelude libraries.
---
--- The programmer level view of packed strings is provided by a GHC
--- system library PackedString.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Pack
- (
- -- (**) - emitted by compiler.
-
- packCString#, -- :: [Char] -> ByteArray# (**)
- unpackCString,
- unpackCString#, -- :: Addr# -> [Char] (**)
- unpackNBytes#, -- :: Addr# -> Int# -> [Char] (**)
- unpackFoldrCString#, -- (**)
- unpackAppendCString#, -- (**)
- )
- where
-
-import GHC.Base
-import GHC.Err ( error )
-import GHC.List ( length )
-import GHC.ST
-import GHC.Num
-import GHC.Ptr
-
-data ByteArray ix = ByteArray ix ix ByteArray#
-data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
-
-unpackCString :: Ptr a -> [Char]
-unpackCString a@(Ptr addr)
- | a == nullPtr = []
- | otherwise = unpackCString# addr
-
-packCString# :: [Char] -> ByteArray#
-packCString# str = case (packString str) of { ByteArray _ _ bytes -> bytes }
-
-packString :: [Char] -> ByteArray Int
-packString str = runST (packStringST str)
-
-packStringST :: [Char] -> ST s (ByteArray Int)
-packStringST str =
- let len = length str in
- packNBytesST len str
-
-packNBytesST :: Int -> [Char] -> ST s (ByteArray Int)
-packNBytesST (I# length#) str =
- {-
- allocate an array that will hold the string
- (not forgetting the NUL byte at the end)
- -}
- new_ps_array (length# +# 1#) >>= \ ch_array ->
- -- fill in packed string from "str"
- fill_in ch_array 0# str >>
- -- freeze the puppy:
- freeze_ps_array ch_array length#
- where
- fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
- fill_in arr_in# idx [] =
- write_ps_array arr_in# idx (chr# 0#) >>
- return ()
-
- fill_in arr_in# idx (C# c : cs) =
- write_ps_array arr_in# idx c >>
- fill_in arr_in# (idx +# 1#) cs
-
--- (Very :-) ``Specialised'' versions of some CharArray things...
-
-new_ps_array :: Int# -> ST s (MutableByteArray s Int)
-write_ps_array :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
-freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
-
-new_ps_array size = ST $ \ s ->
- case (newByteArray# size s) of { (# s2#, barr# #) ->
- (# s2#, MutableByteArray bot bot barr# #) }
- where
- bot = error "new_ps_array"
-
-write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
- case writeCharArray# barr# n ch s# of { s2# ->
- (# s2#, () #) }
-
--- same as unsafeFreezeByteArray
-freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
- case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
- (# s2#, ByteArray 0 (I# len#) frozen# #) }
-\end{code}
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Ptr
--- Copyright : (c) The FFI Task Force, 2000-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : ffi@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- The 'Ptr' and 'FunPtr' types and operations.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Ptr where
-
-import GHC.Base
-import GHC.Show
-import GHC.Num
-import GHC.List ( length, replicate )
-import Numeric ( showHex )
-
-#include "MachDeps.h"
-
-------------------------------------------------------------------------
--- Data pointers.
-
-data Ptr a = Ptr Addr# deriving (Eq, Ord)
--- ^ A value of type @'Ptr' a@ represents a pointer to an object, or an
--- array of objects, which may be marshalled to or from Haskell values
--- of type @a@.
---
--- The type @a@ will often be an instance of class
--- 'Foreign.Storable.Storable' which provides the marshalling operations.
--- However this is not essential, and you can provide your own operations
--- to access the pointer. For example you might write small foreign
--- functions to get or set the fields of a C @struct@.
-
--- |The constant 'nullPtr' contains a distinguished value of 'Ptr'
--- that is not associated with a valid memory location.
-nullPtr :: Ptr a
-nullPtr = Ptr nullAddr#
-
--- |The 'castPtr' function casts a pointer from one type to another.
-castPtr :: Ptr a -> Ptr b
-castPtr (Ptr addr) = Ptr addr
-
--- |Advances the given address by the given offset in bytes.
-plusPtr :: Ptr a -> Int -> Ptr b
-plusPtr (Ptr addr) (I# d) = Ptr (plusAddr# addr d)
-
--- |Given an arbitrary address and an alignment constraint,
--- 'alignPtr' yields the next higher address that fulfills the
--- alignment constraint. An alignment constraint @x@ is fulfilled by
--- any address divisible by @x@. This operation is idempotent.
-alignPtr :: Ptr a -> Int -> Ptr a
-alignPtr addr@(Ptr a) (I# i)
- = case remAddr# a i of {
- 0# -> addr;
- n -> Ptr (plusAddr# a (i -# n)) }
-
--- |Computes the offset required to get from the first to the second
--- argument. We have
---
--- > p2 == p1 `plusPtr` (p2 `minusPtr` p1)
-minusPtr :: Ptr a -> Ptr b -> Int
-minusPtr (Ptr a1) (Ptr a2) = I# (minusAddr# a1 a2)
-
-------------------------------------------------------------------------
--- Function pointers for the default calling convention.
-
-data FunPtr a = FunPtr Addr# deriving (Eq, Ord)
--- ^ A value of type @'FunPtr' a@ is a pointer to a function callable
--- from foreign code. The type @a@ will normally be a /foreign type/,
--- a function type with zero or more arguments where
---
--- * the argument types are /marshallable foreign types/,
--- i.e. 'Char', 'Int', 'Prelude.Double', 'Prelude.Float',
--- 'Bool', 'Data.Int.Int8', 'Data.Int.Int16', 'Data.Int.Int32',
--- 'Data.Int.Int64', 'Data.Word.Word8', 'Data.Word.Word16',
--- 'Data.Word.Word32', 'Data.Word.Word64', @'Ptr' a@, @'FunPtr' a@,
--- @'Foreign.StablePtr.StablePtr' a@ or a renaming of any of these
--- using @newtype@.
---
--- * the return type is either a marshallable foreign type or has the form
--- @'Prelude.IO' t@ where @t@ is a marshallable foreign type or @()@.
---
--- A value of type @'FunPtr' a@ may be a pointer to a foreign function,
--- either returned by another foreign function or imported with a
--- a static address import like
---
--- > foreign import ccall "stdlib.h &free"
--- > p_free :: FunPtr (Ptr a -> IO ())
---
--- or a pointer to a Haskell function created using a /wrapper/ stub
--- declared to produce a 'FunPtr' of the correct type. For example:
---
--- > type Compare = Int -> Int -> Bool
--- > foreign import ccall "wrapper"
--- > mkCompare :: Compare -> IO (FunPtr Compare)
---
--- Calls to wrapper stubs like @mkCompare@ allocate storage, which
--- should be released with 'Foreign.Ptr.freeHaskellFunPtr' when no
--- longer required.
---
--- To convert 'FunPtr' values to corresponding Haskell functions, one
--- can define a /dynamic/ stub for the specific foreign type, e.g.
---
--- > type IntFunction = CInt -> IO ()
--- > foreign import ccall "dynamic"
--- > mkFun :: FunPtr IntFunction -> IntFunction
-
--- |The constant 'nullFunPtr' contains a
--- distinguished value of 'FunPtr' that is not
--- associated with a valid memory location.
-nullFunPtr :: FunPtr a
-nullFunPtr = FunPtr nullAddr#
-
--- |Casts a 'FunPtr' to a 'FunPtr' of a different type.
-castFunPtr :: FunPtr a -> FunPtr b
-castFunPtr (FunPtr addr) = FunPtr addr
-
--- |Casts a 'FunPtr' to a 'Ptr'.
---
--- /Note:/ this is valid only on architectures where data and function
--- pointers range over the same set of addresses, and should only be used
--- for bindings to external libraries whose interface already relies on
--- this assumption.
-castFunPtrToPtr :: FunPtr a -> Ptr b
-castFunPtrToPtr (FunPtr addr) = Ptr addr
-
--- |Casts a 'Ptr' to a 'FunPtr'.
---
--- /Note:/ this is valid only on architectures where data and function
--- pointers range over the same set of addresses, and should only be used
--- for bindings to external libraries whose interface already relies on
--- this assumption.
-castPtrToFunPtr :: Ptr a -> FunPtr b
-castPtrToFunPtr (Ptr addr) = FunPtr addr
-
-
-------------------------------------------------------------------------
--- Show instances for Ptr and FunPtr
--- I have absolutely no idea why the WORD_SIZE_IN_BITS stuff is here
-
-#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64)
-instance Show (Ptr a) where
- showsPrec p (Ptr a) rs = pad_out (showHex (word2Integer(int2Word#(addr2Int# a))) "") rs
- where
- -- want 0s prefixed to pad it out to a fixed length.
- pad_out ls rs =
- '0':'x':(replicate (2*SIZEOF_HSPTR - length ls) '0') ++ ls ++ rs
- -- word2Integer :: Word# -> Integer (stolen from Word.lhs)
- word2Integer w = case word2Integer# w of
- (# s, d #) -> J# s d
-
-instance Show (FunPtr a) where
- showsPrec p = showsPrec p . castFunPtrToPtr
-#endif
-\end{code}
-
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Read
--- Copyright : (c) The University of Glasgow, 1994-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- The 'Read' class and instances for basic data types.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Read
- ( Read(..) -- class
-
- -- ReadS type
- , ReadS -- :: *; = String -> [(a,String)]
-
- -- utility functions
- , reads -- :: Read a => ReadS a
- , readp -- :: Read a => ReadP a
- , readEither -- :: Read a => String -> Either String a
- , read -- :: Read a => String -> a
-
- -- H98 compatibility
- , lex -- :: ReadS String
- , lexLitChar -- :: ReadS String
- , readLitChar -- :: ReadS Char
- , lexDigits -- :: ReadS String
-
- -- defining readers
- , lexP -- :: ReadPrec Lexeme
- , paren -- :: ReadPrec a -> ReadPrec a
- , parens -- :: ReadPrec a -> ReadPrec a
- , list -- :: ReadPrec a -> ReadPrec [a]
- , choose -- :: [(String, ReadPrec a)] -> ReadPrec a
- , readListDefault, readListPrecDefault
-
- -- Temporary
- , readParen
- )
- where
-
-import qualified Text.ParserCombinators.ReadP as P
-
-import Text.ParserCombinators.ReadP
- ( ReadP
- , ReadS
- , readP_to_S
- )
-
-import qualified Text.Read.Lex as L
--- Lex exports 'lex', which is also defined here,
--- hence the qualified import.
--- We can't import *anything* unqualified, because that
--- confuses Haddock.
-
-import Text.ParserCombinators.ReadPrec
-
-import Data.Maybe
-import Data.Either
-
-import {-# SOURCE #-} GHC.Err ( error )
-#ifndef __HADDOCK__
-import {-# SOURCE #-} GHC.Unicode ( isDigit )
-#endif
-import GHC.Num
-import GHC.Real
-import GHC.Float
-import GHC.Show
-import GHC.Base
-import GHC.Arr
-\end{code}
-
-
-\begin{code}
--- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with
--- parentheses.
---
--- @'readParen' 'False' p@ parses what @p@ parses, but optionally
--- surrounded with parentheses.
-readParen :: Bool -> ReadS a -> ReadS a
--- A Haskell 98 function
-readParen b g = if b then mandatory else optional
- where optional r = g r ++ mandatory r
- mandatory r = do
- ("(",s) <- lex r
- (x,t) <- optional s
- (")",u) <- lex t
- return (x,u)
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{The @Read@ class}
-%* *
-%*********************************************************
-
-\begin{code}
-------------------------------------------------------------------------
--- class Read
-
--- | Parsing of 'String's, producing values.
---
--- Minimal complete definition: 'readsPrec' (or, for GHC only, 'readPrec')
---
--- Derived instances of 'Read' make the following assumptions, which
--- derived instances of 'Text.Show.Show' obey:
---
--- * If the constructor is defined to be an infix operator, then the
--- derived 'Read' instance will parse only infix applications of
--- the constructor (not the prefix form).
---
--- * Associativity is not used to reduce the occurrence of parentheses,
--- although precedence may be.
---
--- * If the constructor is defined using record syntax, the derived 'Read'
--- will parse only the record-syntax form, and furthermore, the fields
--- must be given in the same order as the original declaration.
---
--- * The derived 'Read' instance allows arbitrary Haskell whitespace
--- between tokens of the input string. Extra parentheses are also
--- allowed.
---
--- For example, given the declarations
---
--- > infixr 5 :^:
--- > data Tree a = Leaf a | Tree a :^: Tree a
---
--- the derived instance of 'Read' in Haskell 98 is equivalent to
---
--- > instance (Read a) => Read (Tree a) where
--- >
--- > readsPrec d r = readParen (d > app_prec)
--- > (\r -> [(Leaf m,t) |
--- > ("Leaf",s) <- lex r,
--- > (m,t) <- readsPrec (app_prec+1) s]) r
--- >
--- > ++ readParen (d > up_prec)
--- > (\r -> [(u:^:v,w) |
--- > (u,s) <- readsPrec (up_prec+1) r,
--- > (":^:",t) <- lex s,
--- > (v,w) <- readsPrec (up_prec+1) t]) r
--- >
--- > where app_prec = 10
--- > up_prec = 5
---
--- Note that right-associativity of @:^:@ is unused.
---
--- The derived instance in GHC is equivalent to
---
--- > instance (Read a) => Read (Tree a) where
--- >
--- > readPrec = parens $ (prec app_prec $ do
--- > Ident "Leaf" <- lexP
--- > m <- step readPrec
--- > return (Leaf m))
--- >
--- > +++ (prec up_prec $ do
--- > u <- step readPrec
--- > Symbol ":^:" <- lexP
--- > v <- step readPrec
--- > return (u :^: v))
--- >
--- > where app_prec = 10
--- > up_prec = 5
--- >
--- > readListPrec = readListPrecDefault
-
-class Read a where
- -- | attempts to parse a value from the front of the string, returning
- -- a list of (parsed value, remaining string) pairs. If there is no
- -- successful parse, the returned list is empty.
- --
- -- Derived instances of 'Read' and 'Text.Show.Show' satisfy the following:
- --
- -- * @(x,\"\")@ is an element of
- -- @('readsPrec' d ('Text.Show.showsPrec' d x \"\"))@.
- --
- -- That is, 'readsPrec' parses the string produced by
- -- 'Text.Show.showsPrec', and delivers the value that
- -- 'Text.Show.showsPrec' started with.
-
- readsPrec :: Int -- ^ the operator precedence of the enclosing
- -- context (a number from @0@ to @11@).
- -- Function application has precedence @10@.
- -> ReadS a
-
- -- | The method 'readList' is provided to allow the programmer to
- -- give a specialised way of parsing lists of values.
- -- For example, this is used by the predefined 'Read' instance of
- -- the 'Char' type, where values of type 'String' should be are
- -- expected to use double quotes, rather than square brackets.
- readList :: ReadS [a]
-
- -- | Proposed replacement for 'readsPrec' using new-style parsers (GHC only).
- readPrec :: ReadPrec a
-
- -- | Proposed replacement for 'readList' using new-style parsers (GHC only).
- -- The default definition uses 'readList'. Instances that define 'readPrec'
- -- should also define 'readListPrec' as 'readListPrecDefault'.
- readListPrec :: ReadPrec [a]
-
- -- default definitions
- readsPrec = readPrec_to_S readPrec
- readList = readPrec_to_S (list readPrec) 0
- readPrec = readS_to_Prec readsPrec
- readListPrec = readS_to_Prec (\_ -> readList)
-
-readListDefault :: Read a => ReadS [a]
--- ^ A possible replacement definition for the 'readList' method (GHC only).
--- This is only needed for GHC, and even then only for 'Read' instances
--- where 'readListPrec' isn't defined as 'readListPrecDefault'.
-readListDefault = readPrec_to_S readListPrec 0
-
-readListPrecDefault :: Read a => ReadPrec [a]
--- ^ A possible replacement definition for the 'readListPrec' method,
--- defined using 'readPrec' (GHC only).
-readListPrecDefault = list readPrec
-
-------------------------------------------------------------------------
--- utility functions
-
--- | equivalent to 'readsPrec' with a precedence of 0.
-reads :: Read a => ReadS a
-reads = readsPrec minPrec
-
-readp :: Read a => ReadP a
-readp = readPrec_to_P readPrec minPrec
-
-readEither :: Read a => String -> Either String a
-readEither s =
- case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of
- [x] -> Right x
- [] -> Left "Prelude.read: no parse"
- _ -> Left "Prelude.read: ambiguous parse"
- where
- read' =
- do x <- readPrec
- lift P.skipSpaces
- return x
-
--- | The 'read' function reads input from a string, which must be
--- completely consumed by the input process.
-read :: Read a => String -> a
-read s = either error id (readEither s)
-
-------------------------------------------------------------------------
--- H98 compatibility
-
--- | The 'lex' function reads a single lexeme from the input, discarding
--- initial white space, and returning the characters that constitute the
--- lexeme. If the input string contains only white space, 'lex' returns a
--- single successful \`lexeme\' consisting of the empty string. (Thus
--- @'lex' \"\" = [(\"\",\"\")]@.) If there is no legal lexeme at the
--- beginning of the input string, 'lex' fails (i.e. returns @[]@).
---
--- This lexer is not completely faithful to the Haskell lexical syntax
--- in the following respects:
---
--- * Qualified names are not handled properly
---
--- * Octal and hexadecimal numerics are not recognized as a single token
---
--- * Comments are not treated properly
-lex :: ReadS String -- As defined by H98
-lex s = readP_to_S L.hsLex s
-
--- | Read a string representation of a character, using Haskell
--- source-language escape conventions. For example:
---
--- > lexLitChar "\\nHello" = [("\\n", "Hello")]
---
-lexLitChar :: ReadS String -- As defined by H98
-lexLitChar = readP_to_S (do { (s, _) <- P.gather L.lexChar ;
- return s })
- -- There was a skipSpaces before the P.gather L.lexChar,
- -- but that seems inconsistent with readLitChar
-
--- | Read a string representation of a character, using Haskell
--- source-language escape conventions, and convert it to the character
--- that it encodes. For example:
---
--- > readLitChar "\\nHello" = [('\n', "Hello")]
---
-readLitChar :: ReadS Char -- As defined by H98
-readLitChar = readP_to_S L.lexChar
-
--- | Reads a non-empty string of decimal digits.
-lexDigits :: ReadS String
-lexDigits = readP_to_S (P.munch1 isDigit)
-
-------------------------------------------------------------------------
--- utility parsers
-
-lexP :: ReadPrec L.Lexeme
--- ^ Parse a single lexeme
-lexP = lift L.lex
-
-paren :: ReadPrec a -> ReadPrec a
--- ^ @(paren p)@ parses \"(P0)\"
--- where @p@ parses \"P0\" in precedence context zero
-paren p = do L.Punc "(" <- lexP
- x <- reset p
- L.Punc ")" <- lexP
- return x
-
-parens :: ReadPrec a -> ReadPrec a
--- ^ @(parens p)@ parses \"P\", \"(P0)\", \"((P0))\", etc,
--- where @p@ parses \"P\" in the current precedence context
--- and parses \"P0\" in precedence context zero
-parens p = optional
- where
- optional = p +++ mandatory
- mandatory = paren optional
-
-list :: ReadPrec a -> ReadPrec [a]
--- ^ @(list p)@ parses a list of things parsed by @p@,
--- using the usual square-bracket syntax.
-list readx =
- parens
- ( do L.Punc "[" <- lexP
- (listRest False +++ listNext)
- )
- where
- listRest started =
- do L.Punc c <- lexP
- case c of
- "]" -> return []
- "," | started -> listNext
- _ -> pfail
-
- listNext =
- do x <- reset readx
- xs <- listRest True
- return (x:xs)
-
-choose :: [(String, ReadPrec a)] -> ReadPrec a
--- ^ Parse the specified lexeme and continue as specified.
--- Esp useful for nullary constructors; e.g.
--- @choose [(\"A\", return A), (\"B\", return B)]@
-choose sps = foldr ((+++) . try_one) pfail sps
- where
- try_one (s,p) = do { L.Ident s' <- lexP ;
- if s == s' then p else pfail }
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Simple instances of Read}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Read Char where
- readPrec =
- parens
- ( do L.Char c <- lexP
- return c
- )
-
- readListPrec =
- parens
- ( do L.String s <- lexP -- Looks for "foo"
- return s
- +++
- readListPrecDefault -- Looks for ['f','o','o']
- ) -- (more generous than H98 spec)
-
- readList = readListDefault
-
-instance Read Bool where
- readPrec =
- parens
- ( do L.Ident s <- lexP
- case s of
- "True" -> return True
- "False" -> return False
- _ -> pfail
- )
-
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance Read Ordering where
- readPrec =
- parens
- ( do L.Ident s <- lexP
- case s of
- "LT" -> return LT
- "EQ" -> return EQ
- "GT" -> return GT
- _ -> pfail
- )
-
- readListPrec = readListPrecDefault
- readList = readListDefault
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Structure instances of Read: Maybe, List etc}
-%* *
-%*********************************************************
-
-For structured instances of Read we start using the precedences. The
-idea is then that 'parens (prec k p)' will fail immediately when trying
-to parse it in a context with a higher precedence level than k. But if
-there is one parenthesis parsed, then the required precedence level
-drops to 0 again, and parsing inside p may succeed.
-
-'appPrec' is just the precedence level of function application. So,
-if we are parsing function application, we'd better require the
-precedence level to be at least 'appPrec'. Otherwise, we have to put
-parentheses around it.
-
-'step' is used to increase the precedence levels inside a
-parser, and can be used to express left- or right- associativity. For
-example, % is defined to be left associative, so we only increase
-precedence on the right hand side.
-
-Note how step is used in for example the Maybe parser to increase the
-precedence beyond appPrec, so that basically only literals and
-parenthesis-like objects such as (...) and [...] can be an argument to
-'Just'.
-
-\begin{code}
-instance Read a => Read (Maybe a) where
- readPrec =
- parens
- (do L.Ident "Nothing" <- lexP
- return Nothing
- +++
- prec appPrec (
- do L.Ident "Just" <- lexP
- x <- step readPrec
- return (Just x))
- )
-
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b) => Read (Either a b) where
- readPrec =
- parens
- ( prec appPrec
- ( do L.Ident "Left" <- lexP
- x <- step readPrec
- return (Left x)
- +++
- do L.Ident "Right" <- lexP
- y <- step readPrec
- return (Right y)
- )
- )
-
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance Read a => Read [a] where
- readPrec = readListPrec
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Ix a, Read a, Read b) => Read (Array a b) where
- readPrec = parens $ prec appPrec $
- do L.Ident "array" <- lexP
- bounds <- step readPrec
- vals <- step readPrec
- return (array bounds vals)
-
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance Read L.Lexeme where
- readPrec = lexP
- readListPrec = readListPrecDefault
- readList = readListDefault
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Numeric instances of Read}
-%* *
-%*********************************************************
-
-\begin{code}
-readNumber :: Num a => (L.Lexeme -> Maybe a) -> ReadPrec a
--- Read a signed number
-readNumber convert =
- parens
- ( do x <- lexP
- case x of
- L.Symbol "-" -> do n <- readNumber convert
- return (negate n)
-
- _ -> case convert x of
- Just n -> return n
- Nothing -> pfail
- )
-
-convertInt :: Num a => L.Lexeme -> Maybe a
-convertInt (L.Int i) = Just (fromInteger i)
-convertInt _ = Nothing
-
-convertFrac :: Fractional a => L.Lexeme -> Maybe a
-convertFrac (L.Int i) = Just (fromInteger i)
-convertFrac (L.Rat r) = Just (fromRational r)
-convertFrac _ = Nothing
-
-instance Read Int where
- readPrec = readNumber convertInt
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance Read Integer where
- readPrec = readNumber convertInt
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance Read Float where
- readPrec = readNumber convertFrac
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance Read Double where
- readPrec = readNumber convertFrac
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Integral a, Read a) => Read (Ratio a) where
- readPrec =
- parens
- ( prec ratioPrec
- ( do x <- step readPrec
- L.Symbol "%" <- lexP
- y <- step readPrec
- return (x % y)
- )
- )
-
- readListPrec = readListPrecDefault
- readList = readListDefault
-\end{code}
-
-
-%*********************************************************
-%* *
- Tuple instances of Read, up to size 15
-%* *
-%*********************************************************
-
-\begin{code}
-instance Read () where
- readPrec =
- parens
- ( paren
- ( return ()
- )
- )
-
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b) => Read (a,b) where
- readPrec = wrap_tup read_tup2
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-wrap_tup :: ReadPrec a -> ReadPrec a
-wrap_tup p = parens (paren p)
-
-read_comma :: ReadPrec ()
-read_comma = do { L.Punc "," <- lexP; return () }
-
-read_tup2 :: (Read a, Read b) => ReadPrec (a,b)
--- Reads "a , b" no parens!
-read_tup2 = do x <- readPrec
- read_comma
- y <- readPrec
- return (x,y)
-
-read_tup4 :: (Read a, Read b, Read c, Read d) => ReadPrec (a,b,c,d)
-read_tup4 = do (a,b) <- read_tup2
- read_comma
- (c,d) <- read_tup2
- return (a,b,c,d)
-
-
-read_tup8 :: (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h)
- => ReadPrec (a,b,c,d,e,f,g,h)
-read_tup8 = do (a,b,c,d) <- read_tup4
- read_comma
- (e,f,g,h) <- read_tup4
- return (a,b,c,d,e,f,g,h)
-
-
-instance (Read a, Read b, Read c) => Read (a, b, c) where
- readPrec = wrap_tup (do { (a,b) <- read_tup2; read_comma
- ; c <- readPrec
- ; return (a,b,c) })
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where
- readPrec = wrap_tup read_tup4
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where
- readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma
- ; e <- readPrec
- ; return (a,b,c,d,e) })
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b, Read c, Read d, Read e, Read f)
- => Read (a, b, c, d, e, f) where
- readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma
- ; (e,f) <- read_tup2
- ; return (a,b,c,d,e,f) })
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g)
- => Read (a, b, c, d, e, f, g) where
- readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma
- ; (e,f) <- read_tup2; read_comma
- ; g <- readPrec
- ; return (a,b,c,d,e,f,g) })
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h)
- => Read (a, b, c, d, e, f, g, h) where
- readPrec = wrap_tup read_tup8
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i)
- => Read (a, b, c, d, e, f, g, h, i) where
- readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; i <- readPrec
- ; return (a,b,c,d,e,f,g,h,i) })
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i, Read j)
- => Read (a, b, c, d, e, f, g, h, i, j) where
- readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; (i,j) <- read_tup2
- ; return (a,b,c,d,e,f,g,h,i,j) })
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i, Read j, Read k)
- => Read (a, b, c, d, e, f, g, h, i, j, k) where
- readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; (i,j) <- read_tup2; read_comma
- ; k <- readPrec
- ; return (a,b,c,d,e,f,g,h,i,j,k) })
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i, Read j, Read k, Read l)
- => Read (a, b, c, d, e, f, g, h, i, j, k, l) where
- readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; (i,j,k,l) <- read_tup4
- ; return (a,b,c,d,e,f,g,h,i,j,k,l) })
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i, Read j, Read k, Read l, Read m)
- => Read (a, b, c, d, e, f, g, h, i, j, k, l, m) where
- readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; (i,j,k,l) <- read_tup4; read_comma
- ; m <- readPrec
- ; return (a,b,c,d,e,f,g,h,i,j,k,l,m) })
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i, Read j, Read k, Read l, Read m, Read n)
- => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where
- readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; (i,j,k,l) <- read_tup4; read_comma
- ; (m,n) <- read_tup2
- ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n) })
- readListPrec = readListPrecDefault
- readList = readListDefault
-
-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i, Read j, Read k, Read l, Read m, Read n, Read o)
- => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where
- readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; (i,j,k,l) <- read_tup4; read_comma
- ; (m,n) <- read_tup2; read_comma
- ; o <- readPrec
- ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) })
- readListPrec = readListPrecDefault
- readList = readListDefault
-\end{code}
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Real
--- Copyright : (c) The FFI Task Force, 1994-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- The types 'Ratio' and 'Rational', and the classes 'Real', 'Fractional',
--- 'Integral', and 'RealFrac'.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Real where
-
-import {-# SOURCE #-} GHC.Err
-import GHC.Base
-import GHC.Num
-import GHC.List
-import GHC.Enum
-import GHC.Show
-
-infixr 8 ^, ^^
-infixl 7 /, `quot`, `rem`, `div`, `mod`
-infixl 7 %
-
-default () -- Double isn't available yet,
- -- and we shouldn't be using defaults anyway
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{The @Ratio@ and @Rational@ types}
-%* *
-%*********************************************************
-
-\begin{code}
--- | Rational numbers, with numerator and denominator of some 'Integral' type.
-data (Integral a) => Ratio a = !a :% !a deriving (Eq)
-
--- | Arbitrary-precision rational numbers, represented as a ratio of
--- two 'Integer' values. A rational number may be constructed using
--- the '%' operator.
-type Rational = Ratio Integer
-
-ratioPrec, ratioPrec1 :: Int
-ratioPrec = 7 -- Precedence of ':%' constructor
-ratioPrec1 = ratioPrec + 1
-
-infinity, notANumber :: Rational
-infinity = 1 :% 0
-notANumber = 0 :% 0
-
--- Use :%, not % for Inf/NaN; the latter would
--- immediately lead to a runtime error, because it normalises.
-\end{code}
-
-
-\begin{code}
--- | Forms the ratio of two integral numbers.
-{-# SPECIALISE (%) :: Integer -> Integer -> Rational #-}
-(%) :: (Integral a) => a -> a -> Ratio a
-
--- | Extract the numerator of the ratio in reduced form:
--- the numerator and denominator have no common factor and the denominator
--- is positive.
-numerator :: (Integral a) => Ratio a -> a
-
--- | Extract the denominator of the ratio in reduced form:
--- the numerator and denominator have no common factor and the denominator
--- is positive.
-denominator :: (Integral a) => Ratio a -> a
-\end{code}
-
-\tr{reduce} is a subsidiary function used only in this module .
-It normalises a ratio by dividing both numerator and denominator by
-their greatest common divisor.
-
-\begin{code}
-reduce :: (Integral a) => a -> a -> Ratio a
-{-# SPECIALISE reduce :: Integer -> Integer -> Rational #-}
-reduce _ 0 = error "Ratio.%: zero denominator"
-reduce x y = (x `quot` d) :% (y `quot` d)
- where d = gcd x y
-\end{code}
-
-\begin{code}
-x % y = reduce (x * signum y) (abs y)
-
-numerator (x :% _) = x
-denominator (_ :% y) = y
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Standard numeric classes}
-%* *
-%*********************************************************
-
-\begin{code}
-class (Num a, Ord a) => Real a where
- -- | the rational equivalent of its real argument with full precision
- toRational :: a -> Rational
-
--- | Integral numbers, supporting integer division.
---
--- Minimal complete definition: 'quotRem' and 'toInteger'
-class (Real a, Enum a) => Integral a where
- -- | integer division truncated toward zero
- quot :: a -> a -> a
- -- | integer remainder, satisfying
- --
- -- > (x `quot` y)*y + (x `rem` y) == x
- rem :: a -> a -> a
- -- | integer division truncated toward negative infinity
- div :: a -> a -> a
- -- | integer modulus, satisfying
- --
- -- > (x `div` y)*y + (x `mod` y) == x
- mod :: a -> a -> a
- -- | simultaneous 'quot' and 'rem'
- quotRem :: a -> a -> (a,a)
- -- | simultaneous 'div' and 'mod'
- divMod :: a -> a -> (a,a)
- -- | conversion to 'Integer'
- toInteger :: a -> Integer
-
- n `quot` d = q where (q,_) = quotRem n d
- n `rem` d = r where (_,r) = quotRem n d
- n `div` d = q where (q,_) = divMod n d
- n `mod` d = r where (_,r) = divMod n d
- divMod n d = if signum r == negate (signum d) then (q-1, r+d) else qr
- where qr@(q,r) = quotRem n d
-
--- | Fractional numbers, supporting real division.
---
--- Minimal complete definition: 'fromRational' and ('recip' or @('/')@)
-class (Num a) => Fractional a where
- -- | fractional division
- (/) :: a -> a -> a
- -- | reciprocal fraction
- recip :: a -> a
- -- | Conversion from a 'Rational' (that is @'Ratio' 'Integer'@).
- -- A floating literal stands for an application of 'fromRational'
- -- to a value of type 'Rational', so such literals have type
- -- @('Fractional' a) => a@.
- fromRational :: Rational -> a
-
- recip x = 1 / x
- x / y = x * recip y
-
--- | Extracting components of fractions.
---
--- Minimal complete definition: 'properFraction'
-class (Real a, Fractional a) => RealFrac a where
- -- | The function 'properFraction' takes a real fractional number @x@
- -- and returns a pair @(n,f)@ such that @x = n+f@, and:
- --
- -- * @n@ is an integral number with the same sign as @x@; and
- --
- -- * @f@ is a fraction with the same type and sign as @x@,
- -- and with absolute value less than @1@.
- --
- -- The default definitions of the 'ceiling', 'floor', 'truncate'
- -- and 'round' functions are in terms of 'properFraction'.
- properFraction :: (Integral b) => a -> (b,a)
- -- | @'truncate' x@ returns the integer nearest @x@ between zero and @x@
- truncate :: (Integral b) => a -> b
- -- | @'round' x@ returns the nearest integer to @x@
- round :: (Integral b) => a -> b
- -- | @'ceiling' x@ returns the least integer not less than @x@
- ceiling :: (Integral b) => a -> b
- -- | @'floor' x@ returns the greatest integer not greater than @x@
- floor :: (Integral b) => a -> b
-
- truncate x = m where (m,_) = properFraction x
-
- round x = let (n,r) = properFraction x
- m = if r < 0 then n - 1 else n + 1
- in case signum (abs r - 0.5) of
- -1 -> n
- 0 -> if even n then n else m
- 1 -> m
-
- ceiling x = if r > 0 then n + 1 else n
- where (n,r) = properFraction x
-
- floor x = if r < 0 then n - 1 else n
- where (n,r) = properFraction x
-\end{code}
-
-
-These 'numeric' enumerations come straight from the Report
-
-\begin{code}
-numericEnumFrom :: (Fractional a) => a -> [a]
-numericEnumFrom = iterate (+1)
-
-numericEnumFromThen :: (Fractional a) => a -> a -> [a]
-numericEnumFromThen n m = iterate (+(m-n)) n
-
-numericEnumFromTo :: (Ord a, Fractional a) => a -> a -> [a]
-numericEnumFromTo n m = takeWhile (<= m + 1/2) (numericEnumFrom n)
-
-numericEnumFromThenTo :: (Ord a, Fractional a) => a -> a -> a -> [a]
-numericEnumFromThenTo e1 e2 e3 = takeWhile pred (numericEnumFromThen e1 e2)
- where
- mid = (e2 - e1) / 2
- pred | e2 >= e1 = (<= e3 + mid)
- | otherwise = (>= e3 + mid)
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Instances for @Int@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Real Int where
- toRational x = toInteger x % 1
-
-instance Integral Int where
- toInteger i = int2Integer i -- give back a full-blown Integer
-
- a `quot` b
- | b == 0 = divZeroError
- | a == minBound && b == (-1) = overflowError
- | otherwise = a `quotInt` b
-
- a `rem` b
- | b == 0 = divZeroError
- | a == minBound && b == (-1) = overflowError
- | otherwise = a `remInt` b
-
- a `div` b
- | b == 0 = divZeroError
- | a == minBound && b == (-1) = overflowError
- | otherwise = a `divInt` b
-
- a `mod` b
- | b == 0 = divZeroError
- | a == minBound && b == (-1) = overflowError
- | otherwise = a `modInt` b
-
- a `quotRem` b
- | b == 0 = divZeroError
- | a == minBound && b == (-1) = overflowError
- | otherwise = a `quotRemInt` b
-
- a `divMod` b
- | b == 0 = divZeroError
- | a == minBound && b == (-1) = overflowError
- | otherwise = a `divModInt` b
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Instances for @Integer@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Real Integer where
- toRational x = x % 1
-
-instance Integral Integer where
- toInteger n = n
-
- a `quot` 0 = divZeroError
- n `quot` d = n `quotInteger` d
-
- a `rem` 0 = divZeroError
- n `rem` d = n `remInteger` d
-
- a `divMod` 0 = divZeroError
- a `divMod` b = a `divModInteger` b
-
- a `quotRem` 0 = divZeroError
- a `quotRem` b = a `quotRemInteger` b
-
- -- use the defaults for div & mod
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Instances for @Ratio@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance (Integral a) => Ord (Ratio a) where
- {-# SPECIALIZE instance Ord Rational #-}
- (x:%y) <= (x':%y') = x * y' <= x' * y
- (x:%y) < (x':%y') = x * y' < x' * y
-
-instance (Integral a) => Num (Ratio a) where
- {-# SPECIALIZE instance Num Rational #-}
- (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
- (x:%y) - (x':%y') = reduce (x*y' - x'*y) (y*y')
- (x:%y) * (x':%y') = reduce (x * x') (y * y')
- negate (x:%y) = (-x) :% y
- abs (x:%y) = abs x :% y
- signum (x:%_) = signum x :% 1
- fromInteger x = fromInteger x :% 1
-
-instance (Integral a) => Fractional (Ratio a) where
- {-# SPECIALIZE instance Fractional Rational #-}
- (x:%y) / (x':%y') = (x*y') % (y*x')
- recip (x:%y) = y % x
- fromRational (x:%y) = fromInteger x :% fromInteger y
-
-instance (Integral a) => Real (Ratio a) where
- {-# SPECIALIZE instance Real Rational #-}
- toRational (x:%y) = toInteger x :% toInteger y
-
-instance (Integral a) => RealFrac (Ratio a) where
- {-# SPECIALIZE instance RealFrac Rational #-}
- properFraction (x:%y) = (fromInteger (toInteger q), r:%y)
- where (q,r) = quotRem x y
-
-instance (Integral a) => Show (Ratio a) where
- {-# SPECIALIZE instance Show Rational #-}
- showsPrec p (x:%y) = showParen (p > ratioPrec) $
- showsPrec ratioPrec1 x .
- showString "%" . -- H98 report has spaces round the %
- -- but we removed them [May 04]
- showsPrec ratioPrec1 y
-
-instance (Integral a) => Enum (Ratio a) where
- {-# SPECIALIZE instance Enum Rational #-}
- succ x = x + 1
- pred x = x - 1
-
- toEnum n = fromInteger (int2Integer n) :% 1
- fromEnum = fromInteger . truncate
-
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo = numericEnumFromTo
- enumFromThenTo = numericEnumFromThenTo
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Coercions}
-%* *
-%*********************************************************
-
-\begin{code}
--- | general coercion from integral types
-fromIntegral :: (Integral a, Num b) => a -> b
-fromIntegral = fromInteger . toInteger
-
-{-# RULES
-"fromIntegral/Int->Int" fromIntegral = id :: Int -> Int
- #-}
-
--- | general coercion to fractional types
-realToFrac :: (Real a, Fractional b) => a -> b
-realToFrac = fromRational . toRational
-
-{-# RULES
-"realToFrac/Int->Int" realToFrac = id :: Int -> Int
- #-}
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Overloaded numeric functions}
-%* *
-%*********************************************************
-
-\begin{code}
--- | Converts a possibly-negative 'Real' value to a string.
-showSigned :: (Real a)
- => (a -> ShowS) -- ^ a function that can show unsigned values
- -> Int -- ^ the precedence of the enclosing context
- -> a -- ^ the value to show
- -> ShowS
-showSigned showPos p x
- | x < 0 = showParen (p > 6) (showChar '-' . showPos (-x))
- | otherwise = showPos x
-
-even, odd :: (Integral a) => a -> Bool
-even n = n `rem` 2 == 0
-odd = not . even
-
--------------------------------------------------------
--- | raise a number to a non-negative integral power
-{-# SPECIALISE (^) ::
- Integer -> Integer -> Integer,
- Integer -> Int -> Integer,
- Int -> Int -> Int #-}
-(^) :: (Num a, Integral b) => a -> b -> a
-_ ^ 0 = 1
-x ^ n | n > 0 = f x (n-1) x
- where f _ 0 y = y
- f a d y = g a d where
- g b i | even i = g (b*b) (i `quot` 2)
- | otherwise = f b (i-1) (b*y)
-_ ^ _ = error "Prelude.^: negative exponent"
-
--- | raise a number to an integral power
-{-# SPECIALISE (^^) ::
- Rational -> Int -> Rational #-}
-(^^) :: (Fractional a, Integral b) => a -> b -> a
-x ^^ n = if n >= 0 then x^n else recip (x^(negate n))
-
-
--------------------------------------------------------
--- | @'gcd' x y@ is the greatest (positive) integer that divides both @x@
--- and @y@; for example @'gcd' (-3) 6@ = @3@, @'gcd' (-3) (-6)@ = @3@,
--- @'gcd' 0 4@ = @4@. @'gcd' 0 0@ raises a runtime error.
-gcd :: (Integral a) => a -> a -> a
-gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
-gcd x y = gcd' (abs x) (abs y)
- where gcd' a 0 = a
- gcd' a b = gcd' b (a `rem` b)
-
--- | @'lcm' x y@ is the smallest positive integer that both @x@ and @y@ divide.
-lcm :: (Integral a) => a -> a -> a
-{-# SPECIALISE lcm :: Int -> Int -> Int #-}
-lcm _ 0 = 0
-lcm 0 _ = 0
-lcm x y = abs ((x `quot` (gcd x y)) * y)
-
-
-{-# RULES
-"gcd/Int->Int->Int" gcd = gcdInt
-"gcd/Integer->Integer->Integer" gcd = gcdInteger
-"lcm/Integer->Integer->Integer" lcm = lcmInteger
- #-}
-
-integralEnumFrom :: (Integral a, Bounded a) => a -> [a]
-integralEnumFrom n = map fromInteger [toInteger n .. toInteger (maxBound `asTypeOf` n)]
-
-integralEnumFromThen :: (Integral a, Bounded a) => a -> a -> [a]
-integralEnumFromThen n1 n2
- | i_n2 >= i_n1 = map fromInteger [i_n1, i_n2 .. toInteger (maxBound `asTypeOf` n1)]
- | otherwise = map fromInteger [i_n1, i_n2 .. toInteger (minBound `asTypeOf` n1)]
- where
- i_n1 = toInteger n1
- i_n2 = toInteger n2
-
-integralEnumFromTo :: Integral a => a -> a -> [a]
-integralEnumFromTo n m = map fromInteger [toInteger n .. toInteger m]
-
-integralEnumFromThenTo :: Integral a => a -> a -> a -> [a]
-integralEnumFromThenTo n1 n2 m
- = map fromInteger [toInteger n1, toInteger n2 .. toInteger m]
-\end{code}
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.ST
--- Copyright : (c) The University of Glasgow, 1992-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- The 'ST' Monad.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.ST where
-
-import GHC.Base
-import GHC.Show
-import GHC.Num
-
-default ()
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{The @ST@ monad}
-%* *
-%*********************************************************
-
-The state-transformer monad proper. By default the monad is strict;
-too many people got bitten by space leaks when it was lazy.
-
-\begin{code}
--- | The strict state-transformer monad.
--- A computation of type @'ST' s a@ transforms an internal state indexed
--- by @s@, and returns a value of type @a@.
--- The @s@ parameter is either
---
--- * an uninstantiated type variable (inside invocations of 'runST'), or
---
--- * 'RealWorld' (inside invocations of 'Control.Monad.ST.stToIO').
---
--- It serves to keep the internal states of different invocations
--- of 'runST' separate from each other and from invocations of
--- 'Control.Monad.ST.stToIO'.
---
--- The '>>=' and '>>' operations are strict in the state (though not in
--- values stored in the state). For example,
---
--- @'runST' (writeSTRef _|_ v >>= f) = _|_@
-newtype ST s a = ST (STRep s a)
-type STRep s a = State# s -> (# State# s, a #)
-
-instance Functor (ST s) where
- fmap f (ST m) = ST $ \ s ->
- case (m s) of { (# new_s, r #) ->
- (# new_s, f r #) }
-
-instance Monad (ST s) where
- {-# INLINE return #-}
- {-# INLINE (>>) #-}
- {-# INLINE (>>=) #-}
- return x = ST (\ s -> (# s, x #))
- m >> k = m >>= \ _ -> k
-
- (ST m) >>= k
- = ST (\ s ->
- case (m s) of { (# new_s, r #) ->
- case (k r) of { ST k2 ->
- (k2 new_s) }})
-
-data STret s a = STret (State# s) a
-
--- liftST is useful when we want a lifted result from an ST computation. See
--- fixST below.
-liftST :: ST s a -> State# s -> STret s a
-liftST (ST m) = \s -> case m s of (# s', r #) -> STret s' r
-
-{-# NOINLINE unsafeInterleaveST #-}
-unsafeInterleaveST :: ST s a -> ST s a
-unsafeInterleaveST (ST m) = ST ( \ s ->
- let
- r = case m s of (# _, res #) -> res
- in
- (# s, r #)
- )
-
--- | Allow the result of a state transformer computation to be used (lazily)
--- inside the computation.
--- Note that if @f@ is strict, @'fixST' f = _|_@.
-fixST :: (a -> ST s a) -> ST s a
-fixST k = ST $ \ s ->
- let ans = liftST (k r) s
- STret _ r = ans
- in
- case ans of STret s' x -> (# s', x #)
-
-instance Show (ST s a) where
- showsPrec _ _ = showString "<<ST action>>"
- showList = showList__ (showsPrec 0)
-\end{code}
-
-Definition of runST
-~~~~~~~~~~~~~~~~~~~
-
-SLPJ 95/04: Why @runST@ must not have an unfolding; consider:
-\begin{verbatim}
-f x =
- runST ( \ s -> let
- (a, s') = newArray# 100 [] s
- (_, s'') = fill_in_array_or_something a x s'
- in
- freezeArray# a s'' )
-\end{verbatim}
-If we inline @runST@, we'll get:
-\begin{verbatim}
-f x = let
- (a, s') = newArray# 100 [] realWorld#{-NB-}
- (_, s'') = fill_in_array_or_something a x s'
- in
- freezeArray# a s''
-\end{verbatim}
-And now the @newArray#@ binding can be floated to become a CAF, which
-is totally and utterly wrong:
-\begin{verbatim}
-f = let
- (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
- in
- \ x ->
- let (_, s'') = fill_in_array_or_something a x s' in
- freezeArray# a s''
-\end{verbatim}
-All calls to @f@ will share a {\em single} array! End SLPJ 95/04.
-
-\begin{code}
-{-# INLINE runST #-}
--- The INLINE prevents runSTRep getting inlined in *this* module
--- so that it is still visible when runST is inlined in an importing
--- module. Regrettably delicate. runST is behaving like a wrapper.
-
--- | Return the value computed by a state transformer computation.
--- The @forall@ ensures that the internal state used by the 'ST'
--- computation is inaccessible to the rest of the program.
-runST :: (forall s. ST s a) -> a
-runST st = runSTRep (case st of { ST st_rep -> st_rep })
-
--- I'm only letting runSTRep be inlined right at the end, in particular *after* full laziness
--- That's what the "INLINE [0]" says.
--- SLPJ Apr 99
--- {-# INLINE [0] runSTRep #-}
-
--- SDM: further to the above, inline phase 0 is run *before*
--- full-laziness at the moment, which means that the above comment is
--- invalid. Inlining runSTRep doesn't make a huge amount of
--- difference, anyway. Hence:
-
-{-# NOINLINE runSTRep #-}
-runSTRep :: (forall s. STRep s a) -> a
-runSTRep st_rep = case st_rep realWorld# of
- (# _, r #) -> r
-\end{code}
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.STRef
--- Copyright : (c) The University of Glasgow, 1994-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- References in the 'ST' monad.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.STRef where
-
-import GHC.ST
-import GHC.Base
-
-data STRef s a = STRef (MutVar# s a)
--- ^ a value of type @STRef s a@ is a mutable variable in state thread @s@,
--- containing a value of type @a@
-
--- |Build a new 'STRef' in the current state thread
-newSTRef :: a -> ST s (STRef s a)
-newSTRef init = ST $ \s1# ->
- case newMutVar# init s1# of { (# s2#, var# #) ->
- (# s2#, STRef var# #) }
-
--- |Read the value of an 'STRef'
-readSTRef :: STRef s a -> ST s a
-readSTRef (STRef var#) = ST $ \s1# -> readMutVar# var# s1#
-
--- |Write a new value into an 'STRef'
-writeSTRef :: STRef s a -> a -> ST s ()
-writeSTRef (STRef var#) val = ST $ \s1# ->
- case writeMutVar# var# val s1# of { s2# ->
- (# s2#, () #) }
-
--- Just pointer equality on mutable references:
-instance Eq (STRef s a) where
- STRef v1# == STRef v2# = sameMutVar# v1# v2#
-\end{code}
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Show
--- Copyright : (c) The University of Glasgow, 1992-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- The 'Show' class, and related operations.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Show
- (
- Show(..), ShowS,
-
- -- Instances for Show: (), [], Bool, Ordering, Int, Char
-
- -- Show support code
- shows, showChar, showString, showParen, showList__, showSpace,
- showLitChar, protectEsc,
- intToDigit, showSignedInt,
- appPrec, appPrec1,
-
- -- Character operations
- asciiTab,
- )
- where
-
-import GHC.Base
-import Data.Maybe
-import Data.Either
-import GHC.List ( (!!), foldr1
-#ifdef USE_REPORT_PRELUDE
- , concatMap
-#endif
- )
-\end{code}
-
-
-
-%*********************************************************
-%* *
-\subsection{The @Show@ class}
-%* *
-%*********************************************************
-
-\begin{code}
--- | The @shows@ functions return a function that prepends the
--- output 'String' to an existing 'String'. This allows constant-time
--- concatenation of results using function composition.
-type ShowS = String -> String
-
--- | Conversion of values to readable 'String's.
---
--- Minimal complete definition: 'showsPrec' or 'show'.
---
--- Derived instances of 'Show' have the following properties, which
--- are compatible with derived instances of 'Text.Read.Read':
---
--- * The result of 'show' is a syntactically correct Haskell
--- expression containing only constants, given the fixity
--- declarations in force at the point where the type is declared.
--- It contains only the constructor names defined in the data type,
--- parentheses, and spaces. When labelled constructor fields are
--- used, braces, commas, field names, and equal signs are also used.
---
--- * If the constructor is defined to be an infix operator, then
--- 'showsPrec' will produce infix applications of the constructor.
---
--- * the representation will be enclosed in parentheses if the
--- precedence of the top-level constructor in @x@ is less than @d@
--- (associativity is ignored). Thus, if @d@ is @0@ then the result
--- is never surrounded in parentheses; if @d@ is @11@ it is always
--- surrounded in parentheses, unless it is an atomic expression.
---
--- * If the constructor is defined using record syntax, then 'show'
--- will produce the record-syntax form, with the fields given in the
--- same order as the original declaration.
---
--- For example, given the declarations
---
--- > infixr 5 :^:
--- > data Tree a = Leaf a | Tree a :^: Tree a
---
--- the derived instance of 'Show' is equivalent to
---
--- > instance (Show a) => Show (Tree a) where
--- >
--- > showsPrec d (Leaf m) = showParen (d > app_prec) $
--- > showString "Leaf " . showsPrec (app_prec+1) m
--- > where app_prec = 10
--- >
--- > showsPrec d (u :^: v) = showParen (d > up_prec) $
--- > showsPrec (up_prec+1) u .
--- > showString " :^: " .
--- > showsPrec (up_prec+1) v
--- > where up_prec = 5
---
--- Note that right-associativity of @:^:@ is ignored. For example,
---
--- * @'show' (Leaf 1 :^: Leaf 2 :^: Leaf 3)@ produces the string
--- @\"Leaf 1 :^: (Leaf 2 :^: Leaf 3)\"@.
-
-class Show a where
- -- | Convert a value to a readable 'String'.
- --
- -- 'showsPrec' should satisfy the law
- --
- -- > showsPrec d x r ++ s == showsPrec d x (r ++ s)
- --
- -- Derived instances of 'Text.Read.Read' and 'Show' satisfy the following:
- --
- -- * @(x,\"\")@ is an element of
- -- @('Text.Read.readsPrec' d ('showsPrec' d x \"\"))@.
- --
- -- That is, 'Text.Read.readsPrec' parses the string produced by
- -- 'showsPrec', and delivers the value that 'showsPrec' started with.
-
- showsPrec :: Int -- ^ the operator precedence of the enclosing
- -- context (a number from @0@ to @11@).
- -- Function application has precedence @10@.
- -> a -- ^ the value to be converted to a 'String'
- -> ShowS
-
- -- | A specialised variant of 'showsPrec', using precedence context
- -- zero, and returning an ordinary 'String'.
- show :: a -> String
-
- -- | The method 'showList' is provided to allow the programmer to
- -- give a specialised way of showing lists of values.
- -- For example, this is used by the predefined 'Show' instance of
- -- the 'Char' type, where values of type 'String' should be shown
- -- in double quotes, rather than between square brackets.
- showList :: [a] -> ShowS
-
- showsPrec _ x s = show x ++ s
- show x = shows x ""
- showList ls s = showList__ shows ls s
-
-showList__ :: (a -> ShowS) -> [a] -> ShowS
-showList__ _ [] s = "[]" ++ s
-showList__ showx (x:xs) s = '[' : showx x (showl xs)
- where
- showl [] = ']' : s
- showl (y:ys) = ',' : showx y (showl ys)
-
-appPrec, appPrec1 :: Int
- -- Use unboxed stuff because we don't have overloaded numerics yet
-appPrec = I# 10# -- Precedence of application:
- -- one more than the maximum operator precedence of 9
-appPrec1 = I# 11# -- appPrec + 1
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Simple Instances}
-%* *
-%*********************************************************
-
-\begin{code}
-
-instance Show () where
- showsPrec _ () = showString "()"
-
-instance Show a => Show [a] where
- showsPrec _ = showList
-
-instance Show Bool where
- showsPrec _ True = showString "True"
- showsPrec _ False = showString "False"
-
-instance Show Ordering where
- showsPrec _ LT = showString "LT"
- showsPrec _ EQ = showString "EQ"
- showsPrec _ GT = showString "GT"
-
-instance Show Char where
- showsPrec _ '\'' = showString "'\\''"
- showsPrec _ c = showChar '\'' . showLitChar c . showChar '\''
-
- showList cs = showChar '"' . showl cs
- where showl "" s = showChar '"' s
- showl ('"':xs) s = showString "\\\"" (showl xs s)
- showl (x:xs) s = showLitChar x (showl xs s)
- -- Making 's' an explicit parameter makes it clear to GHC
- -- that showl has arity 2, which avoids it allocating an extra lambda
- -- The sticking point is the recursive call to (showl xs), which
- -- it can't figure out would be ok with arity 2.
-
-instance Show Int where
- showsPrec = showSignedInt
-
-instance Show a => Show (Maybe a) where
- showsPrec _p Nothing s = showString "Nothing" s
- showsPrec p (Just x) s
- = (showParen (p > appPrec) $
- showString "Just " .
- showsPrec appPrec1 x) s
-
-instance (Show a, Show b) => Show (Either a b) where
- showsPrec p e s =
- (showParen (p > appPrec) $
- case e of
- Left a -> showString "Left " . showsPrec appPrec1 a
- Right b -> showString "Right " . showsPrec appPrec1 b)
- s
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Show instances for the first few tuples
-%* *
-%*********************************************************
-
-\begin{code}
--- The explicit 's' parameters are important
--- Otherwise GHC thinks that "shows x" might take a lot of work to compute
--- and generates defns like
--- showsPrec _ (x,y) = let sx = shows x; sy = shows y in
--- \s -> showChar '(' (sx (showChar ',' (sy (showChar ')' s))))
-
-instance (Show a, Show b) => Show (a,b) where
- showsPrec _ (a,b) s = show_tuple [shows a, shows b] s
-
-instance (Show a, Show b, Show c) => Show (a, b, c) where
- showsPrec _ (a,b,c) s = show_tuple [shows a, shows b, shows c] s
-
-instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where
- showsPrec _ (a,b,c,d) s = show_tuple [shows a, shows b, shows c, shows d] s
-
-instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where
- showsPrec _ (a,b,c,d,e) s = show_tuple [shows a, shows b, shows c, shows d, shows e] s
-
-instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a,b,c,d,e,f) where
- showsPrec _ (a,b,c,d,e,f) s = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f] s
-
-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g)
- => Show (a,b,c,d,e,f,g) where
- showsPrec _ (a,b,c,d,e,f,g) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g] s
-
-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h)
- => Show (a,b,c,d,e,f,g,h) where
- showsPrec _ (a,b,c,d,e,f,g,h) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h] s
-
-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i)
- => Show (a,b,c,d,e,f,g,h,i) where
- showsPrec _ (a,b,c,d,e,f,g,h,i) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i] s
-
-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j)
- => Show (a,b,c,d,e,f,g,h,i,j) where
- showsPrec _ (a,b,c,d,e,f,g,h,i,j) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i, shows j] s
-
-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k)
- => Show (a,b,c,d,e,f,g,h,i,j,k) where
- showsPrec _ (a,b,c,d,e,f,g,h,i,j,k) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i, shows j, shows k] s
-
-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,
- Show l)
- => Show (a,b,c,d,e,f,g,h,i,j,k,l) where
- showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i, shows j, shows k, shows l] s
-
-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,
- Show l, Show m)
- => Show (a,b,c,d,e,f,g,h,i,j,k,l,m) where
- showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i, shows j, shows k, shows l, shows m] s
-
-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,
- Show l, Show m, Show n)
- => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
- showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i, shows j, shows k, shows l, shows m, shows n] s
-
-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,
- Show l, Show m, Show n, Show o)
- => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
- showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i, shows j, shows k, shows l, shows m, shows n, shows o] s
-
-show_tuple :: [ShowS] -> ShowS
-show_tuple ss = showChar '('
- . foldr1 (\s r -> s . showChar ',' . r) ss
- . showChar ')'
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Support code for @Show@}
-%* *
-%*********************************************************
-
-\begin{code}
--- | equivalent to 'showsPrec' with a precedence of 0.
-shows :: (Show a) => a -> ShowS
-shows = showsPrec zeroInt
-
--- | utility function converting a 'Char' to a show function that
--- simply prepends the character unchanged.
-showChar :: Char -> ShowS
-showChar = (:)
-
--- | utility function converting a 'String' to a show function that
--- simply prepends the string unchanged.
-showString :: String -> ShowS
-showString = (++)
-
--- | utility function that surrounds the inner show function with
--- parentheses when the 'Bool' parameter is 'True'.
-showParen :: Bool -> ShowS -> ShowS
-showParen b p = if b then showChar '(' . p . showChar ')' else p
-
-showSpace :: ShowS
-showSpace = {-showChar ' '-} \ xs -> ' ' : xs
-\end{code}
-
-Code specific for characters
-
-\begin{code}
--- | Convert a character to a string using only printable characters,
--- using Haskell source-language escape conventions. For example:
---
--- > showLitChar '\n' s = "\\n" ++ s
---
-showLitChar :: Char -> ShowS
-showLitChar c s | c > '\DEL' = showChar '\\' (protectEsc isDec (shows (ord c)) s)
-showLitChar '\DEL' s = showString "\\DEL" s
-showLitChar '\\' s = showString "\\\\" s
-showLitChar c s | c >= ' ' = showChar c s
-showLitChar '\a' s = showString "\\a" s
-showLitChar '\b' s = showString "\\b" s
-showLitChar '\f' s = showString "\\f" s
-showLitChar '\n' s = showString "\\n" s
-showLitChar '\r' s = showString "\\r" s
-showLitChar '\t' s = showString "\\t" s
-showLitChar '\v' s = showString "\\v" s
-showLitChar '\SO' s = protectEsc (== 'H') (showString "\\SO") s
-showLitChar c s = showString ('\\' : asciiTab!!ord c) s
- -- I've done manual eta-expansion here, becuase otherwise it's
- -- impossible to stop (asciiTab!!ord) getting floated out as an MFE
-
-isDec c = c >= '0' && c <= '9'
-
-protectEsc :: (Char -> Bool) -> ShowS -> ShowS
-protectEsc p f = f . cont
- where cont s@(c:_) | p c = "\\&" ++ s
- cont s = s
-
-
-asciiTab :: [String]
-asciiTab = -- Using an array drags in the array module. listArray ('\NUL', ' ')
- ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
- "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
- "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
- "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
- "SP"]
-\end{code}
-
-Code specific for Ints.
-
-\begin{code}
--- | Convert an 'Int' in the range @0@..@15@ to the corresponding single
--- digit 'Char'. This function fails on other inputs, and generates
--- lower-case hexadecimal digits.
-intToDigit :: Int -> Char
-intToDigit (I# i)
- | i >=# 0# && i <=# 9# = unsafeChr (ord '0' `plusInt` I# i)
- | i >=# 10# && i <=# 15# = unsafeChr (ord 'a' `minusInt` ten `plusInt` I# i)
- | otherwise = error ("Char.intToDigit: not a digit " ++ show (I# i))
-
-ten = I# 10#
-
-showSignedInt :: Int -> Int -> ShowS
-showSignedInt (I# p) (I# n) r
- | n <# 0# && p ># 6# = '(' : itos n (')' : r)
- | otherwise = itos n r
-
-itos :: Int# -> String -> String
-itos n# cs
- | n# <# 0# =
- let I# minInt# = minInt in
- if n# ==# minInt#
- -- negateInt# minInt overflows, so we can't do that:
- then '-' : itos' (negateInt# (n# `quotInt#` 10#))
- (itos' (negateInt# (n# `remInt#` 10#)) cs)
- else '-' : itos' (negateInt# n#) cs
- | otherwise = itos' n# cs
- where
- itos' :: Int# -> String -> String
- itos' n# cs
- | n# <# 10# = C# (chr# (ord# '0'# +# n#)) : cs
- | otherwise = case chr# (ord# '0'# +# (n# `remInt#` 10#)) of { c# ->
- itos' (n# `quotInt#` 10#) (C# c# : cs) }
-\end{code}
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Stable
--- Copyright : (c) The University of Glasgow, 1992-2004
--- License : see libraries/base/LICENSE
---
--- Maintainer : ffi@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- Stable pointers.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Stable
- ( StablePtr(..)
- , newStablePtr -- :: a -> IO (StablePtr a)
- , deRefStablePtr -- :: StablePtr a -> a
- , freeStablePtr -- :: StablePtr a -> IO ()
- , castStablePtrToPtr -- :: StablePtr a -> Ptr ()
- , castPtrToStablePtr -- :: Ptr () -> StablePtr a
- ) where
-
-import GHC.Ptr
-import GHC.Base
-import GHC.IOBase
-
------------------------------------------------------------------------------
--- Stable Pointers
-
-{- |
-A /stable pointer/ is a reference to a Haskell expression that is
-guaranteed not to be affected by garbage collection, i.e., it will neither be
-deallocated nor will the value of the stable pointer itself change during
-garbage collection (ordinary references may be relocated during garbage
-collection). Consequently, stable pointers can be passed to foreign code,
-which can treat it as an opaque reference to a Haskell value.
-
-A value of type @StablePtr a@ is a stable pointer to a Haskell
-expression of type @a@.
--}
-data StablePtr a = StablePtr (StablePtr# a)
-
--- |
--- Create a stable pointer referring to the given Haskell value.
---
-newStablePtr :: a -> IO (StablePtr a)
-newStablePtr a = IO $ \ s ->
- case makeStablePtr# a s of (# s', sp #) -> (# s', StablePtr sp #)
-
--- |
--- Obtain the Haskell value referenced by a stable pointer, i.e., the
--- same value that was passed to the corresponding call to
--- 'makeStablePtr'. If the argument to 'deRefStablePtr' has
--- already been freed using 'freeStablePtr', the behaviour of
--- 'deRefStablePtr' is undefined.
---
-deRefStablePtr :: StablePtr a -> IO a
-deRefStablePtr (StablePtr sp) = IO $ \s -> deRefStablePtr# sp s
-
--- |
--- Dissolve the association between the stable pointer and the Haskell
--- value. Afterwards, if the stable pointer is passed to
--- 'deRefStablePtr' or 'freeStablePtr', the behaviour is
--- undefined. However, the stable pointer may still be passed to
--- 'castStablePtrToPtr', but the @'Foreign.Ptr.Ptr' ()@ value returned
--- by 'castStablePtrToPtr', in this case, is undefined (in particular,
--- it may be 'Foreign.Ptr.nullPtr'). Nevertheless, the call
--- to 'castStablePtrToPtr' is guaranteed not to diverge.
---
-foreign import ccall unsafe "hs_free_stable_ptr" freeStablePtr :: StablePtr a -> IO ()
-
--- |
--- Coerce a stable pointer to an address. No guarantees are made about
--- the resulting value, except that the original stable pointer can be
--- recovered by 'castPtrToStablePtr'. In particular, the address may not
--- refer to an accessible memory location and any attempt to pass it to
--- the member functions of the class 'Foreign.Storable.Storable' leads to
--- undefined behaviour.
---
-castStablePtrToPtr :: StablePtr a -> Ptr ()
-castStablePtrToPtr (StablePtr s) = Ptr (unsafeCoerce# s)
-
-
--- |
--- The inverse of 'castStablePtrToPtr', i.e., we have the identity
---
--- > sp == castPtrToStablePtr (castStablePtrToPtr sp)
---
--- for any stable pointer @sp@ on which 'freeStablePtr' has
--- not been executed yet. Moreover, 'castPtrToStablePtr' may
--- only be applied to pointers that have been produced by
--- 'castStablePtrToPtr'.
---
-castPtrToStablePtr :: Ptr () -> StablePtr a
-castPtrToStablePtr (Ptr a) = StablePtr (unsafeCoerce# a)
-
-instance Eq (StablePtr a) where
- (StablePtr sp1) == (StablePtr sp2) =
- case eqStablePtr# sp1 sp2 of
- 0# -> False
- _ -> True
-\end{code}
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Storable
--- Copyright : (c) The FFI task force, 2000-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : ffi@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- Helper functions for "Foreign.Storable"
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Storable
- ( readWideCharOffPtr
- , readIntOffPtr
- , readWordOffPtr
- , readPtrOffPtr
- , readFunPtrOffPtr
- , readFloatOffPtr
- , readDoubleOffPtr
- , readStablePtrOffPtr
- , readInt8OffPtr
- , readInt16OffPtr
- , readInt32OffPtr
- , readInt64OffPtr
- , readWord8OffPtr
- , readWord16OffPtr
- , readWord32OffPtr
- , readWord64OffPtr
- , writeWideCharOffPtr
- , writeIntOffPtr
- , writeWordOffPtr
- , writePtrOffPtr
- , writeFunPtrOffPtr
- , writeFloatOffPtr
- , writeDoubleOffPtr
- , writeStablePtrOffPtr
- , writeInt8OffPtr
- , writeInt16OffPtr
- , writeInt32OffPtr
- , writeInt64OffPtr
- , writeWord8OffPtr
- , writeWord16OffPtr
- , writeWord32OffPtr
- , writeWord64OffPtr
- ) where
-
-import GHC.Stable ( StablePtr(..) )
-import GHC.Int
-import GHC.Word
-import GHC.Ptr
-import GHC.Float
-import GHC.IOBase
-import GHC.Base
-\end{code}
-
-\begin{code}
-
-readWideCharOffPtr :: Ptr Char -> Int -> IO Char
-readIntOffPtr :: Ptr Int -> Int -> IO Int
-readWordOffPtr :: Ptr Word -> Int -> IO Word
-readPtrOffPtr :: Ptr (Ptr a) -> Int -> IO (Ptr a)
-readFunPtrOffPtr :: Ptr (FunPtr a) -> Int -> IO (FunPtr a)
-readFloatOffPtr :: Ptr Float -> Int -> IO Float
-readDoubleOffPtr :: Ptr Double -> Int -> IO Double
-readStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> IO (StablePtr a)
-readInt8OffPtr :: Ptr Int8 -> Int -> IO Int8
-readInt16OffPtr :: Ptr Int16 -> Int -> IO Int16
-readInt32OffPtr :: Ptr Int32 -> Int -> IO Int32
-readInt64OffPtr :: Ptr Int64 -> Int -> IO Int64
-readWord8OffPtr :: Ptr Word8 -> Int -> IO Word8
-readWord16OffPtr :: Ptr Word16 -> Int -> IO Word16
-readWord32OffPtr :: Ptr Word32 -> Int -> IO Word32
-readWord64OffPtr :: Ptr Word64 -> Int -> IO Word64
-
-readWideCharOffPtr (Ptr a) (I# i)
- = IO $ \s -> case readWideCharOffAddr# a i s of (# s2, x #) -> (# s2, C# x #)
-readIntOffPtr (Ptr a) (I# i)
- = IO $ \s -> case readIntOffAddr# a i s of (# s2, x #) -> (# s2, I# x #)
-readWordOffPtr (Ptr a) (I# i)
- = IO $ \s -> case readWordOffAddr# a i s of (# s2, x #) -> (# s2, W# x #)
-readPtrOffPtr (Ptr a) (I# i)
- = IO $ \s -> case readAddrOffAddr# a i s of (# s2, x #) -> (# s2, Ptr x #)
-readFunPtrOffPtr (Ptr a) (I# i)
- = IO $ \s -> case readAddrOffAddr# a i s of (# s2, x #) -> (# s2, FunPtr x #)
-readFloatOffPtr (Ptr a) (I# i)
- = IO $ \s -> case readFloatOffAddr# a i s of (# s2, x #) -> (# s2, F# x #)
-readDoubleOffPtr (Ptr a) (I# i)
- = IO $ \s -> case readDoubleOffAddr# a i s of (# s2, x #) -> (# s2, D# x #)
-readStablePtrOffPtr (Ptr a) (I# i)
- = IO $ \s -> case readStablePtrOffAddr# a i s of (# s2, x #) -> (# s2, StablePtr x #)
-readInt8OffPtr (Ptr a) (I# i)
- = IO $ \s -> case readInt8OffAddr# a i s of (# s2, x #) -> (# s2, I8# x #)
-readWord8OffPtr (Ptr a) (I# i)
- = IO $ \s -> case readWord8OffAddr# a i s of (# s2, x #) -> (# s2, W8# x #)
-readInt16OffPtr (Ptr a) (I# i)
- = IO $ \s -> case readInt16OffAddr# a i s of (# s2, x #) -> (# s2, I16# x #)
-readWord16OffPtr (Ptr a) (I# i)
- = IO $ \s -> case readWord16OffAddr# a i s of (# s2, x #) -> (# s2, W16# x #)
-readInt32OffPtr (Ptr a) (I# i)
- = IO $ \s -> case readInt32OffAddr# a i s of (# s2, x #) -> (# s2, I32# x #)
-readWord32OffPtr (Ptr a) (I# i)
- = IO $ \s -> case readWord32OffAddr# a i s of (# s2, x #) -> (# s2, W32# x #)
-readInt64OffPtr (Ptr a) (I# i)
- = IO $ \s -> case readInt64OffAddr# a i s of (# s2, x #) -> (# s2, I64# x #)
-readWord64OffPtr (Ptr a) (I# i)
- = IO $ \s -> case readWord64OffAddr# a i s of (# s2, x #) -> (# s2, W64# x #)
-
-writeWideCharOffPtr :: Ptr Char -> Int -> Char -> IO ()
-writeIntOffPtr :: Ptr Int -> Int -> Int -> IO ()
-writeWordOffPtr :: Ptr Word -> Int -> Word -> IO ()
-writePtrOffPtr :: Ptr (Ptr a) -> Int -> Ptr a -> IO ()
-writeFunPtrOffPtr :: Ptr (FunPtr a) -> Int -> FunPtr a -> IO ()
-writeFloatOffPtr :: Ptr Float -> Int -> Float -> IO ()
-writeDoubleOffPtr :: Ptr Double -> Int -> Double -> IO ()
-writeStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> StablePtr a -> IO ()
-writeInt8OffPtr :: Ptr Int8 -> Int -> Int8 -> IO ()
-writeInt16OffPtr :: Ptr Int16 -> Int -> Int16 -> IO ()
-writeInt32OffPtr :: Ptr Int32 -> Int -> Int32 -> IO ()
-writeInt64OffPtr :: Ptr Int64 -> Int -> Int64 -> IO ()
-writeWord8OffPtr :: Ptr Word8 -> Int -> Word8 -> IO ()
-writeWord16OffPtr :: Ptr Word16 -> Int -> Word16 -> IO ()
-writeWord32OffPtr :: Ptr Word32 -> Int -> Word32 -> IO ()
-writeWord64OffPtr :: Ptr Word64 -> Int -> Word64 -> IO ()
-
-writeWideCharOffPtr (Ptr a) (I# i) (C# x)
- = IO $ \s -> case writeWideCharOffAddr# a i x s of s2 -> (# s2, () #)
-writeIntOffPtr (Ptr a) (I# i) (I# x)
- = IO $ \s -> case writeIntOffAddr# a i x s of s2 -> (# s2, () #)
-writeWordOffPtr (Ptr a) (I# i) (W# x)
- = IO $ \s -> case writeWordOffAddr# a i x s of s2 -> (# s2, () #)
-writePtrOffPtr (Ptr a) (I# i) (Ptr x)
- = IO $ \s -> case writeAddrOffAddr# a i x s of s2 -> (# s2, () #)
-writeFunPtrOffPtr (Ptr a) (I# i) (FunPtr x)
- = IO $ \s -> case writeAddrOffAddr# a i x s of s2 -> (# s2, () #)
-writeFloatOffPtr (Ptr a) (I# i) (F# x)
- = IO $ \s -> case writeFloatOffAddr# a i x s of s2 -> (# s2, () #)
-writeDoubleOffPtr (Ptr a) (I# i) (D# x)
- = IO $ \s -> case writeDoubleOffAddr# a i x s of s2 -> (# s2, () #)
-writeStablePtrOffPtr (Ptr a) (I# i) (StablePtr x)
- = IO $ \s -> case writeStablePtrOffAddr# a i x s of s2 -> (# s2 , () #)
-writeInt8OffPtr (Ptr a) (I# i) (I8# x)
- = IO $ \s -> case writeInt8OffAddr# a i x s of s2 -> (# s2, () #)
-writeWord8OffPtr (Ptr a) (I# i) (W8# x)
- = IO $ \s -> case writeWord8OffAddr# a i x s of s2 -> (# s2, () #)
-writeInt16OffPtr (Ptr a) (I# i) (I16# x)
- = IO $ \s -> case writeInt16OffAddr# a i x s of s2 -> (# s2, () #)
-writeWord16OffPtr (Ptr a) (I# i) (W16# x)
- = IO $ \s -> case writeWord16OffAddr# a i x s of s2 -> (# s2, () #)
-writeInt32OffPtr (Ptr a) (I# i) (I32# x)
- = IO $ \s -> case writeInt32OffAddr# a i x s of s2 -> (# s2, () #)
-writeWord32OffPtr (Ptr a) (I# i) (W32# x)
- = IO $ \s -> case writeWord32OffAddr# a i x s of s2 -> (# s2, () #)
-writeInt64OffPtr (Ptr a) (I# i) (I64# x)
- = IO $ \s -> case writeInt64OffAddr# a i x s of s2 -> (# s2, () #)
-writeWord64OffPtr (Ptr a) (I# i) (W64# x)
- = IO $ \s -> case writeWord64OffAddr# a i x s of s2 -> (# s2, () #)
-
-\end{code}
+++ /dev/null
-\begin{code}
------------------------------------------------------------------------------
--- |
--- Module : GHC.TopHandler
--- Copyright : (c) The University of Glasgow, 2001-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- Support for catching exceptions raised during top-level computations
--- (e.g. @Main.main@, 'Control.Concurrent.forkIO', and foreign exports)
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.TopHandler (
- runMainIO, runIO, runIOFastExit, runNonIO, reportStackOverflow, reportError
- ) where
-
-import Prelude
-
-import System.IO
-import Control.Exception
-
-import Foreign.C ( CInt )
-import GHC.IOBase
-import GHC.Exception
-import GHC.Prim (unsafeCoerce#)
-
--- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is
--- called in the program). It catches otherwise uncaught exceptions,
--- and also flushes stdout\/stderr before exiting.
-runMainIO :: IO a -> IO a
-runMainIO main = (do a <- main; cleanUp; return a) `catchException` topHandler
-
--- | 'runIO' is wrapped around every @foreign export@ and @foreign
--- import \"wrapper\"@ to mop up any uncaught exceptions. Thus, the
--- result of running 'System.Exit.exitWith' in a foreign-exported
--- function is the same as in the main thread: it terminates the
--- program.
---
-runIO :: IO a -> IO a
-runIO main = catchException main topHandler
-
--- | Like 'runIO', but in the event of an exception that causes an exit,
--- we don't shut down the system cleanly, we just exit. This is
--- useful in some cases, because the safe exit version will give other
--- threads a chance to clean up first, which might shut down the
--- system in a different way. For example, try
---
--- main = forkIO (runIO (exitWith (ExitFailure 1))) >> threadDelay 10000
---
--- This will sometimes exit with "interrupted" and code 0, because the
--- main thread is given a chance to shut down when the child thread calls
--- safeExit. There is a race to shut down between the main and child threads.
---
-runIOFastExit :: IO a -> IO a
-runIOFastExit main = catchException main topHandlerFastExit
- -- NB. this is used by the testsuite driver
-
--- | The same as 'runIO', but for non-IO computations. Used for
--- wrapping @foreign export@ and @foreign import \"wrapper\"@ when these
--- are used to export Haskell functions with non-IO types.
---
-runNonIO :: a -> IO a
-runNonIO a = catchException (a `seq` return a) topHandler
-
-topHandler :: Exception -> IO a
-topHandler err = catchException (real_handler safeExit err) topHandler
-
-topHandlerFastExit :: Exception -> IO a
-topHandlerFastExit err =
- catchException (real_handler fastExit err) topHandlerFastExit
-
--- Make sure we handle errors while reporting the error!
--- (e.g. evaluating the string passed to 'error' might generate
--- another error, etc.)
---
-real_handler :: (Int -> IO a) -> Exception -> IO a
-real_handler exit exn =
- cleanUp >>
- case exn of
- AsyncException StackOverflow -> do
- reportStackOverflow
- exit 2
-
- -- only the main thread gets ExitException exceptions
- ExitException ExitSuccess -> exit 0
- ExitException (ExitFailure n) -> exit n
-
- other -> do
- reportError other
- exit 1
-
-
-reportStackOverflow :: IO a
-reportStackOverflow = do callStackOverflowHook; return undefined
-
-reportError :: Exception -> IO a
-reportError ex = do
- handler <- getUncaughtExceptionHandler
- handler ex
- return undefined
-
--- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove
--- the unsafe below.
-foreign import ccall unsafe "stackOverflow"
- callStackOverflowHook :: IO ()
-
--- try to flush stdout/stderr, but don't worry if we fail
--- (these handles might have errors, and we don't want to go into
--- an infinite loop).
-cleanUp :: IO ()
-cleanUp = do
- hFlush stdout `catchException` \_ -> return ()
- hFlush stderr `catchException` \_ -> return ()
-
-cleanUpAndExit :: Int -> IO a
-cleanUpAndExit r = do cleanUp; safeExit r
-
--- we have to use unsafeCoerce# to get the 'IO a' result type, since the
--- compiler doesn't let us declare that as the result type of a foreign export.
-safeExit :: Int -> IO a
-safeExit r = unsafeCoerce# (shutdownHaskellAndExit $ fromIntegral r)
-
--- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
--- re-enter Haskell land through finalizers.
-foreign import ccall "Rts.h shutdownHaskellAndExit"
- shutdownHaskellAndExit :: CInt -> IO ()
-
-fastExit :: Int -> IO a
-fastExit r = unsafeCoerce# (stg_exit (fromIntegral r))
-
-foreign import ccall "Rts.h stg_exit"
- stg_exit :: CInt -> IO ()
-\end{code}
+++ /dev/null
-\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
-module GHC.TopHandler ( reportError, reportStackOverflow ) where
-
-import GHC.Exception ( Exception )
-import GHC.IOBase ( IO )
-
-reportError :: Exception -> IO a
-reportStackOverflow :: IO a
-\end{code}
+++ /dev/null
-{-# OPTIONS -fno-implicit-prelude #-}
-{-# OPTIONS -#include "WCsubst.h" #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Unicode
--- Copyright : (c) The University of Glasgow, 2003
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC extensions)
---
--- Implementations for the character predicates (isLower, isUpper, etc.)
--- and the conversions (toUpper, toLower). The implementation uses
--- libunicode on Unix systems if that is available.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Unicode (
- isAscii, isLatin1, isControl,
- isAsciiUpper, isAsciiLower,
- isPrint, isSpace, isUpper,
- isLower, isAlpha, isDigit,
- isOctDigit, isHexDigit, isAlphaNum,
- toUpper, toLower, toTitle,
- wgencat,
- ) where
-
-import GHC.Base
-import GHC.Real (fromIntegral)
-import GHC.Int
-import GHC.Word
-import GHC.Num (fromInteger)
-
-#include "HsBaseConfig.h"
-
--- | Selects the first 128 characters of the Unicode character set,
--- corresponding to the ASCII character set.
-isAscii :: Char -> Bool
-isAscii c = c < '\x80'
-
--- | Selects the first 256 characters of the Unicode character set,
--- corresponding to the ISO 8859-1 (Latin-1) character set.
-isLatin1 :: Char -> Bool
-isLatin1 c = c <= '\xff'
-
--- | Selects ASCII lower-case letters,
--- i.e. characters satisfying both 'isAscii' and 'isLower'.
-isAsciiLower :: Char -> Bool
-isAsciiLower c = c >= 'a' && c <= 'z'
-
--- | Selects ASCII upper-case letters,
--- i.e. characters satisfying both 'isAscii' and 'isUpper'.
-isAsciiUpper :: Char -> Bool
-isAsciiUpper c = c >= 'A' && c <= 'Z'
-
--- | Selects control characters, which are the non-printing characters of
--- the Latin-1 subset of Unicode.
-isControl :: Char -> Bool
-
--- | Selects printable Unicode characters
--- (letters, numbers, marks, punctuation, symbols and spaces).
-isPrint :: Char -> Bool
-
--- | Selects white-space characters in the Latin-1 range.
--- (In Unicode terms, this includes spaces and some control characters.)
-isSpace :: Char -> Bool
--- isSpace includes non-breaking space
--- Done with explicit equalities both for efficiency, and to avoid a tiresome
--- recursion with GHC.List elem
-isSpace c = c == ' ' ||
- c == '\t' ||
- c == '\n' ||
- c == '\r' ||
- c == '\f' ||
- c == '\v' ||
- c == '\xa0' ||
- iswspace (fromIntegral (ord c)) /= 0
-
--- | Selects upper-case or title-case alphabetic Unicode characters (letters).
--- Title case is used by a small number of letter ligatures like the
--- single-character form of /Lj/.
-isUpper :: Char -> Bool
-
--- | Selects lower-case alphabetic Unicode characters (letters).
-isLower :: Char -> Bool
-
--- | Selects alphabetic Unicode characters (lower-case, upper-case and
--- title-case letters, plus letters of caseless scripts and modifiers letters).
--- This function is equivalent to 'Data.Char.isLetter'.
-isAlpha :: Char -> Bool
-
--- | Selects alphabetic or numeric digit Unicode characters.
---
--- Note that numeric digits outside the ASCII range are selected by this
--- function but not by 'isDigit'. Such digits may be part of identifiers
--- but are not used by the printer and reader to represent numbers.
-isAlphaNum :: Char -> Bool
-
--- | Selects ASCII digits, i.e. @\'0\'@..@\'9\'@.
-isDigit :: Char -> Bool
-isDigit c = c >= '0' && c <= '9'
-
--- | Selects ASCII octal digits, i.e. @\'0\'@..@\'7\'@.
-isOctDigit :: Char -> Bool
-isOctDigit c = c >= '0' && c <= '7'
-
--- | Selects ASCII hexadecimal digits,
--- i.e. @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@.
-isHexDigit :: Char -> Bool
-isHexDigit c = isDigit c || c >= 'A' && c <= 'F' ||
- c >= 'a' && c <= 'f'
-
--- | Convert a letter to the corresponding upper-case letter, if any.
--- Any other character is returned unchanged.
-toUpper :: Char -> Char
-
--- | Convert a letter to the corresponding lower-case letter, if any.
--- Any other character is returned unchanged.
-toLower :: Char -> Char
-
--- | Convert a letter to the corresponding title-case or upper-case
--- letter, if any. (Title case differs from upper case only for a small
--- number of ligature letters.)
--- Any other character is returned unchanged.
-toTitle :: Char -> Char
-
--- -----------------------------------------------------------------------------
--- Implementation with the supplied auto-generated Unicode character properties
--- table (default)
-
-#if 1
-
--- Regardless of the O/S and Library, use the functions contained in WCsubst.c
-
-type CInt = HTYPE_INT
-
-isAlpha c = iswalpha (fromIntegral (ord c)) /= 0
-isAlphaNum c = iswalnum (fromIntegral (ord c)) /= 0
---isSpace c = iswspace (fromIntegral (ord c)) /= 0
-isControl c = iswcntrl (fromIntegral (ord c)) /= 0
-isPrint c = iswprint (fromIntegral (ord c)) /= 0
-isUpper c = iswupper (fromIntegral (ord c)) /= 0
-isLower c = iswlower (fromIntegral (ord c)) /= 0
-
-toLower c = chr (fromIntegral (towlower (fromIntegral (ord c))))
-toUpper c = chr (fromIntegral (towupper (fromIntegral (ord c))))
-toTitle c = chr (fromIntegral (towtitle (fromIntegral (ord c))))
-
-foreign import ccall unsafe "u_iswdigit"
- iswdigit :: CInt -> CInt
-
-foreign import ccall unsafe "u_iswalpha"
- iswalpha :: CInt -> CInt
-
-foreign import ccall unsafe "u_iswalnum"
- iswalnum :: CInt -> CInt
-
-foreign import ccall unsafe "u_iswcntrl"
- iswcntrl :: CInt -> CInt
-
-foreign import ccall unsafe "u_iswspace"
- iswspace :: CInt -> CInt
-
-foreign import ccall unsafe "u_iswprint"
- iswprint :: CInt -> CInt
-
-foreign import ccall unsafe "u_iswlower"
- iswlower :: CInt -> CInt
-
-foreign import ccall unsafe "u_iswupper"
- iswupper :: CInt -> CInt
-
-foreign import ccall unsafe "u_towlower"
- towlower :: CInt -> CInt
-
-foreign import ccall unsafe "u_towupper"
- towupper :: CInt -> CInt
-
-foreign import ccall unsafe "u_towtitle"
- towtitle :: CInt -> CInt
-
-foreign import ccall unsafe "u_gencat"
- wgencat :: CInt -> CInt
-
--- -----------------------------------------------------------------------------
--- No libunicode, so fall back to the ASCII-only implementation (never used, indeed)
-
-#else
-
-isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f'
-isPrint c = not (isControl c)
-
--- The upper case ISO characters have the multiplication sign dumped
--- randomly in the middle of the range. Go figure.
-isUpper c = c >= 'A' && c <= 'Z' ||
- c >= '\xC0' && c <= '\xD6' ||
- c >= '\xD8' && c <= '\xDE'
--- The lower case ISO characters have the division sign dumped
--- randomly in the middle of the range. Go figure.
-isLower c = c >= 'a' && c <= 'z' ||
- c >= '\xDF' && c <= '\xF6' ||
- c >= '\xF8' && c <= '\xFF'
-
-isAlpha c = isLower c || isUpper c
-isAlphaNum c = isAlpha c || isDigit c
-
--- Case-changing operations
-
-toUpper c@(C# c#)
- | isAsciiLower c = C# (chr# (ord# c# -# 32#))
- | isAscii c = c
- -- fall-through to the slower stuff.
- | isLower c && c /= '\xDF' && c /= '\xFF'
- = unsafeChr (ord c `minusInt` ord 'a' `plusInt` ord 'A')
- | otherwise
- = c
-
-
-toLower c@(C# c#)
- | isAsciiUpper c = C# (chr# (ord# c# +# 32#))
- | isAscii c = c
- | isUpper c = unsafeChr (ord c `minusInt` ord 'A' `plusInt` ord 'a')
- | otherwise = c
-
-#endif
-
+++ /dev/null
-{-# OPTIONS -fno-implicit-prelude #-}
-
-module GHC.Unicode where
-import GHC.Base( Char, Bool )
-
-isAscii :: Char -> Bool
-isLatin1 :: Char -> Bool
-isControl :: Char -> Bool
-isPrint :: Char -> Bool
-isSpace :: Char -> Bool
-isUpper :: Char -> Bool
-isLower :: Char -> Bool
-isAlpha :: Char -> Bool
-isDigit :: Char -> Bool
-isOctDigit :: Char -> Bool
-isHexDigit :: Char -> Bool
-isAlphaNum :: Char -> Bool
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Weak
--- Copyright : (c) The University of Glasgow, 1998-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- Weak pointers.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.Weak where
-
-import GHC.Base
-import Data.Maybe
-import GHC.IOBase ( IO(..), unIO )
-import Data.Typeable ( Typeable1(..), mkTyCon, mkTyConApp )
-
-{-|
-A weak pointer object with a key and a value. The value has type @v@.
-
-A weak pointer expresses a relationship between two objects, the
-/key/ and the /value/: if the key is considered to be alive by the
-garbage collector, then the value is also alive. A reference from
-the value to the key does /not/ keep the key alive.
-
-A weak pointer may also have a finalizer of type @IO ()@; if it does,
-then the finalizer will be run at most once, at a time after the key
-has become unreachable by the program (\"dead\"). The storage manager
-attempts to run the finalizer(s) for an object soon after the object
-dies, but promptness is not guaranteed.
-
-It is not guaranteed that a finalizer will eventually run, and no
-attempt is made to run outstanding finalizers when the program exits.
-Therefore finalizers should not be relied on to clean up resources -
-other methods (eg. exception handlers) should be employed, possibly in
-addition to finalisers.
-
-References from the finalizer to the key are treated in the same way
-as references from the value to the key: they do not keep the key
-alive. A finalizer may therefore ressurrect the key, perhaps by
-storing it in the same data structure.
-
-The finalizer, and the relationship between the key and the value,
-exist regardless of whether the program keeps a reference to the
-'Weak' object or not.
-
-There may be multiple weak pointers with the same key. In this
-case, the finalizers for each of these weak pointers will all be
-run in some arbitrary order, or perhaps concurrently, when the key
-dies. If the programmer specifies a finalizer that assumes it has
-the only reference to an object (for example, a file that it wishes
-to close), then the programmer must ensure that there is only one
-such finalizer.
-
-If there are no other threads to run, the runtime system will check
-for runnable finalizers before declaring the system to be deadlocked.
--}
-data Weak v = Weak (Weak# v)
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(Weak,weakTc,"Weak")
-
--- | Establishes a weak pointer to @k@, with value @v@ and a finalizer.
---
--- This is the most general interface for building a weak pointer.
---
-mkWeak :: k -- ^ key
- -> v -- ^ value
- -> Maybe (IO ()) -- ^ finalizer
- -> IO (Weak v) -- ^ returns: a weak pointer object
-
-mkWeak key val (Just finalizer) = IO $ \s ->
- case mkWeak# key val finalizer s of { (# s1, w #) -> (# s1, Weak w #) }
-mkWeak key val Nothing = IO $ \s ->
- case mkWeak# key val (unsafeCoerce# 0#) s of { (# s1, w #) -> (# s1, Weak w #) }
-
-{-|
-Dereferences a weak pointer. If the key is still alive, then
-@'Just' v@ is returned (where @v@ is the /value/ in the weak pointer), otherwise
-'Nothing' is returned.
-
-The return value of 'deRefWeak' depends on when the garbage collector
-runs, hence it is in the 'IO' monad.
--}
-deRefWeak :: Weak v -> IO (Maybe v)
-deRefWeak (Weak w) = IO $ \s ->
- case deRefWeak# w s of
- (# s1, flag, p #) -> case flag of
- 0# -> (# s1, Nothing #)
- _ -> (# s1, Just p #)
-
--- | Causes a the finalizer associated with a weak pointer to be run
--- immediately.
-finalize :: Weak v -> IO ()
-finalize (Weak w) = IO $ \s ->
- case finalizeWeak# w s of
- (# s1, 0#, _ #) -> (# s1, () #) -- already dead, or no finaliser
- (# s1, _, f #) -> f s1
-
-{-
-Instance Eq (Weak v) where
- (Weak w1) == (Weak w2) = w1 `sameWeak#` w2
--}
-
-
--- run a batch of finalizers from the garbage collector. We're given
--- an array of finalizers and the length of the array, and we just
--- call each one in turn.
---
--- the IO primitives are inlined by hand here to get the optimal
--- code (sigh) --SDM.
-
-runFinalizerBatch :: Int -> Array# (IO ()) -> IO ()
-runFinalizerBatch (I# n) arr =
- let go m = IO $ \s ->
- case m of
- 0# -> (# s, () #)
- _ -> let m' = m -# 1# in
- case indexArray# arr m' of { (# io #) ->
- case unIO io s of { (# s, _ #) ->
- unIO (go m') s
- }}
- in
- go n
-
-\end{code}
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.Word
--- Copyright : (c) The University of Glasgow, 1997-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- Sized unsigned integral types: 'Word', 'Word8', 'Word16', 'Word32', and
--- 'Word64'.
---
------------------------------------------------------------------------------
-
-#include "MachDeps.h"
-
--- #hide
-module GHC.Word (
- Word(..), Word8(..), Word16(..), Word32(..), Word64(..),
- toEnumError, fromEnumError, succError, predError)
- where
-
-import Data.Bits
-
-import {-# SOURCE #-} GHC.Err
-import GHC.Base
-import GHC.Enum
-import GHC.Num
-import GHC.Real
-import GHC.Read
-import GHC.Arr
-import GHC.Show
-
-------------------------------------------------------------------------
--- Helper functions
-------------------------------------------------------------------------
-
-{-# NOINLINE toEnumError #-}
-toEnumError :: (Show a) => String -> Int -> (a,a) -> b
-toEnumError inst_ty i bnds =
- error $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" ++
- show i ++
- ") is outside of bounds " ++
- show bnds
-
-{-# NOINLINE fromEnumError #-}
-fromEnumError :: (Show a) => String -> a -> b
-fromEnumError inst_ty x =
- error $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" ++
- show x ++
- ") is outside of Int's bounds " ++
- show (minBound::Int, maxBound::Int)
-
-{-# NOINLINE succError #-}
-succError :: String -> a
-succError inst_ty =
- error $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound"
-
-{-# NOINLINE predError #-}
-predError :: String -> a
-predError inst_ty =
- error $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound"
-
-------------------------------------------------------------------------
--- type Word
-------------------------------------------------------------------------
-
--- |A 'Word' is an unsigned integral type, with the same size as 'Int'.
-data Word = W# Word# deriving (Eq, Ord)
-
-instance Show Word where
- showsPrec p x = showsPrec p (toInteger x)
-
-instance Num Word where
- (W# x#) + (W# y#) = W# (x# `plusWord#` y#)
- (W# x#) - (W# y#) = W# (x# `minusWord#` y#)
- (W# x#) * (W# y#) = W# (x# `timesWord#` y#)
- negate (W# x#) = W# (int2Word# (negateInt# (word2Int# x#)))
- abs x = x
- signum 0 = 0
- signum _ = 1
- fromInteger (S# i#) = W# (int2Word# i#)
- fromInteger (J# s# d#) = W# (integer2Word# s# d#)
-
-instance Real Word where
- toRational x = toInteger x % 1
-
-instance Enum Word where
- succ x
- | x /= maxBound = x + 1
- | otherwise = succError "Word"
- pred x
- | x /= minBound = x - 1
- | otherwise = predError "Word"
- toEnum i@(I# i#)
- | i >= 0 = W# (int2Word# i#)
- | otherwise = toEnumError "Word" i (minBound::Word, maxBound::Word)
- fromEnum x@(W# x#)
- | x <= fromIntegral (maxBound::Int)
- = I# (word2Int# x#)
- | otherwise = fromEnumError "Word" x
- enumFrom = integralEnumFrom
- enumFromThen = integralEnumFromThen
- enumFromTo = integralEnumFromTo
- enumFromThenTo = integralEnumFromThenTo
-
-instance Integral Word where
- quot x@(W# x#) y@(W# y#)
- | y /= 0 = W# (x# `quotWord#` y#)
- | otherwise = divZeroError
- rem x@(W# x#) y@(W# y#)
- | y /= 0 = W# (x# `remWord#` y#)
- | otherwise = divZeroError
- div x@(W# x#) y@(W# y#)
- | y /= 0 = W# (x# `quotWord#` y#)
- | otherwise = divZeroError
- mod x@(W# x#) y@(W# y#)
- | y /= 0 = W# (x# `remWord#` y#)
- | otherwise = divZeroError
- quotRem x@(W# x#) y@(W# y#)
- | y /= 0 = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#))
- | otherwise = divZeroError
- divMod x@(W# x#) y@(W# y#)
- | y /= 0 = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#))
- | otherwise = divZeroError
- toInteger (W# x#)
- | i# >=# 0# = S# i#
- | otherwise = case word2Integer# x# of (# s, d #) -> J# s d
- where
- i# = word2Int# x#
-
-instance Bounded Word where
- minBound = 0
-
- -- use unboxed literals for maxBound, because GHC doesn't optimise
- -- (fromInteger 0xffffffff :: Word).
-#if WORD_SIZE_IN_BITS == 31
- maxBound = W# (int2Word# 0x7FFFFFFF#)
-#elif WORD_SIZE_IN_BITS == 32
- maxBound = W# (int2Word# 0xFFFFFFFF#)
-#else
- maxBound = W# (int2Word# 0xFFFFFFFFFFFFFFFF#)
-#endif
-
-instance Ix Word where
- range (m,n) = [m..n]
- unsafeIndex b@(m,_) i = fromIntegral (i - m)
- inRange (m,n) i = m <= i && i <= n
-
-instance Read Word where
- readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]
-
-instance Bits Word where
- {-# INLINE shift #-}
-
- (W# x#) .&. (W# y#) = W# (x# `and#` y#)
- (W# x#) .|. (W# y#) = W# (x# `or#` y#)
- (W# x#) `xor` (W# y#) = W# (x# `xor#` y#)
- complement (W# x#) = W# (x# `xor#` mb#) where W# mb# = maxBound
- (W# x#) `shift` (I# i#)
- | i# >=# 0# = W# (x# `shiftL#` i#)
- | otherwise = W# (x# `shiftRL#` negateInt# i#)
- (W# x#) `rotate` (I# i#)
- | i'# ==# 0# = W# x#
- | otherwise = W# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (wsib -# i'#)))
- where
- i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#))
- wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -}
- bitSize _ = WORD_SIZE_IN_BITS
- isSigned _ = False
-
-{-# RULES
-"fromIntegral/Int->Word" fromIntegral = \(I# x#) -> W# (int2Word# x#)
-"fromIntegral/Word->Int" fromIntegral = \(W# x#) -> I# (word2Int# x#)
-"fromIntegral/Word->Word" fromIntegral = id :: Word -> Word
- #-}
-
-------------------------------------------------------------------------
--- type Word8
-------------------------------------------------------------------------
-
--- Word8 is represented in the same way as Word. Operations may assume
--- and must ensure that it holds only values from its logical range.
-
-data Word8 = W8# Word# deriving (Eq, Ord)
--- ^ 8-bit unsigned integer type
-
-instance Show Word8 where
- showsPrec p x = showsPrec p (fromIntegral x :: Int)
-
-instance Num Word8 where
- (W8# x#) + (W8# y#) = W8# (narrow8Word# (x# `plusWord#` y#))
- (W8# x#) - (W8# y#) = W8# (narrow8Word# (x# `minusWord#` y#))
- (W8# x#) * (W8# y#) = W8# (narrow8Word# (x# `timesWord#` y#))
- negate (W8# x#) = W8# (narrow8Word# (int2Word# (negateInt# (word2Int# x#))))
- abs x = x
- signum 0 = 0
- signum _ = 1
- fromInteger (S# i#) = W8# (narrow8Word# (int2Word# i#))
- fromInteger (J# s# d#) = W8# (narrow8Word# (integer2Word# s# d#))
-
-instance Real Word8 where
- toRational x = toInteger x % 1
-
-instance Enum Word8 where
- succ x
- | x /= maxBound = x + 1
- | otherwise = succError "Word8"
- pred x
- | x /= minBound = x - 1
- | otherwise = predError "Word8"
- toEnum i@(I# i#)
- | i >= 0 && i <= fromIntegral (maxBound::Word8)
- = W8# (int2Word# i#)
- | otherwise = toEnumError "Word8" i (minBound::Word8, maxBound::Word8)
- fromEnum (W8# x#) = I# (word2Int# x#)
- enumFrom = boundedEnumFrom
- enumFromThen = boundedEnumFromThen
-
-instance Integral Word8 where
- quot x@(W8# x#) y@(W8# y#)
- | y /= 0 = W8# (x# `quotWord#` y#)
- | otherwise = divZeroError
- rem x@(W8# x#) y@(W8# y#)
- | y /= 0 = W8# (x# `remWord#` y#)
- | otherwise = divZeroError
- div x@(W8# x#) y@(W8# y#)
- | y /= 0 = W8# (x# `quotWord#` y#)
- | otherwise = divZeroError
- mod x@(W8# x#) y@(W8# y#)
- | y /= 0 = W8# (x# `remWord#` y#)
- | otherwise = divZeroError
- quotRem x@(W8# x#) y@(W8# y#)
- | y /= 0 = (W8# (x# `quotWord#` y#), W8# (x# `remWord#` y#))
- | otherwise = divZeroError
- divMod x@(W8# x#) y@(W8# y#)
- | y /= 0 = (W8# (x# `quotWord#` y#), W8# (x# `remWord#` y#))
- | otherwise = divZeroError
- toInteger (W8# x#) = S# (word2Int# x#)
-
-instance Bounded Word8 where
- minBound = 0
- maxBound = 0xFF
-
-instance Ix Word8 where
- range (m,n) = [m..n]
- unsafeIndex b@(m,_) i = fromIntegral (i - m)
- inRange (m,n) i = m <= i && i <= n
-
-instance Read Word8 where
- readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]
-
-instance Bits Word8 where
- {-# INLINE shift #-}
-
- (W8# x#) .&. (W8# y#) = W8# (x# `and#` y#)
- (W8# x#) .|. (W8# y#) = W8# (x# `or#` y#)
- (W8# x#) `xor` (W8# y#) = W8# (x# `xor#` y#)
- complement (W8# x#) = W8# (x# `xor#` mb#) where W8# mb# = maxBound
- (W8# x#) `shift` (I# i#)
- | i# >=# 0# = W8# (narrow8Word# (x# `shiftL#` i#))
- | otherwise = W8# (x# `shiftRL#` negateInt# i#)
- (W8# x#) `rotate` (I# i#)
- | i'# ==# 0# = W8# x#
- | otherwise = W8# (narrow8Word# ((x# `uncheckedShiftL#` i'#) `or#`
- (x# `uncheckedShiftRL#` (8# -# i'#))))
- where
- i'# = word2Int# (int2Word# i# `and#` int2Word# 7#)
- bitSize _ = 8
- isSigned _ = False
-
-{-# RULES
-"fromIntegral/Word8->Word8" fromIntegral = id :: Word8 -> Word8
-"fromIntegral/Word8->Integer" fromIntegral = toInteger :: Word8 -> Integer
-"fromIntegral/a->Word8" fromIntegral = \x -> case fromIntegral x of W# x# -> W8# (narrow8Word# x#)
-"fromIntegral/Word8->a" fromIntegral = \(W8# x#) -> fromIntegral (W# x#)
- #-}
-
-------------------------------------------------------------------------
--- type Word16
-------------------------------------------------------------------------
-
--- Word16 is represented in the same way as Word. Operations may assume
--- and must ensure that it holds only values from its logical range.
-
-data Word16 = W16# Word# deriving (Eq, Ord)
--- ^ 16-bit unsigned integer type
-
-instance Show Word16 where
- showsPrec p x = showsPrec p (fromIntegral x :: Int)
-
-instance Num Word16 where
- (W16# x#) + (W16# y#) = W16# (narrow16Word# (x# `plusWord#` y#))
- (W16# x#) - (W16# y#) = W16# (narrow16Word# (x# `minusWord#` y#))
- (W16# x#) * (W16# y#) = W16# (narrow16Word# (x# `timesWord#` y#))
- negate (W16# x#) = W16# (narrow16Word# (int2Word# (negateInt# (word2Int# x#))))
- abs x = x
- signum 0 = 0
- signum _ = 1
- fromInteger (S# i#) = W16# (narrow16Word# (int2Word# i#))
- fromInteger (J# s# d#) = W16# (narrow16Word# (integer2Word# s# d#))
-
-instance Real Word16 where
- toRational x = toInteger x % 1
-
-instance Enum Word16 where
- succ x
- | x /= maxBound = x + 1
- | otherwise = succError "Word16"
- pred x
- | x /= minBound = x - 1
- | otherwise = predError "Word16"
- toEnum i@(I# i#)
- | i >= 0 && i <= fromIntegral (maxBound::Word16)
- = W16# (int2Word# i#)
- | otherwise = toEnumError "Word16" i (minBound::Word16, maxBound::Word16)
- fromEnum (W16# x#) = I# (word2Int# x#)
- enumFrom = boundedEnumFrom
- enumFromThen = boundedEnumFromThen
-
-instance Integral Word16 where
- quot x@(W16# x#) y@(W16# y#)
- | y /= 0 = W16# (x# `quotWord#` y#)
- | otherwise = divZeroError
- rem x@(W16# x#) y@(W16# y#)
- | y /= 0 = W16# (x# `remWord#` y#)
- | otherwise = divZeroError
- div x@(W16# x#) y@(W16# y#)
- | y /= 0 = W16# (x# `quotWord#` y#)
- | otherwise = divZeroError
- mod x@(W16# x#) y@(W16# y#)
- | y /= 0 = W16# (x# `remWord#` y#)
- | otherwise = divZeroError
- quotRem x@(W16# x#) y@(W16# y#)
- | y /= 0 = (W16# (x# `quotWord#` y#), W16# (x# `remWord#` y#))
- | otherwise = divZeroError
- divMod x@(W16# x#) y@(W16# y#)
- | y /= 0 = (W16# (x# `quotWord#` y#), W16# (x# `remWord#` y#))
- | otherwise = divZeroError
- toInteger (W16# x#) = S# (word2Int# x#)
-
-instance Bounded Word16 where
- minBound = 0
- maxBound = 0xFFFF
-
-instance Ix Word16 where
- range (m,n) = [m..n]
- unsafeIndex b@(m,_) i = fromIntegral (i - m)
- inRange (m,n) i = m <= i && i <= n
-
-instance Read Word16 where
- readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]
-
-instance Bits Word16 where
- {-# INLINE shift #-}
-
- (W16# x#) .&. (W16# y#) = W16# (x# `and#` y#)
- (W16# x#) .|. (W16# y#) = W16# (x# `or#` y#)
- (W16# x#) `xor` (W16# y#) = W16# (x# `xor#` y#)
- complement (W16# x#) = W16# (x# `xor#` mb#) where W16# mb# = maxBound
- (W16# x#) `shift` (I# i#)
- | i# >=# 0# = W16# (narrow16Word# (x# `shiftL#` i#))
- | otherwise = W16# (x# `shiftRL#` negateInt# i#)
- (W16# x#) `rotate` (I# i#)
- | i'# ==# 0# = W16# x#
- | otherwise = W16# (narrow16Word# ((x# `uncheckedShiftL#` i'#) `or#`
- (x# `uncheckedShiftRL#` (16# -# i'#))))
- where
- i'# = word2Int# (int2Word# i# `and#` int2Word# 15#)
- bitSize _ = 16
- isSigned _ = False
-
-{-# RULES
-"fromIntegral/Word8->Word16" fromIntegral = \(W8# x#) -> W16# x#
-"fromIntegral/Word16->Word16" fromIntegral = id :: Word16 -> Word16
-"fromIntegral/Word16->Integer" fromIntegral = toInteger :: Word16 -> Integer
-"fromIntegral/a->Word16" fromIntegral = \x -> case fromIntegral x of W# x# -> W16# (narrow16Word# x#)
-"fromIntegral/Word16->a" fromIntegral = \(W16# x#) -> fromIntegral (W# x#)
- #-}
-
-------------------------------------------------------------------------
--- type Word32
-------------------------------------------------------------------------
-
-#if WORD_SIZE_IN_BITS < 32
-
-data Word32 = W32# Word32#
--- ^ 32-bit unsigned integer type
-
-instance Eq Word32 where
- (W32# x#) == (W32# y#) = x# `eqWord32#` y#
- (W32# x#) /= (W32# y#) = x# `neWord32#` y#
-
-instance Ord Word32 where
- (W32# x#) < (W32# y#) = x# `ltWord32#` y#
- (W32# x#) <= (W32# y#) = x# `leWord32#` y#
- (W32# x#) > (W32# y#) = x# `gtWord32#` y#
- (W32# x#) >= (W32# y#) = x# `geWord32#` y#
-
-instance Num Word32 where
- (W32# x#) + (W32# y#) = W32# (int32ToWord32# (word32ToInt32# x# `plusInt32#` word32ToInt32# y#))
- (W32# x#) - (W32# y#) = W32# (int32ToWord32# (word32ToInt32# x# `minusInt32#` word32ToInt32# y#))
- (W32# x#) * (W32# y#) = W32# (int32ToWord32# (word32ToInt32# x# `timesInt32#` word32ToInt32# y#))
- negate (W32# x#) = W32# (int32ToWord32# (negateInt32# (word32ToInt32# x#)))
- abs x = x
- signum 0 = 0
- signum _ = 1
- fromInteger (S# i#) = W32# (int32ToWord32# (intToInt32# i#))
- fromInteger (J# s# d#) = W32# (integerToWord32# s# d#)
-
-instance Enum Word32 where
- succ x
- | x /= maxBound = x + 1
- | otherwise = succError "Word32"
- pred x
- | x /= minBound = x - 1
- | otherwise = predError "Word32"
- toEnum i@(I# i#)
- | i >= 0 = W32# (wordToWord32# (int2Word# i#))
- | otherwise = toEnumError "Word32" i (minBound::Word32, maxBound::Word32)
- fromEnum x@(W32# x#)
- | x <= fromIntegral (maxBound::Int)
- = I# (word2Int# (word32ToWord# x#))
- | otherwise = fromEnumError "Word32" x
- enumFrom = integralEnumFrom
- enumFromThen = integralEnumFromThen
- enumFromTo = integralEnumFromTo
- enumFromThenTo = integralEnumFromThenTo
-
-instance Integral Word32 where
- quot x@(W32# x#) y@(W32# y#)
- | y /= 0 = W32# (x# `quotWord32#` y#)
- | otherwise = divZeroError
- rem x@(W32# x#) y@(W32# y#)
- | y /= 0 = W32# (x# `remWord32#` y#)
- | otherwise = divZeroError
- div x@(W32# x#) y@(W32# y#)
- | y /= 0 = W32# (x# `quotWord32#` y#)
- | otherwise = divZeroError
- mod x@(W32# x#) y@(W32# y#)
- | y /= 0 = W32# (x# `remWord32#` y#)
- | otherwise = divZeroError
- quotRem x@(W32# x#) y@(W32# y#)
- | y /= 0 = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#))
- | otherwise = divZeroError
- divMod x@(W32# x#) y@(W32# y#)
- | y /= 0 = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#))
- | otherwise = divZeroError
- toInteger x@(W32# x#)
- | x <= fromIntegral (maxBound::Int) = S# (word2Int# (word32ToWord# x#))
- | otherwise = case word32ToInteger# x# of (# s, d #) -> J# s d
-
-instance Bits Word32 where
- {-# INLINE shift #-}
-
- (W32# x#) .&. (W32# y#) = W32# (x# `and32#` y#)
- (W32# x#) .|. (W32# y#) = W32# (x# `or32#` y#)
- (W32# x#) `xor` (W32# y#) = W32# (x# `xor32#` y#)
- complement (W32# x#) = W32# (not32# x#)
- (W32# x#) `shift` (I# i#)
- | i# >=# 0# = W32# (x# `shiftL32#` i#)
- | otherwise = W32# (x# `shiftRL32#` negateInt# i#)
- (W32# x#) `rotate` (I# i#)
- | i'# ==# 0# = W32# x#
- | otherwise = W32# ((x# `shiftL32#` i'#) `or32#`
- (x# `shiftRL32#` (32# -# i'#)))
- where
- i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)
- bitSize _ = 32
- isSigned _ = False
-
-foreign import unsafe "stg_eqWord32" eqWord32# :: Word32# -> Word32# -> Bool
-foreign import unsafe "stg_neWord32" neWord32# :: Word32# -> Word32# -> Bool
-foreign import unsafe "stg_ltWord32" ltWord32# :: Word32# -> Word32# -> Bool
-foreign import unsafe "stg_leWord32" leWord32# :: Word32# -> Word32# -> Bool
-foreign import unsafe "stg_gtWord32" gtWord32# :: Word32# -> Word32# -> Bool
-foreign import unsafe "stg_geWord32" geWord32# :: Word32# -> Word32# -> Bool
-foreign import unsafe "stg_int32ToWord32" int32ToWord32# :: Int32# -> Word32#
-foreign import unsafe "stg_word32ToInt32" word32ToInt32# :: Word32# -> Int32#
-foreign import unsafe "stg_intToInt32" intToInt32# :: Int# -> Int32#
-foreign import unsafe "stg_wordToWord32" wordToWord32# :: Word# -> Word32#
-foreign import unsafe "stg_word32ToWord" word32ToWord# :: Word32# -> Word#
-foreign import unsafe "stg_plusInt32" plusInt32# :: Int32# -> Int32# -> Int32#
-foreign import unsafe "stg_minusInt32" minusInt32# :: Int32# -> Int32# -> Int32#
-foreign import unsafe "stg_timesInt32" timesInt32# :: Int32# -> Int32# -> Int32#
-foreign import unsafe "stg_negateInt32" negateInt32# :: Int32# -> Int32#
-foreign import unsafe "stg_quotWord32" quotWord32# :: Word32# -> Word32# -> Word32#
-foreign import unsafe "stg_remWord32" remWord32# :: Word32# -> Word32# -> Word32#
-foreign import unsafe "stg_and32" and32# :: Word32# -> Word32# -> Word32#
-foreign import unsafe "stg_or32" or32# :: Word32# -> Word32# -> Word32#
-foreign import unsafe "stg_xor32" xor32# :: Word32# -> Word32# -> Word32#
-foreign import unsafe "stg_not32" not32# :: Word32# -> Word32#
-foreign import unsafe "stg_shiftL32" shiftL32# :: Word32# -> Int# -> Word32#
-foreign import unsafe "stg_shiftRL32" shiftRL32# :: Word32# -> Int# -> Word32#
-
-{-# RULES
-"fromIntegral/Int->Word32" fromIntegral = \(I# x#) -> W32# (int32ToWord32# (intToInt32# x#))
-"fromIntegral/Word->Word32" fromIntegral = \(W# x#) -> W32# (wordToWord32# x#)
-"fromIntegral/Word32->Int" fromIntegral = \(W32# x#) -> I# (word2Int# (word32ToWord# x#))
-"fromIntegral/Word32->Word" fromIntegral = \(W32# x#) -> W# (word32ToWord# x#)
-"fromIntegral/Word32->Word32" fromIntegral = id :: Word32 -> Word32
- #-}
-
-#else
-
--- Word32 is represented in the same way as Word.
-#if WORD_SIZE_IN_BITS > 32
--- Operations may assume and must ensure that it holds only values
--- from its logical range.
-#endif
-
-data Word32 = W32# Word# deriving (Eq, Ord)
--- ^ 32-bit unsigned integer type
-
-instance Num Word32 where
- (W32# x#) + (W32# y#) = W32# (narrow32Word# (x# `plusWord#` y#))
- (W32# x#) - (W32# y#) = W32# (narrow32Word# (x# `minusWord#` y#))
- (W32# x#) * (W32# y#) = W32# (narrow32Word# (x# `timesWord#` y#))
- negate (W32# x#) = W32# (narrow32Word# (int2Word# (negateInt# (word2Int# x#))))
- abs x = x
- signum 0 = 0
- signum _ = 1
- fromInteger (S# i#) = W32# (narrow32Word# (int2Word# i#))
- fromInteger (J# s# d#) = W32# (narrow32Word# (integer2Word# s# d#))
-
-instance Enum Word32 where
- succ x
- | x /= maxBound = x + 1
- | otherwise = succError "Word32"
- pred x
- | x /= minBound = x - 1
- | otherwise = predError "Word32"
- toEnum i@(I# i#)
- | i >= 0
-#if WORD_SIZE_IN_BITS > 32
- && i <= fromIntegral (maxBound::Word32)
-#endif
- = W32# (int2Word# i#)
- | otherwise = toEnumError "Word32" i (minBound::Word32, maxBound::Word32)
-#if WORD_SIZE_IN_BITS == 32
- fromEnum x@(W32# x#)
- | x <= fromIntegral (maxBound::Int)
- = I# (word2Int# x#)
- | otherwise = fromEnumError "Word32" x
- enumFrom = integralEnumFrom
- enumFromThen = integralEnumFromThen
- enumFromTo = integralEnumFromTo
- enumFromThenTo = integralEnumFromThenTo
-#else
- fromEnum (W32# x#) = I# (word2Int# x#)
- enumFrom = boundedEnumFrom
- enumFromThen = boundedEnumFromThen
-#endif
-
-instance Integral Word32 where
- quot x@(W32# x#) y@(W32# y#)
- | y /= 0 = W32# (x# `quotWord#` y#)
- | otherwise = divZeroError
- rem x@(W32# x#) y@(W32# y#)
- | y /= 0 = W32# (x# `remWord#` y#)
- | otherwise = divZeroError
- div x@(W32# x#) y@(W32# y#)
- | y /= 0 = W32# (x# `quotWord#` y#)
- | otherwise = divZeroError
- mod x@(W32# x#) y@(W32# y#)
- | y /= 0 = W32# (x# `remWord#` y#)
- | otherwise = divZeroError
- quotRem x@(W32# x#) y@(W32# y#)
- | y /= 0 = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#))
- | otherwise = divZeroError
- divMod x@(W32# x#) y@(W32# y#)
- | y /= 0 = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#))
- | otherwise = divZeroError
- toInteger (W32# x#)
-#if WORD_SIZE_IN_BITS == 32
- | i# >=# 0# = S# i#
- | otherwise = case word2Integer# x# of (# s, d #) -> J# s d
- where
- i# = word2Int# x#
-#else
- = S# (word2Int# x#)
-#endif
-
-instance Bits Word32 where
- {-# INLINE shift #-}
-
- (W32# x#) .&. (W32# y#) = W32# (x# `and#` y#)
- (W32# x#) .|. (W32# y#) = W32# (x# `or#` y#)
- (W32# x#) `xor` (W32# y#) = W32# (x# `xor#` y#)
- complement (W32# x#) = W32# (x# `xor#` mb#) where W32# mb# = maxBound
- (W32# x#) `shift` (I# i#)
- | i# >=# 0# = W32# (narrow32Word# (x# `shiftL#` i#))
- | otherwise = W32# (x# `shiftRL#` negateInt# i#)
- (W32# x#) `rotate` (I# i#)
- | i'# ==# 0# = W32# x#
- | otherwise = W32# (narrow32Word# ((x# `uncheckedShiftL#` i'#) `or#`
- (x# `uncheckedShiftRL#` (32# -# i'#))))
- where
- i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)
- bitSize _ = 32
- isSigned _ = False
-
-{-# RULES
-"fromIntegral/Word8->Word32" fromIntegral = \(W8# x#) -> W32# x#
-"fromIntegral/Word16->Word32" fromIntegral = \(W16# x#) -> W32# x#
-"fromIntegral/Word32->Word32" fromIntegral = id :: Word32 -> Word32
-"fromIntegral/Word32->Integer" fromIntegral = toInteger :: Word32 -> Integer
-"fromIntegral/a->Word32" fromIntegral = \x -> case fromIntegral x of W# x# -> W32# (narrow32Word# x#)
-"fromIntegral/Word32->a" fromIntegral = \(W32# x#) -> fromIntegral (W# x#)
- #-}
-
-#endif
-
-instance Show Word32 where
-#if WORD_SIZE_IN_BITS < 33
- showsPrec p x = showsPrec p (toInteger x)
-#else
- showsPrec p x = showsPrec p (fromIntegral x :: Int)
-#endif
-
-
-instance Real Word32 where
- toRational x = toInteger x % 1
-
-instance Bounded Word32 where
- minBound = 0
- maxBound = 0xFFFFFFFF
-
-instance Ix Word32 where
- range (m,n) = [m..n]
- unsafeIndex b@(m,_) i = fromIntegral (i - m)
- inRange (m,n) i = m <= i && i <= n
-
-instance Read Word32 where
-#if WORD_SIZE_IN_BITS < 33
- readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]
-#else
- readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]
-#endif
-
-------------------------------------------------------------------------
--- type Word64
-------------------------------------------------------------------------
-
-#if WORD_SIZE_IN_BITS < 64
-
-data Word64 = W64# Word64#
--- ^ 64-bit unsigned integer type
-
-instance Eq Word64 where
- (W64# x#) == (W64# y#) = x# `eqWord64#` y#
- (W64# x#) /= (W64# y#) = x# `neWord64#` y#
-
-instance Ord Word64 where
- (W64# x#) < (W64# y#) = x# `ltWord64#` y#
- (W64# x#) <= (W64# y#) = x# `leWord64#` y#
- (W64# x#) > (W64# y#) = x# `gtWord64#` y#
- (W64# x#) >= (W64# y#) = x# `geWord64#` y#
-
-instance Num Word64 where
- (W64# x#) + (W64# y#) = W64# (int64ToWord64# (word64ToInt64# x# `plusInt64#` word64ToInt64# y#))
- (W64# x#) - (W64# y#) = W64# (int64ToWord64# (word64ToInt64# x# `minusInt64#` word64ToInt64# y#))
- (W64# x#) * (W64# y#) = W64# (int64ToWord64# (word64ToInt64# x# `timesInt64#` word64ToInt64# y#))
- negate (W64# x#) = W64# (int64ToWord64# (negateInt64# (word64ToInt64# x#)))
- abs x = x
- signum 0 = 0
- signum _ = 1
- fromInteger (S# i#) = W64# (int64ToWord64# (intToInt64# i#))
- fromInteger (J# s# d#) = W64# (integerToWord64# s# d#)
-
-instance Enum Word64 where
- succ x
- | x /= maxBound = x + 1
- | otherwise = succError "Word64"
- pred x
- | x /= minBound = x - 1
- | otherwise = predError "Word64"
- toEnum i@(I# i#)
- | i >= 0 = W64# (wordToWord64# (int2Word# i#))
- | otherwise = toEnumError "Word64" i (minBound::Word64, maxBound::Word64)
- fromEnum x@(W64# x#)
- | x <= fromIntegral (maxBound::Int)
- = I# (word2Int# (word64ToWord# x#))
- | otherwise = fromEnumError "Word64" x
- enumFrom = integralEnumFrom
- enumFromThen = integralEnumFromThen
- enumFromTo = integralEnumFromTo
- enumFromThenTo = integralEnumFromThenTo
-
-instance Integral Word64 where
- quot x@(W64# x#) y@(W64# y#)
- | y /= 0 = W64# (x# `quotWord64#` y#)
- | otherwise = divZeroError
- rem x@(W64# x#) y@(W64# y#)
- | y /= 0 = W64# (x# `remWord64#` y#)
- | otherwise = divZeroError
- div x@(W64# x#) y@(W64# y#)
- | y /= 0 = W64# (x# `quotWord64#` y#)
- | otherwise = divZeroError
- mod x@(W64# x#) y@(W64# y#)
- | y /= 0 = W64# (x# `remWord64#` y#)
- | otherwise = divZeroError
- quotRem x@(W64# x#) y@(W64# y#)
- | y /= 0 = (W64# (x# `quotWord64#` y#), W64# (x# `remWord64#` y#))
- | otherwise = divZeroError
- divMod x@(W64# x#) y@(W64# y#)
- | y /= 0 = (W64# (x# `quotWord64#` y#), W64# (x# `remWord64#` y#))
- | otherwise = divZeroError
- toInteger x@(W64# x#)
- | x <= 0x7FFFFFFF = S# (word2Int# (word64ToWord# x#))
- | otherwise = case word64ToInteger# x# of (# s, d #) -> J# s d
-
-instance Bits Word64 where
- {-# INLINE shift #-}
-
- (W64# x#) .&. (W64# y#) = W64# (x# `and64#` y#)
- (W64# x#) .|. (W64# y#) = W64# (x# `or64#` y#)
- (W64# x#) `xor` (W64# y#) = W64# (x# `xor64#` y#)
- complement (W64# x#) = W64# (not64# x#)
- (W64# x#) `shift` (I# i#)
- | i# >=# 0# = W64# (x# `shiftL64#` i#)
- | otherwise = W64# (x# `shiftRL64#` negateInt# i#)
- (W64# x#) `rotate` (I# i#)
- | i'# ==# 0# = W64# x#
- | otherwise = W64# ((x# `uncheckedShiftL64#` i'#) `or64#`
- (x# `uncheckedShiftRL64#` (64# -# i'#)))
- where
- i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)
- bitSize _ = 64
- isSigned _ = False
-
--- give the 64-bit shift operations the same treatment as the 32-bit
--- ones (see GHC.Base), namely we wrap them in tests to catch the
--- cases when we're shifting more than 64 bits to avoid unspecified
--- behaviour in the C shift operations.
-
-shiftL64#, shiftRL64# :: Word64# -> Int# -> Word64#
-
-a `shiftL64#` b | b >=# 64# = wordToWord64# (int2Word# 0#)
- | otherwise = a `uncheckedShiftL64#` b
-
-a `shiftRL64#` b | b >=# 64# = wordToWord64# (int2Word# 0#)
- | otherwise = a `uncheckedShiftRL64#` b
-
-
-foreign import ccall unsafe "hs_eqWord64" eqWord64# :: Word64# -> Word64# -> Bool
-foreign import ccall unsafe "hs_neWord64" neWord64# :: Word64# -> Word64# -> Bool
-foreign import ccall unsafe "hs_ltWord64" ltWord64# :: Word64# -> Word64# -> Bool
-foreign import ccall unsafe "hs_leWord64" leWord64# :: Word64# -> Word64# -> Bool
-foreign import ccall unsafe "hs_gtWord64" gtWord64# :: Word64# -> Word64# -> Bool
-foreign import ccall unsafe "hs_geWord64" geWord64# :: Word64# -> Word64# -> Bool
-foreign import ccall unsafe "hs_int64ToWord64" int64ToWord64# :: Int64# -> Word64#
-foreign import ccall unsafe "hs_word64ToInt64" word64ToInt64# :: Word64# -> Int64#
-foreign import ccall unsafe "hs_intToInt64" intToInt64# :: Int# -> Int64#
-foreign import ccall unsafe "hs_wordToWord64" wordToWord64# :: Word# -> Word64#
-foreign import ccall unsafe "hs_word64ToWord" word64ToWord# :: Word64# -> Word#
-foreign import ccall unsafe "hs_plusInt64" plusInt64# :: Int64# -> Int64# -> Int64#
-foreign import ccall unsafe "hs_minusInt64" minusInt64# :: Int64# -> Int64# -> Int64#
-foreign import ccall unsafe "hs_timesInt64" timesInt64# :: Int64# -> Int64# -> Int64#
-foreign import ccall unsafe "hs_negateInt64" negateInt64# :: Int64# -> Int64#
-foreign import ccall unsafe "hs_quotWord64" quotWord64# :: Word64# -> Word64# -> Word64#
-foreign import ccall unsafe "hs_remWord64" remWord64# :: Word64# -> Word64# -> Word64#
-foreign import ccall unsafe "hs_and64" and64# :: Word64# -> Word64# -> Word64#
-foreign import ccall unsafe "hs_or64" or64# :: Word64# -> Word64# -> Word64#
-foreign import ccall unsafe "hs_xor64" xor64# :: Word64# -> Word64# -> Word64#
-foreign import ccall unsafe "hs_not64" not64# :: Word64# -> Word64#
-foreign import ccall unsafe "hs_uncheckedShiftL64" uncheckedShiftL64# :: Word64# -> Int# -> Word64#
-foreign import ccall unsafe "hs_uncheckedShiftRL64" uncheckedShiftRL64# :: Word64# -> Int# -> Word64#
-
-foreign import ccall unsafe "hs_integerToWord64" integerToWord64# :: Int# -> ByteArray# -> Word64#
-
-
-{-# RULES
-"fromIntegral/Int->Word64" fromIntegral = \(I# x#) -> W64# (int64ToWord64# (intToInt64# x#))
-"fromIntegral/Word->Word64" fromIntegral = \(W# x#) -> W64# (wordToWord64# x#)
-"fromIntegral/Word64->Int" fromIntegral = \(W64# x#) -> I# (word2Int# (word64ToWord# x#))
-"fromIntegral/Word64->Word" fromIntegral = \(W64# x#) -> W# (word64ToWord# x#)
-"fromIntegral/Word64->Word64" fromIntegral = id :: Word64 -> Word64
- #-}
-
-#else
-
--- Word64 is represented in the same way as Word.
--- Operations may assume and must ensure that it holds only values
--- from its logical range.
-
-data Word64 = W64# Word# deriving (Eq, Ord)
--- ^ 64-bit unsigned integer type
-
-instance Num Word64 where
- (W64# x#) + (W64# y#) = W64# (x# `plusWord#` y#)
- (W64# x#) - (W64# y#) = W64# (x# `minusWord#` y#)
- (W64# x#) * (W64# y#) = W64# (x# `timesWord#` y#)
- negate (W64# x#) = W64# (int2Word# (negateInt# (word2Int# x#)))
- abs x = x
- signum 0 = 0
- signum _ = 1
- fromInteger (S# i#) = W64# (int2Word# i#)
- fromInteger (J# s# d#) = W64# (integer2Word# s# d#)
-
-instance Enum Word64 where
- succ x
- | x /= maxBound = x + 1
- | otherwise = succError "Word64"
- pred x
- | x /= minBound = x - 1
- | otherwise = predError "Word64"
- toEnum i@(I# i#)
- | i >= 0 = W64# (int2Word# i#)
- | otherwise = toEnumError "Word64" i (minBound::Word64, maxBound::Word64)
- fromEnum x@(W64# x#)
- | x <= fromIntegral (maxBound::Int)
- = I# (word2Int# x#)
- | otherwise = fromEnumError "Word64" x
- enumFrom = integralEnumFrom
- enumFromThen = integralEnumFromThen
- enumFromTo = integralEnumFromTo
- enumFromThenTo = integralEnumFromThenTo
-
-instance Integral Word64 where
- quot x@(W64# x#) y@(W64# y#)
- | y /= 0 = W64# (x# `quotWord#` y#)
- | otherwise = divZeroError
- rem x@(W64# x#) y@(W64# y#)
- | y /= 0 = W64# (x# `remWord#` y#)
- | otherwise = divZeroError
- div x@(W64# x#) y@(W64# y#)
- | y /= 0 = W64# (x# `quotWord#` y#)
- | otherwise = divZeroError
- mod x@(W64# x#) y@(W64# y#)
- | y /= 0 = W64# (x# `remWord#` y#)
- | otherwise = divZeroError
- quotRem x@(W64# x#) y@(W64# y#)
- | y /= 0 = (W64# (x# `quotWord#` y#), W64# (x# `remWord#` y#))
- | otherwise = divZeroError
- divMod x@(W64# x#) y@(W64# y#)
- | y /= 0 = (W64# (x# `quotWord#` y#), W64# (x# `remWord#` y#))
- | otherwise = divZeroError
- toInteger (W64# x#)
- | i# >=# 0# = S# i#
- | otherwise = case word2Integer# x# of (# s, d #) -> J# s d
- where
- i# = word2Int# x#
-
-instance Bits Word64 where
- {-# INLINE shift #-}
-
- (W64# x#) .&. (W64# y#) = W64# (x# `and#` y#)
- (W64# x#) .|. (W64# y#) = W64# (x# `or#` y#)
- (W64# x#) `xor` (W64# y#) = W64# (x# `xor#` y#)
- complement (W64# x#) = W64# (x# `xor#` mb#) where W64# mb# = maxBound
- (W64# x#) `shift` (I# i#)
- | i# >=# 0# = W64# (x# `shiftL#` i#)
- | otherwise = W64# (x# `shiftRL#` negateInt# i#)
- (W64# x#) `rotate` (I# i#)
- | i'# ==# 0# = W64# x#
- | otherwise = W64# ((x# `uncheckedShiftL#` i'#) `or#`
- (x# `uncheckedShiftRL#` (64# -# i'#)))
- where
- i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)
- bitSize _ = 64
- isSigned _ = False
-
-{-# RULES
-"fromIntegral/a->Word64" fromIntegral = \x -> case fromIntegral x of W# x# -> W64# x#
-"fromIntegral/Word64->a" fromIntegral = \(W64# x#) -> fromIntegral (W# x#)
- #-}
-
-#endif
-
-instance Show Word64 where
- showsPrec p x = showsPrec p (toInteger x)
-
-instance Real Word64 where
- toRational x = toInteger x % 1
-
-instance Bounded Word64 where
- minBound = 0
- maxBound = 0xFFFFFFFFFFFFFFFF
-
-instance Ix Word64 where
- range (m,n) = [m..n]
- unsafeIndex b@(m,_) i = fromIntegral (i - m)
- inRange (m,n) i = m <= i && i <= n
-
-instance Read Word64 where
- readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]
-This library (libraries/base) is derived from code from several
+This library (libraries/base) is derived from code from two
sources:
* Code from the GHC project which is largely (c) The University of
and freely redistributable (but see the full license for
restrictions).
- * Code from the Haskell Foreign Function Interface specification,
- which is (c) Manuel M. T. Chakravarty and freely redistributable
- (but see the full license for restrictions).
-
-The full text of these licenses is reproduced below. All of the
+The full text of these licenses is reproduced below. Both of the
licenses are BSD-style or compatible.
-----------------------------------------------------------------------------
be a definition of the Haskell 98 Language.
-----------------------------------------------------------------------------
-
-Code derived from the document "The Haskell 98 Foreign Function
-Interface, An Addendum to the Haskell 98 Report" is distributed under
-the following license:
-
- Copyright (c) 2002 Manuel M. T. Chakravarty
-
- The authors intend this Report to belong to the entire Haskell
- community, and so we grant permission to copy and distribute it for
- any purpose, provided that it is reproduced in its entirety,
- including this Notice. Modified versions of this Report may also be
- copied and distributed for any purpose, provided that the modified
- version is clearly presented as such, and that it does not claim to
- be a definition of the Haskell 98 Foreign Function Interface.
-
------------------------------------------------------------------------------
+++ /dev/null
-TOP=..
-include $(TOP)/mk/boilerplate.mk
-
-# -----------------------------------------------------------------------------
-
-SUBDIRS = cbits include
-
-ALL_DIRS = \
- Control \
- Control/Concurrent \
- Control/Parallel \
- Control/Monad \
- Control/Monad/ST \
- Data \
- Data/ByteString \
- Data/ByteString/Lazy \
- Data/Generics \
- Data/Array \
- Data/Array/IO \
- Data/STRef \
- Debug \
- Foreign \
- Foreign/C \
- Foreign/Marshal \
- GHC \
- System \
- System/Console \
- System/Mem \
- System/IO \
- System/Posix \
- System/Process \
- System/Directory \
- Text \
- Text/PrettyPrint \
- Text/ParserCombinators \
- Text/Show \
- Text/Read \
- Unsafe
-
-PACKAGE = base
-VERSION = 2.0
-
-SRC_HC_OPTS += -fglasgow-exts -cpp -Iinclude -"\#include" HsBase.h
-SRC_HSC2HS_OPTS += -Iinclude -I$(GHC_INCLUDE_DIR)
-
-# -----------------------------------------------------------------------------
-# Per-module flags
-
-# ESSENTIAL, for getting reasonable performance from the I/O library:
-SRC_HC_OPTS += -funbox-strict-fields
-
-# -----------------------------------------------------------------------------
-# PrimOpWrappers
-
-# These two lines are required for pre-processing compiler/prelude/primops.txt
-SRC_CPP_OPTS += -I$(GHC_INCLUDE_DIR)
-SRC_CPP_OPTS += ${GhcCppOpts}
-
-ifeq "$(BootingFromHc)" "YES"
-GHC/PrimopWrappers.hs:
- touch GHC/PrimopWrappers.hs
-else
-GHC/PrimopWrappers.hs: $(GHC_COMPILER_DIR)/prelude/primops.txt GHC/Prim.hs
- @$(RM) $@
- $(GENPRIMOP) --make-haskell-wrappers < $< > $@
-endif
-
-GHC/Prim.hs: $(GHC_COMPILER_DIR)/prelude/primops.txt
- @$(RM) $@
- $(GENPRIMOP) --make-haskell-source < $< > $@
-
-EXCLUDED_SRCS = GHC/Prim.hs
-EXTRA_HADDOCK_SRCS = GHC/Prim.hs
-
-boot :: GHC/PrimopWrappers.hs
-
-EXTRA_SRCS += GHC/PrimopWrappers.hs
-CLEAN_FILES += GHC/PrimopWrappers.hs
-
-# -----------------------------------------------------------------------------
-ifneq "$(BootingFromHc)" "YES"
-STUBOBJS += \
- Control/Concurrent_stub.$(way_)o
-
-CLEAN_FILES += $(STUBOBJS) \
- Control/Concurrent_stub.[ch]
-endif
-
-#-----------------------------------------------------------------------------
-# Building the library for GHCi
-#
-# The procedure differs from that in fptools/mk/target.mk in one way:
-# (*) on Win32 we must split it into two, because a single .o file can't
-# have more than 65536 relocations in it [due to a bug in the GNU
-# linker.]
-
-OBJECT_FILEFORMAT=unknown
-ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
-OBJECT_FILEFORMAT=PEi
-endif
-ifeq "$(TARGETPLATFORM)" "i386-unknown-cygwin32"
-OBJECT_FILEFORMAT=PEi
-endif
-
-ifeq "$(OBJECT_FILEFORMAT)" "PEi"
-
-# Turn off standard rule which creates HSbase.o from LIBOBJS.
-#DONT_WANT_STD_GHCI_LIB_RULE=YES
-
-GHCI_LIBOBJS = $(HS_OBJS)
-
-INSTALL_LIBS += HSbase.o
-
-endif # OBJECT_FILEFORMAT = PEi
-
-
-# -----------------------------------------------------------------------------
-# Doc building with Haddock
-
-EXCLUDED_HADDOCK_SRCS = \
- GHC/PrimopWrappers.hs \
- GHC/PArr.hs
-
-SRC_HADDOCK_OPTS += -t "Haskell Hierarchical Libraries ($(PACKAGE) package)" \
- --no-implicit-prelude
-
-# -----------------------------------------------------------------------------
-
-GHC/ForeignPtr.o Data/Array/IO/Internals.o Data/Array/Base.o \
- Data/Generics/Instances.o Data/Complex.o Data/Array.o Data/STRef.o \
- Data/Dynamic.o Data/Typeable.o Data/PackedString.o System/Mem/Weak.o \
- System/Mem/StableName.o System/Posix/Types.o Control/Monad/ST.o \
- Control/Exception.o Foreign/C/Types.o Foreign/ForeignPtr.o: include/Typeable.h
-
-System/Posix/Types.o Foreign/C/Types.o: include/CTypes.h
-
-# -----------------------------------------------------------------------------
-
-DIST_CLEAN_FILES += base.buildinfo config.cache config.status
-
-include $(TOP)/mk/target.mk
+++ /dev/null
-THISPKG = base
-SEARCH = -I$(TOPDIR)/targets/$(MACHINE) -Iinclude \
- -I../../prelude/PreludeIO -I../../prelude/`harch`
-EXTRA_H_FLAGS = -H4M -K3M
-EXTRA_HBC_FLAGS = -H16M -A1M
-
-SRCS = \
- Data/Bits.hs Data/Bool.hs Data/Char.hs Data/Complex.hs \
- Data/Either.hs Data/IORef.hs Data/Int.hs \
- Data/Ix.hs Data/List.hs Data/Maybe.hs Data/PackedString.hs \
- Data/Ratio.hs Data/Set.hs Data/Tuple.hs Data/Word.hs Data/Array.hs \
- Data/HashTable.hs Data/Typeable.hs Data/Dynamic.hs \
- Data/Monoid.hs Data/Tree.hs \
- Data/Map.hs Data/IntMap.hs Data/IntSet.hs \
- Data/Eq.hs Data/Ord.hs \
- Data/Foldable.hs Data/Traversable.hs Data/Sequence.hs \
- Data/Function.hs Data/Graph.hs \
- Control/Monad.hs Control/Monad/Fix.hs Control/Monad/Instances.hs \
- Control/Arrow.hs Control/Applicative.hs \
- Control/Exception.hs \
- Debug/Trace.hs \
- NHC/SizedTypes.hs NHC/PosixTypes.hsc \
- System/IO.hs System/IO/Error.hs System/IO/Unsafe.hs \
- System/Environment.hs System/Exit.hs System/Locale.hs \
- System/Directory.hs System/Mem.hs System/Cmd.hs System/Info.hs \
- System/Console/GetOpt.hs System/Random.hs \
- System/CPUTime.hsc System/Time.hsc \
- System/Directory/Internals.hs \
- Foreign/Ptr.hs Foreign/StablePtr.hs Foreign/Storable.hs \
- Foreign/ForeignPtr.hs Foreign/C/Types.hs \
- Foreign/Marshal/Alloc.hs Foreign/Marshal/Array.hs \
- Foreign/Marshal/Utils.hs Foreign/Marshal/Error.hs \
- Foreign/Marshal/Pool.hs Foreign/Marshal.hs \
- Foreign/C/String.hs Foreign/C/Error.hs Foreign/C.hs Foreign.hs \
- Text/PrettyPrint/HughesPJ.hs Text/PrettyPrint.hs \
- Text/Printf.hs \
- Text/Read.hs Text/Show.hs Text/Show/Functions.hs \
- Text/ParserCombinators/ReadP.hs Data/Version.hs \
- Unsafe/Coerce.hs \
- WCsubst.c \
- System/Posix/Types.hs \
-
-
-# Text/Regex/Posix.hsc Text/Regex.hs \
-# Text/ParserCombinators/ReadPrec.hs
-# [Data/Dynamic.hs] Data/Generics.hs Data/STRef.hs Data/Unique.hs
-# System/Mem.hs System/Mem/StableName.hs System/Mem/Weak.hs
-# System/Posix/Types.hs System/Posix/Signals.hsc
-# Text/Read/Lex.hs
-# System/FilePath.hs
-
-
-# Here are the main rules.
-include ../Makefile.common
-
-# some extra rules
-extra:
- if [ -f Prelude.hs ]; then mv Prelude.hs Prelude.hs.unused; fi
- if [ -f Numeric.hs ]; then mv Numeric.hs Numeric.hs.unused; fi
-extracfiles:
- if [ -f Prelude.hs ]; then mv Prelude.hs Prelude.hs.unused; fi
- if [ -f Numeric.hs ]; then mv Numeric.hs Numeric.hs.unused; fi
-
-# Here are any extra dependencies.
-
-# C-files dependencies.
-
+++ /dev/null
-{-# OPTIONS_NHC98 -I/usr/include #-}
------------------------------------------------------------------------------
--- |
--- Module : NHC.PosixTypes
--- Copyright : (c) Malcolm Wallace 2007
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : non-portable (requires POSIX)
---
--- POSIX data types: Haskell equivalents of the types defined by the
--- @\<sys\/types.h>@ C header on a POSIX system.
---
------------------------------------------------------------------------------
-
-module NHC.PosixTypes (
-
- -- * POSIX data types
- CDev,
- CIno,
- CMode,
- COff,
- CPid,
- CSsize,
-
- CGid,
- CNlink,
- CUid,
- CCc,
- CSpeed,
- CTcflag,
- CRLim,
-
- Fd(..),
-
- LinkCount,
- UserID,
- GroupID,
- ) where
-
-import Foreign
-import Foreign.C
-import Data.Typeable
-import Data.Bits
-import Unsafe.Coerce
-
-import Control.Monad
-
-
--- Curious hack to ensure that the CTypes macros are expanded *after* hsc2hs.
-##include "CTypes.h"
--- C header files that contain all the types we are looking for here.
-#if __APPLE__
-#include <libc.h>
-#endif
-#include <stdlib.h>
-#include <unistd.h>
-#include <sys/resource.h>
-#include <termios.h>
-
-ARITHMETIC_TYPE(CDev,tyConCDev,"CDev",#{type dev_t})
-INTEGRAL_TYPE(CIno,tyConCIno,"CIno",#{type ino_t})
-INTEGRAL_TYPE(CMode,tyConCMode,"CMode",#{type mode_t})
-INTEGRAL_TYPE(COff,tyConCOff,"COff",#{type off_t})
-INTEGRAL_TYPE(CPid,tyConCPid,"CPid",#{type pid_t})
-
-INTEGRAL_TYPE(CSsize,tyConCSsize,"CSsize",#{type ssize_t})
-
-INTEGRAL_TYPE(CGid,tyConCGid,"CGid",#{type gid_t})
-INTEGRAL_TYPE(CNlink,tyConCNlink,"CNlink",#{type nlink_t})
-
-INTEGRAL_TYPE(CUid,tyConCUid,"CUid",#{type uid_t})
-ARITHMETIC_TYPE(CCc,tyConCCc,"CCc",#{type cc_t})
-ARITHMETIC_TYPE(CSpeed,tyConCSpeed,"CSpeed",#{type speed_t})
-INTEGRAL_TYPE(CTcflag,tyConCTcflag,"CTcflag",#{type tcflag_t})
-INTEGRAL_TYPE(CRLim,tyConCRlim,"CRLim",#{type rlim_t})
-
--- ToDo: blksize_t, clockid_t, blkcnt_t, fsblkcnt_t, fsfilcnt_t, id_t, key_t
--- suseconds_t, timer_t, useconds_t
-
--- Make an Fd type rather than using CInt everywhere
-INTEGRAL_TYPE(Fd,tyConFd,"Fd",CInt)
-
--- nicer names, and backwards compatibility with POSIX library:
-type LinkCount = CNlink
-type UserID = CUid
-type GroupID = CGid
+++ /dev/null
-module NHC.SizedTypes
- -- This module just adds instances of Bits for Int/Word[8,16,32,64]
- ( Int8, Int16, Int32, Int64
- , Word8, Word16, Word32, Word64
- ) where
-
-{- Note explicit braces and semicolons here - layout is corrupted by cpp. -}
-
-{
- import NHC.FFI (Int8,Int16,Int32,Int64,Word8,Word16,Word32,Word64)
-; import Data.Bits
-
-#define SIZED_TYPE(T,BS,S) \
-; FOREIGNS(T) \
-; INSTANCE_BITS(T,BS,S)
-
-
-#define FOREIGNS(T) \
-; foreign import ccall nhc_prim/**/T/**/And :: T -> T -> T \
-; foreign import ccall nhc_prim/**/T/**/Or :: T -> T -> T \
-; foreign import ccall nhc_prim/**/T/**/Xor :: T -> T -> T \
-; foreign import ccall nhc_prim/**/T/**/Lsh :: T -> Int -> T \
-; foreign import ccall nhc_prim/**/T/**/Rsh :: T -> Int -> T \
-; foreign import ccall nhc_prim/**/T/**/Compl :: T -> T
-
-
-#define INSTANCE_BITS(T,BS,S) \
-; instance Bits T where \
- { (.&.) = nhc_prim/**/T/**/And \
- ; (.|.) = nhc_prim/**/T/**/Or \
- ; xor = nhc_prim/**/T/**/Xor \
- ; complement = nhc_prim/**/T/**/Compl \
- ; shiftL = nhc_prim/**/T/**/Lsh \
- ; shiftR = nhc_prim/**/T/**/Rsh \
- ; bitSize _ = BS \
- ; isSigned _ = S \
- }
-
-SIZED_TYPE(Int8,8,True)
-SIZED_TYPE(Int16,16,True)
-SIZED_TYPE(Int32,32,True)
-SIZED_TYPE(Int64,64,True)
-
-SIZED_TYPE(Word8,8,False)
-SIZED_TYPE(Word16,16,False)
-SIZED_TYPE(Word32,32,False)
-SIZED_TYPE(Word64,64,False)
-
-}
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Numeric
--- Copyright : (c) The University of Glasgow 2002
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Odds and ends, mostly functions for reading and showing
--- 'RealFloat'-like kind of values.
---
------------------------------------------------------------------------------
-
-module Numeric (
-
- -- * Showing
-
- showSigned, -- :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
-
- showIntAtBase, -- :: Integral a => a -> (a -> Char) -> a -> ShowS
- showInt, -- :: Integral a => a -> ShowS
- showHex, -- :: Integral a => a -> ShowS
- showOct, -- :: Integral a => a -> ShowS
-
- showEFloat, -- :: (RealFloat a) => Maybe Int -> a -> ShowS
- showFFloat, -- :: (RealFloat a) => Maybe Int -> a -> ShowS
- showGFloat, -- :: (RealFloat a) => Maybe Int -> a -> ShowS
- showFloat, -- :: (RealFloat a) => a -> ShowS
-
- floatToDigits, -- :: (RealFloat a) => Integer -> a -> ([Int], Int)
-
- -- * Reading
-
- -- | /NB:/ 'readInt' is the \'dual\' of 'showIntAtBase',
- -- and 'readDec' is the \`dual\' of 'showInt'.
- -- The inconsistent naming is a historical accident.
-
- readSigned, -- :: (Real a) => ReadS a -> ReadS a
-
- readInt, -- :: (Integral a) => a -> (Char -> Bool)
- -- -> (Char -> Int) -> ReadS a
- readDec, -- :: (Integral a) => ReadS a
- readOct, -- :: (Integral a) => ReadS a
- readHex, -- :: (Integral a) => ReadS a
-
- readFloat, -- :: (RealFloat a) => ReadS a
-
- lexDigits, -- :: ReadS String
-
- -- * Miscellaneous
-
- fromRat, -- :: (RealFloat a) => Rational -> a
-
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.Read
-import GHC.Real
-import GHC.Float
-import GHC.Num
-import GHC.Show
-import Data.Maybe
-import Text.ParserCombinators.ReadP( ReadP, readP_to_S, pfail )
-import qualified Text.Read.Lex as L
-#else
-import Data.Char
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude
-import Hugs.Numeric
-#endif
-
-#ifdef __GLASGOW_HASKELL__
--- -----------------------------------------------------------------------------
--- Reading
-
--- | Reads an /unsigned/ 'Integral' value in an arbitrary base.
-readInt :: Num a
- => a -- ^ the base
- -> (Char -> Bool) -- ^ a predicate distinguishing valid digits in this base
- -> (Char -> Int) -- ^ a function converting a valid digit character to an 'Int'
- -> ReadS a
-readInt base isDigit valDigit = readP_to_S (L.readIntP base isDigit valDigit)
-
--- | Read an unsigned number in octal notation.
-readOct :: Num a => ReadS a
-readOct = readP_to_S L.readOctP
-
--- | Read an unsigned number in decimal notation.
-readDec :: Num a => ReadS a
-readDec = readP_to_S L.readDecP
-
--- | Read an unsigned number in hexadecimal notation.
--- Both upper or lower case letters are allowed.
-readHex :: Num a => ReadS a
-readHex = readP_to_S L.readHexP
-
--- | Reads an /unsigned/ 'RealFrac' value,
--- expressed in decimal scientific notation.
-readFloat :: RealFrac a => ReadS a
-readFloat = readP_to_S readFloatP
-
-readFloatP :: RealFrac a => ReadP a
-readFloatP =
- do tok <- L.lex
- case tok of
- L.Rat y -> return (fromRational y)
- L.Int i -> return (fromInteger i)
- other -> pfail
-
--- It's turgid to have readSigned work using list comprehensions,
--- but it's specified as a ReadS to ReadS transformer
--- With a bit of luck no one will use it.
-
--- | Reads a /signed/ 'Real' value, given a reader for an unsigned value.
-readSigned :: (Real a) => ReadS a -> ReadS a
-readSigned readPos = readParen False read'
- where read' r = read'' r ++
- (do
- ("-",s) <- lex r
- (x,t) <- read'' s
- return (-x,t))
- read'' r = do
- (str,s) <- lex r
- (n,"") <- readPos str
- return (n,s)
-
--- -----------------------------------------------------------------------------
--- Showing
-
--- | Show /non-negative/ 'Integral' numbers in base 10.
-showInt :: Integral a => a -> ShowS
-showInt n cs
- | n < 0 = error "Numeric.showInt: can't show negative numbers"
- | otherwise = go n cs
- where
- go n cs
- | n < 10 = case unsafeChr (ord '0' + fromIntegral n) of
- c@(C# _) -> c:cs
- | otherwise = case unsafeChr (ord '0' + fromIntegral r) of
- c@(C# _) -> go q (c:cs)
- where
- (q,r) = n `quotRem` 10
-
--- Controlling the format and precision of floats. The code that
--- implements the formatting itself is in @PrelNum@ to avoid
--- mutual module deps.
-
-{-# SPECIALIZE showEFloat ::
- Maybe Int -> Float -> ShowS,
- Maybe Int -> Double -> ShowS #-}
-{-# SPECIALIZE showFFloat ::
- Maybe Int -> Float -> ShowS,
- Maybe Int -> Double -> ShowS #-}
-{-# SPECIALIZE showGFloat ::
- Maybe Int -> Float -> ShowS,
- Maybe Int -> Double -> ShowS #-}
-
--- | Show a signed 'RealFloat' value
--- using scientific (exponential) notation (e.g. @2.45e2@, @1.5e-3@).
---
--- In the call @'showEFloat' digs val@, if @digs@ is 'Nothing',
--- the value is shown to full precision; if @digs@ is @'Just' d@,
--- then at most @d@ digits after the decimal point are shown.
-showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
-
--- | Show a signed 'RealFloat' value
--- using standard decimal notation (e.g. @245000@, @0.0015@).
---
--- In the call @'showFFloat' digs val@, if @digs@ is 'Nothing',
--- the value is shown to full precision; if @digs@ is @'Just' d@,
--- then at most @d@ digits after the decimal point are shown.
-showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
-
--- | Show a signed 'RealFloat' value
--- using standard decimal notation for arguments whose absolute value lies
--- between @0.1@ and @9,999,999@, and scientific notation otherwise.
---
--- In the call @'showGFloat' digs val@, if @digs@ is 'Nothing',
--- the value is shown to full precision; if @digs@ is @'Just' d@,
--- then at most @d@ digits after the decimal point are shown.
-showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
-
-showEFloat d x = showString (formatRealFloat FFExponent d x)
-showFFloat d x = showString (formatRealFloat FFFixed d x)
-showGFloat d x = showString (formatRealFloat FFGeneric d x)
-#endif /* __GLASGOW_HASKELL__ */
-
--- ---------------------------------------------------------------------------
--- Integer printing functions
-
--- | Shows a /non-negative/ 'Integral' number using the base specified by the
--- first argument, and the character representation specified by the second.
-showIntAtBase :: Integral a => a -> (Int -> Char) -> a -> ShowS
-showIntAtBase base toChr n r
- | base <= 1 = error ("Numeric.showIntAtBase: applied to unsupported base " ++ show base)
- | n < 0 = error ("Numeric.showIntAtBase: applied to negative number " ++ show n)
- | otherwise = showIt (quotRem n base) r
- where
- showIt (n,d) r = seq c $ -- stricter than necessary
- case n of
- 0 -> r'
- _ -> showIt (quotRem n base) r'
- where
- c = toChr (fromIntegral d)
- r' = c : r
-
--- | Show /non-negative/ 'Integral' numbers in base 16.
-showHex :: Integral a => a -> ShowS
-showHex = showIntAtBase 16 intToDigit
-
--- | Show /non-negative/ 'Integral' numbers in base 8.
-showOct :: Integral a => a -> ShowS
-showOct = showIntAtBase 8 intToDigit
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Prelude
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : stable
--- Portability : portable
---
--- The Prelude: a standard module imported by default into all Haskell
--- modules. For more documentation, see the Haskell 98 Report
--- <http://www.haskell.org/onlinereport/>.
---
------------------------------------------------------------------------------
-
-module Prelude (
-
- -- * Standard types, classes and related functions
-
- -- ** Basic data types
- Bool(False, True),
- (&&), (||), not, otherwise,
-
- Maybe(Nothing, Just),
- maybe,
-
- Either(Left, Right),
- either,
-
- Ordering(LT, EQ, GT),
- Char, String,
-
- -- *** Tuples
- fst, snd, curry, uncurry,
-
-#if defined(__NHC__)
- []((:), []), -- Not legal Haskell 98;
- -- ... available through built-in syntax
- module Data.Tuple, -- Includes tuple types
- ()(..), -- Not legal Haskell 98
- (->), -- ... available through built-in syntax
-#endif
-#ifdef __HUGS__
- (:), -- Not legal Haskell 98
-#endif
-
- -- ** Basic type classes
- Eq((==), (/=)),
- Ord(compare, (<), (<=), (>=), (>), max, min),
- Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
- enumFromTo, enumFromThenTo),
- Bounded(minBound, maxBound),
-
- -- ** Numbers
-
- -- *** Numeric types
- Int, Integer, Float, Double,
- Rational,
-
- -- *** Numeric type classes
- Num((+), (-), (*), negate, abs, signum, fromInteger),
- Real(toRational),
- Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
- Fractional((/), recip, fromRational),
- Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
- asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
- RealFrac(properFraction, truncate, round, ceiling, floor),
- RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
- encodeFloat, exponent, significand, scaleFloat, isNaN,
- isInfinite, isDenormalized, isIEEE, isNegativeZero, atan2),
-
- -- *** Numeric functions
- subtract, even, odd, gcd, lcm, (^), (^^),
- fromIntegral, realToFrac,
-
- -- ** Monads and functors
- Monad((>>=), (>>), return, fail),
- Functor(fmap),
- mapM, mapM_, sequence, sequence_, (=<<),
-
- -- ** Miscellaneous functions
- id, const, (.), flip, ($), until,
- asTypeOf, error, undefined,
- seq, ($!),
-
- -- * List operations
- map, (++), filter,
- head, last, tail, init, null, length, (!!),
- reverse,
- -- ** Reducing lists (folds)
- foldl, foldl1, foldr, foldr1,
- -- *** Special folds
- and, or, any, all,
- sum, product,
- concat, concatMap,
- maximum, minimum,
- -- ** Building lists
- -- *** Scans
- scanl, scanl1, scanr, scanr1,
- -- *** Infinite lists
- iterate, repeat, replicate, cycle,
- -- ** Sublists
- take, drop, splitAt, takeWhile, dropWhile, span, break,
- -- ** Searching lists
- elem, notElem, lookup,
- -- ** Zipping and unzipping lists
- zip, zip3, zipWith, zipWith3, unzip, unzip3,
- -- ** Functions on strings
- lines, words, unlines, unwords,
-
- -- * Converting to and from @String@
- -- ** Converting to @String@
- ShowS,
- Show(showsPrec, showList, show),
- shows,
- showChar, showString, showParen,
- -- ** Converting from @String@
- ReadS,
- Read(readsPrec, readList),
- reads, readParen, read, lex,
-
- -- * Basic Input and output
- IO,
- -- ** Simple I\/O operations
- -- All I/O functions defined here are character oriented. The
- -- treatment of the newline character will vary on different systems.
- -- For example, two characters of input, return and linefeed, may
- -- read as a single newline character. These functions cannot be
- -- used portably for binary I/O.
- -- *** Output functions
- putChar,
- putStr, putStrLn, print,
- -- *** Input functions
- getChar,
- getLine, getContents, interact,
- -- *** Files
- FilePath,
- readFile, writeFile, appendFile, readIO, readLn,
- -- ** Exception handling in the I\/O monad
- IOError, ioError, userError, catch
-
- ) where
-
-#ifndef __HUGS__
-import Control.Monad
-import System.IO
-import Text.Read
-import Text.Show
-import Data.List
-import Data.Either
-import Data.Maybe
-import Data.Bool
-import Data.Tuple
-import Data.Eq
-import Data.Ord
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.IOBase
-import GHC.Exception
-import GHC.Read
-import GHC.Enum
-import GHC.Num
-import GHC.Real
-import GHC.Float
-import GHC.Show
-import GHC.Err ( error, undefined )
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude
-#endif
-
-#ifndef __HUGS__
-infixr 0 $!
-
--- -----------------------------------------------------------------------------
--- Miscellaneous functions
-
--- | Strict (call-by-value) application, defined in terms of 'seq'.
-($!) :: (a -> b) -> a -> b
-f $! x = x `seq` f x
-#endif
-
-#ifdef __HADDOCK__
--- | The value of @'seq' a b@ is bottom if @a@ is bottom, and otherwise
--- equal to @b@. 'seq' is usually introduced to improve performance by
--- avoiding unneeded laziness.
-seq :: a -> b -> b
-seq _ y = y
-#endif
-{-
-We need to do some ugly hacks here as base mix of portable and
-unportable stuff, as well as home to some GHC magic.
--}
-
module Main (main) where
-import Control.Monad
import Data.List
+import Distribution.Simple
import Distribution.PackageDescription
import Distribution.Setup
-import Distribution.Simple
import Distribution.Simple.LocalBuildInfo
-import Distribution.Simple.Utils
-import System.Cmd
import System.Environment
-import System.FilePath
-import System.Info
main :: IO ()
main = do args <- getArgs
let (ghcArgs, args') = extractGhcArgs args
- (confArgs, args'') = extractConfigureArgs args'
+ (_, args'') = extractConfigureArgs args'
hooks = defaultUserHooks {
- confHook = add_extra_deps
- $ confHook defaultUserHooks,
- postConf = add_configure_options confArgs
- $ postConf defaultUserHooks,
- buildHook = build_primitive_sources
- $ add_ghc_options ghcArgs
- $ filter_modules_hook
- $ buildHook defaultUserHooks,
- makefileHook = add_ghc_options ghcArgs
- $ filter_modules_hook
- $ makefileHook defaultUserHooks,
- regHook = add_extra_libs
- $ regHook defaultUserHooks,
- instHook = filter_modules_hook
- $ instHook defaultUserHooks }
+ buildHook = add_ghc_options ghcArgs
+ $ buildHook defaultUserHooks }
withArgs args'' $ defaultMainWithHooks hooks
extractGhcArgs :: [String] -> ([String], [String])
| otherwise = Nothing
type Hook a = PackageDescription -> LocalBuildInfo -> UserHooks -> a -> IO ()
-type ConfHook = PackageDescription -> ConfigFlags -> IO LocalBuildInfo
-type PostConfHook = Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo
- -> IO ()
-
--- type PDHook = PackageDescription -> ConfigFlags -> IO ()
-
-build_primitive_sources :: Hook a -> Hook a
-build_primitive_sources f pd lbi uhs x
- = do when (compilerFlavor (compiler lbi) == GHC) $ do
- let genprimopcode = joinPath ["..", "..", "utils",
- "genprimopcode", "genprimopcode"]
- primops = joinPath ["..", "..", "compiler", "prelude",
- "primops.txt"]
- primhs = joinPath ["GHC", "Prim.hs"]
- primopwrappers = joinPath ["GHC", "PrimopWrappers.hs"]
- maybeExit $ system (genprimopcode ++ " --make-haskell-source < "
- ++ primops ++ " > " ++ primhs)
- maybeExit $ system (genprimopcode ++ " --make-haskell-wrappers < "
- ++ primops ++ " > " ++ primopwrappers)
- f pd lbi uhs x
add_ghc_options :: [String] -> Hook a -> Hook a
add_ghc_options args f pd lbi uhs x
pd' = pd { library = Just lib' }
f pd' lbi uhs x
-add_configure_options :: [String] -> PostConfHook -> PostConfHook
-add_configure_options args f as cfs pd lbi
- = f (as ++ args) cfs pd lbi
-
-filter_modules_hook :: Hook a -> Hook a
-filter_modules_hook f pd lbi uhs x
- = let build_filter = case compilerFlavor $ compiler lbi of
- GHC -> forGHCBuild
- _ -> isPortableBuild
- lib' = case library pd of
- Just lib ->
- let ems = filter build_filter (exposedModules lib)
- in lib { exposedModules = ems }
- Nothing -> error "Expected a library"
- pd' = pd { library = Just lib' }
- in f pd' lbi uhs x
-
-isPortableBuild :: String -> Bool
-isPortableBuild s
- | "GHC" `isPrefixOf` s = False
- | "Data.Generics" `isPrefixOf` s = False
- | otherwise = s `notElem` ["Foreign.Concurrent", "System.Process"]
-
-forGHCBuild :: String -> Bool
-forGHCBuild = ("GHC.Prim" /=)
-
-add_extra_deps :: ConfHook -> ConfHook
-add_extra_deps f pd cf
- = do lbi <- f pd cf
- case compilerFlavor (compiler lbi) of
- GHC ->
- do -- Euch. We should just add the right thing to the lbi
- -- ourselves rather than rerunning configure.
- let pd' = pd { buildDepends = Dependency "rts" AnyVersion
- : buildDepends pd }
- f pd' cf
- _ ->
- return lbi
-
-add_extra_libs :: Hook a -> Hook a
-add_extra_libs f pd lbi uhs x
- = let pd' = if (os == "mingw32") && (compilerFlavor (compiler lbi) == GHC)
- then case library pd of
- Just lib ->
- let lib_bi = libBuildInfo lib
- lib_bi' = lib_bi { extraLibs = "wsock32"
- : "msvcrt"
- : "kernel32"
- : "user32"
- : "shell32"
- : extraLibs lib_bi }
- lib' = lib { libBuildInfo = lib_bi' }
- in pd { library = Just lib' }
- Nothing -> error "Expected a library"
- else pd
- in f pd' lbi uhs x
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.CPUTime
--- 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 standard CPUTime library.
---
------------------------------------------------------------------------------
-
-module System.CPUTime
- (
- getCPUTime, -- :: IO Integer
- cpuTimePrecision -- :: Integer
- ) where
-
-import Prelude
-
-import Data.Ratio
-
-#ifdef __HUGS__
-import Hugs.Time ( getCPUTime, clockTicks )
-#endif
-
-#ifdef __NHC__
-import CPUTime ( getCPUTime, cpuTimePrecision )
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-import Foreign
-import Foreign.C
-
-#include "HsBase.h"
-#endif
-
-#ifdef __GLASGOW_HASKELL__
--- -----------------------------------------------------------------------------
--- |Computation 'getCPUTime' returns the number of picoseconds CPU time
--- used by the current program. The precision of this result is
--- implementation-dependent.
-
-getCPUTime :: IO Integer
-getCPUTime = do
-
-#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS)
--- getrusage() is right royal pain to deal with when targetting multiple
--- versions of Solaris, since some versions supply it in libc (2.3 and 2.5),
--- while 2.4 has got it in libucb (I wouldn't be too surprised if it was back
--- again in libucb in 2.6..)
---
--- Avoid the problem by resorting to times() instead.
---
-#if defined(HAVE_GETRUSAGE) && ! irix_HOST_OS && ! solaris2_HOST_OS
- allocaBytes (#const sizeof(struct rusage)) $ \ p_rusage -> do
- getrusage (#const RUSAGE_SELF) p_rusage
-
- let ru_utime = (#ptr struct rusage, ru_utime) p_rusage
- let ru_stime = (#ptr struct rusage, ru_stime) p_rusage
- u_sec <- (#peek struct timeval,tv_sec) ru_utime :: IO CTime
- u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CTime
- s_sec <- (#peek struct timeval,tv_sec) ru_stime :: IO CTime
- s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CTime
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- return ((realToInteger u_sec * 1000000 + realToInteger u_usec +
- realToInteger s_sec * 1000000 + realToInteger s_usec)
- * 1000000)
-
-type CRUsage = ()
-foreign import ccall unsafe getrusage :: CInt -> Ptr CRUsage -> IO CInt
-#else
-# if defined(HAVE_TIMES)
- allocaBytes (#const sizeof(struct tms)) $ \ p_tms -> do
- times p_tms
- u_ticks <- (#peek struct tms,tms_utime) p_tms :: IO CClock
- s_ticks <- (#peek struct tms,tms_stime) p_tms :: IO CClock
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- return (( (realToInteger u_ticks + realToInteger s_ticks) * 1000000000000)
- `div` fromIntegral clockTicks)
-
-type CTms = ()
-foreign import ccall unsafe times :: Ptr CTms -> IO CClock
-# else
- ioException (IOError Nothing UnsupportedOperation
- "getCPUTime"
- "can't get CPU time"
- Nothing)
-# endif
-#endif
-
-#else /* win32 */
- -- NOTE: GetProcessTimes() is only supported on NT-based OSes.
- -- The counts reported by GetProcessTimes() are in 100-ns (10^-7) units.
- allocaBytes (#const sizeof(FILETIME)) $ \ p_creationTime -> do
- allocaBytes (#const sizeof(FILETIME)) $ \ p_exitTime -> do
- allocaBytes (#const sizeof(FILETIME)) $ \ p_kernelTime -> do
- allocaBytes (#const sizeof(FILETIME)) $ \ p_userTime -> do
- pid <- getCurrentProcess
- ok <- getProcessTimes pid p_creationTime p_exitTime p_kernelTime p_userTime
- if toBool ok then do
- ut <- ft2psecs p_userTime
- kt <- ft2psecs p_kernelTime
- return (ut + kt)
- else return 0
- where
- ft2psecs :: Ptr FILETIME -> IO Integer
- ft2psecs ft = do
- high <- (#peek FILETIME,dwHighDateTime) ft :: IO CLong
- low <- (#peek FILETIME,dwLowDateTime) ft :: IO CLong
- -- Convert 100-ns units to picosecs (10^-12)
- -- => multiply by 10^5.
- return (((fromIntegral high) * (2^32) + (fromIntegral low)) * 100000)
-
- -- ToDo: pin down elapsed times to just the OS thread(s) that
- -- are evaluating/managing Haskell code.
-
-type FILETIME = ()
-type HANDLE = ()
--- need proper Haskell names (initial lower-case character)
-foreign import stdcall unsafe "GetCurrentProcess" getCurrentProcess :: IO (Ptr HANDLE)
-foreign import stdcall unsafe "GetProcessTimes" getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt
-
-#endif /* not _WIN32 */
-#endif /* __GLASGOW_HASKELL__ */
-
--- |The 'cpuTimePrecision' constant is the smallest measurable difference
--- in CPU time that the implementation can record, and is given as an
--- integral number of picoseconds.
-
-#ifndef __NHC__
-cpuTimePrecision :: Integer
-cpuTimePrecision = round ((1000000000000::Integer) % fromIntegral (clockTicks))
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-clockTicks :: Int
-clockTicks =
-#if defined(CLK_TCK)
- (#const CLK_TCK)
-#else
- unsafePerformIO (sysconf (#const _SC_CLK_TCK) >>= return . fromIntegral)
-foreign import ccall unsafe sysconf :: CInt -> IO CLong
-#endif
-#endif /* __GLASGOW_HASKELL__ */
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Cmd
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Executing an external command.
---
------------------------------------------------------------------------------
-
-module System.Cmd
- ( system, -- :: String -> IO ExitCode
- rawSystem, -- :: FilePath -> [String] -> IO ExitCode
- ) where
-
-import Prelude
-
-import System.Exit ( ExitCode )
-
-#ifdef __GLASGOW_HASKELL__
-import System.Process
-import GHC.IOBase ( ioException, IOException(..), IOErrorType(..) )
-#if !defined(mingw32_HOST_OS)
-import System.Process.Internals
-import System.Posix.Signals
-#endif
-#endif
-
-#ifdef __HUGS__
-import Hugs.System
-#endif
-
-#ifdef __NHC__
-import System (system)
-#endif
-
--- ---------------------------------------------------------------------------
--- system
-
-{-|
-Computation @system cmd@ returns the exit code
-produced when the operating system processes the command @cmd@.
-
-This computation may fail with
-
- * @PermissionDenied@: The process has insufficient privileges to
- perform the operation.
-
- * @ResourceExhausted@: Insufficient resources are available to
- perform the operation.
-
- * @UnsupportedOperation@: The implementation does not support
- system calls.
-
-On Windows, 'system' is implemented using Windows's native system
-call, which ignores the @SHELL@ environment variable, and always
-passes the command to the Windows command interpreter (@CMD.EXE@ or
-@COMMAND.COM@), hence Unixy shell tricks will not work.
--}
-#ifdef __GLASGOW_HASKELL__
-system :: String -> IO ExitCode
-system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing)
-system str = do
-#if mingw32_HOST_OS
- p <- runCommand str
- waitForProcess p
-#else
- -- The POSIX version of system needs to do some manipulation of signal
- -- handlers. Since we're going to be synchronously waiting for the child,
- -- we want to ignore ^C in the parent, but handle it the default way
- -- in the child (using SIG_DFL isn't really correct, it should be the
- -- original signal handler, but the GHC RTS will have already set up
- -- its own handler and we don't want to use that).
- old_int <- installHandler sigINT Ignore Nothing
- old_quit <- installHandler sigQUIT Ignore Nothing
- (cmd,args) <- commandToProcess str
- p <- runProcessPosix "runCommand" cmd args Nothing Nothing
- Nothing Nothing Nothing
- (Just defaultSignal) (Just defaultSignal)
- r <- waitForProcess p
- installHandler sigINT old_int Nothing
- installHandler sigQUIT old_quit Nothing
- return r
-#endif /* mingw32_HOST_OS */
-#endif /* __GLASGOW_HASKELL__ */
-
-{-|
-The computation @'rawSystem' cmd args@ runs the operating system command
-@cmd@ in such a way that it receives as arguments the @args@ strings
-exactly as given, with no funny escaping or shell meta-syntax expansion.
-It will therefore behave more portably between operating systems than 'system'.
-
-The return codes and possible failures are the same as for 'system'.
--}
-rawSystem :: String -> [String] -> IO ExitCode
-#ifdef __GLASGOW_HASKELL__
-rawSystem cmd args = do
-
-#if mingw32_HOST_OS
- p <- runProcess cmd args Nothing Nothing Nothing Nothing Nothing
- waitForProcess p
-#else
- old_int <- installHandler sigINT Ignore Nothing
- old_quit <- installHandler sigQUIT Ignore Nothing
- p <- runProcessPosix "rawSystem" cmd args Nothing Nothing
- Nothing Nothing Nothing
- (Just defaultSignal) (Just defaultSignal)
- r <- waitForProcess p
- installHandler sigINT old_int Nothing
- installHandler sigQUIT old_quit Nothing
- return r
-#endif
-
-#elif !mingw32_HOST_OS
--- crude fallback implementation: could do much better than this under Unix
-rawSystem cmd args = system (unwords (map translate (cmd:args)))
-
-translate :: String -> String
-translate str = '\'' : foldr escape "'" str
- where escape '\'' = showString "'\\''"
- escape c = showChar c
-#else /* mingw32_HOST_OS && ! __GLASGOW_HASKELL__ */
-# if __HUGS__
-rawSystem cmd args = system (unwords (cmd : map translate args))
-# else
-rawSystem cmd args = system (unwords (map translate (cmd:args)))
-#endif
-
--- copied from System.Process (qv)
-translate :: String -> String
-translate str = '"' : snd (foldr escape (True,"\"") str)
- where escape '"' (b, str) = (True, '\\' : '"' : str)
- escape '\\' (True, str) = (True, '\\' : '\\' : str)
- escape '\\' (False, str) = (False, '\\' : str)
- escape c (b, str) = (False, c : str)
-#endif
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Console.GetOpt
--- Copyright : (c) Sven Panne 2002-2005
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- This library provides facilities for parsing the command-line options
--- in a standalone program. It is essentially a Haskell port of the GNU
--- @getopt@ library.
---
------------------------------------------------------------------------------
-
-{-
-Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small
-changes Dec. 1997)
-
-Two rather obscure features are missing: The Bash 2.0 non-option hack
-(if you don't already know it, you probably don't want to hear about
-it...) and the recognition of long options with a single dash
-(e.g. '-help' is recognised as '--help', as long as there is no short
-option 'h').
-
-Other differences between GNU's getopt and this implementation:
-
-* To enforce a coherent description of options and arguments, there
- are explanation fields in the option/argument descriptor.
-
-* Error messages are now more informative, but no longer POSIX
- compliant... :-(
-
-And a final Haskell advertisement: The GNU C implementation uses well
-over 1100 lines, we need only 195 here, including a 46 line example!
-:-)
--}
-
-module System.Console.GetOpt (
- -- * GetOpt
- getOpt, getOpt',
- usageInfo,
- ArgOrder(..),
- OptDescr(..),
- ArgDescr(..),
-
- -- * Examples
-
- -- |To hopefully illuminate the role of the different data structures,
- -- here are the command-line options for a (very simple) compiler,
- -- done in two different ways.
- -- The difference arises because the type of 'getOpt' is
- -- parameterized by the type of values derived from flags.
-
- -- ** Interpreting flags as concrete values
- -- $example1
-
- -- ** Interpreting flags as transformations of an options record
- -- $example2
-) where
-
-import Prelude -- necessary to get dependencies right
-
-import Data.List ( isPrefixOf )
-
--- |What to do with options following non-options
-data ArgOrder a
- = RequireOrder -- ^ no option processing after first non-option
- | Permute -- ^ freely intersperse options and non-options
- | ReturnInOrder (String -> a) -- ^ wrap non-options into options
-
-{-|
-Each 'OptDescr' describes a single option.
-
-The arguments to 'Option' are:
-
-* list of short option characters
-
-* list of long option strings (without \"--\")
-
-* argument descriptor
-
-* explanation of option for user
--}
-data OptDescr a = -- description of a single options:
- Option [Char] -- list of short option characters
- [String] -- list of long option strings (without "--")
- (ArgDescr a) -- argument descriptor
- String -- explanation of option for user
-
--- |Describes whether an option takes an argument or not, and if so
--- how the argument is injected into a value of type @a@.
-data ArgDescr a
- = NoArg a -- ^ no argument expected
- | ReqArg (String -> a) String -- ^ option requires argument
- | OptArg (Maybe String -> a) String -- ^ optional argument
-
-data OptKind a -- kind of cmd line arg (internal use only):
- = Opt a -- an option
- | UnreqOpt String -- an un-recognized option
- | NonOpt String -- a non-option
- | EndOfOpts -- end-of-options marker (i.e. "--")
- | OptErr String -- something went wrong...
-
--- | Return a string describing the usage of a command, derived from
--- the header (first argument) and the options described by the
--- second argument.
-usageInfo :: String -- header
- -> [OptDescr a] -- option descriptors
- -> String -- nicely formatted decription of options
-usageInfo header optDescr = unlines (header:table)
- where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr
- table = zipWith3 paste (sameLen ss) (sameLen ls) ds
- paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z
- sameLen xs = flushLeft ((maximum . map length) xs) xs
- flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]
-
-fmtOpt :: OptDescr a -> [(String,String,String)]
-fmtOpt (Option sos los ad descr) =
- case lines descr of
- [] -> [(sosFmt,losFmt,"")]
- (d:ds) -> (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ]
- where sepBy _ [] = ""
- sepBy _ [x] = x
- sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs
- sosFmt = sepBy ',' (map (fmtShort ad) sos)
- losFmt = sepBy ',' (map (fmtLong ad) los)
-
-fmtShort :: ArgDescr a -> Char -> String
-fmtShort (NoArg _ ) so = "-" ++ [so]
-fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad
-fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"
-
-fmtLong :: ArgDescr a -> String -> String
-fmtLong (NoArg _ ) lo = "--" ++ lo
-fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
-fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
-
-{-|
-Process the command-line, and return the list of values that matched
-(and those that didn\'t). The arguments are:
-
-* The order requirements (see 'ArgOrder')
-
-* The option descriptions (see 'OptDescr')
-
-* The actual command line arguments (presumably got from
- 'System.Environment.getArgs').
-
-'getOpt' returns a triple consisting of the option arguments, a list
-of non-options, and a list of error messages.
--}
-getOpt :: ArgOrder a -- non-option handling
- -> [OptDescr a] -- option descriptors
- -> [String] -- the command-line arguments
- -> ([a],[String],[String]) -- (options,non-options,error messages)
-getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)
- where (os,xs,us,es) = getOpt' ordering optDescr args
-
-{-|
-This is almost the same as 'getOpt', but returns a quadruple
-consisting of the option arguments, a list of non-options, a list of
-unrecognized options, and a list of error messages.
--}
-getOpt' :: ArgOrder a -- non-option handling
- -> [OptDescr a] -- option descriptors
- -> [String] -- the command-line arguments
- -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)
-getOpt' _ _ [] = ([],[],[],[])
-getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering
- where procNextOpt (Opt o) _ = (o:os,xs,us,es)
- procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es)
- procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[])
- procNextOpt (NonOpt x) Permute = (os,x:xs,us,es)
- procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es)
- procNextOpt EndOfOpts RequireOrder = ([],rest,[],[])
- procNextOpt EndOfOpts Permute = ([],rest,[],[])
- procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[])
- procNextOpt (OptErr e) _ = (os,xs,us,e:es)
-
- (opt,rest) = getNext arg args optDescr
- (os,xs,us,es) = getOpt' ordering optDescr rest
-
--- take a look at the next cmd line arg and decide what to do with it
-getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
-getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)
-getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
-getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr
-getNext a rest _ = (NonOpt a,rest)
-
--- handle long option
-longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
-longOpt ls rs optDescr = long ads arg rs
- where (opt,arg) = break (=='=') ls
- getWith p = [ o | o@(Option _ xs _ _) <- optDescr, x <- xs, opt `p` x ]
- exact = getWith (==)
- options = if null exact then getWith isPrefixOf else exact
- ads = [ ad | Option _ _ ad _ <- options ]
- optStr = ("--"++opt)
-
- long (_:_:_) _ rest = (errAmbig options optStr,rest)
- long [NoArg a ] [] rest = (Opt a,rest)
- long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)
- long [ReqArg _ d] [] [] = (errReq d optStr,[])
- long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)
- long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)
- long [OptArg f _] [] rest = (Opt (f Nothing),rest)
- long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)
- long _ _ rest = (UnreqOpt ("--"++ls),rest)
-
--- handle short option
-shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
-shortOpt y ys rs optDescr = short ads ys rs
- where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]
- ads = [ ad | Option _ _ ad _ <- options ]
- optStr = '-':[y]
-
- short (_:_:_) _ rest = (errAmbig options optStr,rest)
- short (NoArg a :_) [] rest = (Opt a,rest)
- short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)
- short (ReqArg _ d:_) [] [] = (errReq d optStr,[])
- short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)
- short (ReqArg f _:_) xs rest = (Opt (f xs),rest)
- short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)
- short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest)
- short [] [] rest = (UnreqOpt optStr,rest)
- short [] xs rest = (UnreqOpt optStr,('-':xs):rest)
-
--- miscellaneous error formatting
-
-errAmbig :: [OptDescr a] -> String -> OptKind a
-errAmbig ods optStr = OptErr (usageInfo header ods)
- where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
-
-errReq :: String -> String -> OptKind a
-errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
-
-errUnrec :: String -> String
-errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
-
-errNoArg :: String -> OptKind a
-errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
-
-{-
------------------------------------------------------------------------------------------
--- and here a small and hopefully enlightening example:
-
-data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show
-
-options :: [OptDescr Flag]
-options =
- [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files",
- Option ['V','?'] ["version","release"] (NoArg Version) "show version info",
- Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump",
- Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"]
-
-out :: Maybe String -> Flag
-out Nothing = Output "stdout"
-out (Just o) = Output o
-
-test :: ArgOrder Flag -> [String] -> String
-test order cmdline = case getOpt order options cmdline of
- (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n"
- (_,_,errs) -> concat errs ++ usageInfo header options
- where header = "Usage: foobar [OPTION...] files..."
-
--- example runs:
--- putStr (test RequireOrder ["foo","-v"])
--- ==> options=[] args=["foo", "-v"]
--- putStr (test Permute ["foo","-v"])
--- ==> options=[Verbose] args=["foo"]
--- putStr (test (ReturnInOrder Arg) ["foo","-v"])
--- ==> options=[Arg "foo", Verbose] args=[]
--- putStr (test Permute ["foo","--","-v"])
--- ==> options=[] args=["foo", "-v"]
--- putStr (test Permute ["-?o","--name","bar","--na=baz"])
--- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[]
--- putStr (test Permute ["--ver","foo"])
--- ==> option `--ver' is ambiguous; could be one of:
--- -v --verbose verbosely list files
--- -V, -? --version, --release show version info
--- Usage: foobar [OPTION...] files...
--- -v --verbose verbosely list files
--- -V, -? --version, --release show version info
--- -o[FILE] --output[=FILE] use FILE for dump
--- -n USER --name=USER only dump USER's files
------------------------------------------------------------------------------------------
--}
-
-{- $example1
-
-A simple choice for the type associated with flags is to define a type
-@Flag@ as an algebraic type representing the possible flags and their
-arguments:
-
-> module Opts1 where
->
-> import System.Console.GetOpt
-> import Data.Maybe ( fromMaybe )
->
-> data Flag
-> = Verbose | Version
-> | Input String | Output String | LibDir String
-> deriving Show
->
-> options :: [OptDescr Flag]
-> options =
-> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr"
-> , Option ['V','?'] ["version"] (NoArg Version) "show version number"
-> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE"
-> , Option ['c'] [] (OptArg inp "FILE") "input FILE"
-> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory"
-> ]
->
-> inp,outp :: Maybe String -> Flag
-> outp = Output . fromMaybe "stdout"
-> inp = Input . fromMaybe "stdin"
->
-> compilerOpts :: [String] -> IO ([Flag], [String])
-> compilerOpts argv =
-> case getOpt Permute options argv of
-> (o,n,[] ) -> return (o,n)
-> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
-> where header = "Usage: ic [OPTION...] files..."
-
-Then the rest of the program will use the constructed list of flags
-to determine it\'s behaviour.
-
--}
-
-{- $example2
-
-A different approach is to group the option values in a record of type
-@Options@, and have each flag yield a function of type
-@Options -> Options@ transforming this record.
-
-> module Opts2 where
->
-> import System.Console.GetOpt
-> import Data.Maybe ( fromMaybe )
->
-> data Options = Options
-> { optVerbose :: Bool
-> , optShowVersion :: Bool
-> , optOutput :: Maybe FilePath
-> , optInput :: Maybe FilePath
-> , optLibDirs :: [FilePath]
-> } deriving Show
->
-> defaultOptions = Options
-> { optVerbose = False
-> , optShowVersion = False
-> , optOutput = Nothing
-> , optInput = Nothing
-> , optLibDirs = []
-> }
->
-> options :: [OptDescr (Options -> Options)]
-> options =
-> [ Option ['v'] ["verbose"]
-> (NoArg (\ opts -> opts { optVerbose = True }))
-> "chatty output on stderr"
-> , Option ['V','?'] ["version"]
-> (NoArg (\ opts -> opts { optShowVersion = True }))
-> "show version number"
-> , Option ['o'] ["output"]
-> (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output")
-> "FILE")
-> "output FILE"
-> , Option ['c'] []
-> (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input")
-> "FILE")
-> "input FILE"
-> , Option ['L'] ["libdir"]
-> (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR")
-> "library directory"
-> ]
->
-> compilerOpts :: [String] -> IO (Options, [String])
-> compilerOpts argv =
-> case getOpt Permute options argv of
-> (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)
-> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
-> where header = "Usage: ic [OPTION...] files..."
-
-Similarly, each flag could yield a monadic function transforming a record,
-of type @Options -> IO Options@ (or any other monad), allowing option
-processing to perform actions of the chosen monad, e.g. printing help or
-version messages, checking that file arguments exist, etc.
-
--}
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Environment
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Miscellaneous information about the system environment.
---
------------------------------------------------------------------------------
-
-module System.Environment
- (
- getArgs, -- :: IO [String]
- getProgName, -- :: IO String
- getEnv, -- :: String -> IO String
-#ifndef __NHC__
- withArgs,
- withProgName,
-#endif
-#ifdef __GLASGOW_HASKELL__
- getEnvironment,
-#endif
- ) where
-
-import Prelude
-
-#ifdef __GLASGOW_HASKELL__
-import Data.List
-import Foreign
-import Foreign.C
-import Control.Exception ( bracket )
-import Control.Monad
-import GHC.IOBase
-#endif
-
-#ifdef __HUGS__
-import Hugs.System
-#endif
-
-#ifdef __NHC__
-import System
- ( getArgs
- , getProgName
- , getEnv
- )
-#endif
-
--- ---------------------------------------------------------------------------
--- getArgs, getProgName, getEnv
-
--- | Computation 'getArgs' returns a list of the program's command
--- line arguments (not including the program name).
-
-#ifdef __GLASGOW_HASKELL__
-getArgs :: IO [String]
-getArgs =
- alloca $ \ p_argc ->
- alloca $ \ p_argv -> do
- getProgArgv p_argc p_argv
- p <- fromIntegral `liftM` peek p_argc
- argv <- peek p_argv
- peekArray (p - 1) (advancePtr argv 1) >>= mapM peekCString
-
-
-foreign import ccall unsafe "getProgArgv"
- getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
-
-{-|
-Computation 'getProgName' returns the name of the program as it was
-invoked.
-
-However, this is hard-to-impossible to implement on some non-Unix
-OSes, so instead, for maximum portability, we just return the leafname
-of the program as invoked. Even then there are some differences
-between platforms: on Windows, for example, a program invoked as foo
-is probably really @FOO.EXE@, and that is what 'getProgName' will return.
--}
-getProgName :: IO String
-getProgName =
- alloca $ \ p_argc ->
- alloca $ \ p_argv -> do
- getProgArgv p_argc p_argv
- argv <- peek p_argv
- unpackProgName argv
-
-unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0]
-unpackProgName argv = do
- s <- peekElemOff argv 0 >>= peekCString
- return (basename s)
- where
- basename :: String -> String
- basename f = go f f
- where
- go acc [] = acc
- go acc (x:xs)
- | isPathSeparator x = go xs xs
- | otherwise = go acc xs
-
- isPathSeparator :: Char -> Bool
- isPathSeparator '/' = True
-#ifdef mingw32_HOST_OS
- isPathSeparator '\\' = True
-#endif
- isPathSeparator _ = False
-
-
--- | Computation 'getEnv' @var@ returns the value
--- of the environment variable @var@.
---
--- This computation may fail with:
---
--- * 'System.IO.Error.isDoesNotExistError' if the environment variable
--- does not exist.
-
-getEnv :: String -> IO String
-getEnv name =
- withCString name $ \s -> do
- litstring <- c_getenv s
- if litstring /= nullPtr
- then peekCString litstring
- else ioException (IOError Nothing NoSuchThing "getEnv"
- "no environment variable" (Just name))
-
-foreign import ccall unsafe "getenv"
- c_getenv :: CString -> IO (Ptr CChar)
-
-{-|
-'withArgs' @args act@ - while executing action @act@, have 'getArgs'
-return @args@.
--}
-withArgs :: [String] -> IO a -> IO a
-withArgs xs act = do
- p <- System.Environment.getProgName
- withArgv (p:xs) act
-
-{-|
-'withProgName' @name act@ - while executing action @act@,
-have 'getProgName' return @name@.
--}
-withProgName :: String -> IO a -> IO a
-withProgName nm act = do
- xs <- System.Environment.getArgs
- withArgv (nm:xs) act
-
--- Worker routine which marshals and replaces an argv vector for
--- the duration of an action.
-
-withArgv :: [String] -> IO a -> IO a
-withArgv new_args act = do
- pName <- System.Environment.getProgName
- existing_args <- System.Environment.getArgs
- bracket (setArgs new_args)
- (\argv -> do setArgs (pName:existing_args); freeArgv argv)
- (const act)
-
-freeArgv :: Ptr CString -> IO ()
-freeArgv argv = do
- size <- lengthArray0 nullPtr argv
- sequence_ [peek (argv `advancePtr` i) >>= free | i <- [size, size-1 .. 0]]
- free argv
-
-setArgs :: [String] -> IO (Ptr CString)
-setArgs argv = do
- vs <- mapM newCString argv >>= newArray0 nullPtr
- setArgsPrim (genericLength argv) vs
- return vs
-
-foreign import ccall unsafe "setProgArgv"
- setArgsPrim :: CInt -> Ptr CString -> IO ()
-
--- |'getEnvironment' retrieves the entire environment as a
--- list of @(key,value)@ pairs.
---
--- If an environment entry does not contain an @\'=\'@ character,
--- the @key@ is the whole entry and the @value@ is the empty string.
-
-getEnvironment :: IO [(String, String)]
-getEnvironment = do
- pBlock <- getEnvBlock
- if pBlock == nullPtr then return []
- else do
- stuff <- peekArray0 nullPtr pBlock >>= mapM peekCString
- return (map divvy stuff)
- where
- divvy str =
- case break (=='=') str of
- (xs,[]) -> (xs,[]) -- don't barf (like Posix.getEnvironment)
- (name,_:value) -> (name,value)
-
-foreign import ccall unsafe "__hscore_environ"
- getEnvBlock :: IO (Ptr CString)
-#endif /* __GLASGOW_HASKELL__ */
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Exit
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Exiting the program.
---
------------------------------------------------------------------------------
-
-module System.Exit
- (
- ExitCode(ExitSuccess,ExitFailure)
- , exitWith -- :: ExitCode -> IO a
- , exitFailure -- :: IO a
- ) where
-
-import Prelude
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude
-import Hugs.Exception
-#endif
-
-#ifdef __NHC__
-import System
- ( ExitCode(..)
- , exitWith
- )
-#endif
-
--- ---------------------------------------------------------------------------
--- exitWith
-
--- | Computation 'exitWith' @code@ throws 'ExitException' @code@.
--- Normally this terminates the program, returning @code@ to the
--- program's caller. Before the program terminates, any open or
--- semi-closed handles are first closed.
---
--- A program that fails in any other way is treated as if it had
--- called 'exitFailure'.
--- A program that terminates successfully without calling 'exitWith'
--- explicitly is treated as it it had called 'exitWith' 'ExitSuccess'.
---
--- As an 'ExitException' is not an 'IOError', 'exitWith' bypasses
--- the error handling in the 'IO' monad and cannot be intercepted by
--- 'catch' from the "Prelude". However it is an 'Exception', and can
--- be caught using the functions of "Control.Exception". This means
--- that cleanup computations added with 'Control.Exception.bracket'
--- (from "Control.Exception") are also executed properly on 'exitWith'.
-
-#ifndef __NHC__
-exitWith :: ExitCode -> IO a
-exitWith ExitSuccess = throwIO (ExitException ExitSuccess)
-exitWith code@(ExitFailure n)
- | n /= 0 = throwIO (ExitException code)
-#ifdef __GLASGOW_HASKELL__
- | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing)
-#endif
-#endif /* ! __NHC__ */
-
--- | The computation 'exitFailure' is equivalent to
--- 'exitWith' @(@'ExitFailure' /exitfail/@)@,
--- where /exitfail/ is implementation-dependent.
-exitFailure :: IO a
-exitFailure = exitWith (ExitFailure 1)
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : System.IO
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : stable
--- Portability : portable
---
--- The standard IO library.
---
------------------------------------------------------------------------------
-
-module System.IO (
- -- * The IO monad
-
- IO, -- instance MonadFix
- fixIO, -- :: (a -> IO a) -> IO a
-
- -- * Files and handles
-
- FilePath, -- :: String
-
- Handle, -- abstract, instance of: Eq, Show.
-
- -- ** Standard handles
-
- -- | Three handles are allocated during program initialisation,
- -- and are initially open.
-
- stdin, stdout, stderr, -- :: Handle
-
- -- * Opening and closing files
-
- -- ** Opening files
-
- withFile,
- openFile, -- :: FilePath -> IOMode -> IO Handle
- IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),
-
- -- ** Closing files
-
- hClose, -- :: Handle -> IO ()
-
- -- ** Special cases
-
- -- | These functions are also exported by the "Prelude".
-
- readFile, -- :: FilePath -> IO String
- writeFile, -- :: FilePath -> String -> IO ()
- appendFile, -- :: FilePath -> String -> IO ()
-
- -- ** File locking
-
- -- $locking
-
- -- * Operations on handles
-
- -- ** Determining and changing the size of a file
-
- hFileSize, -- :: Handle -> IO Integer
-#ifdef __GLASGOW_HASKELL__
- hSetFileSize, -- :: Handle -> Integer -> IO ()
-#endif
-
- -- ** Detecting the end of input
-
- hIsEOF, -- :: Handle -> IO Bool
- isEOF, -- :: IO Bool
-
- -- ** Buffering operations
-
- BufferMode(NoBuffering,LineBuffering,BlockBuffering),
- hSetBuffering, -- :: Handle -> BufferMode -> IO ()
- hGetBuffering, -- :: Handle -> IO BufferMode
- hFlush, -- :: Handle -> IO ()
-
- -- ** Repositioning handles
-
- hGetPosn, -- :: Handle -> IO HandlePosn
- hSetPosn, -- :: HandlePosn -> IO ()
- HandlePosn, -- abstract, instance of: Eq, Show.
-
- hSeek, -- :: Handle -> SeekMode -> Integer -> IO ()
- SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
-#if !defined(__NHC__)
- hTell, -- :: Handle -> IO Integer
-#endif
-
- -- ** Handle properties
-
- hIsOpen, hIsClosed, -- :: Handle -> IO Bool
- hIsReadable, hIsWritable, -- :: Handle -> IO Bool
- hIsSeekable, -- :: Handle -> IO Bool
-
- -- ** Terminal operations
-
-#if !defined(__NHC__)
- hIsTerminalDevice, -- :: Handle -> IO Bool
-
- hSetEcho, -- :: Handle -> Bool -> IO ()
- hGetEcho, -- :: Handle -> IO Bool
-#endif
-
- -- ** Showing handle state
-
-#ifdef __GLASGOW_HASKELL__
- hShow, -- :: Handle -> IO String
-#endif
-
- -- * Text input and output
-
- -- ** Text input
-
- hWaitForInput, -- :: Handle -> Int -> IO Bool
- hReady, -- :: Handle -> IO Bool
- hGetChar, -- :: Handle -> IO Char
- hGetLine, -- :: Handle -> IO [Char]
- hLookAhead, -- :: Handle -> IO Char
- hGetContents, -- :: Handle -> IO [Char]
-
- -- ** Text output
-
- hPutChar, -- :: Handle -> Char -> IO ()
- hPutStr, -- :: Handle -> [Char] -> IO ()
- hPutStrLn, -- :: Handle -> [Char] -> IO ()
- hPrint, -- :: Show a => Handle -> a -> IO ()
-
- -- ** Special cases for standard input and output
-
- -- | These functions are also exported by the "Prelude".
-
- interact, -- :: (String -> String) -> IO ()
- putChar, -- :: Char -> IO ()
- putStr, -- :: String -> IO ()
- putStrLn, -- :: String -> IO ()
- print, -- :: Show a => a -> IO ()
- getChar, -- :: IO Char
- getLine, -- :: IO String
- getContents, -- :: IO String
- readIO, -- :: Read a => String -> IO a
- readLn, -- :: Read a => IO a
-
- -- * Binary input and output
-
- withBinaryFile,
- openBinaryFile, -- :: FilePath -> IOMode -> IO Handle
- hSetBinaryMode, -- :: Handle -> Bool -> IO ()
- hPutBuf, -- :: Handle -> Ptr a -> Int -> IO ()
- hGetBuf, -- :: Handle -> Ptr a -> Int -> IO Int
-#if !defined(__NHC__) && !defined(__HUGS__)
- hPutBufNonBlocking, -- :: Handle -> Ptr a -> Int -> IO Int
- hGetBufNonBlocking, -- :: Handle -> Ptr a -> Int -> IO Int
-#endif
-
- -- * Temporary files (not portable: GHC only)
-
-#ifdef __GLASGOW_HASKELL__
- openTempFile,
- openBinaryTempFile,
-#endif
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.IOBase -- Together these four Prelude modules define
-import GHC.Handle -- all the stuff exported by IO for the GHC version
-import GHC.IO
-import GHC.Exception
-import GHC.Num
-import GHC.Read
-import GHC.Show
-#endif
-
-#ifdef __HUGS__
-import Hugs.IO
-import Hugs.IOExts
-import Hugs.IORef
-import Hugs.Prelude ( throw, Exception(NonTermination) )
-import Control.Exception ( bracket )
-import System.IO.Unsafe ( unsafeInterleaveIO )
-#endif
-
-#ifdef __NHC__
-import IO
- ( Handle ()
- , HandlePosn ()
- , IOMode (ReadMode,WriteMode,AppendMode,ReadWriteMode)
- , BufferMode (NoBuffering,LineBuffering,BlockBuffering)
- , SeekMode (AbsoluteSeek,RelativeSeek,SeekFromEnd)
- , stdin, stdout, stderr
- , openFile -- :: FilePath -> IOMode -> IO Handle
- , hClose -- :: Handle -> IO ()
- , hFileSize -- :: Handle -> IO Integer
- , hIsEOF -- :: Handle -> IO Bool
- , isEOF -- :: IO Bool
- , hSetBuffering -- :: Handle -> BufferMode -> IO ()
- , hGetBuffering -- :: Handle -> IO BufferMode
- , hFlush -- :: Handle -> IO ()
- , hGetPosn -- :: Handle -> IO HandlePosn
- , hSetPosn -- :: HandlePosn -> IO ()
- , hSeek -- :: Handle -> SeekMode -> Integer -> IO ()
- , hWaitForInput -- :: Handle -> Int -> IO Bool
- , hGetChar -- :: Handle -> IO Char
- , hGetLine -- :: Handle -> IO [Char]
- , hLookAhead -- :: Handle -> IO Char
- , hGetContents -- :: Handle -> IO [Char]
- , hPutChar -- :: Handle -> Char -> IO ()
- , hPutStr -- :: Handle -> [Char] -> IO ()
- , hPutStrLn -- :: Handle -> [Char] -> IO ()
- , hPrint -- :: Handle -> [Char] -> IO ()
- , hReady -- :: Handle -> [Char] -> IO ()
- , hIsOpen, hIsClosed -- :: Handle -> IO Bool
- , hIsReadable, hIsWritable -- :: Handle -> IO Bool
- , hIsSeekable -- :: Handle -> IO Bool
- , bracket
-
- , IO ()
- , FilePath -- :: String
- )
-import NHC.IOExtras (fixIO, hPutBuf, hGetBuf)
-import NHC.FFI (Ptr)
-#endif
-
--- -----------------------------------------------------------------------------
--- Standard IO
-
-#ifdef __GLASGOW_HASKELL__
--- | Write a character to the standard output device
--- (same as 'hPutChar' 'stdout').
-
-putChar :: Char -> IO ()
-putChar c = hPutChar stdout c
-
--- | Write a string to the standard output device
--- (same as 'hPutStr' 'stdout').
-
-putStr :: String -> IO ()
-putStr s = hPutStr stdout s
-
--- | The same as 'putStr', but adds a newline character.
-
-putStrLn :: String -> IO ()
-putStrLn s = do putStr s
- putChar '\n'
-
--- | The 'print' function outputs a value of any printable type to the
--- standard output device.
--- Printable types are those that are instances of class 'Show'; 'print'
--- converts values to strings for output using the 'show' operation and
--- adds a newline.
---
--- For example, a program to print the first 20 integers and their
--- powers of 2 could be written as:
---
--- > main = print ([(n, 2^n) | n <- [0..19]])
-
-print :: Show a => a -> IO ()
-print x = putStrLn (show x)
-
--- | Read a character from the standard input device
--- (same as 'hGetChar' 'stdin').
-
-getChar :: IO Char
-getChar = hGetChar stdin
-
--- | Read a line from the standard input device
--- (same as 'hGetLine' 'stdin').
-
-getLine :: IO String
-getLine = hGetLine stdin
-
--- | The 'getContents' operation returns all user input as a single string,
--- which is read lazily as it is needed
--- (same as 'hGetContents' 'stdin').
-
-getContents :: IO String
-getContents = hGetContents stdin
-
--- | The 'interact' function takes a function of type @String->String@
--- as its argument. The entire input from the standard input device is
--- passed to this function as its argument, and the resulting string is
--- output on the standard output device.
-
-interact :: (String -> String) -> IO ()
-interact f = do s <- getContents
- putStr (f s)
-
--- | The 'readFile' function reads a file and
--- returns the contents of the file as a string.
--- The file is read lazily, on demand, as with 'getContents'.
-
-readFile :: FilePath -> IO String
-readFile name = openFile name ReadMode >>= hGetContents
-
--- | The computation 'writeFile' @file str@ function writes the string @str@,
--- to the file @file@.
-writeFile :: FilePath -> String -> IO ()
-writeFile f txt = withFile f WriteMode (\ hdl -> hPutStr hdl txt)
-
--- | The computation 'appendFile' @file str@ function appends the string @str@,
--- to the file @file@.
---
--- Note that 'writeFile' and 'appendFile' write a literal string
--- to a file. To write a value of any printable type, as with 'print',
--- use the 'show' function to convert the value to a string first.
---
--- > main = appendFile "squares" (show [(x,x*x) | x <- [0,0.1..2]])
-
-appendFile :: FilePath -> String -> IO ()
-appendFile f txt = withFile f AppendMode (\ hdl -> hPutStr hdl txt)
-
--- | The 'readLn' function combines 'getLine' and 'readIO'.
-
-readLn :: Read a => IO a
-readLn = do l <- getLine
- r <- readIO l
- return r
-
--- | The 'readIO' function is similar to 'read' except that it signals
--- parse failure to the 'IO' monad instead of terminating the program.
-
-readIO :: Read a => String -> IO a
-readIO s = case (do { (x,t) <- reads s ;
- ("","") <- lex t ;
- return x }) of
- [x] -> return x
- [] -> ioError (userError "Prelude.readIO: no parse")
- _ -> ioError (userError "Prelude.readIO: ambiguous parse")
-#endif /* __GLASGOW_HASKELL__ */
-
-#ifndef __NHC__
--- | Computation 'hReady' @hdl@ indicates whether at least one item is
--- available for input from handle @hdl@.
---
--- This operation may fail with:
---
--- * 'System.IO.Error.isEOFError' if the end of file has been reached.
-
-hReady :: Handle -> IO Bool
-hReady h = hWaitForInput h 0
-
--- | The same as 'hPutStr', but adds a newline character.
-
-hPutStrLn :: Handle -> String -> IO ()
-hPutStrLn hndl str = do
- hPutStr hndl str
- hPutChar hndl '\n'
-
--- | Computation 'hPrint' @hdl t@ writes the string representation of @t@
--- given by the 'shows' function to the file or channel managed by @hdl@
--- and appends a newline.
---
--- This operation may fail with:
---
--- * 'System.IO.Error.isFullError' if the device is full; or
---
--- * 'System.IO.Error.isPermissionError' if another system resource limit would be exceeded.
-
-hPrint :: Show a => Handle -> a -> IO ()
-hPrint hdl = hPutStrLn hdl . show
-#endif /* !__NHC__ */
-
--- | @'withFile' name mode act@ opens a file using 'openFile' and passes
--- the resulting handle to the computation @act@. The handle will be
--- closed on exit from 'withFile', whether by normal termination or by
--- raising an exception.
-withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
-withFile name mode = bracket (openFile name mode) hClose
-
--- | @'withBinaryFile' name mode act@ opens a file using 'openBinaryFile'
--- and passes the resulting handle to the computation @act@. The handle
--- will be closed on exit from 'withBinaryFile', whether by normal
--- termination or by raising an exception.
-withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
-withBinaryFile name mode = bracket (openBinaryFile name mode) hClose
-
--- ---------------------------------------------------------------------------
--- fixIO
-
-#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
-fixIO :: (a -> IO a) -> IO a
-fixIO k = do
- ref <- newIORef (throw NonTermination)
- ans <- unsafeInterleaveIO (readIORef ref)
- result <- k ans
- writeIORef ref result
- return result
-
--- NOTE: we do our own explicit black holing here, because GHC's lazy
--- blackholing isn't enough. In an infinite loop, GHC may run the IO
--- computation a few times before it notices the loop, which is wrong.
-#endif
-
-#if defined(__NHC__)
--- Assume a unix platform, where text and binary I/O are identical.
-openBinaryFile = openFile
-hSetBinaryMode _ _ = return ()
-#endif
-
--- $locking
--- Implementations should enforce as far as possible, at least locally to the
--- Haskell process, multiple-reader single-writer locking on files.
--- That is, /there may either be many handles on the same file which manage
--- input, or just one handle on the file which manages output/. If any
--- open or semi-closed handle is managing a file for output, no new
--- handle can be allocated for that file. If any open or semi-closed
--- handle is managing a file for input, new handles can only be allocated
--- if they do not manage output. Whether two files are the same is
--- implementation-dependent, but they should normally be the same if they
--- have the same absolute path name and neither has been renamed, for
--- example.
---
--- /Warning/: the 'readFile' operation holds a semi-closed handle on
--- the file until the entire contents of the file have been consumed.
--- It follows that an attempt to write to a file (using 'writeFile', for
--- example) that was earlier opened by 'readFile' will usually result in
--- failure with 'System.IO.Error.isAlreadyInUseError'.
-
--- -----------------------------------------------------------------------------
--- Utils
-
-#ifdef __GLASGOW_HASKELL__
--- Copied here to avoid recursive dependency with Control.Exception
-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 <- catchException
- (unblock (thing a))
- (\e -> do { after a; throw e })
- after a
- return r
- )
-#endif
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
-
------------------------------------------------------------------------------
--- |
--- Module : System.IO.Error
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Standard IO Errors.
---
------------------------------------------------------------------------------
-
-module System.IO.Error (
-
- -- * I\/O errors
- IOError, -- = IOException
-
- userError, -- :: String -> IOError
-
-#ifndef __NHC__
- mkIOError, -- :: IOErrorType -> String -> Maybe Handle
- -- -> Maybe FilePath -> IOError
-
- annotateIOError, -- :: IOError -> String -> Maybe Handle
- -- -> Maybe FilePath -> IOError
-#endif
-
- -- ** Classifying I\/O errors
- isAlreadyExistsError, -- :: IOError -> Bool
- isDoesNotExistError,
- isAlreadyInUseError,
- isFullError,
- isEOFError,
- isIllegalOperation,
- isPermissionError,
- isUserError,
-
- -- ** Attributes of I\/O errors
-#ifndef __NHC__
- ioeGetErrorType, -- :: IOError -> IOErrorType
- ioeGetLocation, -- :: IOError -> String
-#endif
- ioeGetErrorString, -- :: IOError -> String
- ioeGetHandle, -- :: IOError -> Maybe Handle
- ioeGetFileName, -- :: IOError -> Maybe FilePath
-
-#ifndef __NHC__
- ioeSetErrorType, -- :: IOError -> IOErrorType -> IOError
- ioeSetErrorString, -- :: IOError -> String -> IOError
- ioeSetLocation, -- :: IOError -> String -> IOError
- ioeSetHandle, -- :: IOError -> Handle -> IOError
- ioeSetFileName, -- :: IOError -> FilePath -> IOError
-#endif
-
- -- * Types of I\/O error
- IOErrorType, -- abstract
-
- alreadyExistsErrorType, -- :: IOErrorType
- doesNotExistErrorType,
- alreadyInUseErrorType,
- fullErrorType,
- eofErrorType,
- illegalOperationErrorType,
- permissionErrorType,
- userErrorType,
-
- -- ** 'IOErrorType' predicates
- isAlreadyExistsErrorType, -- :: IOErrorType -> Bool
- isDoesNotExistErrorType,
- isAlreadyInUseErrorType,
- isFullErrorType,
- isEOFErrorType,
- isIllegalOperationErrorType,
- isPermissionErrorType,
- isUserErrorType,
-
- -- * Throwing and catching I\/O errors
-
- ioError, -- :: IOError -> IO a
-
- catch, -- :: IO a -> (IOError -> IO a) -> IO a
- try, -- :: IO a -> IO (Either IOError a)
-
-#ifndef __NHC__
- modifyIOError, -- :: (IOError -> IOError) -> IO a -> IO a
-#endif
- ) where
-
-import Data.Either
-import Data.Maybe
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.IOBase
-import GHC.Exception
-import Text.Show
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude(Handle, IOException(..), IOErrorType(..))
-#endif
-
-#ifdef __NHC__
-import IO
- ( IOError ()
- , try
- , ioError
- , userError
- , isAlreadyExistsError -- :: IOError -> Bool
- , isDoesNotExistError
- , isAlreadyInUseError
- , isFullError
- , isEOFError
- , isIllegalOperation
- , isPermissionError
- , isUserError
- , ioeGetErrorString -- :: IOError -> String
- , ioeGetHandle -- :: IOError -> Maybe Handle
- , ioeGetFileName -- :: IOError -> Maybe FilePath
- )
---import Data.Maybe (fromJust)
---import Control.Monad (MonadPlus(mplus))
-#endif
-
--- | The construct 'try' @comp@ exposes IO errors which occur within a
--- computation, and which are not fully handled.
---
--- Non-I\/O exceptions are not caught by this variant; to catch all
--- exceptions, use 'Control.Exception.try' from "Control.Exception".
-
-#ifndef __NHC__
-try :: IO a -> IO (Either IOError a)
-try f = catch (do r <- f
- return (Right r))
- (return . Left)
-#endif
-
-#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
--- -----------------------------------------------------------------------------
--- Constructing an IOError
-
--- | Construct an 'IOError' of the given type where the second argument
--- describes the error location and the third and fourth argument
--- contain the file handle and file path of the file involved in the
--- error if applicable.
-mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> IOError
-mkIOError t location maybe_hdl maybe_filename =
- IOError{ ioe_type = t,
- ioe_location = location,
- ioe_description = "",
- ioe_handle = maybe_hdl,
- ioe_filename = maybe_filename
- }
-#ifdef __NHC__
-mkIOError EOF location maybe_hdl maybe_filename =
- EOFError location (fromJust maybe_hdl)
-mkIOError UserError location maybe_hdl maybe_filename =
- UserError location ""
-mkIOError t location maybe_hdl maybe_filename =
- NHC.FFI.mkIOError location maybe_filename maybe_handle (ioeTypeToInt t)
- where
- ioeTypeToInt AlreadyExists = fromEnum EEXIST
- ioeTypeToInt NoSuchThing = fromEnum ENOENT
- ioeTypeToInt ResourceBusy = fromEnum EBUSY
- ioeTypeToInt ResourceExhausted = fromEnum ENOSPC
- ioeTypeToInt IllegalOperation = fromEnum EPERM
- ioeTypeToInt PermissionDenied = fromEnum EACCES
-#endif
-#endif /* __GLASGOW_HASKELL__ || __HUGS__ */
-
-#ifndef __NHC__
--- -----------------------------------------------------------------------------
--- IOErrorType
-
--- | An error indicating that an 'IO' operation failed because
--- one of its arguments already exists.
-isAlreadyExistsError :: IOError -> Bool
-isAlreadyExistsError = isAlreadyExistsErrorType . ioeGetErrorType
-
--- | An error indicating that an 'IO' operation failed because
--- one of its arguments does not exist.
-isDoesNotExistError :: IOError -> Bool
-isDoesNotExistError = isDoesNotExistErrorType . ioeGetErrorType
-
--- | An error indicating that an 'IO' operation failed because
--- one of its arguments is a single-use resource, which is already
--- being used (for example, opening the same file twice for writing
--- might give this error).
-isAlreadyInUseError :: IOError -> Bool
-isAlreadyInUseError = isAlreadyInUseErrorType . ioeGetErrorType
-
--- | An error indicating that an 'IO' operation failed because
--- the device is full.
-isFullError :: IOError -> Bool
-isFullError = isFullErrorType . ioeGetErrorType
-
--- | An error indicating that an 'IO' operation failed because
--- the end of file has been reached.
-isEOFError :: IOError -> Bool
-isEOFError = isEOFErrorType . ioeGetErrorType
-
--- | An error indicating that an 'IO' operation failed because
--- the operation was not possible.
--- Any computation which returns an 'IO' result may fail with
--- 'isIllegalOperation'. In some cases, an implementation will not be
--- able to distinguish between the possible error causes. In this case
--- it should fail with 'isIllegalOperation'.
-isIllegalOperation :: IOError -> Bool
-isIllegalOperation = isIllegalOperationErrorType . ioeGetErrorType
-
--- | An error indicating that an 'IO' operation failed because
--- the user does not have sufficient operating system privilege
--- to perform that operation.
-isPermissionError :: IOError -> Bool
-isPermissionError = isPermissionErrorType . ioeGetErrorType
-
--- | A programmer-defined error value constructed using 'userError'.
-isUserError :: IOError -> Bool
-isUserError = isUserErrorType . ioeGetErrorType
-#endif /* __NHC__ */
-
--- -----------------------------------------------------------------------------
--- IOErrorTypes
-
-#ifdef __NHC__
-data IOErrorType = AlreadyExists | NoSuchThing | ResourceBusy
- | ResourceExhausted | EOF | IllegalOperation
- | PermissionDenied | UserError
-#endif
-
--- | I\/O error where the operation failed because one of its arguments
--- already exists.
-alreadyExistsErrorType :: IOErrorType
-alreadyExistsErrorType = AlreadyExists
-
--- | I\/O error where the operation failed because one of its arguments
--- does not exist.
-doesNotExistErrorType :: IOErrorType
-doesNotExistErrorType = NoSuchThing
-
--- | I\/O error where the operation failed because one of its arguments
--- is a single-use resource, which is already being used.
-alreadyInUseErrorType :: IOErrorType
-alreadyInUseErrorType = ResourceBusy
-
--- | I\/O error where the operation failed because the device is full.
-fullErrorType :: IOErrorType
-fullErrorType = ResourceExhausted
-
--- | I\/O error where the operation failed because the end of file has
--- been reached.
-eofErrorType :: IOErrorType
-eofErrorType = EOF
-
--- | I\/O error where the operation is not possible.
-illegalOperationErrorType :: IOErrorType
-illegalOperationErrorType = IllegalOperation
-
--- | I\/O error where the operation failed because the user does not
--- have sufficient operating system privilege to perform that operation.
-permissionErrorType :: IOErrorType
-permissionErrorType = PermissionDenied
-
--- | I\/O error that is programmer-defined.
-userErrorType :: IOErrorType
-userErrorType = UserError
-
--- -----------------------------------------------------------------------------
--- IOErrorType predicates
-
--- | I\/O error where the operation failed because one of its arguments
--- already exists.
-isAlreadyExistsErrorType :: IOErrorType -> Bool
-isAlreadyExistsErrorType AlreadyExists = True
-isAlreadyExistsErrorType _ = False
-
--- | I\/O error where the operation failed because one of its arguments
--- does not exist.
-isDoesNotExistErrorType :: IOErrorType -> Bool
-isDoesNotExistErrorType NoSuchThing = True
-isDoesNotExistErrorType _ = False
-
--- | I\/O error where the operation failed because one of its arguments
--- is a single-use resource, which is already being used.
-isAlreadyInUseErrorType :: IOErrorType -> Bool
-isAlreadyInUseErrorType ResourceBusy = True
-isAlreadyInUseErrorType _ = False
-
--- | I\/O error where the operation failed because the device is full.
-isFullErrorType :: IOErrorType -> Bool
-isFullErrorType ResourceExhausted = True
-isFullErrorType _ = False
-
--- | I\/O error where the operation failed because the end of file has
--- been reached.
-isEOFErrorType :: IOErrorType -> Bool
-isEOFErrorType EOF = True
-isEOFErrorType _ = False
-
--- | I\/O error where the operation is not possible.
-isIllegalOperationErrorType :: IOErrorType -> Bool
-isIllegalOperationErrorType IllegalOperation = True
-isIllegalOperationErrorType _ = False
-
--- | I\/O error where the operation failed because the user does not
--- have sufficient operating system privilege to perform that operation.
-isPermissionErrorType :: IOErrorType -> Bool
-isPermissionErrorType PermissionDenied = True
-isPermissionErrorType _ = False
-
--- | I\/O error that is programmer-defined.
-isUserErrorType :: IOErrorType -> Bool
-isUserErrorType UserError = True
-isUserErrorType _ = False
-
--- -----------------------------------------------------------------------------
--- Miscellaneous
-
-#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
-ioeGetErrorType :: IOError -> IOErrorType
-ioeGetErrorString :: IOError -> String
-ioeGetLocation :: IOError -> String
-ioeGetHandle :: IOError -> Maybe Handle
-ioeGetFileName :: IOError -> Maybe FilePath
-
-ioeGetErrorType ioe = ioe_type ioe
-
-ioeGetErrorString ioe
- | isUserErrorType (ioe_type ioe) = ioe_description ioe
- | otherwise = show (ioe_type ioe)
-
-ioeGetLocation ioe = ioe_location ioe
-
-ioeGetHandle ioe = ioe_handle ioe
-
-ioeGetFileName ioe = ioe_filename ioe
-
-ioeSetErrorType :: IOError -> IOErrorType -> IOError
-ioeSetErrorString :: IOError -> String -> IOError
-ioeSetLocation :: IOError -> String -> IOError
-ioeSetHandle :: IOError -> Handle -> IOError
-ioeSetFileName :: IOError -> FilePath -> IOError
-
-ioeSetErrorType ioe errtype = ioe{ ioe_type = errtype }
-ioeSetErrorString ioe str = ioe{ ioe_description = str }
-ioeSetLocation ioe str = ioe{ ioe_location = str }
-ioeSetHandle ioe hdl = ioe{ ioe_handle = Just hdl }
-ioeSetFileName ioe filename = ioe{ ioe_filename = Just filename }
-
--- | Catch any 'IOError' that occurs in the computation and throw a
--- modified version.
-modifyIOError :: (IOError -> IOError) -> IO a -> IO a
-modifyIOError f io = catch io (\e -> ioError (f e))
-
--- -----------------------------------------------------------------------------
--- annotating an IOError
-
--- | Adds a location description and maybe a file path and file handle
--- to an 'IOError'. If any of the file handle or file path is not given
--- the corresponding value in the 'IOError' remains unaltered.
-annotateIOError :: IOError
- -> String
- -> Maybe Handle
- -> Maybe FilePath
- -> IOError
-annotateIOError (IOError ohdl errTy _ str opath) loc hdl path =
- IOError (hdl `mplus` ohdl) errTy loc str (path `mplus` opath)
- where
- Nothing `mplus` ys = ys
- xs `mplus` _ = xs
-#endif /* __GLASGOW_HASKELL__ || __HUGS__ */
-
-#if 0 /*__NHC__*/
-annotateIOError (IOError msg file hdl code) msg' file' hdl' =
- IOError (msg++'\n':msg') (file`mplus`file') (hdl`mplus`hdl') code
-annotateIOError (EOFError msg hdl) msg' file' hdl' =
- EOFError (msg++'\n':msg') (hdl`mplus`hdl')
-annotateIOError (UserError loc msg) msg' file' hdl' =
- UserError loc (msg++'\n':msg')
-annotateIOError (PatternError loc) msg' file' hdl' =
- PatternError (loc++'\n':msg')
-#endif
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : System.IO.Unsafe
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- \"Unsafe\" IO operations.
---
------------------------------------------------------------------------------
-
-module System.IO.Unsafe (
- -- * Unsafe 'System.IO.IO' operations
- unsafePerformIO, -- :: IO a -> a
- unsafeInterleaveIO, -- :: IO a -> IO a
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase (unsafePerformIO, unsafeInterleaveIO)
-#endif
-
-#ifdef __HUGS__
-import Hugs.IOExts (unsafePerformIO, unsafeInterleaveIO)
-#endif
-
-#ifdef __NHC__
-import NHC.Internal (unsafePerformIO)
-#endif
-
-#if !__GLASGOW_HASKELL__ && !__HUGS__
-unsafeInterleaveIO :: IO a -> IO a
-unsafeInterleaveIO f = return (unsafePerformIO f)
-#endif
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Info
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Information about the characteristics of the host
--- system lucky enough to run your program.
---
------------------------------------------------------------------------------
-
-module System.Info
- (
- os, -- :: String
- arch, -- :: String
- compilerName, -- :: String
- compilerVersion -- :: Version
- ) where
-
-import Prelude
-import Data.Version
-
--- | The version of 'compilerName' with which the program was compiled
--- or is being interpreted.
-compilerVersion :: Version
-compilerVersion = Version {versionBranch=[maj,min], versionTags=[]}
- where (maj,min) = compilerVersionRaw `divMod` 100
-
--- | The operating system on which the program is running.
-os :: String
-
--- | The machine architecture on which the program is running.
-arch :: String
-
--- | The Haskell implementation with which the program was compiled
--- or is being interpreted.
-compilerName :: String
-
-compilerVersionRaw :: Int
-
-#if defined(__NHC__)
-#include "OSInfo.hs"
-compilerName = "nhc98"
-compilerVersionRaw = __NHC__
-
-#elif defined(__GLASGOW_HASKELL__)
-#include "ghcplatform.h"
-os = HOST_OS
-arch = HOST_ARCH
-compilerName = "ghc"
-compilerVersionRaw = __GLASGOW_HASKELL__
-
-#elif defined(__HUGS__)
-#include "platform.h"
-os = HOST_OS
-arch = HOST_ARCH
-compilerName = "hugs"
-compilerVersionRaw = 0 -- ToDo
-
-#else
-#error Unknown compiler name
-#endif
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Locale
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : stable
--- Portability : portable
---
--- This module provides the ability to adapt to local conventions.
--- At present, it supports only time and date information as used by
--- 'System.Time.calendarTimeToString' from the "System.Time" module.
---
------------------------------------------------------------------------------
-
-module System.Locale (
-
- TimeLocale(..)
-
- , defaultTimeLocale
-
- , iso8601DateFormat
- , rfc822DateFormat
- )
-where
-
-import Prelude
-
-data TimeLocale = TimeLocale {
- -- |full and abbreviated week days
- wDays :: [(String, String)],
- -- |full and abbreviated months
- months :: [(String, String)],
- intervals :: [(String, String)],
- -- |AM\/PM symbols
- amPm :: (String, String),
- -- |formatting strings
- dateTimeFmt, dateFmt,
- timeFmt, time12Fmt :: String
- } deriving (Eq, Ord, Show)
-
-defaultTimeLocale :: TimeLocale
-defaultTimeLocale = TimeLocale {
- wDays = [("Sunday", "Sun"), ("Monday", "Mon"),
- ("Tuesday", "Tue"), ("Wednesday", "Wed"),
- ("Thursday", "Thu"), ("Friday", "Fri"),
- ("Saturday", "Sat")],
-
- months = [("January", "Jan"), ("February", "Feb"),
- ("March", "Mar"), ("April", "Apr"),
- ("May", "May"), ("June", "Jun"),
- ("July", "Jul"), ("August", "Aug"),
- ("September", "Sep"), ("October", "Oct"),
- ("November", "Nov"), ("December", "Dec")],
-
- intervals = [ ("year","years")
- , ("month", "months")
- , ("day","days")
- , ("hour","hours")
- , ("min","mins")
- , ("sec","secs")
- , ("usec","usecs")
- ],
-
- amPm = ("AM", "PM"),
- dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y",
- dateFmt = "%m/%d/%y",
- timeFmt = "%H:%M:%S",
- time12Fmt = "%I:%M:%S %p"
- }
-
-
--- |Normally, ISO-8601 just defines YYYY-MM-DD
--- but we can add a time spec.
-
-iso8601DateFormat :: Maybe String -> String
-iso8601DateFormat timeFmt =
- "%Y-%m-%d" ++ case timeFmt of
- Nothing -> ""
- Just fmt -> ' ' : fmt
-
-
-rfc822DateFormat :: String
-rfc822DateFormat = "%a, %_d %b %Y %H:%M:%S %Z"
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Mem
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Memory-related system things.
---
------------------------------------------------------------------------------
-
-module System.Mem (
- performGC -- :: IO ()
- ) where
-
-import Prelude
-
-#ifdef __HUGS__
-import Hugs.IOExts
-#endif
-
-#ifdef __GLASGOW_HASKELL__
--- | Triggers an immediate garbage collection
-foreign import ccall {-safe-} "performMajorGC" performGC :: IO ()
-#endif
-
-#ifdef __NHC__
-import NHC.IOExtras (performGC)
-#endif
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Mem.StableName
--- 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
---
--- Stable names are a way of performing fast (O(1)), not-quite-exact
--- comparison between objects.
---
--- Stable names solve the following problem: suppose you want to build
--- a hash table with Haskell objects as keys, but you want to use
--- pointer equality for comparison; maybe because the keys are large
--- and hashing would be slow, or perhaps because the keys are infinite
--- in size. We can\'t build a hash table using the address of the
--- object as the key, because objects get moved around by the garbage
--- collector, meaning a re-hash would be necessary after every garbage
--- collection.
---
--------------------------------------------------------------------------------
-
-module System.Mem.StableName (
- -- * Stable Names
- StableName,
- makeStableName,
- hashStableName,
- ) where
-
-import Prelude
-
-import Data.Typeable
-
-#ifdef __HUGS__
-import Hugs.Stable
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase ( IO(..) )
-import GHC.Base ( Int(..), StableName#, makeStableName#
- , eqStableName#, stableNameToInt# )
-
------------------------------------------------------------------------------
--- Stable Names
-
-{-|
- An abstract name for an object, that supports equality and hashing.
-
- Stable names have the following property:
-
- * If @sn1 :: StableName@ and @sn2 :: StableName@ and @sn1 == sn2@
- then @sn1@ and @sn2@ were created by calls to @makeStableName@ on
- the same object.
-
- The reverse is not necessarily true: if two stable names are not
- equal, then the objects they name may still be equal.
-
- Stable Names are similar to Stable Pointers ("Foreign.StablePtr"),
- but differ in the following ways:
-
- * There is no @freeStableName@ operation, unlike "Foreign.StablePtr"s.
- Stable names are reclaimed by the runtime system when they are no
- longer needed.
-
- * There is no @deRefStableName@ operation. You can\'t get back from
- a stable name to the original Haskell object. The reason for
- this is that the existence of a stable name for an object does not
- guarantee the existence of the object itself; it can still be garbage
- collected.
--}
-
-data StableName a = StableName (StableName# a)
-
-
--- | Makes a 'StableName' for an arbitrary object. The object passed as
--- the first argument is not evaluated by 'makeStableName'.
-makeStableName :: a -> IO (StableName a)
-#if defined(__PARALLEL_HASKELL__)
-makeStableName a =
- error "makeStableName not implemented in parallel Haskell"
-#else
-makeStableName a = IO $ \ s ->
- case makeStableName# a s of (# s', sn #) -> (# s', StableName sn #)
-#endif
-
--- | Convert a 'StableName' to an 'Int'. The 'Int' returned is not
--- necessarily unique; several 'StableName's may map to the same 'Int'
--- (in practice however, the chances of this are small, so the result
--- of 'hashStableName' makes a good hash key).
-hashStableName :: StableName a -> Int
-#if defined(__PARALLEL_HASKELL__)
-hashStableName (StableName sn) =
- error "hashStableName not implemented in parallel Haskell"
-#else
-hashStableName (StableName sn) = I# (stableNameToInt# sn)
-#endif
-
-instance Eq (StableName a) where
-#if defined(__PARALLEL_HASKELL__)
- (StableName sn1) == (StableName sn2) =
- error "eqStableName not implemented in parallel Haskell"
-#else
- (StableName sn1) == (StableName sn2) =
- case eqStableName# sn1 sn2 of
- 0# -> False
- _ -> True
-#endif
-
-#endif /* __GLASGOW_HASKELL__ */
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(StableName,stableNameTc,"StableName")
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Mem.Weak
--- 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
---
--- In general terms, a weak pointer is a reference to an object that is
--- not followed by the garbage collector - that is, the existence of a
--- weak pointer to an object has no effect on the lifetime of that
--- object. A weak pointer can be de-referenced to find out
--- whether the object it refers to is still alive or not, and if so
--- to return the object itself.
---
--- Weak pointers are particularly useful for caches and memo tables.
--- To build a memo table, you build a data structure
--- mapping from the function argument (the key) to its result (the
--- value). When you apply the function to a new argument you first
--- check whether the key\/value pair is already in the memo table.
--- The key point is that the memo table itself should not keep the
--- key and value alive. So the table should contain a weak pointer
--- to the key, not an ordinary pointer. The pointer to the value must
--- not be weak, because the only reference to the value might indeed be
--- from the memo table.
---
--- So it looks as if the memo table will keep all its values
--- alive for ever. One way to solve this is to purge the table
--- occasionally, by deleting entries whose keys have died.
---
--- The weak pointers in this library
--- support another approach, called /finalization/.
--- When the key referred to by a weak pointer dies, the storage manager
--- arranges to run a programmer-specified finalizer. In the case of memo
--- tables, for example, the finalizer could remove the key\/value pair
--- from the memo table.
---
--- Another difficulty with the memo table is that the value of a
--- key\/value pair might itself contain a pointer to the key.
--- So the memo table keeps the value alive, which keeps the key alive,
--- even though there may be no other references to the key so both should
--- die. The weak pointers in this library provide a slight
--- generalisation of the basic weak-pointer idea, in which each
--- weak pointer actually contains both a key and a value.
---
------------------------------------------------------------------------------
-
-module System.Mem.Weak (
- -- * The @Weak@ type
- Weak, -- abstract
-
- -- * The general interface
- mkWeak, -- :: k -> v -> Maybe (IO ()) -> IO (Weak v)
- deRefWeak, -- :: Weak v -> IO (Maybe v)
- finalize, -- :: Weak v -> IO ()
-
- -- * Specialised versions
- mkWeakPtr, -- :: k -> Maybe (IO ()) -> IO (Weak k)
- addFinalizer, -- :: key -> IO () -> IO ()
- mkWeakPair, -- :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v))
- -- replaceFinaliser -- :: Weak v -> IO () -> IO ()
-
- -- * A precise semantics
-
- -- $precise
- ) where
-
-import Prelude
-
-import Data.Typeable
-
-#ifdef __HUGS__
-import Hugs.Weak
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Weak
-#endif
-
--- | A specialised version of 'mkWeak', where the key and the value are
--- the same object:
---
--- > mkWeakPtr key finalizer = mkWeak key key finalizer
---
-mkWeakPtr :: k -> Maybe (IO ()) -> IO (Weak k)
-mkWeakPtr key finalizer = mkWeak key key finalizer
-
-{-|
- A specialised version of 'mkWeakPtr', where the 'Weak' object
- returned is simply thrown away (however the finalizer will be
- remembered by the garbage collector, and will still be run
- when the key becomes unreachable).
-
- Note: adding a finalizer to a 'Foreign.ForeignPtr.ForeignPtr' using
- 'addFinalizer' won't work as well as using the specialised version
- 'Foreign.ForeignPtr.addForeignPtrFinalizer' because the latter
- version adds the finalizer to the primitive 'ForeignPtr#' object
- inside, whereas the generic 'addFinalizer' will add the finalizer to
- the box. Optimisations tend to remove the box, which may cause the
- finalizer to run earlier than you intended. The same motivation
- justifies the existence of
- 'Control.Concurrent.MVar.addMVarFinalizer' and
- 'Data.IORef.mkWeakIORef' (the non-uniformity is accidental).
--}
-addFinalizer :: key -> IO () -> IO ()
-addFinalizer key finalizer = do
- mkWeakPtr key (Just finalizer) -- throw it away
- return ()
-
--- | A specialised version of 'mkWeak' where the value is actually a pair
--- of the key and value passed to 'mkWeakPair':
---
--- > mkWeakPair key val finalizer = mkWeak key (key,val) finalizer
---
--- The advantage of this is that the key can be retrieved by 'deRefWeak'
--- in addition to the value.
-mkWeakPair :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v))
-mkWeakPair key val finalizer = mkWeak key (key,val) finalizer
-
-
-{- $precise
-
-The above informal specification is fine for simple situations, but
-matters can get complicated. In particular, it needs to be clear
-exactly when a key dies, so that any weak pointers that refer to it
-can be finalized. Suppose, for example, the value of one weak pointer
-refers to the key of another...does that keep the key alive?
-
-The behaviour is simply this:
-
- * If a weak pointer (object) refers to an /unreachable/
- key, it may be finalized.
-
- * Finalization means (a) arrange that subsequent calls
- to 'deRefWeak' return 'Nothing'; and (b) run the finalizer.
-
-This behaviour depends on what it means for a key to be reachable.
-Informally, something is reachable if it can be reached by following
-ordinary pointers from the root set, but not following weak pointers.
-We define reachability more precisely as follows A heap object is
-reachable if:
-
- * It is a member of the /root set/.
-
- * It is directly pointed to by a reachable object, other than
- a weak pointer object.
-
- * It is a weak pointer object whose key is reachable.
-
- * It is the value or finalizer of an object whose key is reachable.
--}
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
-
------------------------------------------------------------------------------
--- |
--- Module : System.Posix.Internals
--- Copyright : (c) The University of Glasgow, 1992-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (requires POSIX)
---
--- POSIX support layer for the standard libraries.
--- This library is built on *every* platform, including Win32.
---
--- Non-posix compliant in order to support the following features:
--- * S_ISSOCK (no sockets in POSIX)
---
------------------------------------------------------------------------------
-
--- #hide
-module System.Posix.Internals where
-
-#include "HsBaseConfig.h"
-
-import Control.Monad
-import System.Posix.Types
-
-import Foreign
-import Foreign.C
-
-import Data.Bits
-import Data.Maybe
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.Num
-import GHC.Real
-import GHC.IOBase
-#else
-import System.IO
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude (IOException(..), IOErrorType(..))
-
-{-# CFILES cbits/PrelIOUtils.c cbits/dirUtils.c cbits/consUtils.c #-}
-#endif
-
--- ---------------------------------------------------------------------------
--- Types
-
-type CDir = ()
-type CDirent = ()
-type CFLock = ()
-type CGroup = ()
-type CLconv = ()
-type CPasswd = ()
-type CSigaction = ()
-type CSigset = ()
-type CStat = ()
-type CTermios = ()
-type CTm = ()
-type CTms = ()
-type CUtimbuf = ()
-type CUtsname = ()
-
-#ifndef __GLASGOW_HASKELL__
-type FD = CInt
-#endif
-
--- ---------------------------------------------------------------------------
--- stat()-related stuff
-
-fdFileSize :: FD -> IO Integer
-fdFileSize fd =
- allocaBytes sizeof_stat $ \ p_stat -> do
- throwErrnoIfMinus1Retry "fileSize" $
- c_fstat fd p_stat
- c_mode <- st_mode p_stat :: IO CMode
- if not (s_isreg c_mode)
- then return (-1)
- else do
- c_size <- st_size p_stat :: IO COff
- return (fromIntegral c_size)
-
-data FDType = Directory | Stream | RegularFile | RawDevice
- deriving (Eq)
-
-fileType :: FilePath -> IO FDType
-fileType file =
- allocaBytes sizeof_stat $ \ p_stat -> do
- withCString file $ \p_file -> do
- throwErrnoIfMinus1Retry "fileType" $
- c_stat p_file p_stat
- statGetType p_stat
-
--- NOTE: On Win32 platforms, this will only work with file descriptors
--- referring to file handles. i.e., it'll fail for socket FDs.
-fdType :: FD -> IO FDType
-fdType fd =
- allocaBytes sizeof_stat $ \ p_stat -> do
- throwErrnoIfMinus1Retry "fdType" $
- c_fstat fd p_stat
- statGetType p_stat
-
-statGetType p_stat = do
- c_mode <- st_mode p_stat :: IO CMode
- case () of
- _ | s_isdir c_mode -> return Directory
- | s_isfifo c_mode || s_issock c_mode || s_ischr c_mode
- -> return Stream
- | s_isreg c_mode -> return RegularFile
- -- Q: map char devices to RawDevice too?
- | s_isblk c_mode -> return RawDevice
- | otherwise -> ioError ioe_unknownfiletype
-
-
-ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
- "unknown file type" Nothing
-
-#if __GLASGOW_HASKELL__ && (defined(mingw32_HOST_OS) || defined(__MINGW32__))
-closeFd :: Bool -> CInt -> IO CInt
-closeFd isStream fd
- | isStream = c_closesocket fd
- | otherwise = c_close fd
-
-foreign import stdcall unsafe "HsBase.h closesocket"
- c_closesocket :: CInt -> IO CInt
-#endif
-
-fdGetMode :: FD -> IO IOMode
-fdGetMode fd = do
-#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
- -- XXX: this code is *BROKEN*, _setmode only deals with O_TEXT/O_BINARY
- flags1 <- throwErrnoIfMinus1Retry "fdGetMode"
- (c__setmode fd (fromIntegral o_WRONLY))
- flags <- throwErrnoIfMinus1Retry "fdGetMode"
- (c__setmode fd (fromIntegral flags1))
-#else
- flags <- throwErrnoIfMinus1Retry "fdGetMode"
- (c_fcntl_read fd const_f_getfl)
-#endif
- let
- wH = (flags .&. o_WRONLY) /= 0
- aH = (flags .&. o_APPEND) /= 0
- rwH = (flags .&. o_RDWR) /= 0
-
- mode
- | wH && aH = AppendMode
- | wH = WriteMode
- | rwH = ReadWriteMode
- | otherwise = ReadMode
-
- return mode
-
--- ---------------------------------------------------------------------------
--- Terminal-related stuff
-
-fdIsTTY :: FD -> IO Bool
-fdIsTTY fd = c_isatty fd >>= return.toBool
-
-#if defined(HTYPE_TCFLAG_T)
-
-setEcho :: FD -> Bool -> IO ()
-setEcho fd on = do
- tcSetAttr fd $ \ p_tios -> do
- c_lflag <- c_lflag p_tios :: IO CTcflag
- let new_c_lflag
- | on = c_lflag .|. fromIntegral const_echo
- | otherwise = c_lflag .&. complement (fromIntegral const_echo)
- poke_c_lflag p_tios (new_c_lflag :: CTcflag)
-
-getEcho :: FD -> IO Bool
-getEcho fd = do
- tcSetAttr fd $ \ p_tios -> do
- c_lflag <- c_lflag p_tios :: IO CTcflag
- return ((c_lflag .&. fromIntegral const_echo) /= 0)
-
-setCooked :: FD -> Bool -> IO ()
-setCooked fd cooked =
- tcSetAttr fd $ \ p_tios -> do
-
- -- turn on/off ICANON
- c_lflag <- c_lflag p_tios :: IO CTcflag
- let new_c_lflag | cooked = c_lflag .|. (fromIntegral const_icanon)
- | otherwise = c_lflag .&. complement (fromIntegral const_icanon)
- poke_c_lflag p_tios (new_c_lflag :: CTcflag)
-
- -- set VMIN & VTIME to 1/0 respectively
- when (not cooked) $ do
- c_cc <- ptr_c_cc p_tios
- let vmin = (c_cc `plusPtr` (fromIntegral const_vmin)) :: Ptr Word8
- vtime = (c_cc `plusPtr` (fromIntegral const_vtime)) :: Ptr Word8
- poke vmin 1
- poke vtime 0
-
-tcSetAttr :: FD -> (Ptr CTermios -> IO a) -> IO a
-tcSetAttr fd fun = do
- allocaBytes sizeof_termios $ \p_tios -> do
- throwErrnoIfMinus1Retry "tcSetAttr"
- (c_tcgetattr fd p_tios)
-
-#ifdef __GLASGOW_HASKELL__
- -- Save a copy of termios, if this is a standard file descriptor.
- -- These terminal settings are restored in hs_exit().
- when (fd <= 2) $ do
- p <- get_saved_termios fd
- when (p == nullPtr) $ do
- saved_tios <- mallocBytes sizeof_termios
- copyBytes saved_tios p_tios sizeof_termios
- set_saved_termios fd saved_tios
-#endif
-
- -- tcsetattr() when invoked by a background process causes the process
- -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
- -- in its terminal flags (try it...). This function provides a
- -- wrapper which temporarily blocks SIGTTOU around the call, making it
- -- transparent.
- allocaBytes sizeof_sigset_t $ \ p_sigset -> do
- allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do
- c_sigemptyset p_sigset
- c_sigaddset p_sigset const_sigttou
- c_sigprocmask const_sig_block p_sigset p_old_sigset
- r <- fun p_tios -- do the business
- throwErrnoIfMinus1Retry_ "tcSetAttr" $
- c_tcsetattr fd const_tcsanow p_tios
- c_sigprocmask const_sig_setmask p_old_sigset nullPtr
- return r
-
-#ifdef __GLASGOW_HASKELL__
-foreign import ccall unsafe "HsBase.h __hscore_get_saved_termios"
- get_saved_termios :: CInt -> IO (Ptr CTermios)
-
-foreign import ccall unsafe "HsBase.h __hscore_set_saved_termios"
- set_saved_termios :: CInt -> (Ptr CTermios) -> IO ()
-#endif
-
-#else
-
--- 'raw' mode for Win32 means turn off 'line input' (=> buffering and
--- character translation for the console.) The Win32 API for doing
--- this is GetConsoleMode(), which also requires echoing to be disabled
--- when turning off 'line input' processing. Notice that turning off
--- 'line input' implies enter/return is reported as '\r' (and it won't
--- report that character until another character is input..odd.) This
--- latter feature doesn't sit too well with IO actions like IO.hGetLine..
--- consider yourself warned.
-setCooked :: FD -> Bool -> IO ()
-setCooked fd cooked = do
- x <- set_console_buffering fd (if cooked then 1 else 0)
- if (x /= 0)
- then ioError (ioe_unk_error "setCooked" "failed to set buffering")
- else return ()
-
-ioe_unk_error loc msg
- = IOError Nothing OtherError loc msg Nothing
-
--- Note: echoing goes hand in hand with enabling 'line input' / raw-ness
--- for Win32 consoles, hence setEcho ends up being the inverse of setCooked.
-setEcho :: FD -> Bool -> IO ()
-setEcho fd on = do
- x <- set_console_echo fd (if on then 1 else 0)
- if (x /= 0)
- then ioError (ioe_unk_error "setEcho" "failed to set echoing")
- else return ()
-
-getEcho :: FD -> IO Bool
-getEcho fd = do
- r <- get_console_echo fd
- if (r == (-1))
- then ioError (ioe_unk_error "getEcho" "failed to get echoing")
- else return (r == 1)
-
-foreign import ccall unsafe "consUtils.h set_console_buffering__"
- set_console_buffering :: CInt -> CInt -> IO CInt
-
-foreign import ccall unsafe "consUtils.h set_console_echo__"
- set_console_echo :: CInt -> CInt -> IO CInt
-
-foreign import ccall unsafe "consUtils.h get_console_echo__"
- get_console_echo :: CInt -> IO CInt
-
-#endif
-
--- ---------------------------------------------------------------------------
--- Turning on non-blocking for a file descriptor
-
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-
-setNonBlockingFD fd = do
- flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
- (c_fcntl_read fd const_f_getfl)
- -- An error when setting O_NONBLOCK isn't fatal: on some systems
- -- there are certain file handles on which this will fail (eg. /dev/null
- -- on FreeBSD) so we throw away the return code from fcntl_write.
- unless (testBit flags (fromIntegral o_NONBLOCK)) $ do
- c_fcntl_write fd const_f_setfl (fromIntegral (flags .|. o_NONBLOCK))
- return ()
-#else
-
--- bogus defns for win32
-setNonBlockingFD fd = return ()
-
-#endif
-
--- -----------------------------------------------------------------------------
--- foreign imports
-
-foreign import ccall unsafe "HsBase.h access"
- c_access :: CString -> CInt -> IO CInt
-
-foreign import ccall unsafe "HsBase.h chmod"
- c_chmod :: CString -> CMode -> IO CInt
-
-foreign import ccall unsafe "HsBase.h chdir"
- c_chdir :: CString -> IO CInt
-
-foreign import ccall unsafe "HsBase.h close"
- c_close :: CInt -> IO CInt
-
-foreign import ccall unsafe "HsBase.h closedir"
- c_closedir :: Ptr CDir -> IO CInt
-
-foreign import ccall unsafe "HsBase.h creat"
- c_creat :: CString -> CMode -> IO CInt
-
-foreign import ccall unsafe "HsBase.h dup"
- c_dup :: CInt -> IO CInt
-
-foreign import ccall unsafe "HsBase.h dup2"
- c_dup2 :: CInt -> CInt -> IO CInt
-
-foreign import ccall unsafe "HsBase.h __hscore_fstat"
- c_fstat :: CInt -> Ptr CStat -> IO CInt
-
-foreign import ccall unsafe "HsBase.h getcwd"
- c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar)
-
-foreign import ccall unsafe "HsBase.h isatty"
- c_isatty :: CInt -> IO CInt
-
-foreign import ccall unsafe "HsBase.h __hscore_lseek"
- c_lseek :: CInt -> COff -> CInt -> IO COff
-
-foreign import ccall unsafe "HsBase.h __hscore_lstat"
- lstat :: CString -> Ptr CStat -> IO CInt
-
-foreign import ccall unsafe "HsBase.h __hscore_open"
- c_open :: CString -> CInt -> CMode -> IO CInt
-
-foreign import ccall unsafe "HsBase.h opendir"
- c_opendir :: CString -> IO (Ptr CDir)
-
-foreign import ccall unsafe "HsBase.h __hscore_mkdir"
- mkdir :: CString -> CInt -> IO CInt
-
-foreign import ccall unsafe "HsBase.h read"
- c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
-
-foreign import ccall unsafe "dirUtils.h __hscore_renameFile"
- c_rename :: CString -> CString -> IO CInt
-
-foreign import ccall unsafe "HsBase.h rewinddir"
- c_rewinddir :: Ptr CDir -> IO ()
-
-foreign import ccall unsafe "HsBase.h rmdir"
- c_rmdir :: CString -> IO CInt
-
-foreign import ccall unsafe "HsBase.h __hscore_stat"
- c_stat :: CString -> Ptr CStat -> IO CInt
-
-foreign import ccall unsafe "HsBase.h umask"
- c_umask :: CMode -> IO CMode
-
-foreign import ccall unsafe "HsBase.h write"
- c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
-
-foreign import ccall unsafe "HsBase.h __hscore_ftruncate"
- c_ftruncate :: CInt -> COff -> IO CInt
-
-foreign import ccall unsafe "HsBase.h unlink"
- c_unlink :: CString -> IO CInt
-
-foreign import ccall unsafe "HsBase.h getpid"
- c_getpid :: IO CPid
-
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-foreign import ccall unsafe "HsBase.h fcntl"
- c_fcntl_read :: CInt -> CInt -> IO CInt
-
-foreign import ccall unsafe "HsBase.h fcntl"
- c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt
-
-foreign import ccall unsafe "HsBase.h fcntl"
- c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt
-
-foreign import ccall unsafe "HsBase.h fork"
- c_fork :: IO CPid
-
-foreign import ccall unsafe "HsBase.h link"
- c_link :: CString -> CString -> IO CInt
-
-foreign import ccall unsafe "HsBase.h mkfifo"
- c_mkfifo :: CString -> CMode -> IO CInt
-
-foreign import ccall unsafe "HsBase.h pipe"
- c_pipe :: Ptr CInt -> IO CInt
-
-foreign import ccall unsafe "HsBase.h __hscore_sigemptyset"
- c_sigemptyset :: Ptr CSigset -> IO CInt
-
-foreign import ccall unsafe "HsBase.h __hscore_sigaddset"
- c_sigaddset :: Ptr CSigset -> CInt -> IO CInt
-
-foreign import ccall unsafe "HsBase.h sigprocmask"
- c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO CInt
-
-foreign import ccall unsafe "HsBase.h tcgetattr"
- c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt
-
-foreign import ccall unsafe "HsBase.h tcsetattr"
- c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt
-
-foreign import ccall unsafe "HsBase.h utime"
- c_utime :: CString -> Ptr CUtimbuf -> IO CInt
-
-foreign import ccall unsafe "HsBase.h waitpid"
- c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
-#else
-foreign import ccall unsafe "HsBase.h _setmode"
- c__setmode :: CInt -> CInt -> IO CInt
-
--- /* Set "stdin" to have binary mode: */
--- result = _setmode( _fileno( stdin ), _O_BINARY );
--- if( result == -1 )
--- perror( "Cannot set mode" );
--- else
--- printf( "'stdin' successfully changed to binary mode\n" );
-#endif
-
--- traversing directories
-foreign import ccall unsafe "dirUtils.h __hscore_readdir"
- readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
-
-foreign import ccall unsafe "HsBase.h __hscore_free_dirent"
- freeDirEnt :: Ptr CDirent -> IO ()
-
-foreign import ccall unsafe "HsBase.h __hscore_end_of_dir"
- end_of_dir :: CInt
-
-foreign import ccall unsafe "HsBase.h __hscore_d_name"
- d_name :: Ptr CDirent -> IO CString
-
--- POSIX flags only:
-foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_o_rdwr" o_RDWR :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_o_append" o_APPEND :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_o_creat" o_CREAT :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_o_excl" o_EXCL :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_o_trunc" o_TRUNC :: CInt
-
--- non-POSIX flags.
-foreign import ccall unsafe "HsBase.h __hscore_o_noctty" o_NOCTTY :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_o_nonblock" o_NONBLOCK :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_o_binary" o_BINARY :: CInt
-
-foreign import ccall unsafe "HsBase.h __hscore_s_isreg" c_s_isreg :: CMode -> CInt
-foreign import ccall unsafe "HsBase.h __hscore_s_ischr" c_s_ischr :: CMode -> CInt
-foreign import ccall unsafe "HsBase.h __hscore_s_isblk" c_s_isblk :: CMode -> CInt
-foreign import ccall unsafe "HsBase.h __hscore_s_isdir" c_s_isdir :: CMode -> CInt
-foreign import ccall unsafe "HsBase.h __hscore_s_isfifo" c_s_isfifo :: CMode -> CInt
-
-s_isreg :: CMode -> Bool
-s_isreg cm = c_s_isreg cm /= 0
-s_ischr :: CMode -> Bool
-s_ischr cm = c_s_ischr cm /= 0
-s_isblk :: CMode -> Bool
-s_isblk cm = c_s_isblk cm /= 0
-s_isdir :: CMode -> Bool
-s_isdir cm = c_s_isdir cm /= 0
-s_isfifo :: CMode -> Bool
-s_isfifo cm = c_s_isfifo cm /= 0
-
-foreign import ccall unsafe "HsBase.h __hscore_sizeof_stat" sizeof_stat :: Int
-foreign import ccall unsafe "HsBase.h __hscore_st_mtime" st_mtime :: Ptr CStat -> IO CTime
-foreign import ccall unsafe "HsBase.h __hscore_st_size" st_size :: Ptr CStat -> IO COff
-foreign import ccall unsafe "HsBase.h __hscore_st_mode" st_mode :: Ptr CStat -> IO CMode
-
-foreign import ccall unsafe "HsBase.h __hscore_echo" const_echo :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_tcsanow" const_tcsanow :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_icanon" const_icanon :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_vmin" const_vmin :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_vtime" const_vtime :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_sigttou" const_sigttou :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_sig_block" const_sig_block :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_sig_setmask" const_sig_setmask :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_f_getfl" const_f_getfl :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_f_setfl" const_f_setfl :: CInt
-
-#if defined(HTYPE_TCFLAG_T)
-foreign import ccall unsafe "HsBase.h __hscore_sizeof_termios" sizeof_termios :: Int
-foreign import ccall unsafe "HsBase.h __hscore_sizeof_sigset_t" sizeof_sigset_t :: Int
-
-foreign import ccall unsafe "HsBase.h __hscore_lflag" c_lflag :: Ptr CTermios -> IO CTcflag
-foreign import ccall unsafe "HsBase.h __hscore_poke_lflag" poke_c_lflag :: Ptr CTermios -> CTcflag -> IO ()
-foreign import ccall unsafe "HsBase.h __hscore_ptr_c_cc" ptr_c_cc :: Ptr CTermios -> IO (Ptr Word8)
-#endif
-
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-foreign import ccall unsafe "HsBase.h __hscore_s_issock" c_s_issock :: CMode -> CInt
-s_issock :: CMode -> Bool
-s_issock cmode = c_s_issock cmode /= 0
-#else
-s_issock :: CMode -> Bool
-s_issock cmode = False
-#endif
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Posix.Signals
--- Copyright : (c) The University of Glasgow 2002
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : non-portable (requires POSIX)
---
--- POSIX signal support
---
------------------------------------------------------------------------------
-
-#include "HsBaseConfig.h"
-
-module System.Posix.Signals (
-#ifndef mingw32_HOST_OS
- -- * The Signal type
- Signal,
-
- -- * Specific signals
- nullSignal,
- internalAbort, sigABRT,
- realTimeAlarm, sigALRM,
- busError, sigBUS,
- processStatusChanged, sigCHLD,
- continueProcess, sigCONT,
- floatingPointException, sigFPE,
- lostConnection, sigHUP,
- illegalInstruction, sigILL,
- keyboardSignal, sigINT,
- killProcess, sigKILL,
- openEndedPipe, sigPIPE,
- keyboardTermination, sigQUIT,
- segmentationViolation, sigSEGV,
- softwareStop, sigSTOP,
- softwareTermination, sigTERM,
- keyboardStop, sigTSTP,
- backgroundRead, sigTTIN,
- backgroundWrite, sigTTOU,
- userDefinedSignal1, sigUSR1,
- userDefinedSignal2, sigUSR2,
-#if CONST_SIGPOLL != -1
- pollableEvent, sigPOLL,
-#endif
- profilingTimerExpired, sigPROF,
- badSystemCall, sigSYS,
- breakpointTrap, sigTRAP,
- urgentDataAvailable, sigURG,
- virtualTimerExpired, sigVTALRM,
- cpuTimeLimitExceeded, sigXCPU,
- fileSizeLimitExceeded, sigXFSZ,
-
- -- * Sending signals
- raiseSignal,
- signalProcess,
- signalProcessGroup,
-
-#ifdef __GLASGOW_HASKELL__
- -- * Handling signals
- Handler(..),
- installHandler,
-#endif
-
- -- * Signal sets
- SignalSet,
- emptySignalSet, fullSignalSet,
- addSignal, deleteSignal, inSignalSet,
-
- -- * The process signal mask
- getSignalMask, setSignalMask, blockSignals, unblockSignals,
-
- -- * The alarm timer
- scheduleAlarm,
-
- -- * Waiting for signals
- getPendingSignals,
-#ifndef cygwin32_HOST_OS
- awaitSignal,
-#endif
-
-#ifdef __GLASGOW_HASKELL__
- -- * The @NOCLDSTOP@ flag
- setStoppedChildFlag, queryStoppedChildFlag,
-#endif
-
- -- MISSING FUNCTIONALITY:
- -- sigaction(), (inc. the sigaction structure + flags etc.)
- -- the siginfo structure
- -- sigaltstack()
- -- sighold, sigignore, sigpause, sigrelse, sigset
- -- siginterrupt
-#endif
- ) where
-
-import Prelude -- necessary to get dependencies right
-
-import Foreign
-import Foreign.C
-import System.IO.Unsafe
-import System.Posix.Types
-import System.Posix.Internals
-
-#ifndef mingw32_HOST_OS
--- WHOLE FILE...
-
-#ifdef __GLASGOW_HASKELL__
-#include "Signals.h"
-import GHC.Conc ( ensureIOManagerIsRunning )
-#endif
-
--- -----------------------------------------------------------------------------
--- Specific signals
-
-type Signal = CInt
-
-nullSignal :: Signal
-nullSignal = 0
-
-sigABRT :: CInt
-sigABRT = CONST_SIGABRT
-sigALRM :: CInt
-sigALRM = CONST_SIGALRM
-sigBUS :: CInt
-sigBUS = CONST_SIGBUS
-sigCHLD :: CInt
-sigCHLD = CONST_SIGCHLD
-sigCONT :: CInt
-sigCONT = CONST_SIGCONT
-sigFPE :: CInt
-sigFPE = CONST_SIGFPE
-sigHUP :: CInt
-sigHUP = CONST_SIGHUP
-sigILL :: CInt
-sigILL = CONST_SIGILL
-sigINT :: CInt
-sigINT = CONST_SIGINT
-sigKILL :: CInt
-sigKILL = CONST_SIGKILL
-sigPIPE :: CInt
-sigPIPE = CONST_SIGPIPE
-sigQUIT :: CInt
-sigQUIT = CONST_SIGQUIT
-sigSEGV :: CInt
-sigSEGV = CONST_SIGSEGV
-sigSTOP :: CInt
-sigSTOP = CONST_SIGSTOP
-sigTERM :: CInt
-sigTERM = CONST_SIGTERM
-sigTSTP :: CInt
-sigTSTP = CONST_SIGTSTP
-sigTTIN :: CInt
-sigTTIN = CONST_SIGTTIN
-sigTTOU :: CInt
-sigTTOU = CONST_SIGTTOU
-sigUSR1 :: CInt
-sigUSR1 = CONST_SIGUSR1
-sigUSR2 :: CInt
-sigUSR2 = CONST_SIGUSR2
-sigPOLL :: CInt
-sigPOLL = CONST_SIGPOLL
-sigPROF :: CInt
-sigPROF = CONST_SIGPROF
-sigSYS :: CInt
-sigSYS = CONST_SIGSYS
-sigTRAP :: CInt
-sigTRAP = CONST_SIGTRAP
-sigURG :: CInt
-sigURG = CONST_SIGURG
-sigVTALRM :: CInt
-sigVTALRM = CONST_SIGVTALRM
-sigXCPU :: CInt
-sigXCPU = CONST_SIGXCPU
-sigXFSZ :: CInt
-sigXFSZ = CONST_SIGXFSZ
-
-internalAbort ::Signal
-internalAbort = sigABRT
-
-realTimeAlarm :: Signal
-realTimeAlarm = sigALRM
-
-busError :: Signal
-busError = sigBUS
-
-processStatusChanged :: Signal
-processStatusChanged = sigCHLD
-
-continueProcess :: Signal
-continueProcess = sigCONT
-
-floatingPointException :: Signal
-floatingPointException = sigFPE
-
-lostConnection :: Signal
-lostConnection = sigHUP
-
-illegalInstruction :: Signal
-illegalInstruction = sigILL
-
-keyboardSignal :: Signal
-keyboardSignal = sigINT
-
-killProcess :: Signal
-killProcess = sigKILL
-
-openEndedPipe :: Signal
-openEndedPipe = sigPIPE
-
-keyboardTermination :: Signal
-keyboardTermination = sigQUIT
-
-segmentationViolation :: Signal
-segmentationViolation = sigSEGV
-
-softwareStop :: Signal
-softwareStop = sigSTOP
-
-softwareTermination :: Signal
-softwareTermination = sigTERM
-
-keyboardStop :: Signal
-keyboardStop = sigTSTP
-
-backgroundRead :: Signal
-backgroundRead = sigTTIN
-
-backgroundWrite :: Signal
-backgroundWrite = sigTTOU
-
-userDefinedSignal1 :: Signal
-userDefinedSignal1 = sigUSR1
-
-userDefinedSignal2 :: Signal
-userDefinedSignal2 = sigUSR2
-
-#if CONST_SIGPOLL != -1
-pollableEvent :: Signal
-pollableEvent = sigPOLL
-#endif
-
-profilingTimerExpired :: Signal
-profilingTimerExpired = sigPROF
-
-badSystemCall :: Signal
-badSystemCall = sigSYS
-
-breakpointTrap :: Signal
-breakpointTrap = sigTRAP
-
-urgentDataAvailable :: Signal
-urgentDataAvailable = sigURG
-
-virtualTimerExpired :: Signal
-virtualTimerExpired = sigVTALRM
-
-cpuTimeLimitExceeded :: Signal
-cpuTimeLimitExceeded = sigXCPU
-
-fileSizeLimitExceeded :: Signal
-fileSizeLimitExceeded = sigXFSZ
-
--- -----------------------------------------------------------------------------
--- Signal-related functions
-
--- | @signalProcess int pid@ calls @kill@ to signal process @pid@
--- with interrupt signal @int@.
-signalProcess :: Signal -> ProcessID -> IO ()
-signalProcess sig pid
- = throwErrnoIfMinus1_ "signalProcess" (c_kill (fromIntegral pid) sig)
-
-foreign import ccall unsafe "kill"
- c_kill :: CPid -> CInt -> IO CInt
-
-
--- | @signalProcessGroup int pgid@ calls @kill@ to signal
--- all processes in group @pgid@ with interrupt signal @int@.
-signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
-signalProcessGroup sig pgid
- = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg (fromIntegral pgid) sig)
-
-foreign import ccall unsafe "killpg"
- c_killpg :: CPid -> CInt -> IO CInt
-
--- | @raiseSignal int@ calls @kill@ to signal the current process
--- with interrupt signal @int@.
-raiseSignal :: Signal -> IO ()
-raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig)
-
-#if defined(__GLASGOW_HASKELL__) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS))
-foreign import ccall unsafe "genericRaise"
- c_raise :: CInt -> IO CInt
-#else
-foreign import ccall unsafe "raise"
- c_raise :: CInt -> IO CInt
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-data Handler = Default
- | Ignore
- -- not yet: | Hold
- | Catch (IO ())
- | CatchOnce (IO ())
-
--- | @installHandler int handler iset@ calls @sigaction@ to install an
--- interrupt handler for signal @int@. If @handler@ is @Default@,
--- @SIG_DFL@ is installed; if @handler@ is @Ignore@, @SIG_IGN@ is
--- installed; if @handler@ is @Catch action@, a handler is installed
--- which will invoke @action@ in a new thread when (or shortly after) the
--- signal is received.
--- If @iset@ is @Just s@, then the @sa_mask@ of the @sigaction@ structure
--- is set to @s@; otherwise it is cleared. The previously installed
--- signal handler for @int@ is returned
-installHandler :: Signal
- -> Handler
- -> Maybe SignalSet -- ^ other signals to block
- -> IO Handler -- ^ old handler
-
-#ifdef __PARALLEL_HASKELL__
-installHandler =
- error "installHandler: not available for Parallel Haskell"
-#else
-
-installHandler int handler maybe_mask = do
- ensureIOManagerIsRunning -- for the threaded RTS
- case maybe_mask of
- Nothing -> install' nullPtr
- Just (SignalSet x) -> withForeignPtr x $ install'
- where
- install' mask =
- alloca $ \p_sp -> do
-
- rc <- case handler of
- Default -> stg_sig_install int STG_SIG_DFL p_sp mask
- Ignore -> stg_sig_install int STG_SIG_IGN p_sp mask
- Catch m -> hinstall m p_sp mask int STG_SIG_HAN
- CatchOnce m -> hinstall m p_sp mask int STG_SIG_RST
-
- case rc of
- STG_SIG_DFL -> return Default
- STG_SIG_IGN -> return Ignore
- STG_SIG_ERR -> throwErrno "installHandler"
- STG_SIG_HAN -> do
- m <- peekHandler p_sp
- return (Catch m)
- STG_SIG_RST -> do
- m <- peekHandler p_sp
- return (CatchOnce m)
- _other ->
- error "internal error: System.Posix.Signals.installHandler"
-
- hinstall m p_sp mask int reset = do
- sptr <- newStablePtr m
- poke p_sp sptr
- stg_sig_install int reset p_sp mask
-
- peekHandler p_sp = do
- osptr <- peek p_sp
- deRefStablePtr osptr
-
-foreign import ccall unsafe
- stg_sig_install
- :: CInt -- sig no.
- -> CInt -- action code (STG_SIG_HAN etc.)
- -> Ptr (StablePtr (IO ())) -- (in, out) Haskell handler
- -> Ptr CSigset -- (in, out) blocked
- -> IO CInt -- (ret) action code
-
-#endif /* !__PARALLEL_HASKELL__ */
-#endif /* __GLASGOW_HASKELL__ */
-
--- -----------------------------------------------------------------------------
--- Alarms
-
--- | @scheduleAlarm i@ calls @alarm@ to schedule a real time
--- alarm at least @i@ seconds in the future.
-scheduleAlarm :: Int -> IO Int
-scheduleAlarm secs = do
- r <- c_alarm (fromIntegral secs)
- return (fromIntegral r)
-
-foreign import ccall unsafe "alarm"
- c_alarm :: CUInt -> IO CUInt
-
-#ifdef __GLASGOW_HASKELL__
--- -----------------------------------------------------------------------------
--- The NOCLDSTOP flag
-
-foreign import ccall "&nocldstop" nocldstop :: Ptr Int
-
--- | Tells the system whether or not to set the @SA_NOCLDSTOP@ flag when
--- installing new signal handlers.
-setStoppedChildFlag :: Bool -> IO Bool
-setStoppedChildFlag b = do
- rc <- peek nocldstop
- poke nocldstop $ fromEnum (not b)
- return (rc == (0::Int))
-
--- | Queries the current state of the stopped child flag.
-queryStoppedChildFlag :: IO Bool
-queryStoppedChildFlag = do
- rc <- peek nocldstop
- return (rc == (0::Int))
-#endif /* __GLASGOW_HASKELL__ */
-
--- -----------------------------------------------------------------------------
--- Manipulating signal sets
-
-newtype SignalSet = SignalSet (ForeignPtr CSigset)
-
-emptySignalSet :: SignalSet
-emptySignalSet = unsafePerformIO $ do
- fp <- mallocForeignPtrBytes sizeof_sigset_t
- throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset)
- return (SignalSet fp)
-
-fullSignalSet :: SignalSet
-fullSignalSet = unsafePerformIO $ do
- fp <- mallocForeignPtrBytes sizeof_sigset_t
- throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset)
- return (SignalSet fp)
-
-infixr `addSignal`, `deleteSignal`
-addSignal :: Signal -> SignalSet -> SignalSet
-addSignal sig (SignalSet fp1) = unsafePerformIO $ do
- fp2 <- mallocForeignPtrBytes sizeof_sigset_t
- withForeignPtr fp1 $ \p1 ->
- withForeignPtr fp2 $ \p2 -> do
- copyBytes p2 p1 sizeof_sigset_t
- throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig)
- return (SignalSet fp2)
-
-deleteSignal :: Signal -> SignalSet -> SignalSet
-deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do
- fp2 <- mallocForeignPtrBytes sizeof_sigset_t
- withForeignPtr fp1 $ \p1 ->
- withForeignPtr fp2 $ \p2 -> do
- copyBytes p2 p1 sizeof_sigset_t
- throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig)
- return (SignalSet fp2)
-
-inSignalSet :: Signal -> SignalSet -> Bool
-inSignalSet sig (SignalSet fp) = unsafePerformIO $
- withForeignPtr fp $ \p -> do
- r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig)
- return (r /= 0)
-
--- | @getSignalMask@ calls @sigprocmask@ to determine the
--- set of interrupts which are currently being blocked.
-getSignalMask :: IO SignalSet
-getSignalMask = do
- fp <- mallocForeignPtrBytes sizeof_sigset_t
- withForeignPtr fp $ \p ->
- throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 nullPtr p)
- return (SignalSet fp)
-
-sigProcMask :: String -> CInt -> SignalSet -> IO ()
-sigProcMask fn how (SignalSet set) =
- withForeignPtr set $ \p_set ->
- throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr)
-
--- | @setSignalMask mask@ calls @sigprocmask@ with
--- @SIG_SETMASK@ to block all interrupts in @mask@.
-setSignalMask :: SignalSet -> IO ()
-setSignalMask set = sigProcMask "setSignalMask" (CONST_SIG_SETMASK :: CInt) set
-
--- | @blockSignals mask@ calls @sigprocmask@ with
--- @SIG_BLOCK@ to add all interrupts in @mask@ to the
--- set of blocked interrupts.
-blockSignals :: SignalSet -> IO ()
-blockSignals set = sigProcMask "blockSignals" (CONST_SIG_BLOCK :: CInt) set
-
--- | @unblockSignals mask@ calls @sigprocmask@ with
--- @SIG_UNBLOCK@ to remove all interrupts in @mask@ from the
--- set of blocked interrupts.
-unblockSignals :: SignalSet -> IO ()
-unblockSignals set = sigProcMask "unblockSignals" (CONST_SIG_UNBLOCK :: CInt) set
-
--- | @getPendingSignals@ calls @sigpending@ to obtain
--- the set of interrupts which have been received but are currently blocked.
-getPendingSignals :: IO SignalSet
-getPendingSignals = do
- fp <- mallocForeignPtrBytes sizeof_sigset_t
- withForeignPtr fp $ \p ->
- throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p)
- return (SignalSet fp)
-
-#ifndef cygwin32_HOST_OS
-
--- | @awaitSignal iset@ suspends execution until an interrupt is received.
--- If @iset@ is @Just s@, @awaitSignal@ calls @sigsuspend@, installing
--- @s@ as the new signal mask before suspending execution; otherwise, it
--- calls @pause@. @awaitSignal@ returns on receipt of a signal. If you
--- have installed any signal handlers with @installHandler@, it may be
--- wise to call @yield@ directly after @awaitSignal@ to ensure that the
--- signal handler runs as promptly as possible.
-awaitSignal :: Maybe SignalSet -> IO ()
-awaitSignal maybe_sigset = do
- fp <- case maybe_sigset of
- Nothing -> do SignalSet fp <- getSignalMask; return fp
- Just (SignalSet fp) -> return fp
- withForeignPtr fp $ \p -> do
- c_sigsuspend p
- return ()
- -- ignore the return value; according to the docs it can only ever be
- -- (-1) with errno set to EINTR.
-
-foreign import ccall unsafe "sigsuspend"
- c_sigsuspend :: Ptr CSigset -> IO CInt
-#endif
-
-#ifdef __HUGS__
-foreign import ccall unsafe "sigdelset"
- c_sigdelset :: Ptr CSigset -> CInt -> IO CInt
-
-foreign import ccall unsafe "sigfillset"
- c_sigfillset :: Ptr CSigset -> IO CInt
-
-foreign import ccall unsafe "sigismember"
- c_sigismember :: Ptr CSigset -> CInt -> IO CInt
-#else
-foreign import ccall unsafe "__hscore_sigdelset"
- c_sigdelset :: Ptr CSigset -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_sigfillset"
- c_sigfillset :: Ptr CSigset -> IO CInt
-
-foreign import ccall unsafe "__hscore_sigismember"
- c_sigismember :: Ptr CSigset -> CInt -> IO CInt
-#endif /* __HUGS__ */
-
-foreign import ccall unsafe "sigpending"
- c_sigpending :: Ptr CSigset -> IO CInt
-
-#endif /* mingw32_HOST_OS */
-
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : System.Posix.Types
--- Copyright : (c) The University of Glasgow 2002
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : non-portable (requires POSIX)
---
--- POSIX data types: Haskell equivalents of the types defined by the
--- @\<sys\/types.h>@ C header on a POSIX system.
---
------------------------------------------------------------------------------
-#ifdef __NHC__
-#define HTYPE_DEV_T
-#define HTYPE_INO_T
-#define HTYPE_MODE_T
-#define HTYPE_OFF_T
-#define HTYPE_PID_T
-#define HTYPE_SSIZE_T
-#define HTYPE_GID_T
-#define HTYPE_NLINK_T
-#define HTYPE_UID_T
-#define HTYPE_CC_T
-#define HTYPE_SPEED_T
-#define HTYPE_TCFLAG_T
-#define HTYPE_RLIM_T
-#define HTYPE_NLINK_T
-#define HTYPE_UID_T
-#define HTYPE_GID_T
-#else
-#include "HsBaseConfig.h"
-#endif
-
-module System.Posix.Types (
-
- -- * POSIX data types
-#if defined(HTYPE_DEV_T)
- CDev,
-#endif
-#if defined(HTYPE_INO_T)
- CIno,
-#endif
-#if defined(HTYPE_MODE_T)
- CMode,
-#endif
-#if defined(HTYPE_OFF_T)
- COff,
-#endif
-#if defined(HTYPE_PID_T)
- CPid,
-#endif
-#if defined(HTYPE_SSIZE_T)
- CSsize,
-#endif
-
-#if defined(HTYPE_GID_T)
- CGid,
-#endif
-#if defined(HTYPE_NLINK_T)
- CNlink,
-#endif
-#if defined(HTYPE_UID_T)
- CUid,
-#endif
-#if defined(HTYPE_CC_T)
- CCc,
-#endif
-#if defined(HTYPE_SPEED_T)
- CSpeed,
-#endif
-#if defined(HTYPE_TCFLAG_T)
- CTcflag,
-#endif
-#if defined(HTYPE_RLIM_T)
- CRLim,
-#endif
-
- Fd(..),
-
-#if defined(HTYPE_NLINK_T)
- LinkCount,
-#endif
-#if defined(HTYPE_UID_T)
- UserID,
-#endif
-#if defined(HTYPE_GID_T)
- GroupID,
-#endif
-
- ByteCount,
- ClockTick,
- EpochTime,
- FileOffset,
- ProcessID,
- ProcessGroupID,
- DeviceID,
- FileID,
- FileMode,
- Limit
- ) where
-
-#ifdef __NHC__
-import NHC.PosixTypes
-import Foreign.C
-#else
-
-import Foreign
-import Foreign.C
-import Data.Typeable
-import Data.Bits
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.Enum
-import GHC.Num
-import GHC.Real
-import GHC.Prim
-import GHC.Read
-import GHC.Show
-#else
-import Control.Monad
-#endif
-
-#include "CTypes.h"
-
-#if defined(HTYPE_DEV_T)
-ARITHMETIC_TYPE(CDev,tyConCDev,"CDev",HTYPE_DEV_T)
-#endif
-#if defined(HTYPE_INO_T)
-INTEGRAL_TYPE(CIno,tyConCIno,"CIno",HTYPE_INO_T)
-#endif
-#if defined(HTYPE_MODE_T)
-INTEGRAL_TYPE(CMode,tyConCMode,"CMode",HTYPE_MODE_T)
-#endif
-#if defined(HTYPE_OFF_T)
-INTEGRAL_TYPE(COff,tyConCOff,"COff",HTYPE_OFF_T)
-#endif
-#if defined(HTYPE_PID_T)
-INTEGRAL_TYPE(CPid,tyConCPid,"CPid",HTYPE_PID_T)
-#endif
-
-#if defined(HTYPE_SSIZE_T)
-INTEGRAL_TYPE(CSsize,tyConCSsize,"CSsize",HTYPE_SSIZE_T)
-#endif
-
-#if defined(HTYPE_GID_T)
-INTEGRAL_TYPE(CGid,tyConCGid,"CGid",HTYPE_GID_T)
-#endif
-#if defined(HTYPE_NLINK_T)
-INTEGRAL_TYPE(CNlink,tyConCNlink,"CNlink",HTYPE_NLINK_T)
-#endif
-
-#if defined(HTYPE_UID_T)
-INTEGRAL_TYPE(CUid,tyConCUid,"CUid",HTYPE_UID_T)
-#endif
-#if defined(HTYPE_CC_T)
-ARITHMETIC_TYPE(CCc,tyConCCc,"CCc",HTYPE_CC_T)
-#endif
-#if defined(HTYPE_SPEED_T)
-ARITHMETIC_TYPE(CSpeed,tyConCSpeed,"CSpeed",HTYPE_SPEED_T)
-#endif
-#if defined(HTYPE_TCFLAG_T)
-INTEGRAL_TYPE(CTcflag,tyConCTcflag,"CTcflag",HTYPE_TCFLAG_T)
-#endif
-#if defined(HTYPE_RLIM_T)
-INTEGRAL_TYPE(CRLim,tyConCRlim,"CRLim",HTYPE_RLIM_T)
-#endif
-
--- ToDo: blksize_t, clockid_t, blkcnt_t, fsblkcnt_t, fsfilcnt_t, id_t, key_t
--- suseconds_t, timer_t, useconds_t
-
--- Make an Fd type rather than using CInt everywhere
-INTEGRAL_TYPE(Fd,tyConFd,"Fd",CInt)
-
--- nicer names, and backwards compatibility with POSIX library:
-#if defined(HTYPE_NLINK_T)
-type LinkCount = CNlink
-#endif
-#if defined(HTYPE_UID_T)
-type UserID = CUid
-#endif
-#if defined(HTYPE_GID_T)
-type GroupID = CGid
-#endif
-
-#endif /* !__NHC__ */
-
-type ByteCount = CSize
-type ClockTick = CClock
-type EpochTime = CTime
-type DeviceID = CDev
-type FileID = CIno
-type FileMode = CMode
-type ProcessID = CPid
-type FileOffset = COff
-type ProcessGroupID = CPid
-type Limit = CLong
-
+++ /dev/null
-{-# OPTIONS_GHC -cpp -fffi #-}
------------------------------------------------------------------------------
--- |
--- Module : System.Process
--- Copyright : (c) The University of Glasgow 2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Operations for creating and interacting with sub-processes.
---
------------------------------------------------------------------------------
-
--- ToDo:
--- * Flag to control whether exiting the parent also kills the child.
--- * Windows impl of runProcess should close the Handles.
--- * Add system/rawSystem replacements
-
-{- NOTES on createPipe:
-
- createPipe is no longer exported, because of the following problems:
-
- - it wasn't used to implement runInteractiveProcess on Unix, because
- the file descriptors for the unused ends of the pipe need to be closed
- in the child process.
-
- - on Windows, a special version of createPipe is needed that sets
- the inheritance flags correctly on the ends of the pipe (see
- mkAnonPipe below).
--}
-
-module System.Process (
- -- * Running sub-processes
- ProcessHandle,
- runCommand,
- runProcess,
- runInteractiveCommand,
- runInteractiveProcess,
-
- -- * Process completion
- waitForProcess,
- getProcessExitCode,
- terminateProcess,
- ) where
-
-import Prelude
-
-import System.Process.Internals
-
-import Foreign
-import Foreign.C
-import System.IO ( IOMode(..), Handle, hClose )
-import System.Exit ( ExitCode(..) )
-
-import System.Posix.Internals
-import GHC.IOBase ( FD )
-import GHC.Handle ( openFd )
-
--- ----------------------------------------------------------------------------
--- runCommand
-
-{- | Runs a command using the shell.
- -}
-runCommand
- :: String
- -> IO ProcessHandle
-
-runCommand string = do
- (cmd,args) <- commandToProcess string
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
- runProcessPosix "runCommand" cmd args Nothing Nothing Nothing Nothing Nothing
- Nothing Nothing
-#else
- runProcessWin32 "runCommand" cmd [] Nothing Nothing Nothing Nothing Nothing args
-#endif
-
--- ----------------------------------------------------------------------------
--- runProcess
-
-{- | Runs a raw command, optionally specifying 'Handle's from which to
- take the @stdin@, @stdout@ and @stderr@ channels for the new
- process (otherwise these handles are inherited from the current
- process).
-
- Any 'Handle's passed to 'runProcess' are placed immediately in the
- closed state.
--}
-runProcess
- :: FilePath -- ^ Filename of the executable
- -> [String] -- ^ Arguments to pass to the executable
- -> Maybe FilePath -- ^ Optional path to the working directory
- -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit)
- -> Maybe Handle -- ^ Handle to use for @stdin@
- -> Maybe Handle -- ^ Handle to use for @stdout@
- -> Maybe Handle -- ^ Handle to use for @stderr@
- -> IO ProcessHandle
-
-runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr = do
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
- h <- runProcessPosix "runProcess" cmd args mb_cwd mb_env
- mb_stdin mb_stdout mb_stderr
- Nothing Nothing
-#else
- h <- runProcessWin32 "runProcess" cmd args mb_cwd mb_env
- mb_stdin mb_stdout mb_stderr ""
-#endif
- maybe (return ()) hClose mb_stdin
- maybe (return ()) hClose mb_stdout
- maybe (return ()) hClose mb_stderr
- return h
-
--- ----------------------------------------------------------------------------
--- runInteractiveCommand
-
-{- | Runs a command using the shell, and returns 'Handle's that may
- be used to communicate with the process via its @stdin@, @stdout@,
- and @stderr@ respectively.
--}
-runInteractiveCommand
- :: String
- -> IO (Handle,Handle,Handle,ProcessHandle)
-
-runInteractiveCommand string = do
- (cmd,args) <- commandToProcess string
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
- runInteractiveProcess1 "runInteractiveCommand" cmd args Nothing Nothing
-#else
- runInteractiveProcess1 "runInteractiveCommand" cmd [] Nothing Nothing args
-#endif
-
--- ----------------------------------------------------------------------------
--- runInteractiveProcess
-
-{- | Runs a raw command, and returns 'Handle's that may be used to communicate
- with the process via its @stdin@, @stdout@ and @stderr@ respectively.
-
- For example, to start a process and feed a string to its stdin:
-
-> (inp,out,err,pid) <- runInteractiveProcess "..."
-> forkIO (hPutStr inp str)
--}
-runInteractiveProcess
- :: FilePath -- ^ Filename of the executable
- -> [String] -- ^ Arguments to pass to the executable
- -> Maybe FilePath -- ^ Optional path to the working directory
- -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit)
- -> IO (Handle,Handle,Handle,ProcessHandle)
-
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-
-runInteractiveProcess cmd args mb_cwd mb_env =
- runInteractiveProcess1 "runInteractiveProcess" cmd args mb_cwd mb_env
-
-runInteractiveProcess1 fun cmd args mb_cwd mb_env = do
- withFilePathException cmd $
- alloca $ \ pfdStdInput ->
- alloca $ \ pfdStdOutput ->
- alloca $ \ pfdStdError ->
- maybeWith withCEnvironment mb_env $ \pEnv ->
- maybeWith withCString mb_cwd $ \pWorkDir ->
- withMany withCString (cmd:args) $ \cstrs ->
- withArray0 nullPtr cstrs $ \pargs -> do
- proc_handle <- throwErrnoIfMinus1 fun
- (c_runInteractiveProcess pargs pWorkDir pEnv
- pfdStdInput pfdStdOutput pfdStdError)
- hndStdInput <- fdToHandle pfdStdInput WriteMode
- hndStdOutput <- fdToHandle pfdStdOutput ReadMode
- hndStdError <- fdToHandle pfdStdError ReadMode
- ph <- mkProcessHandle proc_handle
- return (hndStdInput, hndStdOutput, hndStdError, ph)
-
-foreign import ccall unsafe "runInteractiveProcess"
- c_runInteractiveProcess
- :: Ptr CString
- -> CString
- -> Ptr CString
- -> Ptr FD
- -> Ptr FD
- -> Ptr FD
- -> IO PHANDLE
-
-#else
-
-runInteractiveProcess cmd args mb_cwd mb_env =
- runInteractiveProcess1 "runInteractiveProcess" cmd args mb_cwd mb_env ""
-
-runInteractiveProcess1 fun cmd args workDir env extra_cmdline
- = withFilePathException cmd $ do
- let cmdline = translate cmd ++
- concat (map ((' ':) . translate) args) ++
- (if null extra_cmdline then "" else ' ':extra_cmdline)
- withCString cmdline $ \pcmdline ->
- alloca $ \ pfdStdInput ->
- alloca $ \ pfdStdOutput ->
- alloca $ \ pfdStdError -> do
- maybeWith withCEnvironment env $ \pEnv -> do
- maybeWith withCString workDir $ \pWorkDir -> do
- proc_handle <- throwErrnoIfMinus1 fun $
- c_runInteractiveProcess pcmdline pWorkDir pEnv
- pfdStdInput pfdStdOutput pfdStdError
- hndStdInput <- fdToHandle pfdStdInput WriteMode
- hndStdOutput <- fdToHandle pfdStdOutput ReadMode
- hndStdError <- fdToHandle pfdStdError ReadMode
- ph <- mkProcessHandle proc_handle
- return (hndStdInput, hndStdOutput, hndStdError, ph)
-
-foreign import ccall unsafe "runInteractiveProcess"
- c_runInteractiveProcess
- :: CString
- -> CString
- -> Ptr ()
- -> Ptr FD
- -> Ptr FD
- -> Ptr FD
- -> IO PHANDLE
-
-#endif
-
-fdToHandle :: Ptr FD -> IOMode -> IO Handle
-fdToHandle pfd mode = do
- fd <- peek pfd
- openFd fd (Just Stream)
- False{-not a socket-}
- ("fd:" ++ show fd) mode True{-binary-}
-
--- ----------------------------------------------------------------------------
--- waitForProcess
-
-{- | Waits for the specified process to terminate, and returns its exit code.
-
- GHC Note: in order to call @waitForProcess@ without blocking all the
- other threads in the system, you must compile the program with
- @-threaded@.
--}
-waitForProcess
- :: ProcessHandle
- -> IO ExitCode
-waitForProcess ph = do
- p_ <- withProcessHandle ph $ \p_ -> return (p_,p_)
- case p_ of
- ClosedHandle e -> return e
- OpenHandle h -> do
- -- don't hold the MVar while we call c_waitForProcess...
- -- (XXX but there's a small race window here during which another
- -- thread could close the handle or call waitForProcess)
- code <- throwErrnoIfMinus1 "waitForProcess" (c_waitForProcess h)
- withProcessHandle ph $ \p_ ->
- case p_ of
- ClosedHandle e -> return (p_,e)
- OpenHandle ph -> do
- closePHANDLE ph
- let e = if (code == 0)
- then ExitSuccess
- else (ExitFailure (fromIntegral code))
- return (ClosedHandle e, e)
-
--- ----------------------------------------------------------------------------
--- terminateProcess
-
--- | Attempts to terminate the specified process. This function should
--- not be used under normal circumstances - no guarantees are given regarding
--- how cleanly the process is terminated. To check whether the process
--- has indeed terminated, use 'getProcessExitCode'.
---
--- On Unix systems, 'terminateProcess' sends the process the SIGKILL signal.
--- On Windows systems, the Win32 @TerminateProcess@ function is called, passing
--- an exit code of 1.
-terminateProcess :: ProcessHandle -> IO ()
-terminateProcess ph = do
- withProcessHandle_ ph $ \p_ ->
- case p_ of
- ClosedHandle _ -> return p_
- OpenHandle h -> do
- throwErrnoIfMinus1_ "terminateProcess" $ c_terminateProcess h
- return p_
- -- does not close the handle, we might want to try terminating it
- -- again, or get its exit code.
-
--- ----------------------------------------------------------------------------
--- getProcessExitCode
-
-{- |
-This is a non-blocking version of 'waitForProcess'. If the process is
-still running, 'Nothing' is returned. If the process has exited, then
-@'Just' e@ is returned where @e@ is the exit code of the process.
-Subsequent calls to @getProcessExitStatus@ always return @'Just'
-'ExitSuccess'@, regardless of what the original exit code was.
--}
-getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode)
-getProcessExitCode ph = do
- withProcessHandle ph $ \p_ ->
- case p_ of
- ClosedHandle e -> return (p_, Just e)
- OpenHandle h ->
- alloca $ \pExitCode -> do
- res <- throwErrnoIfMinus1 "getProcessExitCode" $
- c_getProcessExitCode h pExitCode
- code <- peek pExitCode
- if res == 0
- then return (p_, Nothing)
- else do
- closePHANDLE h
- let e | code == 0 = ExitSuccess
- | otherwise = ExitFailure (fromIntegral code)
- return (ClosedHandle e, Just e)
-
--- ----------------------------------------------------------------------------
--- Interface to C bits
-
-foreign import ccall unsafe "terminateProcess"
- c_terminateProcess
- :: PHANDLE
- -> IO CInt
-
-foreign import ccall unsafe "getProcessExitCode"
- c_getProcessExitCode
- :: PHANDLE
- -> Ptr CInt
- -> IO CInt
-
-foreign import ccall safe "waitForProcess" -- NB. safe - can block
- c_waitForProcess
- :: PHANDLE
- -> IO CInt
+++ /dev/null
-{-# OPTIONS_GHC -cpp -fffi #-}
------------------------------------------------------------------------------
--- |
--- Module : System.Process.Internals
--- Copyright : (c) The University of Glasgow 2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Operations for creating and interacting with sub-processes.
---
------------------------------------------------------------------------------
-
--- #hide
-module System.Process.Internals (
-#ifndef __HUGS__
- ProcessHandle(..), ProcessHandle__(..),
- PHANDLE, closePHANDLE, mkProcessHandle,
- withProcessHandle, withProcessHandle_,
-#endif
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
- pPrPr_disableITimers, c_execvpe,
-# ifdef __GLASGOW_HASKELL__
- runProcessPosix,
-# endif
- ignoreSignal, defaultSignal,
-#else
-# ifdef __GLASGOW_HASKELL__
- runProcessWin32, translate,
-# endif
-#endif
-#ifndef __HUGS__
- commandToProcess,
-#endif
- withFilePathException, withCEnvironment
- ) where
-
-import Prelude -- necessary to get dependencies right
-
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-import System.Posix.Types ( CPid )
-import System.IO ( Handle )
-#else
-import Data.Word ( Word32 )
-import Data.IORef
-#endif
-
-import System.Exit ( ExitCode )
-import Data.Maybe ( fromMaybe )
-# ifdef __GLASGOW_HASKELL__
-import GHC.IOBase ( haFD, FD, Exception(..), IOException(..) )
-import GHC.Handle ( stdin, stdout, stderr, withHandle_ )
-# elif __HUGS__
-import Hugs.Exception ( Exception(..), IOException(..) )
-# endif
-
-import Control.Concurrent
-import Control.Exception ( handle, throwIO )
-import Foreign.C
-import Foreign
-
-#if defined(mingw32_HOST_OS)
-import Control.Monad ( when )
-import System.Directory ( doesFileExist )
-import Control.Exception ( catchJust, ioErrors )
-import System.IO.Error ( isDoesNotExistError, doesNotExistErrorType,
- mkIOError )
-import System.Environment ( getEnv )
-import System.Directory.Internals ( parseSearchPath, joinFileName )
-#endif
-
-#ifdef __HUGS__
-{-# CFILES cbits/execvpe.c #-}
-#endif
-
-#include "HsBaseConfig.h"
-
-#ifndef __HUGS__
--- ----------------------------------------------------------------------------
--- ProcessHandle type
-
-{- | A handle to a process, which can be used to wait for termination
- of the process using 'waitForProcess'.
-
- None of the process-creation functions in this library wait for
- termination: they all return a 'ProcessHandle' which may be used
- to wait for the process later.
--}
-data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode
-newtype ProcessHandle = ProcessHandle (MVar ProcessHandle__)
-
-withProcessHandle
- :: ProcessHandle
- -> (ProcessHandle__ -> IO (ProcessHandle__, a))
- -> IO a
-withProcessHandle (ProcessHandle m) io = modifyMVar m io
-
-withProcessHandle_
- :: ProcessHandle
- -> (ProcessHandle__ -> IO ProcessHandle__)
- -> IO ()
-withProcessHandle_ (ProcessHandle m) io = modifyMVar_ m io
-
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-
-type PHANDLE = CPid
-
-mkProcessHandle :: PHANDLE -> IO ProcessHandle
-mkProcessHandle p = do
- m <- newMVar (OpenHandle p)
- return (ProcessHandle m)
-
-closePHANDLE :: PHANDLE -> IO ()
-closePHANDLE _ = return ()
-
-#else
-
-type PHANDLE = Word32
-
--- On Windows, we have to close this HANDLE when it is no longer required,
--- hence we add a finalizer to it, using an IORef as the box on which to
--- attach the finalizer.
-mkProcessHandle :: PHANDLE -> IO ProcessHandle
-mkProcessHandle h = do
- m <- newMVar (OpenHandle h)
- addMVarFinalizer m (processHandleFinaliser m)
- return (ProcessHandle m)
-
-processHandleFinaliser m =
- modifyMVar_ m $ \p_ -> do
- case p_ of
- OpenHandle ph -> closePHANDLE ph
- _ -> return ()
- return (error "closed process handle")
-
-closePHANDLE :: PHANDLE -> IO ()
-closePHANDLE ph = c_CloseHandle ph
-
-foreign import stdcall unsafe "CloseHandle"
- c_CloseHandle
- :: PHANDLE
- -> IO ()
-#endif
-#endif /* !__HUGS__ */
-
--- ----------------------------------------------------------------------------
-
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-
--- this function disables the itimer, which would otherwise cause confusing
--- signals to be sent to the new process.
-foreign import ccall unsafe "pPrPr_disableITimers"
- pPrPr_disableITimers :: IO ()
-
-foreign import ccall unsafe "execvpe"
- c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt
-
-#endif
-
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-
-#ifdef __GLASGOW_HASKELL__
--- -----------------------------------------------------------------------------
--- POSIX runProcess with signal handling in the child
-
-runProcessPosix
- :: String
- -> FilePath -- ^ Filename of the executable
- -> [String] -- ^ Arguments to pass to the executable
- -> Maybe FilePath -- ^ Optional path to the working directory
- -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit)
- -> Maybe Handle -- ^ Handle to use for @stdin@
- -> Maybe Handle -- ^ Handle to use for @stdout@
- -> Maybe Handle -- ^ Handle to use for @stderr@
- -> Maybe CLong -- handler for SIGINT
- -> Maybe CLong -- handler for SIGQUIT
- -> IO ProcessHandle
-
-runProcessPosix fun cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
- mb_sigint mb_sigquit
- = withFilePathException cmd $ do
- fd_stdin <- withHandle_ fun (fromMaybe stdin mb_stdin) $ return . haFD
- fd_stdout <- withHandle_ fun (fromMaybe stdout mb_stdout) $ return . haFD
- fd_stderr <- withHandle_ fun (fromMaybe stderr mb_stderr) $ return . haFD
- -- some of these might refer to the same Handle, so don't do
- -- nested withHandle_'s (that will deadlock).
- maybeWith withCEnvironment mb_env $ \pEnv -> do
- maybeWith withCString mb_cwd $ \pWorkDir -> do
- withMany withCString (cmd:args) $ \cstrs -> do
- let (set_int, inthand)
- = case mb_sigint of
- Nothing -> (0, 0)
- Just hand -> (1, hand)
- (set_quit, quithand)
- = case mb_sigquit of
- Nothing -> (0, 0)
- Just hand -> (1, hand)
- withArray0 nullPtr cstrs $ \pargs -> do
- ph <- throwErrnoIfMinus1 fun $
- c_runProcess pargs pWorkDir pEnv
- fd_stdin fd_stdout fd_stderr
- set_int inthand set_quit quithand
- mkProcessHandle ph
-
-foreign import ccall unsafe "runProcess"
- c_runProcess
- :: Ptr CString -- args
- -> CString -- working directory (or NULL)
- -> Ptr CString -- env (or NULL)
- -> FD -- stdin
- -> FD -- stdout
- -> FD -- stderr
- -> CInt -- non-zero: set child's SIGINT handler
- -> CLong -- SIGINT handler
- -> CInt -- non-zero: set child's SIGQUIT handler
- -> CLong -- SIGQUIT handler
- -> IO PHANDLE
-
-#endif /* __GLASGOW_HASKELL__ */
-
-ignoreSignal = CONST_SIG_IGN :: CLong
-defaultSignal = CONST_SIG_DFL :: CLong
-
-#else
-
-#ifdef __GLASGOW_HASKELL__
-
-runProcessWin32 fun cmd args mb_cwd mb_env
- mb_stdin mb_stdout mb_stderr extra_cmdline
- = withFilePathException cmd $ do
- fd_stdin <- withHandle_ fun (fromMaybe stdin mb_stdin) $ return . haFD
- fd_stdout <- withHandle_ fun (fromMaybe stdout mb_stdout) $ return . haFD
- fd_stderr <- withHandle_ fun (fromMaybe stderr mb_stderr) $ return . haFD
- -- some of these might refer to the same Handle, so don't do
- -- nested withHandle_'s (that will deadlock).
- maybeWith withCEnvironment mb_env $ \pEnv -> do
- maybeWith withCString mb_cwd $ \pWorkDir -> do
- let cmdline = translate cmd ++
- concat (map ((' ':) . translate) args) ++
- (if null extra_cmdline then "" else ' ':extra_cmdline)
- withCString cmdline $ \pcmdline -> do
- proc_handle <- throwErrnoIfMinus1 fun
- (c_runProcess pcmdline pWorkDir pEnv
- fd_stdin fd_stdout fd_stderr)
- mkProcessHandle proc_handle
-
-foreign import ccall unsafe "runProcess"
- c_runProcess
- :: CString
- -> CString
- -> Ptr ()
- -> FD
- -> FD
- -> FD
- -> IO PHANDLE
-
--- ------------------------------------------------------------------------
--- Passing commands to the OS on Windows
-
-{-
-On Windows this is tricky. We use CreateProcess, passing a single
-command-line string (lpCommandLine) as its argument. (CreateProcess
-is well documented on http://msdn.microsoft/com.)
-
- - It parses the beginning of the string to find the command. If the
- file name has embedded spaces, it must be quoted, using double
- quotes thus
- "foo\this that\cmd" arg1 arg2
-
- - The invoked command can in turn access the entire lpCommandLine string,
- and the C runtime does indeed do so, parsing it to generate the
- traditional argument vector argv[0], argv[1], etc. It does this
- using a complex and arcane set of rules which are described here:
-
- http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vccelng/htm/progs_12.asp
-
- (if this URL stops working, you might be able to find it by
- searching for "Parsing C Command-Line Arguments" on MSDN. Also,
- the code in the Microsoft C runtime that does this translation
- is shipped with VC++).
-
-Our goal in runProcess is to take a command filename and list of
-arguments, and construct a string which inverts the translatsions
-described above, such that the program at the other end sees exactly
-the same arguments in its argv[] that we passed to rawSystem.
-
-This inverse translation is implemented by 'translate' below.
-
-Here are some pages that give informations on Windows-related
-limitations and deviations from Unix conventions:
-
- http://support.microsoft.com/default.aspx?scid=kb;en-us;830473
- Command lines and environment variables effectively limited to 8191
- characters on Win XP, 2047 on NT/2000 (probably even less on Win 9x):
-
- http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/percent.asp
- Command-line substitution under Windows XP. IIRC these facilities (or at
- least a large subset of them) are available on Win NT and 2000. Some
- might be available on Win 9x.
-
- http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/Cmd.asp
- How CMD.EXE processes command lines.
-
-
-Note: CreateProcess does have a separate argument (lpApplicationName)
-with which you can specify the command, but we have to slap the
-command into lpCommandLine anyway, so that argv[0] is what a C program
-expects (namely the application name). So it seems simpler to just
-use lpCommandLine alone, which CreateProcess supports.
--}
-
--- Translate command-line arguments for passing to CreateProcess().
-translate :: String -> String
-translate str = '"' : snd (foldr escape (True,"\"") str)
- where escape '"' (b, str) = (True, '\\' : '"' : str)
- escape '\\' (True, str) = (True, '\\' : '\\' : str)
- escape '\\' (False, str) = (False, '\\' : str)
- escape c (b, str) = (False, c : str)
- -- See long comment above for what this function is trying to do.
- --
- -- The Bool passed back along the string is True iff the
- -- rest of the string is a sequence of backslashes followed by
- -- a double quote.
-
-#endif /* __GLASGOW_HASKELL__ */
-
-#endif
-
-#ifndef __HUGS__
--- ----------------------------------------------------------------------------
--- commandToProcess
-
-{- | Turns a shell command into a raw command. Usually this involves
- wrapping it in an invocation of the shell.
-
- There's a difference in the signature of commandToProcess between
- the Windows and Unix versions. On Unix, exec takes a list of strings,
- and we want to pass our command to /bin/sh as a single argument.
-
- On Windows, CreateProcess takes a single string for the command,
- which is later decomposed by cmd.exe. In this case, we just want
- to prepend @\"c:\WINDOWS\CMD.EXE \/c\"@ to our command line. The
- command-line translation that we normally do for arguments on
- Windows isn't required (or desirable) here.
--}
-
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-
-commandToProcess
- :: String
- -> IO (FilePath,[String])
-commandToProcess string = return ("/bin/sh", ["-c", string])
-
-#else
-
-commandToProcess
- :: String
- -> IO (FilePath,String)
-commandToProcess string = do
- cmd <- findCommandInterpreter
- return (cmd, "/c "++string)
- -- We don't want to put the cmd into a single
- -- argument, because cmd.exe will not try to split it up. Instead,
- -- we just tack the command on the end of the cmd.exe command line,
- -- which partly works. There seem to be some quoting issues, but
- -- I don't have the energy to find+fix them right now (ToDo). --SDM
- -- (later) Now I don't know what the above comment means. sigh.
-
--- Find CMD.EXE (or COMMAND.COM on Win98). We use the same algorithm as
--- system() in the VC++ CRT (Vc7/crt/src/system.c in a VC++ installation).
-findCommandInterpreter :: IO FilePath
-findCommandInterpreter = do
- -- try COMSPEC first
- catchJust ioErrors (getEnv "COMSPEC") $ \e -> do
- when (not (isDoesNotExistError e)) $ ioError e
-
- -- try to find CMD.EXE or COMMAND.COM
- osver <- c_get_osver
- let filename | osver .&. 0x8000 /= 0 = "command.com"
- | otherwise = "cmd.exe"
- path <- getEnv "PATH"
- let
- -- use our own version of System.Directory.findExecutable, because
- -- that assumes the .exe suffix.
- search :: [FilePath] -> IO (Maybe FilePath)
- search [] = return Nothing
- search (d:ds) = do
- let path = d `joinFileName` filename
- b <- doesFileExist path
- if b then return (Just path)
- else search ds
- --
- mb_path <- search (parseSearchPath path)
-
- case mb_path of
- Nothing -> ioError (mkIOError doesNotExistErrorType
- "findCommandInterpreter" Nothing Nothing)
- Just cmd -> return cmd
-
-
-foreign import ccall unsafe "__hscore_get_osver"
- c_get_osver :: IO CUInt
-#endif
-
-#endif /* __HUGS__ */
-
--- ----------------------------------------------------------------------------
--- Utils
-
-withFilePathException :: FilePath -> IO a -> IO a
-withFilePathException fpath act = handle mapEx act
- where
- mapEx (IOException (IOError h iot fun str _)) = ioError (IOError h iot fun str (Just fpath))
- mapEx e = throwIO e
-
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-withCEnvironment :: [(String,String)] -> (Ptr CString -> IO a) -> IO a
-withCEnvironment env act =
- let env' = map (\(name, val) -> name ++ ('=':val)) env
- in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act)
-#else
-withCEnvironment :: [(String,String)] -> (Ptr () -> IO a) -> IO a
-withCEnvironment env act =
- let env' = foldr (\(name, val) env -> name ++ ('=':val)++'\0':env) "\0" env
- in withCString env' (act . castPtr)
-#endif
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Random
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : stable
--- Portability : portable
---
--- This library deals with the common task of pseudo-random number
--- generation. The library makes it possible to generate repeatable
--- results, by starting with a specified initial random number generator,
--- or to get different results on each run by using the system-initialised
--- generator or by supplying a seed from some other source.
---
--- The library is split into two layers:
---
--- * A core /random number generator/ provides a supply of bits.
--- The class 'RandomGen' provides a common interface to such generators.
--- The library provides one instance of 'RandomGen', the abstract
--- data type 'StdGen'. Programmers may, of course, supply their own
--- instances of 'RandomGen'.
---
--- * The class 'Random' provides a way to extract values of a particular
--- type from a random number generator. For example, the 'Float'
--- instance of 'Random' allows one to generate random values of type
--- 'Float'.
---
--- This implementation uses the Portable Combined Generator of L'Ecuyer
--- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by
--- Lennart Augustsson. It has a period of roughly 2.30584e18.
---
------------------------------------------------------------------------------
-
-module System.Random
- (
-
- -- $intro
-
- -- * Random number generators
-
- RandomGen(next, split, genRange)
-
- -- ** Standard random number generators
- , StdGen
- , mkStdGen
-
- -- ** The global random number generator
-
- -- $globalrng
-
- , getStdRandom
- , getStdGen
- , setStdGen
- , newStdGen
-
- -- * Random values of various types
- , Random ( random, randomR,
- randoms, randomRs,
- randomIO, randomRIO )
-
- -- * References
- -- $references
-
- ) where
-
-import Prelude
-
-#ifdef __NHC__
-import CPUTime ( getCPUTime )
-import Foreign.Ptr ( Ptr, nullPtr )
-import Foreign.C ( CTime, CUInt )
-#else
-import System.CPUTime ( getCPUTime )
-import System.Time ( getClockTime, ClockTime(..) )
-#endif
-import Data.Char ( isSpace, chr, ord )
-import System.IO.Unsafe ( unsafePerformIO )
-import Data.IORef
-import Numeric ( readDec )
-
--- The standard nhc98 implementation of Time.ClockTime does not match
--- the extended one expected in this module, so we lash-up a quick
--- replacement here.
-#ifdef __NHC__
-data ClockTime = TOD Integer ()
-foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime
-getClockTime :: IO ClockTime
-getClockTime = do CTime t <- readtime nullPtr; return (TOD (toInteger t) ())
-#endif
-
--- | The class 'RandomGen' provides a common interface to random number
--- generators.
---
--- Minimal complete definition: 'next' and 'split'.
-
-class RandomGen g where
-
- -- |The 'next' operation returns an 'Int' that is uniformly distributed
- -- in the range returned by 'genRange' (including both end points),
- -- and a new generator.
- next :: g -> (Int, g)
-
- -- |The 'split' operation allows one to obtain two distinct random number
- -- generators. This is very useful in functional programs (for example, when
- -- passing a random number generator down to recursive calls), but very
- -- little work has been done on statistically robust implementations of
- -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"]
- -- are the only examples we know of).
- split :: g -> (g, g)
-
- -- |The 'genRange' operation yields the range of values returned by
- -- the generator.
- --
- -- It is required that:
- --
- -- * If @(a,b) = 'genRange' g@, then @a < b@.
- --
- -- * 'genRange' always returns a pair of defined 'Int's.
- --
- -- The second condition ensures that 'genRange' cannot examine its
- -- argument, and hence the value it returns can be determined only by the
- -- instance of 'RandomGen'. That in turn allows an implementation to make
- -- a single call to 'genRange' to establish a generator's range, without
- -- being concerned that the generator returned by (say) 'next' might have
- -- a different range to the generator passed to 'next'.
- --
- -- The default definition spans the full range of 'Int'.
- genRange :: g -> (Int,Int)
-
- -- default method
- genRange g = (minBound,maxBound)
-
-{- |
-The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits.
-
-The result of repeatedly using 'next' should be at least as statistically
-robust as the /Minimal Standard Random Number Generator/ described by
-["System.Random\#Park", "System.Random\#Carta"].
-Until more is known about implementations of 'split', all we require is
-that 'split' deliver generators that are (a) not identical and
-(b) independently robust in the sense just given.
-
-The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the
-state of a random number generator.
-It is required that @'read' ('show' g) == g@.
-
-In addition, 'read' may be used to map an arbitrary string (not necessarily one
-produced by 'show') onto a value of type 'StdGen'. In general, the 'read'
-instance of 'StdGen' has the following properties:
-
-* It guarantees to succeed on any string.
-
-* It guarantees to consume only a finite portion of the string.
-
-* Different argument strings are likely to result in different results.
-
--}
-
-data StdGen
- = StdGen Int Int
-
-instance RandomGen StdGen where
- next = stdNext
- split = stdSplit
- genRange _ = stdRange
-
-instance Show StdGen where
- showsPrec p (StdGen s1 s2) =
- showsPrec p s1 .
- showChar ' ' .
- showsPrec p s2
-
-instance Read StdGen where
- readsPrec _p = \ r ->
- case try_read r of
- r@[_] -> r
- _ -> [stdFromString r] -- because it shouldn't ever fail.
- where
- try_read r = do
- (s1, r1) <- readDec (dropWhile isSpace r)
- (s2, r2) <- readDec (dropWhile isSpace r1)
- return (StdGen s1 s2, r2)
-
-{-
- If we cannot unravel the StdGen from a string, create
- one based on the string given.
--}
-stdFromString :: String -> (StdGen, String)
-stdFromString s = (mkStdGen num, rest)
- where (cs, rest) = splitAt 6 s
- num = foldl (\a x -> x + 3 * a) 1 (map ord cs)
-
-
-{- |
-The function 'mkStdGen' provides an alternative way of producing an initial
-generator, by mapping an 'Int' into a generator. Again, distinct arguments
-should be likely to produce distinct generators.
--}
-mkStdGen :: Int -> StdGen -- why not Integer ?
-mkStdGen s
- | s < 0 = mkStdGen (-s)
- | otherwise = StdGen (s1+1) (s2+1)
- where
- (q, s1) = s `divMod` 2147483562
- s2 = q `mod` 2147483398
-
-createStdGen :: Integer -> StdGen
-createStdGen s
- | s < 0 = createStdGen (-s)
- | otherwise = StdGen (fromInteger (s1+1)) (fromInteger (s2+1))
- where
- (q, s1) = s `divMod` 2147483562
- s2 = q `mod` 2147483398
-
--- FIXME: 1/2/3 below should be ** (vs@30082002) XXX
-
-{- |
-With a source of random number supply in hand, the 'Random' class allows the
-programmer to extract random values of a variety of types.
-
-Minimal complete definition: 'randomR' and 'random'.
-
--}
-
-class Random a where
- -- | Takes a range /(lo,hi)/ and a random number generator
- -- /g/, and returns a random value uniformly distributed in the closed
- -- interval /[lo,hi]/, together with a new generator. It is unspecified
- -- what happens if /lo>hi/. For continuous types there is no requirement
- -- that the values /lo/ and /hi/ are ever produced, but they may be,
- -- depending on the implementation and the interval.
- randomR :: RandomGen g => (a,a) -> g -> (a,g)
-
- -- | The same as 'randomR', but using a default range determined by the type:
- --
- -- * For bounded types (instances of 'Bounded', such as 'Char'),
- -- the range is normally the whole type.
- --
- -- * For fractional types, the range is normally the semi-closed interval
- -- @[0,1)@.
- --
- -- * For 'Integer', the range is (arbitrarily) the range of 'Int'.
- random :: RandomGen g => g -> (a, g)
-
- -- | Plural variant of 'randomR', producing an infinite list of
- -- random values instead of returning a new generator.
- randomRs :: RandomGen g => (a,a) -> g -> [a]
- randomRs ival g = x : randomRs ival g' where (x,g') = randomR ival g
-
- -- | Plural variant of 'random', producing an infinite list of
- -- random values instead of returning a new generator.
- randoms :: RandomGen g => g -> [a]
- randoms g = (\(x,g') -> x : randoms g') (random g)
-
- -- | A variant of 'randomR' that uses the global random number generator
- -- (see "System.Random#globalrng").
- randomRIO :: (a,a) -> IO a
- randomRIO range = getStdRandom (randomR range)
-
- -- | A variant of 'random' that uses the global random number generator
- -- (see "System.Random#globalrng").
- randomIO :: IO a
- randomIO = getStdRandom random
-
-
-instance Random Int where
- randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g
- random g = randomR (minBound,maxBound) g
-
-instance Random Char where
- randomR (a,b) g =
- case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of
- (x,g) -> (chr x, g)
- random g = randomR (minBound,maxBound) g
-
-instance Random Bool where
- randomR (a,b) g =
- case (randomIvalInteger (toInteger (bool2Int a), toInteger (bool2Int b)) g) of
- (x, g) -> (int2Bool x, g)
- where
- bool2Int False = 0
- bool2Int True = 1
-
- int2Bool 0 = False
- int2Bool _ = True
-
- random g = randomR (minBound,maxBound) g
-
-instance Random Integer where
- randomR ival g = randomIvalInteger ival g
- random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g
-
-instance Random Double where
- randomR ival g = randomIvalDouble ival id g
- random g = randomR (0::Double,1) g
-
--- hah, so you thought you were saving cycles by using Float?
-instance Random Float where
- random g = randomIvalDouble (0::Double,1) realToFrac g
- randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g
-
-mkStdRNG :: Integer -> IO StdGen
-mkStdRNG o = do
- ct <- getCPUTime
- (TOD sec _) <- getClockTime
- return (createStdGen (sec * 12345 + ct + o))
-
-randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)
-randomIvalInteger (l,h) rng
- | l > h = randomIvalInteger (h,l) rng
- | otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')
- where
- k = h - l + 1
- b = 2147483561
- n = iLogBase b k
-
- f 0 acc g = (acc, g)
- f n acc g =
- let
- (x,g') = next g
- in
- f (n-1) (fromIntegral x + acc * b) g'
-
-randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g)
-randomIvalDouble (l,h) fromDouble rng
- | l > h = randomIvalDouble (h,l) fromDouble rng
- | otherwise =
- case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of
- (x, rng') ->
- let
- scaled_x =
- fromDouble ((l+h)/2) +
- fromDouble ((h-l) / realToFrac intRange) *
- fromIntegral (x::Int)
- in
- (scaled_x, rng')
-
-intRange :: Integer
-intRange = toInteger (maxBound::Int) - toInteger (minBound::Int)
-
-iLogBase :: Integer -> Integer -> Integer
-iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)
-
-stdRange :: (Int,Int)
-stdRange = (0, 2147483562)
-
-stdNext :: StdGen -> (Int, StdGen)
--- Returns values in the range stdRange
-stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'')
- where z' = if z < 1 then z + 2147483562 else z
- z = s1'' - s2''
-
- k = s1 `quot` 53668
- s1' = 40014 * (s1 - k * 53668) - k * 12211
- s1'' = if s1' < 0 then s1' + 2147483563 else s1'
-
- k' = s2 `quot` 52774
- s2' = 40692 * (s2 - k' * 52774) - k' * 3791
- s2'' = if s2' < 0 then s2' + 2147483399 else s2'
-
-stdSplit :: StdGen -> (StdGen, StdGen)
-stdSplit std@(StdGen s1 s2)
- = (left, right)
- where
- -- no statistical foundation for this!
- left = StdGen new_s1 t2
- right = StdGen t1 new_s2
-
- new_s1 | s1 == 2147483562 = 1
- | otherwise = s1 + 1
-
- new_s2 | s2 == 1 = 2147483398
- | otherwise = s2 - 1
-
- StdGen t1 t2 = snd (next std)
-
--- The global random number generator
-
-{- $globalrng #globalrng#
-
-There is a single, implicit, global random number generator of type
-'StdGen', held in some global variable maintained by the 'IO' monad. It is
-initialised automatically in some system-dependent fashion, for example, by
-using the time of day, or Linux's kernel random number generator. To get
-deterministic behaviour, use 'setStdGen'.
--}
-
--- |Sets the global random number generator.
-setStdGen :: StdGen -> IO ()
-setStdGen sgen = writeIORef theStdGen sgen
-
--- |Gets the global random number generator.
-getStdGen :: IO StdGen
-getStdGen = readIORef theStdGen
-
-theStdGen :: IORef StdGen
-theStdGen = unsafePerformIO $ do
- rng <- mkStdRNG 0
- newIORef rng
-
--- |Applies 'split' to the current global random generator,
--- updates it with one of the results, and returns the other.
-newStdGen :: IO StdGen
-newStdGen = do
- rng <- getStdGen
- let (a,b) = split rng
- setStdGen a
- return b
-
-{- |Uses the supplied function to get a value from the current global
-random generator, and updates the global generator with the new generator
-returned by the function. For example, @rollDice@ gets a random integer
-between 1 and 6:
-
-> rollDice :: IO Int
-> rollDice = getStdRandom (randomR (1,6))
-
--}
-
-getStdRandom :: (StdGen -> (a,StdGen)) -> IO a
-getStdRandom f = do
- rng <- getStdGen
- let (v, new_rng) = f rng
- setStdGen new_rng
- return v
-
-{- $references
-
-1. FW #Burton# Burton and RL Page, /Distributed random number generation/,
-Journal of Functional Programming, 2(2):203-212, April 1992.
-
-2. SK #Park# Park, and KW Miller, /Random number generators -
-good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201.
-
-3. DG #Carta# Carta, /Two fast implementations of the minimal standard
-random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88.
-
-4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/,
-Department of Mathematics, University of Salzburg,
-<http://random.mat.sbg.ac.at/~peter/pads98.ps>, 1998.
-
-5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random
-number generators/, Comm ACM, 31(6), Jun 1988, pp742-749.
-
-The Web site <http://random.mat.sbg.ac.at/> is a great source of information.
-
--}
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Time
--- 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 standard Time library, providing standard functionality for clock
--- times, including timezone information (i.e, the functionality of
--- \"@time.h@\", adapted to the Haskell environment). It follows RFC
--- 1129 in its use of Coordinated Universal Time (UTC).
------------------------------------------------------------------------------
-
-{-
-Haskell 98 Time of Day Library
-------------------------------
-
-2000/06/17 <michael.weber@post.rwth-aachen.de>:
-RESTRICTIONS:
- * min./max. time diff currently is restricted to
- [minBound::Int, maxBound::Int]
-
- * surely other restrictions wrt. min/max bounds
-
-
-NOTES:
- * printing times
-
- `showTime' (used in `instance Show ClockTime') always prints time
- converted to the local timezone (even if it is taken from
- `(toClockTime . toUTCTime)'), whereas `calendarTimeToString'
- honors the tzone & tz fields and prints UTC or whatever timezone
- is stored inside CalendarTime.
-
- Maybe `showTime' should be changed to use UTC, since it would
- better correspond to the actual representation of `ClockTime'
- (can be done by replacing localtime(3) by gmtime(3)).
-
-
-BUGS:
- * add proper handling of microsecs, currently, they're mostly
- ignored
-
- * `formatFOO' case of `%s' is currently broken...
-
-
-TODO:
- * check for unusual date cases, like 1970/1/1 00:00h, and conversions
- between different timezone's etc.
-
- * check, what needs to be in the IO monad, the current situation
- seems to be a bit inconsistent to me
-
- * check whether `isDst = -1' works as expected on other arch's
- (Solaris anyone?)
-
- * add functions to parse strings to `CalendarTime' (some day...)
-
- * implement padding capabilities ("%_", "%-") in `formatFOO'
-
- * add rfc822 timezone (+0200 is CEST) representation ("%z") in `formatFOO'
--}
-
-module System.Time
- (
- -- * Clock times
-
- ClockTime(..) -- non-standard, lib. report gives this as abstract
- -- instance Eq, Ord
- -- instance Show (non-standard)
-
- , getClockTime
-
- -- * Time differences
-
- , TimeDiff(..)
- , noTimeDiff -- non-standard (but useful when constructing TimeDiff vals.)
- , diffClockTimes
- , addToClockTime
-
- , normalizeTimeDiff -- non-standard
- , timeDiffToString -- non-standard
- , formatTimeDiff -- non-standard
-
- -- * Calendar times
-
- , CalendarTime(..)
- , Month(..)
- , Day(..)
- , toCalendarTime
- , toUTCTime
- , toClockTime
- , calendarTimeToString
- , formatCalendarTime
-
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-#include "HsBase.h"
-#endif
-
-#ifdef __NHC__
-#include <time.h>
-# if defined(__sun) || defined(__CYGWIN32__)
-# define HAVE_TZNAME 1
-# else
-# define HAVE_TM_ZONE 1
-# endif
-import Ix
-#endif
-
-import Prelude
-
-import Data.Ix
-import System.Locale
-import System.IO.Unsafe
-
-#ifdef __HUGS__
-import Hugs.Time ( getClockTimePrim, toCalTimePrim, toClockTimePrim )
-#else
-import Foreign
-import Foreign.C
-#endif
-
--- One way to partition and give name to chunks of a year and a week:
-
--- | A month of the year.
-
-data Month
- = January | February | March | April
- | May | June | July | August
- | September | October | November | December
- deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
-
--- | A day of the week.
-
-data Day
- = Sunday | Monday | Tuesday | Wednesday
- | Thursday | Friday | Saturday
- deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
-
--- | A representation of the internal clock time.
--- Clock times may be compared, converted to strings, or converted to an
--- external calendar time 'CalendarTime' for I\/O or other manipulations.
-
-data ClockTime = TOD Integer Integer
- -- ^ Construct a clock time. The arguments are a number
- -- of seconds since 00:00:00 (UTC) on 1 January 1970,
- -- and an additional number of picoseconds.
- --
- -- In Haskell 98, the 'ClockTime' type is abstract.
- deriving (Eq, Ord)
-
--- When a ClockTime is shown, it is converted to a CalendarTime in the current
--- timezone and then printed. FIXME: This is arguably wrong, since we can't
--- get the current timezone without being in the IO monad.
-
-instance Show ClockTime where
- showsPrec _ t = showString (calendarTimeToString
- (unsafePerformIO (toCalendarTime t)))
-
-{-
-The numeric fields have the following ranges.
-
-\begin{verbatim}
-Value Range Comments
------ ----- --------
-
-year -maxInt .. maxInt [Pre-Gregorian dates are inaccurate]
-day 1 .. 31
-hour 0 .. 23
-min 0 .. 59
-sec 0 .. 61 [Allows for two leap seconds]
-picosec 0 .. (10^12)-1 [This could be over-precise?]
-yday 0 .. 365 [364 in non-Leap years]
-tz -43200 .. 43200 [Variation from UTC in seconds]
-\end{verbatim}
--}
-
--- | 'CalendarTime' is a user-readable and manipulable
--- representation of the internal 'ClockTime' type.
-
-data CalendarTime
- = CalendarTime {
- ctYear :: Int -- ^ Year (pre-Gregorian dates are inaccurate)
- , ctMonth :: Month -- ^ Month of the year
- , ctDay :: Int -- ^ Day of the month (1 to 31)
- , ctHour :: Int -- ^ Hour of the day (0 to 23)
- , ctMin :: Int -- ^ Minutes (0 to 59)
- , ctSec :: Int -- ^ Seconds (0 to 61, allowing for up to
- -- two leap seconds)
- , ctPicosec :: Integer -- ^ Picoseconds
- , ctWDay :: Day -- ^ Day of the week
- , ctYDay :: Int -- ^ Day of the year
- -- (0 to 364, or 365 in leap years)
- , ctTZName :: String -- ^ Name of the time zone
- , ctTZ :: Int -- ^ Variation from UTC in seconds
- , ctIsDST :: Bool -- ^ 'True' if Daylight Savings Time would
- -- be in effect, and 'False' otherwise
- }
- deriving (Eq,Ord,Read,Show)
-
--- | records the difference between two clock times in a user-readable way.
-
-data TimeDiff
- = TimeDiff {
- tdYear :: Int,
- tdMonth :: Int,
- tdDay :: Int,
- tdHour :: Int,
- tdMin :: Int,
- tdSec :: Int,
- tdPicosec :: Integer -- not standard
- }
- deriving (Eq,Ord,Read,Show)
-
--- | null time difference.
-
-noTimeDiff :: TimeDiff
-noTimeDiff = TimeDiff 0 0 0 0 0 0 0
-
--- -----------------------------------------------------------------------------
--- | returns the current time in its internal representation.
-
-getClockTime :: IO ClockTime
-#ifdef __HUGS__
-getClockTime = do
- (sec,usec) <- getClockTimePrim
- return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000000))
-
-#elif HAVE_GETTIMEOFDAY
-getClockTime = do
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- allocaBytes (#const sizeof(struct timeval)) $ \ p_timeval -> do
- throwErrnoIfMinus1_ "getClockTime" $ gettimeofday p_timeval nullPtr
- sec <- (#peek struct timeval,tv_sec) p_timeval :: IO CTime
- usec <- (#peek struct timeval,tv_usec) p_timeval :: IO CTime
- return (TOD (realToInteger sec) ((realToInteger usec) * 1000000))
-
-#elif HAVE_FTIME
-getClockTime = do
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- allocaBytes (#const sizeof(struct timeb)) $ \ p_timeb -> do
- ftime p_timeb
- sec <- (#peek struct timeb,time) p_timeb :: IO CTime
- msec <- (#peek struct timeb,millitm) p_timeb :: IO CUShort
- return (TOD (realToInteger sec) (fromIntegral msec * 1000000000))
-
-#else /* use POSIX time() */
-getClockTime = do
- secs <- time nullPtr -- can't fail, according to POSIX
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- return (TOD (realToInteger secs) 0)
-
-#endif
-
--- -----------------------------------------------------------------------------
--- | @'addToClockTime' d t@ adds a time difference @d@ and a
--- clock time @t@ to yield a new clock time. The difference @d@
--- may be either positive or negative.
-
-addToClockTime :: TimeDiff -> ClockTime -> ClockTime
-addToClockTime (TimeDiff year mon day hour min sec psec)
- (TOD c_sec c_psec) =
- let
- sec_diff = toInteger sec +
- 60 * toInteger min +
- 3600 * toInteger hour +
- 24 * 3600 * toInteger day
- (d_sec, d_psec) = (c_psec + psec) `quotRem` 1000000000000
- cal = toUTCTime (TOD (c_sec + sec_diff + d_sec) d_psec)
- new_mon = fromEnum (ctMonth cal) + r_mon
- month' = fst tmp
- yr_diff = snd tmp
- tmp
- | new_mon < 0 = (toEnum (12 + new_mon), (-1))
- | new_mon > 11 = (toEnum (new_mon `mod` 12), 1)
- | otherwise = (toEnum new_mon, 0)
-
- (r_yr, r_mon) = mon `quotRem` 12
-
- year' = ctYear cal + year + r_yr + yr_diff
- in
- toClockTime cal{ctMonth=month', ctYear=year'}
-
--- | @'diffClockTimes' t1 t2@ returns the difference between two clock
--- times @t1@ and @t2@ as a 'TimeDiff'.
-
-diffClockTimes :: ClockTime -> ClockTime -> TimeDiff
--- diffClockTimes is meant to be the dual to `addToClockTime'.
--- If you want to have the TimeDiff properly splitted, use
--- `normalizeTimeDiff' on this function's result
---
--- CAVEAT: see comment of normalizeTimeDiff
-diffClockTimes (TOD sa pa) (TOD sb pb) =
- noTimeDiff{ tdSec = fromIntegral (sa - sb)
- -- FIXME: can handle just 68 years...
- , tdPicosec = pa - pb
- }
-
-
--- | converts a time difference to normal form.
-
-normalizeTimeDiff :: TimeDiff -> TimeDiff
--- FIXME: handle psecs properly
--- FIXME: ?should be called by formatTimeDiff automagically?
---
--- when applied to something coming out of `diffClockTimes', you loose
--- the duality to `addToClockTime', since a year does not always have
--- 365 days, etc.
---
--- apply this function as late as possible to prevent those "rounding"
--- errors
-normalizeTimeDiff td =
- let
- rest0 = toInteger (tdSec td)
- + 60 * (toInteger (tdMin td)
- + 60 * (toInteger (tdHour td)
- + 24 * (toInteger (tdDay td)
- + 30 * toInteger (tdMonth td)
- + 365 * toInteger (tdYear td))))
-
- (diffYears, rest1) = rest0 `quotRem` (365 * 24 * 3600)
- (diffMonths, rest2) = rest1 `quotRem` (30 * 24 * 3600)
- (diffDays, rest3) = rest2 `quotRem` (24 * 3600)
- (diffHours, rest4) = rest3 `quotRem` 3600
- (diffMins, diffSecs) = rest4 `quotRem` 60
- in
- td{ tdYear = fromInteger diffYears
- , tdMonth = fromInteger diffMonths
- , tdDay = fromInteger diffDays
- , tdHour = fromInteger diffHours
- , tdMin = fromInteger diffMins
- , tdSec = fromInteger diffSecs
- }
-
-#ifndef __HUGS__
--- -----------------------------------------------------------------------------
--- How do we deal with timezones on this architecture?
-
--- The POSIX way to do it is through the global variable tzname[].
--- But that's crap, so we do it The BSD Way if we can: namely use the
--- tm_zone and tm_gmtoff fields of struct tm, if they're available.
-
-zone :: Ptr CTm -> IO (Ptr CChar)
-gmtoff :: Ptr CTm -> IO CLong
-#if HAVE_TM_ZONE
-zone x = (#peek struct tm,tm_zone) x
-gmtoff x = (#peek struct tm,tm_gmtoff) x
-
-#else /* ! HAVE_TM_ZONE */
-# if HAVE_TZNAME || defined(_WIN32)
-# if cygwin32_HOST_OS
-# define tzname _tzname
-# endif
-# ifndef mingw32_HOST_OS
-foreign import ccall unsafe "time.h &tzname" tzname :: Ptr CString
-# else
-foreign import ccall unsafe "__hscore_timezone" timezone :: Ptr CLong
-foreign import ccall unsafe "__hscore_tzname" tzname :: Ptr CString
-# endif
-zone x = do
- dst <- (#peek struct tm,tm_isdst) x
- if dst then peekElemOff tzname 1 else peekElemOff tzname 0
-# else /* ! HAVE_TZNAME */
--- We're in trouble. If you should end up here, please report this as a bug.
-# error "Don't know how to get at timezone name on your OS."
-# endif /* ! HAVE_TZNAME */
-
--- Get the offset in secs from UTC, if (struct tm) doesn't supply it. */
-# if HAVE_DECL_ALTZONE
-foreign import ccall "&altzone" altzone :: Ptr CTime
-foreign import ccall "&timezone" timezone :: Ptr CTime
-gmtoff x = do
- dst <- (#peek struct tm,tm_isdst) x
- tz <- if dst then peek altzone else peek timezone
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- return (-fromIntegral (realToInteger tz))
-# else /* ! HAVE_DECL_ALTZONE */
-
-#if !defined(mingw32_HOST_OS)
-foreign import ccall "time.h &timezone" timezone :: Ptr CLong
-#endif
-
--- Assume that DST offset is 1 hour ...
-gmtoff x = do
- dst <- (#peek struct tm,tm_isdst) x
- tz <- peek timezone
- -- According to the documentation for tzset(),
- -- http://www.opengroup.org/onlinepubs/007908799/xsh/tzset.html
- -- timezone offsets are > 0 west of the Prime Meridian.
- --
- -- This module assumes the interpretation of tm_gmtoff, i.e., offsets
- -- are > 0 East of the Prime Meridian, so flip the sign.
- return (- (if dst then (fromIntegral tz - 3600) else tz))
-# endif /* ! HAVE_DECL_ALTZONE */
-#endif /* ! HAVE_TM_ZONE */
-#endif /* ! __HUGS__ */
-
--- -----------------------------------------------------------------------------
--- | converts an internal clock time to a local time, modified by the
--- timezone and daylight savings time settings in force at the time
--- of conversion. Because of this dependence on the local environment,
--- 'toCalendarTime' is in the 'IO' monad.
-
-toCalendarTime :: ClockTime -> IO CalendarTime
-#ifdef __HUGS__
-toCalendarTime = toCalTime False
-#elif HAVE_LOCALTIME_R
-toCalendarTime = clockToCalendarTime_reentrant (throwAwayReturnPointer localtime_r) False
-#else
-toCalendarTime = clockToCalendarTime_static localtime False
-#endif
-
--- | converts an internal clock time into a 'CalendarTime' in standard
--- UTC format.
-
-toUTCTime :: ClockTime -> CalendarTime
-#ifdef __HUGS__
-toUTCTime = unsafePerformIO . toCalTime True
-#elif HAVE_GMTIME_R
-toUTCTime = unsafePerformIO . clockToCalendarTime_reentrant (throwAwayReturnPointer gmtime_r) True
-#else
-toUTCTime = unsafePerformIO . clockToCalendarTime_static gmtime True
-#endif
-
-#ifdef __HUGS__
-toCalTime :: Bool -> ClockTime -> IO CalendarTime
-toCalTime toUTC (TOD s psecs)
- | (s > fromIntegral (maxBound :: Int)) ||
- (s < fromIntegral (minBound :: Int))
- = error ((if toUTC then "toUTCTime: " else "toCalendarTime: ") ++
- "clock secs out of range")
- | otherwise = do
- (sec,min,hour,mday,mon,year,wday,yday,isdst,zone,off) <-
- toCalTimePrim (if toUTC then 1 else 0) (fromIntegral s)
- return (CalendarTime{ ctYear=1900+year
- , ctMonth=toEnum mon
- , ctDay=mday
- , ctHour=hour
- , ctMin=min
- , ctSec=sec
- , ctPicosec=psecs
- , ctWDay=toEnum wday
- , ctYDay=yday
- , ctTZName=(if toUTC then "UTC" else zone)
- , ctTZ=(if toUTC then 0 else off)
- , ctIsDST=not toUTC && (isdst/=0)
- })
-#else /* ! __HUGS__ */
-throwAwayReturnPointer :: (Ptr CTime -> Ptr CTm -> IO (Ptr CTm))
- -> (Ptr CTime -> Ptr CTm -> IO ( ))
-throwAwayReturnPointer fun x y = fun x y >> return ()
-
-#if !HAVE_LOCALTIME_R || !HAVE_GMTIME_R
-clockToCalendarTime_static :: (Ptr CTime -> IO (Ptr CTm)) -> Bool -> ClockTime
- -> IO CalendarTime
-clockToCalendarTime_static fun is_utc (TOD secs psec) = do
- with (fromIntegral secs :: CTime) $ \ p_timer -> do
- p_tm <- fun p_timer -- can't fail, according to POSIX
- clockToCalendarTime_aux is_utc p_tm psec
-#endif
-
-#if HAVE_LOCALTIME_R || HAVE_GMTIME_R
-clockToCalendarTime_reentrant :: (Ptr CTime -> Ptr CTm -> IO ()) -> Bool -> ClockTime
- -> IO CalendarTime
-clockToCalendarTime_reentrant fun is_utc (TOD secs psec) = do
- with (fromIntegral secs :: CTime) $ \ p_timer -> do
- allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do
- fun p_timer p_tm
- clockToCalendarTime_aux is_utc p_tm psec
-#endif
-
-clockToCalendarTime_aux :: Bool -> Ptr CTm -> Integer -> IO CalendarTime
-clockToCalendarTime_aux is_utc p_tm psec = do
- sec <- (#peek struct tm,tm_sec ) p_tm :: IO CInt
- min <- (#peek struct tm,tm_min ) p_tm :: IO CInt
- hour <- (#peek struct tm,tm_hour ) p_tm :: IO CInt
- mday <- (#peek struct tm,tm_mday ) p_tm :: IO CInt
- mon <- (#peek struct tm,tm_mon ) p_tm :: IO CInt
- year <- (#peek struct tm,tm_year ) p_tm :: IO CInt
- wday <- (#peek struct tm,tm_wday ) p_tm :: IO CInt
- yday <- (#peek struct tm,tm_yday ) p_tm :: IO CInt
- isdst <- (#peek struct tm,tm_isdst) p_tm :: IO CInt
- zone <- zone p_tm
- tz <- gmtoff p_tm
-
- tzname <- peekCString zone
-
- let month | mon >= 0 && mon <= 11 = toEnum (fromIntegral mon)
- | otherwise = error ("toCalendarTime: illegal month value: " ++ show mon)
-
- return (CalendarTime
- (1900 + fromIntegral year)
- month
- (fromIntegral mday)
- (fromIntegral hour)
- (fromIntegral min)
- (fromIntegral sec)
- psec
- (toEnum (fromIntegral wday))
- (fromIntegral yday)
- (if is_utc then "UTC" else tzname)
- (if is_utc then 0 else fromIntegral tz)
- (if is_utc then False else isdst /= 0))
-#endif /* ! __HUGS__ */
-
--- | converts a 'CalendarTime' into the corresponding internal
--- 'ClockTime', ignoring the contents of the 'ctWDay', 'ctYDay',
--- 'ctTZName' and 'ctIsDST' fields.
-
-toClockTime :: CalendarTime -> ClockTime
-#ifdef __HUGS__
-toClockTime (CalendarTime yr mon mday hour min sec psec
- _wday _yday _tzname tz _isdst) =
- unsafePerformIO $ do
- s <- toClockTimePrim (yr-1900) (fromEnum mon) mday hour min sec tz
- return (TOD (fromIntegral s) psec)
-#else /* ! __HUGS__ */
-toClockTime (CalendarTime year mon mday hour min sec psec
- _wday _yday _tzname tz isdst) =
-
- -- `isDst' causes the date to be wrong by one hour...
- -- FIXME: check, whether this works on other arch's than Linux, too...
- --
- -- so we set it to (-1) (means `unknown') and let `mktime' determine
- -- the real value...
- let isDst = -1 :: CInt in -- if isdst then (1::Int) else 0
-
- if psec < 0 || psec > 999999999999 then
- error "Time.toClockTime: picoseconds out of range"
- else if tz < -43200 || tz > 43200 then
- error "Time.toClockTime: timezone offset out of range"
- else
- unsafePerformIO $ do
- allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do
- (#poke struct tm,tm_sec ) p_tm (fromIntegral sec :: CInt)
- (#poke struct tm,tm_min ) p_tm (fromIntegral min :: CInt)
- (#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt)
- (#poke struct tm,tm_mday ) p_tm (fromIntegral mday :: CInt)
- (#poke struct tm,tm_mon ) p_tm (fromIntegral (fromEnum mon) :: CInt)
- (#poke struct tm,tm_year ) p_tm (fromIntegral year - 1900 :: CInt)
- (#poke struct tm,tm_isdst) p_tm isDst
- t <- throwIf (== -1) (\_ -> "Time.toClockTime: invalid input")
- (mktime p_tm)
- --
- -- mktime expects its argument to be in the local timezone, but
- -- toUTCTime makes UTC-encoded CalendarTime's ...
- --
- -- Since there is no any_tz_struct_tm-to-time_t conversion
- -- function, we have to fake one... :-) If not in all, it works in
- -- most cases (before, it was the other way round...)
- --
- -- Luckily, mktime tells us, what it *thinks* the timezone is, so,
- -- to compensate, we add the timezone difference to mktime's
- -- result.
- --
- gmtoff <- gmtoff p_tm
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- res = realToInteger t - fromIntegral tz + fromIntegral gmtoff
- return (TOD res psec)
-#endif /* ! __HUGS__ */
-
--- -----------------------------------------------------------------------------
--- Converting time values to strings.
-
--- | formats calendar times using local conventions.
-
-calendarTimeToString :: CalendarTime -> String
-calendarTimeToString = formatCalendarTime defaultTimeLocale "%c"
-
--- | formats calendar times using local conventions and a formatting string.
--- The formatting string is that understood by the ISO C @strftime()@
--- function.
-
-formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String
-formatCalendarTime l fmt (CalendarTime year mon day hour min sec _
- wday yday tzname _ _) =
- doFmt fmt
- where doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
- doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
- doFmt ('%':c:cs) = decode c ++ doFmt cs
- doFmt (c:cs) = c : doFmt cs
- doFmt "" = ""
-
- decode 'A' = fst (wDays l !! fromEnum wday) -- day of the week, full name
- decode 'a' = snd (wDays l !! fromEnum wday) -- day of the week, abbrev.
- decode 'B' = fst (months l !! fromEnum mon) -- month, full name
- decode 'b' = snd (months l !! fromEnum mon) -- month, abbrev
- decode 'h' = snd (months l !! fromEnum mon) -- ditto
- decode 'C' = show2 (year `quot` 100) -- century
- decode 'c' = doFmt (dateTimeFmt l) -- locale's data and time format.
- decode 'D' = doFmt "%m/%d/%y"
- decode 'd' = show2 day -- day of the month
- decode 'e' = show2' day -- ditto, padded
- decode 'H' = show2 hour -- hours, 24-hour clock, padded
- decode 'I' = show2 (to12 hour) -- hours, 12-hour clock
- decode 'j' = show3 yday -- day of the year
- decode 'k' = show2' hour -- hours, 24-hour clock, no padding
- decode 'l' = show2' (to12 hour) -- hours, 12-hour clock, no padding
- decode 'M' = show2 min -- minutes
- decode 'm' = show2 (fromEnum mon+1) -- numeric month
- decode 'n' = "\n"
- decode 'p' = (if hour < 12 then fst else snd) (amPm l) -- am or pm
- decode 'R' = doFmt "%H:%M"
- decode 'r' = doFmt (time12Fmt l)
- decode 'T' = doFmt "%H:%M:%S"
- decode 't' = "\t"
- decode 'S' = show2 sec -- seconds
- decode 's' = show2 sec -- number of secs since Epoch. (ToDo.)
- decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) -- week number, starting on Sunday.
- decode 'u' = show (let n = fromEnum wday in -- numeric day of the week (1=Monday, 7=Sunday)
- if n == 0 then 7 else n)
- decode 'V' = -- week number (as per ISO-8601.)
- let (week, days) = -- [yep, I've always wanted to be able to display that too.]
- (yday + 7 - if fromEnum wday > 0 then
- fromEnum wday - 1 else 6) `divMod` 7
- in show2 (if days >= 4 then
- week+1
- else if week == 0 then 53 else week)
-
- decode 'W' = -- week number, weeks starting on monday
- show2 ((yday + 7 - if fromEnum wday > 0 then
- fromEnum wday - 1 else 6) `div` 7)
- decode 'w' = show (fromEnum wday) -- numeric day of the week, weeks starting on Sunday.
- decode 'X' = doFmt (timeFmt l) -- locale's preferred way of printing time.
- decode 'x' = doFmt (dateFmt l) -- locale's preferred way of printing dates.
- decode 'Y' = show year -- year, including century.
- decode 'y' = show2 (year `rem` 100) -- year, within century.
- decode 'Z' = tzname -- timezone name
- decode '%' = "%"
- decode c = [c]
-
-
-show2, show2', show3 :: Int -> String
-show2 x
- | x' < 10 = '0': show x'
- | otherwise = show x'
- where x' = x `rem` 100
-
-show2' x
- | x' < 10 = ' ': show x'
- | otherwise = show x'
- where x' = x `rem` 100
-
-show3 x = show (x `quot` 100) ++ show2 (x `rem` 100)
-
-to12 :: Int -> Int
-to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'
-
--- Useful extensions for formatting TimeDiffs.
-
--- | formats time differences using local conventions.
-
-timeDiffToString :: TimeDiff -> String
-timeDiffToString = formatTimeDiff defaultTimeLocale "%c"
-
--- | formats time differences using local conventions and a formatting string.
--- The formatting string is that understood by the ISO C @strftime()@
--- function.
-
-formatTimeDiff :: TimeLocale -> String -> TimeDiff -> String
-formatTimeDiff l fmt td@(TimeDiff year month day hour min sec _)
- = doFmt fmt
- where
- doFmt "" = ""
- doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
- doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
- doFmt ('%':c:cs) = decode c ++ doFmt cs
- doFmt (c:cs) = c : doFmt cs
-
- decode spec =
- case spec of
- 'B' -> fst (months l !! fromEnum month)
- 'b' -> snd (months l !! fromEnum month)
- 'h' -> snd (months l !! fromEnum month)
- 'c' -> defaultTimeDiffFmt td
- 'C' -> show2 (year `quot` 100)
- 'D' -> doFmt "%m/%d/%y"
- 'd' -> show2 day
- 'e' -> show2' day
- 'H' -> show2 hour
- 'I' -> show2 (to12 hour)
- 'k' -> show2' hour
- 'l' -> show2' (to12 hour)
- 'M' -> show2 min
- 'm' -> show2 (fromEnum month + 1)
- 'n' -> "\n"
- 'p' -> (if hour < 12 then fst else snd) (amPm l)
- 'R' -> doFmt "%H:%M"
- 'r' -> doFmt (time12Fmt l)
- 'T' -> doFmt "%H:%M:%S"
- 't' -> "\t"
- 'S' -> show2 sec
- 's' -> show2 sec -- Implementation-dependent, sez the lib doc..
- 'X' -> doFmt (timeFmt l)
- 'x' -> doFmt (dateFmt l)
- 'Y' -> show year
- 'y' -> show2 (year `rem` 100)
- '%' -> "%"
- c -> [c]
-
- defaultTimeDiffFmt (TimeDiff year month day hour min sec _) =
- foldr (\ (v,s) rest ->
- (if v /= 0
- then show v ++ ' ':(addS v s)
- ++ if null rest then "" else ", "
- else "") ++ rest
- )
- ""
- (zip [year, month, day, hour, min, sec] (intervals l))
-
- addS v s = if abs v == 1 then fst s else snd s
-
-#ifndef __HUGS__
--- -----------------------------------------------------------------------------
--- Foreign time interface (POSIX)
-
-type CTm = () -- struct tm
-
-#if HAVE_LOCALTIME_R
-foreign import ccall unsafe "time.h localtime_r"
- localtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm)
-#else
-foreign import ccall unsafe "time.h localtime"
- localtime :: Ptr CTime -> IO (Ptr CTm)
-#endif
-#if HAVE_GMTIME_R
-foreign import ccall unsafe "time.h gmtime_r"
- gmtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm)
-#else
-foreign import ccall unsafe "time.h gmtime"
- gmtime :: Ptr CTime -> IO (Ptr CTm)
-#endif
-foreign import ccall unsafe "time.h mktime"
- mktime :: Ptr CTm -> IO CTime
-
-#if HAVE_GETTIMEOFDAY
-type CTimeVal = ()
-type CTimeZone = ()
-foreign import ccall unsafe "time.h gettimeofday"
- gettimeofday :: Ptr CTimeVal -> Ptr CTimeZone -> IO CInt
-#elif HAVE_FTIME
-type CTimeB = ()
-#ifndef mingw32_HOST_OS
-foreign import ccall unsafe "time.h ftime" ftime :: Ptr CTimeB -> IO CInt
-#else
-foreign import ccall unsafe "time.h ftime" ftime :: Ptr CTimeB -> IO ()
-#endif
-#else
-foreign import ccall unsafe "time.h time" time :: Ptr CTime -> IO CTime
-#endif
-#endif /* ! __HUGS__ */
+++ /dev/null
-{-# OPTIONS -fglasgow-exts #-}
--------------------------------------------------------------------------------
--- |
--- Module : System.Timeout
--- Copyright : (c) The University of Glasgow 2007
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable
---
--- Attach a timeout event to arbitrary 'IO' computations.
---
--------------------------------------------------------------------------------
-
-module System.Timeout ( timeout ) where
-
-import Prelude (IO, Ord((<)), Eq((==)), Int, (.), otherwise, fmap)
-import Data.Maybe (Maybe(..))
-import Control.Monad (Monad(..), guard)
-import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)
-import Control.Exception (handleJust, throwDynTo, dynExceptions, bracket)
-import Data.Dynamic (Typeable, fromDynamic)
-import Data.Unique (Unique, newUnique)
-
--- An internal type that is thrown as a dynamic exception to
--- interrupt the running IO computation when the timeout has
--- expired.
-
-data Timeout = Timeout Unique deriving (Eq, Typeable)
-
--- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result
--- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result
--- is available before the timeout expires, @Just a@ is returned. A negative
--- timeout interval means \"wait indefinitely\". When specifying long timeouts,
--- be careful not to exceed @maxBound :: Int@.
---
--- The design of this combinator was guided by the objective that @timeout n f@
--- should behave exactly the same as @f@ as long as @f@ doesn't time out. This
--- means that @f@ has the same 'myThreadId' it would have without the timeout
--- wrapper. Any exceptions @f@ might throw cancel the timeout and propagate
--- further up. It also possible for @f@ to receive exceptions thrown to it by
--- another thread.
---
--- A tricky implementation detail is the question of how to abort an @IO@
--- computation. This combinator relies on asynchronous exceptions internally.
--- The technique works very well for computations executing inside of the
--- Haskell runtime system, but it doesn't work at all for non-Haskell code.
--- Foreign function calls, for example, cannot be timed out with this
--- combinator simply because an arbitrary C function cannot receive
--- asynchronous exceptions. When @timeout@ is used to wrap an FFI call that
--- blocks, no timeout event can be delivered until the FFI call returns, which
--- pretty much negates the purpose of the combinator. In practice, however,
--- this limitation is less severe than it may sound. Standard I\/O functions
--- like 'System.IO.hGetBuf', 'System.IO.hPutBuf', 'Network.Socket.accept', or
--- 'System.IO.hWaitForInput' appear to be blocking, but they really don't
--- because the runtime system uses scheduling mechanisms like @select(2)@ to
--- perform asynchronous I\/O, so it is possible to interrupt standard socket
--- I\/O or file I\/O using this combinator.
-
-timeout :: Int -> IO a -> IO (Maybe a)
-timeout n f
- | n < 0 = fmap Just f
- | n == 0 = return Nothing
- | otherwise = do
- pid <- myThreadId
- ex <- fmap Timeout newUnique
- handleJust (\e -> dynExceptions e >>= fromDynamic >>= guard . (ex ==))
- (\_ -> return Nothing)
- (bracket (forkIO (threadDelay n >> throwDynTo pid ex))
- (killThread)
- (\_ -> fmap Just f))
+++ /dev/null
-{-# OPTIONS_GHC -fglasgow-exts -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Text.ParserCombinators.ReadP
--- Copyright : (c) The University of Glasgow 2002
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : non-portable (local universal quantification)
---
--- This is a library of parser combinators, originally written by Koen Claessen.
--- It parses all alternatives in parallel, so it never keeps hold of
--- the beginning of the input string, a common source of space leaks with
--- other parsers. The '(+++)' choice combinator is genuinely commutative;
--- it makes no difference which branch is \"shorter\".
-
------------------------------------------------------------------------------
-
-module Text.ParserCombinators.ReadP
- (
- -- * The 'ReadP' type
-#ifndef __NHC__
- ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus
-#else
- ReadPN, -- :: * -> * -> *; instance Functor, Monad, MonadPlus
-#endif
-
- -- * Primitive operations
- get, -- :: ReadP Char
- look, -- :: ReadP String
- (+++), -- :: ReadP a -> ReadP a -> ReadP a
- (<++), -- :: ReadP a -> ReadP a -> ReadP a
- gather, -- :: ReadP a -> ReadP (String, a)
-
- -- * Other operations
- pfail, -- :: ReadP a
- satisfy, -- :: (Char -> Bool) -> ReadP Char
- char, -- :: Char -> ReadP Char
- string, -- :: String -> ReadP String
- munch, -- :: (Char -> Bool) -> ReadP String
- munch1, -- :: (Char -> Bool) -> ReadP String
- skipSpaces, -- :: ReadP ()
- choice, -- :: [ReadP a] -> ReadP a
- count, -- :: Int -> ReadP a -> ReadP [a]
- between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a
- option, -- :: a -> ReadP a -> ReadP a
- optional, -- :: ReadP a -> ReadP ()
- many, -- :: ReadP a -> ReadP [a]
- many1, -- :: ReadP a -> ReadP [a]
- skipMany, -- :: ReadP a -> ReadP ()
- skipMany1, -- :: ReadP a -> ReadP ()
- sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
- sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
- endBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
- endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
- chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
- chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
- chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
- chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
- manyTill, -- :: ReadP a -> ReadP end -> ReadP [a]
-
- -- * Running a parser
- ReadS, -- :: *; = String -> [(a,String)]
- readP_to_S, -- :: ReadP a -> ReadS a
- readS_to_P, -- :: ReadS a -> ReadP a
-
- -- * Properties
- -- $properties
- )
- where
-
-import Control.Monad( MonadPlus(..), sequence, liftM2 )
-
-#ifdef __GLASGOW_HASKELL__
-#ifndef __HADDOCK__
-import {-# SOURCE #-} GHC.Unicode ( isSpace )
-#endif
-import GHC.List ( replicate )
-import GHC.Base
-#else
-import Data.Char( isSpace )
-#endif
-
-infixr 5 +++, <++
-
-#ifdef __GLASGOW_HASKELL__
-------------------------------------------------------------------------
--- ReadS
-
--- | A parser for a type @a@, represented as a function that takes a
--- 'String' and returns a list of possible parses as @(a,'String')@ pairs.
---
--- Note that this kind of backtracking parser is very inefficient;
--- reading a large structure may be quite slow (cf 'ReadP').
-type ReadS a = String -> [(a,String)]
-#endif
-
--- ---------------------------------------------------------------------------
--- The P type
--- is representation type -- should be kept abstract
-
-data P a
- = Get (Char -> P a)
- | Look (String -> P a)
- | Fail
- | Result a (P a)
- | Final [(a,String)] -- invariant: list is non-empty!
-
--- Monad, MonadPlus
-
-instance Monad P where
- return x = Result x Fail
-
- (Get f) >>= k = Get (\c -> f c >>= k)
- (Look f) >>= k = Look (\s -> f s >>= k)
- Fail >>= k = Fail
- (Result x p) >>= k = k x `mplus` (p >>= k)
- (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
-
- fail _ = Fail
-
-instance MonadPlus P where
- mzero = Fail
-
- -- most common case: two gets are combined
- Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c)
-
- -- results are delivered as soon as possible
- Result x p `mplus` q = Result x (p `mplus` q)
- p `mplus` Result x q = Result x (p `mplus` q)
-
- -- fail disappears
- Fail `mplus` p = p
- p `mplus` Fail = p
-
- -- two finals are combined
- -- final + look becomes one look and one final (=optimization)
- -- final + sthg else becomes one look and one final
- Final r `mplus` Final t = Final (r ++ t)
- Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s))
- Final r `mplus` p = Look (\s -> Final (r ++ run p s))
- Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r))
- p `mplus` Final r = Look (\s -> Final (run p s ++ r))
-
- -- two looks are combined (=optimization)
- -- look + sthg else floats upwards
- Look f `mplus` Look g = Look (\s -> f s `mplus` g s)
- Look f `mplus` p = Look (\s -> f s `mplus` p)
- p `mplus` Look f = Look (\s -> p `mplus` f s)
-
--- ---------------------------------------------------------------------------
--- The ReadP type
-
-#ifndef __NHC__
-newtype ReadP a = R (forall b . (a -> P b) -> P b)
-#else
-#define ReadP (ReadPN b)
-newtype ReadPN b a = R ((a -> P b) -> P b)
-#endif
-
--- Functor, Monad, MonadPlus
-
-instance Functor ReadP where
- fmap h (R f) = R (\k -> f (k . h))
-
-instance Monad ReadP where
- return x = R (\k -> k x)
- fail _ = R (\_ -> Fail)
- R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
-
-instance MonadPlus ReadP where
- mzero = pfail
- mplus = (+++)
-
--- ---------------------------------------------------------------------------
--- Operations over P
-
-final :: [(a,String)] -> P a
--- Maintains invariant for Final constructor
-final [] = Fail
-final r = Final r
-
-run :: P a -> ReadS a
-run (Get f) (c:s) = run (f c) s
-run (Look f) s = run (f s) s
-run (Result x p) s = (x,s) : run p s
-run (Final r) _ = r
-run _ _ = []
-
--- ---------------------------------------------------------------------------
--- Operations over ReadP
-
-get :: ReadP Char
--- ^ Consumes and returns the next character.
--- Fails if there is no input left.
-get = R Get
-
-look :: ReadP String
--- ^ Look-ahead: returns the part of the input that is left, without
--- consuming it.
-look = R Look
-
-pfail :: ReadP a
--- ^ Always fails.
-pfail = R (\_ -> Fail)
-
-(+++) :: ReadP a -> ReadP a -> ReadP a
--- ^ Symmetric choice.
-R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
-
-#ifndef __NHC__
-(<++) :: ReadP a -> ReadP a -> ReadP a
-#else
-(<++) :: ReadPN a a -> ReadPN a a -> ReadPN a a
-#endif
--- ^ Local, exclusive, left-biased choice: If left parser
--- locally produces any result at all, then right parser is
--- not used.
-#ifdef __GLASGOW_HASKELL__
-R f <++ q =
- do s <- look
- probe (f return) s 0#
- where
- probe (Get f) (c:s) n = probe (f c) s (n+#1#)
- probe (Look f) s n = probe (f s) s n
- probe p@(Result _ _) _ n = discard n >> R (p >>=)
- probe (Final r) _ _ = R (Final r >>=)
- probe _ _ _ = q
-
- discard 0# = return ()
- discard n = get >> discard (n-#1#)
-#else
-R f <++ q =
- do s <- look
- probe (f return) s 0
- where
- probe (Get f) (c:s) n = probe (f c) s (n+1)
- probe (Look f) s n = probe (f s) s n
- probe p@(Result _ _) _ n = discard n >> R (p >>=)
- probe (Final r) _ _ = R (Final r >>=)
- probe _ _ _ = q
-
- discard 0 = return ()
- discard n = get >> discard (n-1)
-#endif
-
-#ifndef __NHC__
-gather :: ReadP a -> ReadP (String, a)
-#else
--- gather :: ReadPN (String->P b) a -> ReadPN (String->P b) (String, a)
-#endif
--- ^ Transforms a parser into one that does the same, but
--- in addition returns the exact characters read.
--- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
--- is built using any occurrences of readS_to_P.
-gather (R m) =
- R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
- where
- gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))
- gath l Fail = Fail
- gath l (Look f) = Look (\s -> gath l (f s))
- gath l (Result k p) = k (l []) `mplus` gath l p
- gath l (Final r) = error "do not use readS_to_P in gather!"
-
--- ---------------------------------------------------------------------------
--- Derived operations
-
-satisfy :: (Char -> Bool) -> ReadP Char
--- ^ Consumes and returns the next character, if it satisfies the
--- specified predicate.
-satisfy p = do c <- get; if p c then return c else pfail
-
-char :: Char -> ReadP Char
--- ^ Parses and returns the specified character.
-char c = satisfy (c ==)
-
-string :: String -> ReadP String
--- ^ Parses and returns the specified string.
-string this = do s <- look; scan this s
- where
- scan [] _ = do return this
- scan (x:xs) (y:ys) | x == y = do get; scan xs ys
- scan _ _ = do pfail
-
-munch :: (Char -> Bool) -> ReadP String
--- ^ Parses the first zero or more characters satisfying the predicate.
-munch p =
- do s <- look
- scan s
- where
- scan (c:cs) | p c = do get; s <- scan cs; return (c:s)
- scan _ = do return ""
-
-munch1 :: (Char -> Bool) -> ReadP String
--- ^ Parses the first one or more characters satisfying the predicate.
-munch1 p =
- do c <- get
- if p c then do s <- munch p; return (c:s) else pfail
-
-choice :: [ReadP a] -> ReadP a
--- ^ Combines all parsers in the specified list.
-choice [] = pfail
-choice [p] = p
-choice (p:ps) = p +++ choice ps
-
-skipSpaces :: ReadP ()
--- ^ Skips all whitespace.
-skipSpaces =
- do s <- look
- skip s
- where
- skip (c:s) | isSpace c = do get; skip s
- skip _ = do return ()
-
-count :: Int -> ReadP a -> ReadP [a]
--- ^ @count n p@ parses @n@ occurrences of @p@ in sequence. A list of
--- results is returned.
-count n p = sequence (replicate n p)
-
-between :: ReadP open -> ReadP close -> ReadP a -> ReadP a
--- ^ @between open close p@ parses @open@, followed by @p@ and finally
--- @close@. Only the value of @p@ is returned.
-between open close p = do open
- x <- p
- close
- return x
-
-option :: a -> ReadP a -> ReadP a
--- ^ @option x p@ will either parse @p@ or return @x@ without consuming
--- any input.
-option x p = p +++ return x
-
-optional :: ReadP a -> ReadP ()
--- ^ @optional p@ optionally parses @p@ and always returns @()@.
-optional p = (p >> return ()) +++ return ()
-
-many :: ReadP a -> ReadP [a]
--- ^ Parses zero or more occurrences of the given parser.
-many p = return [] +++ many1 p
-
-many1 :: ReadP a -> ReadP [a]
--- ^ Parses one or more occurrences of the given parser.
-many1 p = liftM2 (:) p (many p)
-
-skipMany :: ReadP a -> ReadP ()
--- ^ Like 'many', but discards the result.
-skipMany p = many p >> return ()
-
-skipMany1 :: ReadP a -> ReadP ()
--- ^ Like 'many1', but discards the result.
-skipMany1 p = p >> skipMany p
-
-sepBy :: ReadP a -> ReadP sep -> ReadP [a]
--- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.
--- Returns a list of values returned by @p@.
-sepBy p sep = sepBy1 p sep +++ return []
-
-sepBy1 :: ReadP a -> ReadP sep -> ReadP [a]
--- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.
--- Returns a list of values returned by @p@.
-sepBy1 p sep = liftM2 (:) p (many (sep >> p))
-
-endBy :: ReadP a -> ReadP sep -> ReadP [a]
--- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended
--- by @sep@.
-endBy p sep = many (do x <- p ; sep ; return x)
-
-endBy1 :: ReadP a -> ReadP sep -> ReadP [a]
--- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended
--- by @sep@.
-endBy1 p sep = many1 (do x <- p ; sep ; return x)
-
-chainr :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
--- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
--- Returns a value produced by a /right/ associative application of all
--- functions returned by @op@. If there are no occurrences of @p@, @x@ is
--- returned.
-chainr p op x = chainr1 p op +++ return x
-
-chainl :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
--- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.
--- Returns a value produced by a /left/ associative application of all
--- functions returned by @op@. If there are no occurrences of @p@, @x@ is
--- returned.
-chainl p op x = chainl1 p op +++ return x
-
-chainr1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
--- ^ Like 'chainr', but parses one or more occurrences of @p@.
-chainr1 p op = scan
- where scan = p >>= rest
- rest x = do f <- op
- y <- scan
- return (f x y)
- +++ return x
-
-chainl1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
--- ^ Like 'chainl', but parses one or more occurrences of @p@.
-chainl1 p op = p >>= rest
- where rest x = do f <- op
- y <- p
- rest (f x y)
- +++ return x
-
-#ifndef __NHC__
-manyTill :: ReadP a -> ReadP end -> ReadP [a]
-#else
-manyTill :: ReadPN [a] a -> ReadPN [a] end -> ReadPN [a] [a]
-#endif
--- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@
--- succeeds. Returns a list of values returned by @p@.
-manyTill p end = scan
- where scan = (end >> return []) <++ (liftM2 (:) p scan)
-
--- ---------------------------------------------------------------------------
--- Converting between ReadP and Read
-
-#ifndef __NHC__
-readP_to_S :: ReadP a -> ReadS a
-#else
-readP_to_S :: ReadPN a a -> ReadS a
-#endif
--- ^ Converts a parser into a Haskell ReadS-style function.
--- This is the main way in which you can \"run\" a 'ReadP' parser:
--- the expanded type is
--- @ readP_to_S :: ReadP a -> String -> [(a,String)] @
-readP_to_S (R f) = run (f return)
-
-readS_to_P :: ReadS a -> ReadP a
--- ^ Converts a Haskell ReadS-style function into a parser.
--- Warning: This introduces local backtracking in the resulting
--- parser, and therefore a possible inefficiency.
-readS_to_P r =
- R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
-
--- ---------------------------------------------------------------------------
--- QuickCheck properties that hold for the combinators
-
-{- $properties
-The following are QuickCheck specifications of what the combinators do.
-These can be seen as formal specifications of the behavior of the
-combinators.
-
-We use bags to give semantics to the combinators.
-
-> type Bag a = [a]
-
-Equality on bags does not care about the order of elements.
-
-> (=~) :: Ord a => Bag a -> Bag a -> Bool
-> xs =~ ys = sort xs == sort ys
-
-A special equality operator to avoid unresolved overloading
-when testing the properties.
-
-> (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool
-> (=~.) = (=~)
-
-Here follow the properties:
-
-> prop_Get_Nil =
-> readP_to_S get [] =~ []
->
-> prop_Get_Cons c s =
-> readP_to_S get (c:s) =~ [(c,s)]
->
-> prop_Look s =
-> readP_to_S look s =~ [(s,s)]
->
-> prop_Fail s =
-> readP_to_S pfail s =~. []
->
-> prop_Return x s =
-> readP_to_S (return x) s =~. [(x,s)]
->
-> prop_Bind p k s =
-> readP_to_S (p >>= k) s =~.
-> [ ys''
-> | (x,s') <- readP_to_S p s
-> , ys'' <- readP_to_S (k (x::Int)) s'
-> ]
->
-> prop_Plus p q s =
-> readP_to_S (p +++ q) s =~.
-> (readP_to_S p s ++ readP_to_S q s)
->
-> prop_LeftPlus p q s =
-> readP_to_S (p <++ q) s =~.
-> (readP_to_S p s +<+ readP_to_S q s)
-> where
-> [] +<+ ys = ys
-> xs +<+ _ = xs
->
-> prop_Gather s =
-> forAll readPWithoutReadS $ \p ->
-> readP_to_S (gather p) s =~
-> [ ((pre,x::Int),s')
-> | (x,s') <- readP_to_S p s
-> , let pre = take (length s - length s') s
-> ]
->
-> prop_String_Yes this s =
-> readP_to_S (string this) (this ++ s) =~
-> [(this,s)]
->
-> prop_String_Maybe this s =
-> readP_to_S (string this) s =~
-> [(this, drop (length this) s) | this `isPrefixOf` s]
->
-> prop_Munch p s =
-> readP_to_S (munch p) s =~
-> [(takeWhile p s, dropWhile p s)]
->
-> prop_Munch1 p s =
-> readP_to_S (munch1 p) s =~
-> [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]
->
-> prop_Choice ps s =
-> readP_to_S (choice ps) s =~.
-> readP_to_S (foldr (+++) pfail ps) s
->
-> prop_ReadS r s =
-> readP_to_S (readS_to_P r) s =~. r s
--}
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Text.ParserCombinators.ReadPrec
--- Copyright : (c) The University of Glasgow 2002
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : non-portable (uses Text.ParserCombinators.ReadP)
---
--- This library defines parser combinators for precedence parsing.
-
------------------------------------------------------------------------------
-
-module Text.ParserCombinators.ReadPrec
- (
- ReadPrec, -- :: * -> *; instance Functor, Monad, MonadPlus
-
- -- * Precedences
- Prec, -- :: *; = Int
- minPrec, -- :: Prec; = 0
-
- -- * Precedence operations
- lift, -- :: ReadP a -> ReadPrec a
- prec, -- :: Prec -> ReadPrec a -> ReadPrec a
- step, -- :: ReadPrec a -> ReadPrec a
- reset, -- :: ReadPrec a -> ReadPrec a
-
- -- * Other operations
- -- | All are based directly on their similarly-named 'ReadP' counterparts.
- get, -- :: ReadPrec Char
- look, -- :: ReadPrec String
- (+++), -- :: ReadPrec a -> ReadPrec a -> ReadPrec a
- (<++), -- :: ReadPrec a -> ReadPrec a -> ReadPrec a
- pfail, -- :: ReadPrec a
- choice, -- :: [ReadPrec a] -> ReadPrec a
-
- -- * Converters
- readPrec_to_P, -- :: ReadPrec a -> (Int -> ReadP a)
- readP_to_Prec, -- :: (Int -> ReadP a) -> ReadPrec a
- readPrec_to_S, -- :: ReadPrec a -> (Int -> ReadS a)
- readS_to_Prec, -- :: (Int -> ReadS a) -> ReadPrec a
- )
- where
-
-
-import Text.ParserCombinators.ReadP
- ( ReadP
- , ReadS
- , readP_to_S
- , readS_to_P
- )
-
-import qualified Text.ParserCombinators.ReadP as ReadP
- ( get
- , look
- , (+++), (<++)
- , pfail
- )
-
-import Control.Monad( MonadPlus(..) )
-#ifdef __GLASGOW_HASKELL__
-import GHC.Num( Num(..) )
-import GHC.Base
-#endif
-
--- ---------------------------------------------------------------------------
--- The readPrec type
-
-newtype ReadPrec a = P { unP :: Prec -> ReadP a }
-
--- Functor, Monad, MonadPlus
-
-instance Functor ReadPrec where
- fmap h (P f) = P (\n -> fmap h (f n))
-
-instance Monad ReadPrec where
- return x = P (\_ -> return x)
- fail s = P (\_ -> fail s)
- P f >>= k = P (\n -> do a <- f n; let P f' = k a in f' n)
-
-instance MonadPlus ReadPrec where
- mzero = pfail
- mplus = (+++)
-
--- precedences
-
-type Prec = Int
-
-minPrec :: Prec
-minPrec = 0
-
--- ---------------------------------------------------------------------------
--- Operations over ReadPrec
-
-lift :: ReadP a -> ReadPrec a
--- ^ Lift a precedence-insensitive 'ReadP' to a 'ReadPrec'.
-lift m = P (\_ -> m)
-
-step :: ReadPrec a -> ReadPrec a
--- ^ Increases the precedence context by one.
-step (P f) = P (\n -> f (n+1))
-
-reset :: ReadPrec a -> ReadPrec a
--- ^ Resets the precedence context to zero.
-reset (P f) = P (\n -> f minPrec)
-
-prec :: Prec -> ReadPrec a -> ReadPrec a
--- ^ @(prec n p)@ checks whether the precedence context is
--- less than or equal to @n@, and
---
--- * if not, fails
---
--- * if so, parses @p@ in context @n@.
-prec n (P f) = P (\c -> if c <= n then f n else ReadP.pfail)
-
--- ---------------------------------------------------------------------------
--- Derived operations
-
-get :: ReadPrec Char
--- ^ Consumes and returns the next character.
--- Fails if there is no input left.
-get = lift ReadP.get
-
-look :: ReadPrec String
--- ^ Look-ahead: returns the part of the input that is left, without
--- consuming it.
-look = lift ReadP.look
-
-(+++) :: ReadPrec a -> ReadPrec a -> ReadPrec a
--- ^ Symmetric choice.
-P f1 +++ P f2 = P (\n -> f1 n ReadP.+++ f2 n)
-
-(<++) :: ReadPrec a -> ReadPrec a -> ReadPrec a
--- ^ Local, exclusive, left-biased choice: If left parser
--- locally produces any result at all, then right parser is
--- not used.
-P f1 <++ P f2 = P (\n -> f1 n ReadP.<++ f2 n)
-
-pfail :: ReadPrec a
--- ^ Always fails.
-pfail = lift ReadP.pfail
-
-choice :: [ReadPrec a] -> ReadPrec a
--- ^ Combines all parsers in the specified list.
-choice ps = foldr (+++) pfail ps
-
--- ---------------------------------------------------------------------------
--- Converting between ReadPrec and Read
-
-readPrec_to_P :: ReadPrec a -> (Int -> ReadP a)
-readPrec_to_P (P f) = f
-
-readP_to_Prec :: (Int -> ReadP a) -> ReadPrec a
-readP_to_Prec f = P f
-
-readPrec_to_S :: ReadPrec a -> (Int -> ReadS a)
-readPrec_to_S (P f) n = readP_to_S (f n)
-
-readS_to_Prec :: (Int -> ReadS a) -> ReadPrec a
-readS_to_Prec f = P (\n -> readS_to_P (f n))
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Text.Printf
--- Copyright : (c) Lennart Augustsson, 2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : lennart@augustsson.net
--- Stability : provisional
--- Portability : portable
---
--- A C printf like formatter.
---
------------------------------------------------------------------------------
-
-module Text.Printf(
- printf, hPrintf,
- PrintfType, HPrintfType, PrintfArg, IsChar
-) where
-
-import Prelude
-import Data.Array
-import Data.Char
-import Numeric(showEFloat, showFFloat, showGFloat)
-import System.IO
-
--------------------
-
--- | Format a variable number of arguments with the C-style formatting string.
--- The return value is either 'String' or @('IO' a)@.
---
--- The format string consists of ordinary characters and /conversion
--- specifications/, which specify how to format one of the arguments
--- to printf in the output string. A conversion specification begins with the
--- character @%@, followed by one or more of the following flags:
---
--- > - left adjust (default is right adjust)
--- > 0 pad with zeroes rather than spaces
---
--- followed optionally by a field width:
---
--- > num field width
--- > * as num, but taken from argument list
---
--- followed optionally by a precision:
---
--- > .num precision (number of decimal places)
---
--- and finally, a format character:
---
--- > c character Char, Int, Integer
--- > d decimal Char, Int, Integer
--- > o octal Char, Int, Integer
--- > x hexadecimal Char, Int, Integer
--- > u unsigned decimal Char, Int, Integer
--- > f floating point Float, Double
--- > g general format float Float, Double
--- > e exponent format float Float, Double
--- > s string String
---
--- Mismatch between the argument types and the format string will cause
--- an exception to be thrown at runtime.
---
--- Examples:
---
--- > > printf "%d\n" (23::Int)
--- > 23
--- > > printf "%s %s\n" "Hello" "World"
--- > Hello World
--- > > printf "%.2f\n" pi
--- > 3.14
---
-printf :: (PrintfType r) => String -> r
-printf fmt = spr fmt []
-
--- | Similar to 'printf', except that output is via the specified
--- 'Handle'. The return type is restricted to @('IO' a)@.
-hPrintf :: (HPrintfType r) => Handle -> String -> r
-hPrintf hdl fmt = hspr hdl fmt []
-
--- |The 'PrintfType' class provides the variable argument magic for
--- 'printf'. Its implementation is intentionally not visible from
--- this module. If you attempt to pass an argument of a type which
--- is not an instance of this class to 'printf' or 'hPrintf', then
--- the compiler will report it as a missing instance of 'PrintfArg'.
-class PrintfType t where
- spr :: String -> [UPrintf] -> t
-
--- | The 'HPrintfType' class provides the variable argument magic for
--- 'hPrintf'. Its implementation is intentionally not visible from
--- this module.
-class HPrintfType t where
- hspr :: Handle -> String -> [UPrintf] -> t
-
-{- not allowed in Haskell 98
-instance PrintfType String where
- spr fmt args = uprintf fmt (reverse args)
--}
-instance (IsChar c) => PrintfType [c] where
- spr fmt args = map fromChar (uprintf fmt (reverse args))
-
-instance PrintfType (IO a) where
- spr fmt args = do
- putStr (uprintf fmt (reverse args))
- return undefined
-
-instance HPrintfType (IO a) where
- hspr hdl fmt args = do
- hPutStr hdl (uprintf fmt (reverse args))
- return undefined
-
-instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where
- spr fmt args = \ a -> spr fmt (toUPrintf a : args)
-
-instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where
- hspr hdl fmt args = \ a -> hspr hdl fmt (toUPrintf a : args)
-
-class PrintfArg a where
- toUPrintf :: a -> UPrintf
-
-instance PrintfArg Char where
- toUPrintf c = UChar c
-
-{- not allowed in Haskell 98
-instance PrintfArg String where
- toUPrintf s = UString s
--}
-instance (IsChar c) => PrintfArg [c] where
- toUPrintf s = UString (map toChar s)
-
-instance PrintfArg Int where
- toUPrintf i = UInt i
-
-instance PrintfArg Integer where
- toUPrintf i = UInteger i
-
-instance PrintfArg Float where
- toUPrintf f = UFloat f
-
-instance PrintfArg Double where
- toUPrintf d = UDouble d
-
-class IsChar c where
- toChar :: c -> Char
- fromChar :: Char -> c
-
-instance IsChar Char where
- toChar c = c
- fromChar c = c
-
--------------------
-
-data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double
-
-uprintf :: String -> [UPrintf] -> String
-uprintf "" [] = ""
-uprintf "" (_:_) = fmterr
-uprintf ('%':'%':cs) us = '%':uprintf cs us
-uprintf ('%':_) [] = argerr
-uprintf ('%':cs) us@(_:_) = fmt cs us
-uprintf (c:cs) us = c:uprintf cs us
-
-fmt :: String -> [UPrintf] -> String
-fmt cs us =
- let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us
- adjust (pre, str) =
- let lstr = length str
- lpre = length pre
- fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
- in if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str
- in
- case cs' of
- [] -> fmterr
- c:cs'' ->
- case us' of
- [] -> argerr
- u:us'' ->
- (case c of
- 'c' -> adjust ("", [toEnum (toint u)])
- 'd' -> adjust (fmti u)
- 'x' -> adjust ("", fmtu 16 u)
- 'o' -> adjust ("", fmtu 8 u)
- 'u' -> adjust ("", fmtu 10 u)
- 'e' -> adjust (dfmt' c prec u)
- 'f' -> adjust (dfmt' c prec u)
- 'g' -> adjust (dfmt' c prec u)
- 's' -> adjust ("", tostr u)
- c -> perror ("bad formatting char " ++ [c])
- ) ++ uprintf cs'' us''
-
-fmti (UInt i) = if i < 0 then
- if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))
- else
- ("", itos i)
-fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)
-fmti (UChar c) = fmti (UInt (fromEnum c))
-fmti u = baderr
-
-fmtu b (UInt i) = if i < 0 then
- if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))
- else
- itosb b (toInteger i)
-fmtu b (UInteger i) = itosb b i
-fmtu b (UChar c) = itosb b (toInteger (fromEnum c))
-fmtu b u = baderr
-
-maxi :: Integer
-maxi = (toInteger (maxBound::Int) + 1) * 2
-
-toint (UInt i) = i
-toint (UInteger i) = toInt i
-toint (UChar c) = fromEnum c
-toint u = baderr
-
-tostr (UString s) = s
-tostr u = baderr
-
-itos n =
- if n < 10 then
- [toEnum (fromEnum '0' + toInt n)]
- else
- let (q, r) = quotRem n 10 in
- itos q ++ [toEnum (fromEnum '0' + toInt r)]
-
-chars = array (0,15) (zipWith (,) [0..] "0123456789abcdef")
-itosb :: Integer -> Integer -> String
-itosb b n =
- if n < b then
- [chars!n]
- else
- let (q, r) = quotRem n b in
- itosb b q ++ [chars!r]
-
-stoi :: Int -> String -> (Int, String)
-stoi a (c:cs) | isDigit c = stoi (a*10 + fromEnum c - fromEnum '0') cs
-stoi a cs = (a, cs)
-
-getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])
-getSpecs l z ('-':cs) us = getSpecs True z cs us
-getSpecs l z ('0':cs) us = getSpecs l True cs us
-getSpecs l z ('*':cs) us =
- case us of
- [] -> argerr
- nu : us' ->
- let n = toint nu
- (p, cs'', us'') =
- case cs of
- '.':'*':r -> case us' of { [] -> argerr; pu:us'' -> (toint pu, r, us'') }
- '.':r -> let (n, cs') = stoi 0 r in (n, cs', us')
- _ -> (-1, cs, us')
- in (n, p, l, z, cs'', us'')
-getSpecs l z ('.':cs) us =
- let (p, cs') = stoi 0 cs
- in (0, p, l, z, cs', us)
-getSpecs l z cs@(c:_) us | isDigit c =
- let (n, cs') = stoi 0 cs
- (p, cs'') = case cs' of
- '.':r -> stoi 0 r
- _ -> (-1, cs')
- in (n, p, l, z, cs'', us)
-getSpecs l z cs us = (0, -1, l, z, cs, us)
-
-dfmt' c p (UDouble d) = dfmt c p d
-dfmt' c p (UFloat f) = dfmt c p f
-dfmt' c p u = baderr
-
-dfmt c p d =
- case (case c of 'e' -> showEFloat; 'f' -> showFFloat; 'g' -> showGFloat)
- (if p < 0 then Nothing else Just p) d "" of
- '-':cs -> ("-", cs)
- cs -> ("" , cs)
-
-perror s = error ("Printf.printf: "++s)
-fmterr = perror "formatting string ended prematurely"
-argerr = perror "argument list ended prematurely"
-baderr = perror "bad argument"
-
-toInt :: (Integral a) => a -> Int
-toInt x = fromInteger (toInteger x)
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Text.Read
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : non-portable (uses Text.ParserCombinators.ReadP)
---
--- Converting strings to values.
---
--- The "Text.Read" library is the canonical library to import for
--- 'Read'-class facilities. For GHC only, it offers an extended and much
--- improved 'Read' class, which constitutes a proposed alternative to the
--- Haskell 98 'Read'. In particular, writing parsers is easier, and
--- the parsers are much more efficient.
---
------------------------------------------------------------------------------
-
-module Text.Read (
- -- * The 'Read' class
- Read(..), -- The Read class
- ReadS, -- String -> Maybe (a,String)
-
- -- * Haskell 98 functions
- reads, -- :: (Read a) => ReadS a
- read, -- :: (Read a) => String -> a
- readParen, -- :: Bool -> ReadS a -> ReadS a
- lex, -- :: ReadS String
-
-#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
- -- * New parsing functions
- module Text.ParserCombinators.ReadPrec,
- L.Lexeme(..),
- lexP, -- :: ReadPrec Lexeme
- parens, -- :: ReadPrec a -> ReadPrec a
-#endif
-#ifdef __GLASGOW_HASKELL__
- readListDefault, -- :: Read a => ReadS [a]
- readListPrecDefault, -- :: Read a => ReadPrec [a]
-#endif
-
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Read
-#endif
-#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
-import Text.ParserCombinators.ReadPrec
-import qualified Text.Read.Lex as L
-#endif
-
-#ifdef __HUGS__
--- copied from GHC.Read
-
-lexP :: ReadPrec L.Lexeme
-lexP = lift L.lex
-
-parens :: ReadPrec a -> ReadPrec a
-parens p = optional
- where
- optional = p +++ mandatory
- mandatory = do
- L.Punc "(" <- lexP
- x <- reset optional
- L.Punc ")" <- lexP
- return x
-#endif
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Text.Read.Lex
--- Copyright : (c) The University of Glasgow 2002
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : non-portable (uses Text.ParserCombinators.ReadP)
---
--- The cut-down Haskell lexer, used by Text.Read
---
------------------------------------------------------------------------------
-
-module Text.Read.Lex
- -- lexing types
- ( Lexeme(..) -- :: *; Show, Eq
-
- -- lexer
- , lex -- :: ReadP Lexeme Skips leading spaces
- , hsLex -- :: ReadP String
- , lexChar -- :: ReadP Char Reads just one char, with H98 escapes
-
- , readIntP -- :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
- , readOctP -- :: Num a => ReadP a
- , readDecP -- :: Num a => ReadP a
- , readHexP -- :: Num a => ReadP a
- )
- where
-
-import Text.ParserCombinators.ReadP
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.Num( Num(..), Integer )
-import GHC.Show( Show(..) )
-#ifndef __HADDOCK__
-import {-# SOURCE #-} GHC.Unicode ( isSpace, isAlpha, isAlphaNum )
-#endif
-import GHC.Real( Ratio(..), Integral, Rational, (%), fromIntegral,
- toInteger, (^), (^^), infinity, notANumber )
-import GHC.List
-import GHC.Enum( maxBound )
-#else
-import Prelude hiding ( lex )
-import Data.Char( chr, ord, isSpace, isAlpha, isAlphaNum )
-import Data.Ratio( Ratio, (%) )
-#endif
-#ifdef __HUGS__
-import Hugs.Prelude( Ratio(..) )
-#endif
-import Data.Maybe
-import Control.Monad
-
--- -----------------------------------------------------------------------------
--- Lexing types
-
--- ^ Haskell lexemes.
-data Lexeme
- = Char Char -- ^ Character literal
- | String String -- ^ String literal, with escapes interpreted
- | Punc String -- ^ Punctuation or reserved symbol, e.g. @(@, @::@
- | Ident String -- ^ Haskell identifier, e.g. @foo@, @Baz@
- | Symbol String -- ^ Haskell symbol, e.g. @>>@, @:%@
- | Int Integer -- ^ Integer literal
- | Rat Rational -- ^ Floating point literal
- | EOF
- deriving (Eq, Show)
-
--- -----------------------------------------------------------------------------
--- Lexing
-
-lex :: ReadP Lexeme
-lex = skipSpaces >> lexToken
-
-hsLex :: ReadP String
--- ^ Haskell lexer: returns the lexed string, rather than the lexeme
-hsLex = do skipSpaces
- (s,_) <- gather lexToken
- return s
-
-lexToken :: ReadP Lexeme
-lexToken = lexEOF +++
- lexLitChar +++
- lexString +++
- lexPunc +++
- lexSymbol +++
- lexId +++
- lexNumber
-
-
--- ----------------------------------------------------------------------
--- End of file
-lexEOF :: ReadP Lexeme
-lexEOF = do s <- look
- guard (null s)
- return EOF
-
--- ---------------------------------------------------------------------------
--- Single character lexemes
-
-lexPunc :: ReadP Lexeme
-lexPunc =
- do c <- satisfy isPuncChar
- return (Punc [c])
- where
- isPuncChar c = c `elem` ",;()[]{}`"
-
--- ----------------------------------------------------------------------
--- Symbols
-
-lexSymbol :: ReadP Lexeme
-lexSymbol =
- do s <- munch1 isSymbolChar
- if s `elem` reserved_ops then
- return (Punc s) -- Reserved-ops count as punctuation
- else
- return (Symbol s)
- where
- isSymbolChar c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
- reserved_ops = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]
-
--- ----------------------------------------------------------------------
--- identifiers
-
-lexId :: ReadP Lexeme
-lexId = lex_nan <++ lex_id
- where
- -- NaN and Infinity look like identifiers, so
- -- we parse them first.
- lex_nan = (string "NaN" >> return (Rat notANumber)) +++
- (string "Infinity" >> return (Rat infinity))
-
- lex_id = do c <- satisfy isIdsChar
- s <- munch isIdfChar
- return (Ident (c:s))
-
- -- Identifiers can start with a '_'
- isIdsChar c = isAlpha c || c == '_'
- isIdfChar c = isAlphaNum c || c `elem` "_'"
-
-#ifndef __GLASGOW_HASKELL__
-infinity, notANumber :: Rational
-infinity = 1 :% 0
-notANumber = 0 :% 0
-#endif
-
--- ---------------------------------------------------------------------------
--- Lexing character literals
-
-lexLitChar :: ReadP Lexeme
-lexLitChar =
- do char '\''
- (c,esc) <- lexCharE
- guard (esc || c /= '\'') -- Eliminate '' possibility
- char '\''
- return (Char c)
-
-lexChar :: ReadP Char
-lexChar = do { (c,_) <- lexCharE; return c }
-
-lexCharE :: ReadP (Char, Bool) -- "escaped or not"?
-lexCharE =
- do c <- get
- if c == '\\'
- then do c <- lexEsc; return (c, True)
- else do return (c, False)
- where
- lexEsc =
- lexEscChar
- +++ lexNumeric
- +++ lexCntrlChar
- +++ lexAscii
-
- lexEscChar =
- do c <- get
- case c of
- 'a' -> return '\a'
- 'b' -> return '\b'
- 'f' -> return '\f'
- 'n' -> return '\n'
- 'r' -> return '\r'
- 't' -> return '\t'
- 'v' -> return '\v'
- '\\' -> return '\\'
- '\"' -> return '\"'
- '\'' -> return '\''
- _ -> pfail
-
- lexNumeric =
- do base <- lexBaseChar <++ return 10
- n <- lexInteger base
- guard (n <= toInteger (ord maxBound))
- return (chr (fromInteger n))
-
- lexCntrlChar =
- do char '^'
- c <- get
- case c of
- '@' -> return '\^@'
- 'A' -> return '\^A'
- 'B' -> return '\^B'
- 'C' -> return '\^C'
- 'D' -> return '\^D'
- 'E' -> return '\^E'
- 'F' -> return '\^F'
- 'G' -> return '\^G'
- 'H' -> return '\^H'
- 'I' -> return '\^I'
- 'J' -> return '\^J'
- 'K' -> return '\^K'
- 'L' -> return '\^L'
- 'M' -> return '\^M'
- 'N' -> return '\^N'
- 'O' -> return '\^O'
- 'P' -> return '\^P'
- 'Q' -> return '\^Q'
- 'R' -> return '\^R'
- 'S' -> return '\^S'
- 'T' -> return '\^T'
- 'U' -> return '\^U'
- 'V' -> return '\^V'
- 'W' -> return '\^W'
- 'X' -> return '\^X'
- 'Y' -> return '\^Y'
- 'Z' -> return '\^Z'
- '[' -> return '\^['
- '\\' -> return '\^\'
- ']' -> return '\^]'
- '^' -> return '\^^'
- '_' -> return '\^_'
- _ -> pfail
-
- lexAscii =
- do choice
- [ (string "SOH" >> return '\SOH') <++
- (string "SO" >> return '\SO')
- -- \SO and \SOH need maximal-munch treatment
- -- See the Haskell report Sect 2.6
-
- , string "NUL" >> return '\NUL'
- , string "STX" >> return '\STX'
- , string "ETX" >> return '\ETX'
- , string "EOT" >> return '\EOT'
- , string "ENQ" >> return '\ENQ'
- , string "ACK" >> return '\ACK'
- , string "BEL" >> return '\BEL'
- , string "BS" >> return '\BS'
- , string "HT" >> return '\HT'
- , string "LF" >> return '\LF'
- , string "VT" >> return '\VT'
- , string "FF" >> return '\FF'
- , string "CR" >> return '\CR'
- , string "SI" >> return '\SI'
- , string "DLE" >> return '\DLE'
- , string "DC1" >> return '\DC1'
- , string "DC2" >> return '\DC2'
- , string "DC3" >> return '\DC3'
- , string "DC4" >> return '\DC4'
- , string "NAK" >> return '\NAK'
- , string "SYN" >> return '\SYN'
- , string "ETB" >> return '\ETB'
- , string "CAN" >> return '\CAN'
- , string "EM" >> return '\EM'
- , string "SUB" >> return '\SUB'
- , string "ESC" >> return '\ESC'
- , string "FS" >> return '\FS'
- , string "GS" >> return '\GS'
- , string "RS" >> return '\RS'
- , string "US" >> return '\US'
- , string "SP" >> return '\SP'
- , string "DEL" >> return '\DEL'
- ]
-
-
--- ---------------------------------------------------------------------------
--- string literal
-
-lexString :: ReadP Lexeme
-lexString =
- do char '"'
- body id
- where
- body f =
- do (c,esc) <- lexStrItem
- if c /= '"' || esc
- then body (f.(c:))
- else let s = f "" in
- return (String s)
-
- lexStrItem = (lexEmpty >> lexStrItem)
- +++ lexCharE
-
- lexEmpty =
- do char '\\'
- c <- get
- case c of
- '&' -> do return ()
- _ | isSpace c -> do skipSpaces; char '\\'; return ()
- _ -> do pfail
-
--- ---------------------------------------------------------------------------
--- Lexing numbers
-
-type Base = Int
-type Digits = [Int]
-
-lexNumber :: ReadP Lexeme
-lexNumber
- = lexHexOct <++ -- First try for hex or octal 0x, 0o etc
- -- If that fails, try for a decimal number
- lexDecNumber -- Start with ordinary digits
-
-lexHexOct :: ReadP Lexeme
-lexHexOct
- = do char '0'
- base <- lexBaseChar
- digits <- lexDigits base
- return (Int (val (fromIntegral base) 0 digits))
-
-lexBaseChar :: ReadP Int
--- Lex a single character indicating the base; fail if not there
-lexBaseChar = do { c <- get;
- case c of
- 'o' -> return 8
- 'O' -> return 8
- 'x' -> return 16
- 'X' -> return 16
- _ -> pfail }
-
-lexDecNumber :: ReadP Lexeme
-lexDecNumber =
- do xs <- lexDigits 10
- mFrac <- lexFrac <++ return Nothing
- mExp <- lexExp <++ return Nothing
- return (value xs mFrac mExp)
- where
- value xs mFrac mExp = valueFracExp (val 10 0 xs) mFrac mExp
-
- valueFracExp :: Integer -> Maybe Digits -> Maybe Integer
- -> Lexeme
- valueFracExp a Nothing Nothing
- = Int a -- 43
- valueFracExp a Nothing (Just exp)
- | exp >= 0 = Int (a * (10 ^ exp)) -- 43e7
- | otherwise = Rat (valExp (fromInteger a) exp) -- 43e-7
- valueFracExp a (Just fs) mExp
- = case mExp of
- Nothing -> Rat rat -- 4.3
- Just exp -> Rat (valExp rat exp) -- 4.3e-4
- where
- rat :: Rational
- rat = fromInteger a + frac 10 0 1 fs
-
- valExp :: Rational -> Integer -> Rational
- valExp rat exp = rat * (10 ^^ exp)
-
-lexFrac :: ReadP (Maybe Digits)
--- Read the fractional part; fail if it doesn't
--- start ".d" where d is a digit
-lexFrac = do char '.'
- frac <- lexDigits 10
- return (Just frac)
-
-lexExp :: ReadP (Maybe Integer)
-lexExp = do char 'e' +++ char 'E'
- exp <- signedExp +++ lexInteger 10
- return (Just exp)
- where
- signedExp
- = do c <- char '-' +++ char '+'
- n <- lexInteger 10
- return (if c == '-' then -n else n)
-
-lexDigits :: Int -> ReadP Digits
--- Lex a non-empty sequence of digits in specified base
-lexDigits base =
- do s <- look
- xs <- scan s id
- guard (not (null xs))
- return xs
- where
- scan (c:cs) f = case valDig base c of
- Just n -> do get; scan cs (f.(n:))
- Nothing -> do return (f [])
- scan [] f = do return (f [])
-
-lexInteger :: Base -> ReadP Integer
-lexInteger base =
- do xs <- lexDigits base
- return (val (fromIntegral base) 0 xs)
-
-val :: Num a => a -> a -> Digits -> a
--- val base y [d1,..,dn] = y ++ [d1,..,dn], as it were
-val base y [] = y
-val base y (x:xs) = y' `seq` val base y' xs
- where
- y' = y * base + fromIntegral x
-
-frac :: Integral a => a -> a -> a -> Digits -> Ratio a
-frac base a b [] = a % b
-frac base a b (x:xs) = a' `seq` b' `seq` frac base a' b' xs
- where
- a' = a * base + fromIntegral x
- b' = b * base
-
-valDig :: Num a => a -> Char -> Maybe Int
-valDig 8 c
- | '0' <= c && c <= '7' = Just (ord c - ord '0')
- | otherwise = Nothing
-
-valDig 10 c = valDecDig c
-
-valDig 16 c
- | '0' <= c && c <= '9' = Just (ord c - ord '0')
- | 'a' <= c && c <= 'f' = Just (ord c - ord 'a' + 10)
- | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10)
- | otherwise = Nothing
-
-valDecDig c
- | '0' <= c && c <= '9' = Just (ord c - ord '0')
- | otherwise = Nothing
-
--- ----------------------------------------------------------------------
--- other numeric lexing functions
-
-readIntP :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
-readIntP base isDigit valDigit =
- do s <- munch1 isDigit
- return (val base 0 (map valDigit s))
-
-readIntP' :: Num a => a -> ReadP a
-readIntP' base = readIntP base isDigit valDigit
- where
- isDigit c = maybe False (const True) (valDig base c)
- valDigit c = maybe 0 id (valDig base c)
-
-readOctP, readDecP, readHexP :: Num a => ReadP a
-readOctP = readIntP' 8
-readDecP = readIntP' 10
-readHexP = readIntP' 16
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Text.Show
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Converting values to readable strings:
--- the 'Show' class and associated functions.
---
------------------------------------------------------------------------------
-
-module Text.Show (
- ShowS, -- String -> String
- Show(
- showsPrec, -- :: Int -> a -> ShowS
- show, -- :: a -> String
- showList -- :: [a] -> ShowS
- ),
- shows, -- :: (Show a) => a -> ShowS
- showChar, -- :: Char -> ShowS
- showString, -- :: String -> ShowS
- showParen, -- :: Bool -> ShowS -> ShowS
- showListWith, -- :: (a -> ShowS) -> [a] -> ShowS
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Show
-#endif
-
--- | Show a list (using square brackets and commas), given a function
--- for showing elements.
-showListWith :: (a -> ShowS) -> [a] -> ShowS
-showListWith = showList__
-
-#ifndef __GLASGOW_HASKELL__
-showList__ :: (a -> ShowS) -> [a] -> ShowS
-showList__ _ [] s = "[]" ++ s
-showList__ showx (x:xs) s = '[' : showx x (showl xs)
- where
- showl [] = ']' : s
- showl (y:ys) = ',' : showx y (showl ys)
-#endif
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Text.Show.Functions
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Optional instance of 'Text.Show.Show' for functions:
---
--- > instance Show (a -> b) where
--- > showsPrec _ _ = showString \"\<function\>\"
---
------------------------------------------------------------------------------
-
-module Text.Show.Functions () where
-
-import Prelude
-
-#ifndef __NHC__
-instance Show (a -> b) where
- showsPrec _ _ = showString "<function>"
-#endif
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Unsafe.Coerce
--- Copyright : Malcolm Wallace 2006
--- License : BSD-style (see the LICENSE file in the distribution)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- The highly unsafe primitive 'unsafeCoerce' converts a value from any
--- type to any other type. Needless to say, if you use this function,
--- it is your responsibility to ensure that the old and new types have
--- identical internal representations, in order to prevent runtime corruption.
-
-module Unsafe.Coerce (unsafeCoerce) where
-
-#if defined(__GLASGOW_HASKELL__)
-import GHC.Base (unsafeCoerce#)
-unsafeCoerce :: a -> b
-unsafeCoerce = unsafeCoerce#
-#endif
-
-#if defined(__NHC__)
-import NonStdUnsafeCoerce (unsafeCoerce)
-#endif
-
-#if defined(__HUGS__)
-import Hugs.IOExts (unsafeCoerce)
-#endif
+++ /dev/null
-# FP_DECL_ALTZONE
-# ---------------
-# Defines HAVE_DECL_ALTZONE to 1 if declared, 0 otherwise.
-#
-# Used by base package.
-AC_DEFUN([FP_DECL_ALTZONE],
-[AC_REQUIRE([AC_HEADER_TIME])dnl
-AC_CHECK_HEADERS([sys/time.h])
-AC_CHECK_DECLS([altzone], [], [],[#if TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-#else
-# if HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-#endif])
-])# FP_DECL_ALTZONE
-
-
-# FP_COMPUTE_INT(EXPRESSION, VARIABLE, INCLUDES, IF-FAILS)
-# --------------------------------------------------------
-# Assign VARIABLE the value of the compile-time EXPRESSION using INCLUDES for
-# compilation. Execute IF-FAILS when unable to determine the value. Works for
-# cross-compilation, too.
-#
-# Implementation note: We are lazy and use an internal autoconf macro, but it
-# is supported in autoconf versions 2.50 up to the actual 2.57, so there is
-# little risk.
-AC_DEFUN([FP_COMPUTE_INT],
-[_AC_COMPUTE_INT([$1], [$2], [$3], [$4])[]dnl
-])# FP_COMPUTE_INT
-
-
-# FP_CHECK_CONST(EXPRESSION, [INCLUDES = DEFAULT-INCLUDES], [VALUE-IF-FAIL = -1])
-# -------------------------------------------------------------------------------
-# Defines CONST_EXPRESSION to the value of the compile-time EXPRESSION, using
-# INCLUDES. If the value cannot be determined, use VALUE-IF-FAIL.
-AC_DEFUN([FP_CHECK_CONST],
-[AS_VAR_PUSHDEF([fp_Cache], [fp_cv_const_$1])[]dnl
-AC_CACHE_CHECK([value of $1], fp_Cache,
-[FP_COMPUTE_INT([$1], fp_check_const_result, [AC_INCLUDES_DEFAULT([$2])],
- [fp_check_const_result=m4_default([$3], ['-1'])])
-AS_VAR_SET(fp_Cache, [$fp_check_const_result])])[]dnl
-AC_DEFINE_UNQUOTED(AS_TR_CPP([CONST_$1]), AS_VAR_GET(fp_Cache), [The value of $1.])[]dnl
-AS_VAR_POPDEF([fp_Cache])[]dnl
-])# FP_CHECK_CONST
-
-
-# FP_CHECK_CONSTS_TEMPLATE(EXPRESSION...)
-# ---------------------------------------
-# autoheader helper for FP_CHECK_CONSTS
-m4_define([FP_CHECK_CONSTS_TEMPLATE],
-[AC_FOREACH([fp_Const], [$1],
- [AH_TEMPLATE(AS_TR_CPP(CONST_[]fp_Const),
- [The value of ]fp_Const[.])])[]dnl
-])# FP_CHECK_CONSTS_TEMPLATE
-
-
-# FP_CHECK_CONSTS(EXPRESSION..., [INCLUDES = DEFAULT-INCLUDES], [VALUE-IF-FAIL = -1])
-# -----------------------------------------------------------------------------------
-# List version of FP_CHECK_CONST
-AC_DEFUN([FP_CHECK_CONSTS],
-[FP_CHECK_CONSTS_TEMPLATE([$1])dnl
-for fp_const_name in $1
-do
-FP_CHECK_CONST([$fp_const_name], [$2], [$3])
-done
-])# FP_CHECK_CONSTS
-
-
-dnl ** Map an arithmetic C type to a Haskell type.
-dnl Based on autconf's AC_CHECK_SIZEOF.
-
-dnl FPTOOLS_CHECK_HTYPE(TYPE [, DEFAULT_VALUE, [, VALUE-FOR-CROSS-COMPILATION])
-AC_DEFUN([FPTOOLS_CHECK_HTYPE],
-[changequote(<<, >>)dnl
-dnl The name to #define.
-define(<<AC_TYPE_NAME>>, translit(htype_$1, [a-z *], [A-Z_P]))dnl
-dnl The cache variable name.
-define(<<AC_CV_NAME>>, translit(fptools_cv_htype_$1, [ *], [_p]))dnl
-define(<<AC_CV_NAME_supported>>, translit(fptools_cv_htype_sup_$1, [ *], [_p]))dnl
-changequote([, ])dnl
-AC_MSG_CHECKING(Haskell type for $1)
-AC_CACHE_VAL(AC_CV_NAME,
-[AC_CV_NAME_supported=yes
-fp_check_htype_save_cppflags="$CPPFLAGS"
-CPPFLAGS="$CPPFLAGS $X_CFLAGS"
-AC_RUN_IFELSE([AC_LANG_SOURCE([[#include <stdio.h>
-#include <stddef.h>
-
-#if HAVE_SYS_TYPES_H
-# include <sys/types.h>
-#endif
-
-#if HAVE_UNISTD_H
-# include <unistd.h>
-#endif
-
-#if HAVE_SYS_STAT_H
-# include <sys/stat.h>
-#endif
-
-#if HAVE_FCNTL_H
-# include <fcntl.h>
-#endif
-
-#if HAVE_SIGNAL_H
-# include <signal.h>
-#endif
-
-#if HAVE_TIME_H
-# include <time.h>
-#endif
-
-#if HAVE_TERMIOS_H
-# include <termios.h>
-#endif
-
-#if HAVE_STRING_H
-# include <string.h>
-#endif
-
-#if HAVE_CTYPE_H
-# include <ctype.h>
-#endif
-
-#if HAVE_INTTYPES_H
-# include <inttypes.h>
-#else
-# if HAVE_STDINT_H
-# include <stdint.h>
-# endif
-#endif
-
-#if defined(HAVE_GL_GL_H)
-# include <GL/gl.h>
-#elif defined(HAVE_OPENGL_GL_H)
-# include <OpenGL/gl.h>
-#endif
-
-#if defined(HAVE_AL_AL_H)
-# include <AL/al.h>
-#elif defined(HAVE_OPENAL_AL_H)
-# include <OpenAL/al.h>
-#endif
-
-#if defined(HAVE_AL_ALC_H)
-# include <AL/alc.h>
-#elif defined(HAVE_OPENAL_ALC_H)
-# include <OpenAL/alc.h>
-#endif
-
-#if HAVE_SYS_RESOURCE_H
-# include <sys/resource.h>
-#endif
-
-typedef $1 testing;
-
-main() {
- FILE *f=fopen("conftestval", "w");
- if (!f) exit(1);
- if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {
- fprintf(f, "%s%d\n",
- ((testing)(-1) < (testing)0) ? "Int" : "Word",
- sizeof(testing)*8);
- } else {
- fprintf(f,"%s\n",
- (sizeof(testing) > sizeof(double)) ? "LDouble" :
- (sizeof(testing) == sizeof(double)) ? "Double" : "Float");
- }
- fclose(f);
- exit(0);
-}]])],[AC_CV_NAME=`cat conftestval`],
-[ifelse([$2], , [AC_CV_NAME=NotReallyAType; AC_CV_NAME_supported=no], [AC_CV_NAME=$2])],
-[ifelse([$3], , [AC_CV_NAME=NotReallyATypeCross; AC_CV_NAME_supported=no], [AC_CV_NAME=$3])])
-CPPFLAGS="$fp_check_htype_save_cppflags"]) dnl
-if test "$AC_CV_NAME_supported" = yes; then
- AC_MSG_RESULT($AC_CV_NAME)
- AC_DEFINE_UNQUOTED(AC_TYPE_NAME, $AC_CV_NAME, [Define to Haskell type for $1])
-else
- AC_MSG_RESULT([not supported])
-fi
-undefine([AC_TYPE_NAME])dnl
-undefine([AC_CV_NAME])dnl
-undefine([AC_CV_NAME_supported])dnl
-])
-
-
-# FP_READDIR_EOF_ERRNO
-# --------------------
-# Defines READDIR_ERRNO_EOF to what readdir() sets 'errno' to upon reaching end
-# of directory (not set => 0); not setting it is the correct thing to do, but
-# MinGW based versions have set it to ENOENT until recently (summer 2004).
-AC_DEFUN([FP_READDIR_EOF_ERRNO],
-[AC_CACHE_CHECK([what readdir sets errno to upon EOF], [fptools_cv_readdir_eof_errno],
-[AC_RUN_IFELSE([AC_LANG_SOURCE([[#include <dirent.h>
-#include <stdio.h>
-#include <errno.h>
-int
-main(argc, argv)
-int argc;
-char **argv;
-{
- FILE *f=fopen("conftestval", "w");
-#if defined(__MINGW32__)
- int fd = mkdir("testdir");
-#else
- int fd = mkdir("testdir", 0666);
-#endif
- DIR* dp;
- struct dirent* de;
- int err = 0;
-
- if (!f) return 1;
- if (fd == -1) {
- fprintf(stderr,"unable to create directory; quitting.\n");
- return 1;
- }
- close(fd);
- dp = opendir("testdir");
- if (!dp) {
- fprintf(stderr,"unable to browse directory; quitting.\n");
- rmdir("testdir");
- return 1;
- }
-
- /* the assumption here is that readdir() will only return NULL
- * due to reaching the end of the directory.
- */
- while (de = readdir(dp)) {
- ;
- }
- err = errno;
- fprintf(f,"%d", err);
- fclose(f);
- closedir(dp);
- rmdir("testdir");
- return 0;
-}]])],
-[fptools_cv_readdir_eof_errno=`cat conftestval`],
-[AC_MSG_WARN([failed to determine the errno value])
- fptools_cv_readdir_eof_errno=0],
-[fptools_cv_readdir_eof_errno=0])])
-AC_DEFINE_UNQUOTED([READDIR_ERRNO_EOF], [$fptools_cv_readdir_eof_errno], [readdir() sets errno to this upon EOF])
-])# FP_READDIR_EOF_ERRNO
+++ /dev/null
-name: base
-version: 2.1
-license: BSD3
-license-file: LICENSE
-maintainer: libraries@haskell.org
-synopsis: Basic libraries
-description:
- This package contains the Prelude and its support libraries,
- and a large collection of useful libraries ranging from data
- structures to parsing combinators and debugging utilities.
-exposed-modules:
- Control.Applicative,
- Control.Arrow,
- Control.Concurrent,
- Control.Concurrent.Chan,
- Control.Concurrent.MVar,
- Control.Concurrent.QSem,
- Control.Concurrent.QSemN,
- Control.Concurrent.SampleVar,
- Control.Exception,
- Control.Monad,
- Control.Monad.Fix,
- Control.Monad.Instances,
- Control.Monad.ST,
- Control.Monad.ST.Lazy,
- Control.Monad.ST.Strict,
- Data.Array,
- Data.Array.Base,
- Data.Array.Diff,
- Data.Array.IArray,
- Data.Array.IO,
- Data.Array.MArray,
- Data.Array.ST,
- Data.Array.Storable,
- Data.Array.Unboxed,
- Data.Bits,
- Data.Bool,
- Data.ByteString,
- Data.ByteString.Char8,
- Data.ByteString.Lazy
- Data.ByteString.Lazy.Char8
- Data.ByteString.Base
- Data.ByteString.Fusion
- Data.Char,
- Data.Complex,
- Data.Dynamic,
- Data.Either,
- Data.Eq,
- Data.Foldable,
- Data.Fixed,
- Data.Function,
- Data.Generics,
- Data.Generics.Aliases,
- Data.Generics.Basics,
- Data.Generics.Instances,
- Data.Generics.Schemes,
- Data.Generics.Text,
- Data.Generics.Twins,
- Data.Graph,
- Data.HashTable,
- Data.IORef,
- Data.Int,
- Data.IntMap,
- Data.IntSet,
- Data.Ix,
- Data.List,
- Data.Maybe,
- Data.Map,
- Data.Monoid,
- Data.Ord,
- Data.PackedString,
- Data.Ratio,
- Data.STRef,
- Data.STRef.Lazy,
- Data.STRef.Strict,
- Data.Sequence,
- Data.Set,
- Data.String,
- Data.Tree,
- Data.Traversable,
- Data.Tuple,
- Data.Typeable,
- Data.Unique,
- Data.Version,
- Data.Word,
- Debug.Trace,
- Foreign,
- Foreign.C,
- Foreign.C.Error,
- Foreign.C.String,
- Foreign.C.Types,
- Foreign.Concurrent,
- Foreign.ForeignPtr,
- Foreign.Marshal,
- Foreign.Marshal.Alloc,
- Foreign.Marshal.Array,
- Foreign.Marshal.Error,
- Foreign.Marshal.Pool,
- Foreign.Marshal.Utils,
- Foreign.Ptr,
- Foreign.StablePtr,
- Foreign.Storable,
- GHC.Arr,
- GHC.Base,
- GHC.Conc,
- GHC.ConsoleHandler,
- GHC.Dotnet,
- GHC.Enum,
- GHC.Err,
- GHC.Exception,
- GHC.Exts,
- GHC.Float,
- GHC.ForeignPtr,
- GHC.Handle,
- GHC.IO,
- GHC.IOBase,
- GHC.Int,
- GHC.List,
- GHC.Num,
- GHC.PArr,
- GHC.Pack,
- GHC.Prim,
- GHC.PrimopWrappers,
- GHC.Ptr,
- GHC.Read,
- GHC.Real,
- GHC.ST,
- GHC.STRef,
- GHC.Show,
- GHC.Stable,
- GHC.Storable,
- GHC.TopHandler,
- GHC.Unicode,
- GHC.Weak,
- GHC.Word,
- Numeric,
- Prelude,
- System.Cmd,
- System.Console.GetOpt,
- System.CPUTime,
- System.Directory,
- System.Directory.Internals,
- System.Environment,
- System.Exit,
- System.IO,
- System.IO.Error,
- System.IO.Unsafe,
- System.Info,
- System.Locale,
- System.Mem,
- System.Mem.StableName,
- System.Mem.Weak,
- System.Posix.Internals,
- System.Posix.Signals,
- System.Posix.Types,
- System.Process,
- System.Process.Internals,
- System.Random,
- System.Time,
- Text.ParserCombinators.ReadP,
- Text.ParserCombinators.ReadPrec,
- Text.Printf,
- Text.Read,
- Text.Read.Lex,
- Text.Show,
- Text.Show.Functions
- Unsafe.Coerce
-other-modules:
- Data.Array.IO.Internals
-c-sources:
- cbits/PrelIOUtils.c
- cbits/WCsubst.c
- cbits/Win32Utils.c
- cbits/consUtils.c
- cbits/dirUtils.c
- cbits/execvpe.c
- cbits/fpstring.c
- cbits/inputReady.c
- cbits/lockFile.c
- cbits/longlong.c
- cbits/runProcess.c
- cbits/selectUtils.c
- cbits/timeUtils.c
-include-dirs: include, ../../includes, ../../rts
-includes: HsBase.h
-install-includes: HsBase.h
-extensions: CPP
--- XXX is there an extension for using # in varids?
--- We need to set the package name to base (without a version number)
--- as it's magic.
-ghc-options: -fglasgow-exts -package-name base
-
+++ /dev/null
-# $Id: Makefile,v 1.14 2005/02/01 00:52:22 ross Exp $
-
-TOP = ../..
-include $(TOP)/mk/boilerplate.mk
-
-HC = $(GHC_INPLACE)
-
-UseGhcForCc = YES
-
-ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
-EXCLUDED_SRCS += consUtils.c
-endif
-
-SRC_CC_OPTS += -Wall -DCOMPILING_STDLIB
-SRC_CC_OPTS += -I$(GHC_INCLUDE_DIR) -I$(GHC_RTS_DIR) -I../include
-
-LIBRARY = libHSbase_cbits.a
-LIBOBJS = $(C_OBJS)
-
-include $(TOP)/mk/target.mk
+++ /dev/null
-/*
- * (c) The University of Glasgow 2002
- *
- * static versions of the inline functions in HsCore.h
- */
-
-#define INLINE
-#include "HsBase.h"
-
+++ /dev/null
-/*-------------------------------------------------------------------------
-This is an automatically generated file: do not edit
-Generated by udconfc at Mon Jan 31 23:37:36 EST 2005
--------------------------------------------------------------------------*/
-
-#include "WCsubst.h"
-
-/* Unicode general categories, listed in the same order as in the Unicode
- * standard -- this must be the same order as in GHC.Unicode.
- */
-
-enum {
- NUMCAT_LU, /* Letter, Uppercase */
- NUMCAT_LL, /* Letter, Lowercase */
- NUMCAT_LT, /* Letter, Titlecase */
- NUMCAT_LM, /* Letter, Modifier */
- NUMCAT_LO, /* Letter, Other */
- NUMCAT_MN, /* Mark, Non-Spacing */
- NUMCAT_MC, /* Mark, Spacing Combining */
- NUMCAT_ME, /* Mark, Enclosing */
- NUMCAT_ND, /* Number, Decimal */
- NUMCAT_NL, /* Number, Letter */
- NUMCAT_NO, /* Number, Other */
- NUMCAT_PC, /* Punctuation, Connector */
- NUMCAT_PD, /* Punctuation, Dash */
- NUMCAT_PS, /* Punctuation, Open */
- NUMCAT_PE, /* Punctuation, Close */
- NUMCAT_PI, /* Punctuation, Initial quote */
- NUMCAT_PF, /* Punctuation, Final quote */
- NUMCAT_PO, /* Punctuation, Other */
- NUMCAT_SM, /* Symbol, Math */
- NUMCAT_SC, /* Symbol, Currency */
- NUMCAT_SK, /* Symbol, Modifier */
- NUMCAT_SO, /* Symbol, Other */
- NUMCAT_ZS, /* Separator, Space */
- NUMCAT_ZL, /* Separator, Line */
- NUMCAT_ZP, /* Separator, Paragraph */
- NUMCAT_CC, /* Other, Control */
- NUMCAT_CF, /* Other, Format */
- NUMCAT_CS, /* Other, Surrogate */
- NUMCAT_CO, /* Other, Private Use */
- NUMCAT_CN /* Other, Not Assigned */
-};
-
-struct _convrule_
-{
- unsigned int category;
- unsigned int catnumber;
- int possible;
- int updist;
- int lowdist;
- int titledist;
-};
-
-struct _charblock_
-{
- int start;
- int length;
- const struct _convrule_ *rule;
-};
-
-#define GENCAT_ZP 67108864
-#define GENCAT_MC 8388608
-#define GENCAT_NO 65536
-#define GENCAT_SK 1024
-#define GENCAT_CO 268435456
-#define GENCAT_ME 4194304
-#define GENCAT_ND 256
-#define GENCAT_PO 4
-#define GENCAT_LT 524288
-#define GENCAT_PC 2048
-#define GENCAT_SM 64
-#define GENCAT_ZS 2
-#define GENCAT_CC 1
-#define GENCAT_LU 512
-#define GENCAT_PD 128
-#define GENCAT_SO 8192
-#define GENCAT_PE 32
-#define GENCAT_CS 134217728
-#define GENCAT_PF 131072
-#define GENCAT_CF 32768
-#define GENCAT_PS 16
-#define GENCAT_SC 8
-#define GENCAT_LL 4096
-#define GENCAT_ZL 33554432
-#define GENCAT_LM 1048576
-#define GENCAT_PI 16384
-#define GENCAT_NL 16777216
-#define GENCAT_MN 2097152
-#define GENCAT_LO 262144
-#define MAX_UNI_CHAR 1114109
-#define NUM_BLOCKS 1916
-#define NUM_CONVBLOCKS 835
-#define NUM_SPACEBLOCKS 8
-#define NUM_LAT1BLOCKS 63
-#define NUM_RULES 126
-static const struct _convrule_ rule116={GENCAT_LU, NUMCAT_LU, 1, 0, -8383, 0};
-static const struct _convrule_ rule108={GENCAT_LU, NUMCAT_LU, 1, 0, -86, 0};
-static const struct _convrule_ rule88={GENCAT_LU, NUMCAT_LU, 1, 0, 80, 0};
-static const struct _convrule_ rule86={GENCAT_LL, NUMCAT_LL, 1, -96, 0, -96};
-static const struct _convrule_ rule79={GENCAT_LU, NUMCAT_LU, 0, 0, 0, 0};
-static const struct _convrule_ rule56={GENCAT_LL, NUMCAT_LL, 1, -203, 0, -203};
-static const struct _convrule_ rule54={GENCAT_LL, NUMCAT_LL, 1, -205, 0, -205};
-static const struct _convrule_ rule48={GENCAT_LL, NUMCAT_LL, 1, -79, 0, -79};
-static const struct _convrule_ rule40={GENCAT_LU, NUMCAT_LU, 1, 0, 218, 0};
-static const struct _convrule_ rule113={GENCAT_ZL, NUMCAT_ZL, 0, 0, 0, 0};
-static const struct _convrule_ rule103={GENCAT_LT, NUMCAT_LT, 1, 0, -8, 0};
-static const struct _convrule_ rule98={GENCAT_LL, NUMCAT_LL, 1, 86, 0, 86};
-static const struct _convrule_ rule95={GENCAT_LL, NUMCAT_LL, 1, 8, 0, 8};
-static const struct _convrule_ rule39={GENCAT_LU, NUMCAT_LU, 1, 0, 214, 0};
-static const struct _convrule_ rule119={GENCAT_NL, NUMCAT_NL, 1, -16, 0, -16};
-static const struct _convrule_ rule101={GENCAT_LL, NUMCAT_LL, 1, 112, 0, 112};
-static const struct _convrule_ rule93={GENCAT_NL, NUMCAT_NL, 0, 0, 0, 0};
-static const struct _convrule_ rule60={GENCAT_LL, NUMCAT_LL, 1, -213, 0, -213};
-static const struct _convrule_ rule59={GENCAT_LL, NUMCAT_LL, 1, -211, 0, -211};
-static const struct _convrule_ rule42={GENCAT_LU, NUMCAT_LU, 1, 0, 219, 0};
-static const struct _convrule_ rule38={GENCAT_LL, NUMCAT_LL, 1, 130, 0, 130};
-static const struct _convrule_ rule34={GENCAT_LL, NUMCAT_LL, 1, 97, 0, 97};
-static const struct _convrule_ rule25={GENCAT_LU, NUMCAT_LU, 1, 0, -121, 0};
-static const struct _convrule_ rule24={GENCAT_LL, NUMCAT_LL, 1, -232, 0, -232};
-static const struct _convrule_ rule20={GENCAT_LL, NUMCAT_LL, 1, 121, 0, 121};
-static const struct _convrule_ rule16={GENCAT_CF, NUMCAT_CF, 0, 0, 0, 0};
-static const struct _convrule_ rule4={GENCAT_PS, NUMCAT_PS, 0, 0, 0, 0};
-static const struct _convrule_ rule123={GENCAT_CO, NUMCAT_CO, 0, 0, 0, 0};
-static const struct _convrule_ rule112={GENCAT_LU, NUMCAT_LU, 1, 0, -126, 0};
-static const struct _convrule_ rule106={GENCAT_LT, NUMCAT_LT, 1, 0, -9, 0};
-static const struct _convrule_ rule105={GENCAT_LU, NUMCAT_LU, 1, 0, -74, 0};
-static const struct _convrule_ rule97={GENCAT_LL, NUMCAT_LL, 1, 74, 0, 74};
-static const struct _convrule_ rule65={GENCAT_LM, NUMCAT_LM, 0, 0, 0, 0};
-static const struct _convrule_ rule30={GENCAT_LU, NUMCAT_LU, 1, 0, 79, 0};
-static const struct _convrule_ rule5={GENCAT_PE, NUMCAT_PE, 0, 0, 0, 0};
-static const struct _convrule_ rule114={GENCAT_ZP, NUMCAT_ZP, 0, 0, 0, 0};
-static const struct _convrule_ rule104={GENCAT_LL, NUMCAT_LL, 1, 9, 0, 9};
-static const struct _convrule_ rule94={GENCAT_LL, NUMCAT_LL, 1, -59, 0, -59};
-static const struct _convrule_ rule92={GENCAT_MC, NUMCAT_MC, 0, 0, 0, 0};
-static const struct _convrule_ rule91={GENCAT_LL, NUMCAT_LL, 1, -48, 0, -48};
-static const struct _convrule_ rule82={GENCAT_LL, NUMCAT_LL, 1, -86, 0, -86};
-static const struct _convrule_ rule78={GENCAT_LL, NUMCAT_LL, 1, -57, 0, -57};
-static const struct _convrule_ rule66={GENCAT_MN, NUMCAT_MN, 0, 0, 0, 0};
-static const struct _convrule_ rule55={GENCAT_LL, NUMCAT_LL, 1, -202, 0, -202};
-static const struct _convrule_ rule50={GENCAT_LU, NUMCAT_LU, 1, 0, -56, 0};
-static const struct _convrule_ rule45={GENCAT_LU, NUMCAT_LU, 1, 0, 2, 1};
-static const struct _convrule_ rule31={GENCAT_LU, NUMCAT_LU, 1, 0, 202, 0};
-static const struct _convrule_ rule6={GENCAT_SM, NUMCAT_SM, 0, 0, 0, 0};
-static const struct _convrule_ rule107={GENCAT_LL, NUMCAT_LL, 1, -7205, 0, -7205};
-static const struct _convrule_ rule90={GENCAT_LU, NUMCAT_LU, 1, 0, 48, 0};
-static const struct _convrule_ rule87={GENCAT_LU, NUMCAT_LU, 1, 0, -7, 0};
-static const struct _convrule_ rule44={GENCAT_LL, NUMCAT_LL, 1, 56, 0, 56};
-static const struct _convrule_ rule33={GENCAT_LU, NUMCAT_LU, 1, 0, 207, 0};
-static const struct _convrule_ rule18={GENCAT_LL, NUMCAT_LL, 1, 743, 0, 743};
-static const struct _convrule_ rule17={GENCAT_NO, NUMCAT_NO, 0, 0, 0, 0};
-static const struct _convrule_ rule10={GENCAT_SK, NUMCAT_SK, 0, 0, 0, 0};
-static const struct _convrule_ rule8={GENCAT_ND, NUMCAT_ND, 0, 0, 0, 0};
-static const struct _convrule_ rule122={GENCAT_CS, NUMCAT_CS, 0, 0, 0, 0};
-static const struct _convrule_ rule99={GENCAT_LL, NUMCAT_LL, 1, 100, 0, 100};
-static const struct _convrule_ rule67={GENCAT_MN, NUMCAT_MN, 1, 84, 0, 84};
-static const struct _convrule_ rule52={GENCAT_LL, NUMCAT_LL, 1, -210, 0, -210};
-static const struct _convrule_ rule51={GENCAT_LU, NUMCAT_LU, 1, 0, -130, 0};
-static const struct _convrule_ rule32={GENCAT_LU, NUMCAT_LU, 1, 0, 203, 0};
-static const struct _convrule_ rule27={GENCAT_LU, NUMCAT_LU, 1, 0, 210, 0};
-static const struct _convrule_ rule15={GENCAT_PI, NUMCAT_PI, 0, 0, 0, 0};
-static const struct _convrule_ rule111={GENCAT_LU, NUMCAT_LU, 1, 0, -128, 0};
-static const struct _convrule_ rule96={GENCAT_LU, NUMCAT_LU, 1, 0, -8, 0};
-static const struct _convrule_ rule71={GENCAT_LU, NUMCAT_LU, 1, 0, 63, 0};
-static const struct _convrule_ rule64={GENCAT_LL, NUMCAT_LL, 1, -219, 0, -219};
-static const struct _convrule_ rule62={GENCAT_LL, NUMCAT_LL, 1, -218, 0, -218};
-static const struct _convrule_ rule23={GENCAT_LU, NUMCAT_LU, 1, 0, -199, 0};
-static const struct _convrule_ rule19={GENCAT_PF, NUMCAT_PF, 0, 0, 0, 0};
-static const struct _convrule_ rule1={GENCAT_ZS, NUMCAT_ZS, 0, 0, 0, 0};
-static const struct _convrule_ rule120={GENCAT_SO, NUMCAT_SO, 1, 0, 26, 0};
-static const struct _convrule_ rule115={GENCAT_LU, NUMCAT_LU, 1, 0, -7517, 0};
-static const struct _convrule_ rule83={GENCAT_LL, NUMCAT_LL, 1, -80, 0, -80};
-static const struct _convrule_ rule81={GENCAT_LL, NUMCAT_LL, 1, -54, 0, -54};
-static const struct _convrule_ rule80={GENCAT_LL, NUMCAT_LL, 1, -47, 0, -47};
-static const struct _convrule_ rule77={GENCAT_LL, NUMCAT_LL, 1, -62, 0, -62};
-static const struct _convrule_ rule76={GENCAT_LL, NUMCAT_LL, 1, -63, 0, -63};
-static const struct _convrule_ rule75={GENCAT_LL, NUMCAT_LL, 1, -64, 0, -64};
-static const struct _convrule_ rule73={GENCAT_LL, NUMCAT_LL, 1, -37, 0, -37};
-static const struct _convrule_ rule72={GENCAT_LL, NUMCAT_LL, 1, -38, 0, -38};
-static const struct _convrule_ rule35={GENCAT_LU, NUMCAT_LU, 1, 0, 211, 0};
-static const struct _convrule_ rule14={GENCAT_LL, NUMCAT_LL, 0, 0, 0, 0};
-static const struct _convrule_ rule11={GENCAT_PC, NUMCAT_PC, 0, 0, 0, 0};
-static const struct _convrule_ rule3={GENCAT_SC, NUMCAT_SC, 0, 0, 0, 0};
-static const struct _convrule_ rule2={GENCAT_PO, NUMCAT_PO, 0, 0, 0, 0};
-static const struct _convrule_ rule70={GENCAT_LU, NUMCAT_LU, 1, 0, 64, 0};
-static const struct _convrule_ rule58={GENCAT_LL, NUMCAT_LL, 1, -209, 0, -209};
-static const struct _convrule_ rule57={GENCAT_LL, NUMCAT_LL, 1, -207, 0, -207};
-static const struct _convrule_ rule53={GENCAT_LL, NUMCAT_LL, 1, -206, 0, -206};
-static const struct _convrule_ rule46={GENCAT_LT, NUMCAT_LT, 1, -1, 1, 0};
-static const struct _convrule_ rule36={GENCAT_LU, NUMCAT_LU, 1, 0, 209, 0};
-static const struct _convrule_ rule26={GENCAT_LL, NUMCAT_LL, 1, -300, 0, -300};
-static const struct _convrule_ rule9={GENCAT_LU, NUMCAT_LU, 1, 0, 32, 0};
-static const struct _convrule_ rule121={GENCAT_SO, NUMCAT_SO, 1, -26, 0, -26};
-static const struct _convrule_ rule117={GENCAT_LU, NUMCAT_LU, 1, 0, -8262, 0};
-static const struct _convrule_ rule109={GENCAT_LU, NUMCAT_LU, 1, 0, -100, 0};
-static const struct _convrule_ rule69={GENCAT_LU, NUMCAT_LU, 1, 0, 37, 0};
-static const struct _convrule_ rule29={GENCAT_LU, NUMCAT_LU, 1, 0, 205, 0};
-static const struct _convrule_ rule21={GENCAT_LU, NUMCAT_LU, 1, 0, 1, 0};
-static const struct _convrule_ rule124={GENCAT_LU, NUMCAT_LU, 1, 0, 40, 0};
-static const struct _convrule_ rule110={GENCAT_LU, NUMCAT_LU, 1, 0, -112, 0};
-static const struct _convrule_ rule102={GENCAT_LL, NUMCAT_LL, 1, 126, 0, 126};
-static const struct _convrule_ rule100={GENCAT_LL, NUMCAT_LL, 1, 128, 0, 128};
-static const struct _convrule_ rule85={GENCAT_LU, NUMCAT_LU, 1, 0, -60, 0};
-static const struct _convrule_ rule84={GENCAT_LL, NUMCAT_LL, 1, 7, 0, 7};
-static const struct _convrule_ rule63={GENCAT_LL, NUMCAT_LL, 1, -217, 0, -217};
-static const struct _convrule_ rule61={GENCAT_LL, NUMCAT_LL, 1, -214, 0, -214};
-static const struct _convrule_ rule43={GENCAT_LO, NUMCAT_LO, 0, 0, 0, 0};
-static const struct _convrule_ rule41={GENCAT_LU, NUMCAT_LU, 1, 0, 217, 0};
-static const struct _convrule_ rule125={GENCAT_LL, NUMCAT_LL, 1, -40, 0, -40};
-static const struct _convrule_ rule118={GENCAT_NL, NUMCAT_NL, 1, 0, 16, 0};
-static const struct _convrule_ rule89={GENCAT_ME, NUMCAT_ME, 0, 0, 0, 0};
-static const struct _convrule_ rule74={GENCAT_LL, NUMCAT_LL, 1, -31, 0, -31};
-static const struct _convrule_ rule68={GENCAT_LU, NUMCAT_LU, 1, 0, 38, 0};
-static const struct _convrule_ rule49={GENCAT_LU, NUMCAT_LU, 1, 0, -97, 0};
-static const struct _convrule_ rule47={GENCAT_LL, NUMCAT_LL, 1, -2, 0, -1};
-static const struct _convrule_ rule37={GENCAT_LU, NUMCAT_LU, 1, 0, 213, 0};
-static const struct _convrule_ rule28={GENCAT_LU, NUMCAT_LU, 1, 0, 206, 0};
-static const struct _convrule_ rule22={GENCAT_LL, NUMCAT_LL, 1, -1, 0, -1};
-static const struct _convrule_ rule13={GENCAT_SO, NUMCAT_SO, 0, 0, 0, 0};
-static const struct _convrule_ rule12={GENCAT_LL, NUMCAT_LL, 1, -32, 0, -32};
-static const struct _convrule_ rule7={GENCAT_PD, NUMCAT_PD, 0, 0, 0, 0};
-static const struct _convrule_ rule0={GENCAT_CC, NUMCAT_CC, 0, 0, 0, 0};
-static const struct _charblock_ allchars[]={
- {0, 32, &rule0},
- {32, 1, &rule1},
- {33, 3, &rule2},
- {36, 1, &rule3},
- {37, 3, &rule2},
- {40, 1, &rule4},
- {41, 1, &rule5},
- {42, 1, &rule2},
- {43, 1, &rule6},
- {44, 1, &rule2},
- {45, 1, &rule7},
- {46, 2, &rule2},
- {48, 10, &rule8},
- {58, 2, &rule2},
- {60, 3, &rule6},
- {63, 2, &rule2},
- {65, 26, &rule9},
- {91, 1, &rule4},
- {92, 1, &rule2},
- {93, 1, &rule5},
- {94, 1, &rule10},
- {95, 1, &rule11},
- {96, 1, &rule10},
- {97, 26, &rule12},
- {123, 1, &rule4},
- {124, 1, &rule6},
- {125, 1, &rule5},
- {126, 1, &rule6},
- {127, 33, &rule0},
- {160, 1, &rule1},
- {161, 1, &rule2},
- {162, 4, &rule3},
- {166, 2, &rule13},
- {168, 1, &rule10},
- {169, 1, &rule13},
- {170, 1, &rule14},
- {171, 1, &rule15},
- {172, 1, &rule6},
- {173, 1, &rule16},
- {174, 1, &rule13},
- {175, 1, &rule10},
- {176, 1, &rule13},
- {177, 1, &rule6},
- {178, 2, &rule17},
- {180, 1, &rule10},
- {181, 1, &rule18},
- {182, 1, &rule13},
- {183, 1, &rule2},
- {184, 1, &rule10},
- {185, 1, &rule17},
- {186, 1, &rule14},
- {187, 1, &rule19},
- {188, 3, &rule17},
- {191, 1, &rule2},
- {192, 23, &rule9},
- {215, 1, &rule6},
- {216, 7, &rule9},
- {223, 1, &rule14},
- {224, 23, &rule12},
- {247, 1, &rule6},
- {248, 7, &rule12},
- {255, 1, &rule20},
- {256, 1, &rule21},
- {257, 1, &rule22},
- {258, 1, &rule21},
- {259, 1, &rule22},
- {260, 1, &rule21},
- {261, 1, &rule22},
- {262, 1, &rule21},
- {263, 1, &rule22},
- {264, 1, &rule21},
- {265, 1, &rule22},
- {266, 1, &rule21},
- {267, 1, &rule22},
- {268, 1, &rule21},
- {269, 1, &rule22},
- {270, 1, &rule21},
- {271, 1, &rule22},
- {272, 1, &rule21},
- {273, 1, &rule22},
- {274, 1, &rule21},
- {275, 1, &rule22},
- {276, 1, &rule21},
- {277, 1, &rule22},
- {278, 1, &rule21},
- {279, 1, &rule22},
- {280, 1, &rule21},
- {281, 1, &rule22},
- {282, 1, &rule21},
- {283, 1, &rule22},
- {284, 1, &rule21},
- {285, 1, &rule22},
- {286, 1, &rule21},
- {287, 1, &rule22},
- {288, 1, &rule21},
- {289, 1, &rule22},
- {290, 1, &rule21},
- {291, 1, &rule22},
- {292, 1, &rule21},
- {293, 1, &rule22},
- {294, 1, &rule21},
- {295, 1, &rule22},
- {296, 1, &rule21},
- {297, 1, &rule22},
- {298, 1, &rule21},
- {299, 1, &rule22},
- {300, 1, &rule21},
- {301, 1, &rule22},
- {302, 1, &rule21},
- {303, 1, &rule22},
- {304, 1, &rule23},
- {305, 1, &rule24},
- {306, 1, &rule21},
- {307, 1, &rule22},
- {308, 1, &rule21},
- {309, 1, &rule22},
- {310, 1, &rule21},
- {311, 1, &rule22},
- {312, 1, &rule14},
- {313, 1, &rule21},
- {314, 1, &rule22},
- {315, 1, &rule21},
- {316, 1, &rule22},
- {317, 1, &rule21},
- {318, 1, &rule22},
- {319, 1, &rule21},
- {320, 1, &rule22},
- {321, 1, &rule21},
- {322, 1, &rule22},
- {323, 1, &rule21},
- {324, 1, &rule22},
- {325, 1, &rule21},
- {326, 1, &rule22},
- {327, 1, &rule21},
- {328, 1, &rule22},
- {329, 1, &rule14},
- {330, 1, &rule21},
- {331, 1, &rule22},
- {332, 1, &rule21},
- {333, 1, &rule22},
- {334, 1, &rule21},
- {335, 1, &rule22},
- {336, 1, &rule21},
- {337, 1, &rule22},
- {338, 1, &rule21},
- {339, 1, &rule22},
- {340, 1, &rule21},
- {341, 1, &rule22},
- {342, 1, &rule21},
- {343, 1, &rule22},
- {344, 1, &rule21},
- {345, 1, &rule22},
- {346, 1, &rule21},
- {347, 1, &rule22},
- {348, 1, &rule21},
- {349, 1, &rule22},
- {350, 1, &rule21},
- {351, 1, &rule22},
- {352, 1, &rule21},
- {353, 1, &rule22},
- {354, 1, &rule21},
- {355, 1, &rule22},
- {356, 1, &rule21},
- {357, 1, &rule22},
- {358, 1, &rule21},
- {359, 1, &rule22},
- {360, 1, &rule21},
- {361, 1, &rule22},
- {362, 1, &rule21},
- {363, 1, &rule22},
- {364, 1, &rule21},
- {365, 1, &rule22},
- {366, 1, &rule21},
- {367, 1, &rule22},
- {368, 1, &rule21},
- {369, 1, &rule22},
- {370, 1, &rule21},
- {371, 1, &rule22},
- {372, 1, &rule21},
- {373, 1, &rule22},
- {374, 1, &rule21},
- {375, 1, &rule22},
- {376, 1, &rule25},
- {377, 1, &rule21},
- {378, 1, &rule22},
- {379, 1, &rule21},
- {380, 1, &rule22},
- {381, 1, &rule21},
- {382, 1, &rule22},
- {383, 1, &rule26},
- {384, 1, &rule14},
- {385, 1, &rule27},
- {386, 1, &rule21},
- {387, 1, &rule22},
- {388, 1, &rule21},
- {389, 1, &rule22},
- {390, 1, &rule28},
- {391, 1, &rule21},
- {392, 1, &rule22},
- {393, 2, &rule29},
- {395, 1, &rule21},
- {396, 1, &rule22},
- {397, 1, &rule14},
- {398, 1, &rule30},
- {399, 1, &rule31},
- {400, 1, &rule32},
- {401, 1, &rule21},
- {402, 1, &rule22},
- {403, 1, &rule29},
- {404, 1, &rule33},
- {405, 1, &rule34},
- {406, 1, &rule35},
- {407, 1, &rule36},
- {408, 1, &rule21},
- {409, 1, &rule22},
- {410, 2, &rule14},
- {412, 1, &rule35},
- {413, 1, &rule37},
- {414, 1, &rule38},
- {415, 1, &rule39},
- {416, 1, &rule21},
- {417, 1, &rule22},
- {418, 1, &rule21},
- {419, 1, &rule22},
- {420, 1, &rule21},
- {421, 1, &rule22},
- {422, 1, &rule40},
- {423, 1, &rule21},
- {424, 1, &rule22},
- {425, 1, &rule40},
- {426, 2, &rule14},
- {428, 1, &rule21},
- {429, 1, &rule22},
- {430, 1, &rule40},
- {431, 1, &rule21},
- {432, 1, &rule22},
- {433, 2, &rule41},
- {435, 1, &rule21},
- {436, 1, &rule22},
- {437, 1, &rule21},
- {438, 1, &rule22},
- {439, 1, &rule42},
- {440, 1, &rule21},
- {441, 1, &rule22},
- {442, 1, &rule14},
- {443, 1, &rule43},
- {444, 1, &rule21},
- {445, 1, &rule22},
- {446, 1, &rule14},
- {447, 1, &rule44},
- {448, 4, &rule43},
- {452, 1, &rule45},
- {453, 1, &rule46},
- {454, 1, &rule47},
- {455, 1, &rule45},
- {456, 1, &rule46},
- {457, 1, &rule47},
- {458, 1, &rule45},
- {459, 1, &rule46},
- {460, 1, &rule47},
- {461, 1, &rule21},
- {462, 1, &rule22},
- {463, 1, &rule21},
- {464, 1, &rule22},
- {465, 1, &rule21},
- {466, 1, &rule22},
- {467, 1, &rule21},
- {468, 1, &rule22},
- {469, 1, &rule21},
- {470, 1, &rule22},
- {471, 1, &rule21},
- {472, 1, &rule22},
- {473, 1, &rule21},
- {474, 1, &rule22},
- {475, 1, &rule21},
- {476, 1, &rule22},
- {477, 1, &rule48},
- {478, 1, &rule21},
- {479, 1, &rule22},
- {480, 1, &rule21},
- {481, 1, &rule22},
- {482, 1, &rule21},
- {483, 1, &rule22},
- {484, 1, &rule21},
- {485, 1, &rule22},
- {486, 1, &rule21},
- {487, 1, &rule22},
- {488, 1, &rule21},
- {489, 1, &rule22},
- {490, 1, &rule21},
- {491, 1, &rule22},
- {492, 1, &rule21},
- {493, 1, &rule22},
- {494, 1, &rule21},
- {495, 1, &rule22},
- {496, 1, &rule14},
- {497, 1, &rule45},
- {498, 1, &rule46},
- {499, 1, &rule47},
- {500, 1, &rule21},
- {501, 1, &rule22},
- {502, 1, &rule49},
- {503, 1, &rule50},
- {504, 1, &rule21},
- {505, 1, &rule22},
- {506, 1, &rule21},
- {507, 1, &rule22},
- {508, 1, &rule21},
- {509, 1, &rule22},
- {510, 1, &rule21},
- {511, 1, &rule22},
- {512, 1, &rule21},
- {513, 1, &rule22},
- {514, 1, &rule21},
- {515, 1, &rule22},
- {516, 1, &rule21},
- {517, 1, &rule22},
- {518, 1, &rule21},
- {519, 1, &rule22},
- {520, 1, &rule21},
- {521, 1, &rule22},
- {522, 1, &rule21},
- {523, 1, &rule22},
- {524, 1, &rule21},
- {525, 1, &rule22},
- {526, 1, &rule21},
- {527, 1, &rule22},
- {528, 1, &rule21},
- {529, 1, &rule22},
- {530, 1, &rule21},
- {531, 1, &rule22},
- {532, 1, &rule21},
- {533, 1, &rule22},
- {534, 1, &rule21},
- {535, 1, &rule22},
- {536, 1, &rule21},
- {537, 1, &rule22},
- {538, 1, &rule21},
- {539, 1, &rule22},
- {540, 1, &rule21},
- {541, 1, &rule22},
- {542, 1, &rule21},
- {543, 1, &rule22},
- {544, 1, &rule51},
- {545, 1, &rule14},
- {546, 1, &rule21},
- {547, 1, &rule22},
- {548, 1, &rule21},
- {549, 1, &rule22},
- {550, 1, &rule21},
- {551, 1, &rule22},
- {552, 1, &rule21},
- {553, 1, &rule22},
- {554, 1, &rule21},
- {555, 1, &rule22},
- {556, 1, &rule21},
- {557, 1, &rule22},
- {558, 1, &rule21},
- {559, 1, &rule22},
- {560, 1, &rule21},
- {561, 1, &rule22},
- {562, 1, &rule21},
- {563, 1, &rule22},
- {564, 3, &rule14},
- {592, 3, &rule14},
- {595, 1, &rule52},
- {596, 1, &rule53},
- {597, 1, &rule14},
- {598, 2, &rule54},
- {600, 1, &rule14},
- {601, 1, &rule55},
- {602, 1, &rule14},
- {603, 1, &rule56},
- {604, 4, &rule14},
- {608, 1, &rule54},
- {609, 2, &rule14},
- {611, 1, &rule57},
- {612, 4, &rule14},
- {616, 1, &rule58},
- {617, 1, &rule59},
- {618, 5, &rule14},
- {623, 1, &rule59},
- {624, 2, &rule14},
- {626, 1, &rule60},
- {627, 2, &rule14},
- {629, 1, &rule61},
- {630, 10, &rule14},
- {640, 1, &rule62},
- {641, 2, &rule14},
- {643, 1, &rule62},
- {644, 4, &rule14},
- {648, 1, &rule62},
- {649, 1, &rule14},
- {650, 2, &rule63},
- {652, 6, &rule14},
- {658, 1, &rule64},
- {659, 29, &rule14},
- {688, 18, &rule65},
- {706, 4, &rule10},
- {710, 12, &rule65},
- {722, 14, &rule10},
- {736, 5, &rule65},
- {741, 9, &rule10},
- {750, 1, &rule65},
- {751, 17, &rule10},
- {768, 69, &rule66},
- {837, 1, &rule67},
- {838, 18, &rule66},
- {861, 19, &rule66},
- {884, 2, &rule10},
- {890, 1, &rule65},
- {894, 1, &rule2},
- {900, 2, &rule10},
- {902, 1, &rule68},
- {903, 1, &rule2},
- {904, 3, &rule69},
- {908, 1, &rule70},
- {910, 2, &rule71},
- {912, 1, &rule14},
- {913, 17, &rule9},
- {931, 9, &rule9},
- {940, 1, &rule72},
- {941, 3, &rule73},
- {944, 1, &rule14},
- {945, 17, &rule12},
- {962, 1, &rule74},
- {963, 9, &rule12},
- {972, 1, &rule75},
- {973, 2, &rule76},
- {976, 1, &rule77},
- {977, 1, &rule78},
- {978, 3, &rule79},
- {981, 1, &rule80},
- {982, 1, &rule81},
- {983, 1, &rule14},
- {984, 1, &rule21},
- {985, 1, &rule22},
- {986, 1, &rule21},
- {987, 1, &rule22},
- {988, 1, &rule21},
- {989, 1, &rule22},
- {990, 1, &rule21},
- {991, 1, &rule22},
- {992, 1, &rule21},
- {993, 1, &rule22},
- {994, 1, &rule21},
- {995, 1, &rule22},
- {996, 1, &rule21},
- {997, 1, &rule22},
- {998, 1, &rule21},
- {999, 1, &rule22},
- {1000, 1, &rule21},
- {1001, 1, &rule22},
- {1002, 1, &rule21},
- {1003, 1, &rule22},
- {1004, 1, &rule21},
- {1005, 1, &rule22},
- {1006, 1, &rule21},
- {1007, 1, &rule22},
- {1008, 1, &rule82},
- {1009, 1, &rule83},
- {1010, 1, &rule84},
- {1011, 1, &rule14},
- {1012, 1, &rule85},
- {1013, 1, &rule86},
- {1014, 1, &rule6},
- {1015, 1, &rule21},
- {1016, 1, &rule22},
- {1017, 1, &rule87},
- {1018, 1, &rule21},
- {1019, 1, &rule22},
- {1024, 16, &rule88},
- {1040, 32, &rule9},
- {1072, 32, &rule12},
- {1104, 16, &rule83},
- {1120, 1, &rule21},
- {1121, 1, &rule22},
- {1122, 1, &rule21},
- {1123, 1, &rule22},
- {1124, 1, &rule21},
- {1125, 1, &rule22},
- {1126, 1, &rule21},
- {1127, 1, &rule22},
- {1128, 1, &rule21},
- {1129, 1, &rule22},
- {1130, 1, &rule21},
- {1131, 1, &rule22},
- {1132, 1, &rule21},
- {1133, 1, &rule22},
- {1134, 1, &rule21},
- {1135, 1, &rule22},
- {1136, 1, &rule21},
- {1137, 1, &rule22},
- {1138, 1, &rule21},
- {1139, 1, &rule22},
- {1140, 1, &rule21},
- {1141, 1, &rule22},
- {1142, 1, &rule21},
- {1143, 1, &rule22},
- {1144, 1, &rule21},
- {1145, 1, &rule22},
- {1146, 1, &rule21},
- {1147, 1, &rule22},
- {1148, 1, &rule21},
- {1149, 1, &rule22},
- {1150, 1, &rule21},
- {1151, 1, &rule22},
- {1152, 1, &rule21},
- {1153, 1, &rule22},
- {1154, 1, &rule13},
- {1155, 4, &rule66},
- {1160, 2, &rule89},
- {1162, 1, &rule21},
- {1163, 1, &rule22},
- {1164, 1, &rule21},
- {1165, 1, &rule22},
- {1166, 1, &rule21},
- {1167, 1, &rule22},
- {1168, 1, &rule21},
- {1169, 1, &rule22},
- {1170, 1, &rule21},
- {1171, 1, &rule22},
- {1172, 1, &rule21},
- {1173, 1, &rule22},
- {1174, 1, &rule21},
- {1175, 1, &rule22},
- {1176, 1, &rule21},
- {1177, 1, &rule22},
- {1178, 1, &rule21},
- {1179, 1, &rule22},
- {1180, 1, &rule21},
- {1181, 1, &rule22},
- {1182, 1, &rule21},
- {1183, 1, &rule22},
- {1184, 1, &rule21},
- {1185, 1, &rule22},
- {1186, 1, &rule21},
- {1187, 1, &rule22},
- {1188, 1, &rule21},
- {1189, 1, &rule22},
- {1190, 1, &rule21},
- {1191, 1, &rule22},
- {1192, 1, &rule21},
- {1193, 1, &rule22},
- {1194, 1, &rule21},
- {1195, 1, &rule22},
- {1196, 1, &rule21},
- {1197, 1, &rule22},
- {1198, 1, &rule21},
- {1199, 1, &rule22},
- {1200, 1, &rule21},
- {1201, 1, &rule22},
- {1202, 1, &rule21},
- {1203, 1, &rule22},
- {1204, 1, &rule21},
- {1205, 1, &rule22},
- {1206, 1, &rule21},
- {1207, 1, &rule22},
- {1208, 1, &rule21},
- {1209, 1, &rule22},
- {1210, 1, &rule21},
- {1211, 1, &rule22},
- {1212, 1, &rule21},
- {1213, 1, &rule22},
- {1214, 1, &rule21},
- {1215, 1, &rule22},
- {1216, 1, &rule79},
- {1217, 1, &rule21},
- {1218, 1, &rule22},
- {1219, 1, &rule21},
- {1220, 1, &rule22},
- {1221, 1, &rule21},
- {1222, 1, &rule22},
- {1223, 1, &rule21},
- {1224, 1, &rule22},
- {1225, 1, &rule21},
- {1226, 1, &rule22},
- {1227, 1, &rule21},
- {1228, 1, &rule22},
- {1229, 1, &rule21},
- {1230, 1, &rule22},
- {1232, 1, &rule21},
- {1233, 1, &rule22},
- {1234, 1, &rule21},
- {1235, 1, &rule22},
- {1236, 1, &rule21},
- {1237, 1, &rule22},
- {1238, 1, &rule21},
- {1239, 1, &rule22},
- {1240, 1, &rule21},
- {1241, 1, &rule22},
- {1242, 1, &rule21},
- {1243, 1, &rule22},
- {1244, 1, &rule21},
- {1245, 1, &rule22},
- {1246, 1, &rule21},
- {1247, 1, &rule22},
- {1248, 1, &rule21},
- {1249, 1, &rule22},
- {1250, 1, &rule21},
- {1251, 1, &rule22},
- {1252, 1, &rule21},
- {1253, 1, &rule22},
- {1254, 1, &rule21},
- {1255, 1, &rule22},
- {1256, 1, &rule21},
- {1257, 1, &rule22},
- {1258, 1, &rule21},
- {1259, 1, &rule22},
- {1260, 1, &rule21},
- {1261, 1, &rule22},
- {1262, 1, &rule21},
- {1263, 1, &rule22},
- {1264, 1, &rule21},
- {1265, 1, &rule22},
- {1266, 1, &rule21},
- {1267, 1, &rule22},
- {1268, 1, &rule21},
- {1269, 1, &rule22},
- {1272, 1, &rule21},
- {1273, 1, &rule22},
- {1280, 1, &rule21},
- {1281, 1, &rule22},
- {1282, 1, &rule21},
- {1283, 1, &rule22},
- {1284, 1, &rule21},
- {1285, 1, &rule22},
- {1286, 1, &rule21},
- {1287, 1, &rule22},
- {1288, 1, &rule21},
- {1289, 1, &rule22},
- {1290, 1, &rule21},
- {1291, 1, &rule22},
- {1292, 1, &rule21},
- {1293, 1, &rule22},
- {1294, 1, &rule21},
- {1295, 1, &rule22},
- {1329, 38, &rule90},
- {1369, 1, &rule65},
- {1370, 6, &rule2},
- {1377, 38, &rule91},
- {1415, 1, &rule14},
- {1417, 1, &rule2},
- {1418, 1, &rule7},
- {1425, 17, &rule66},
- {1443, 23, &rule66},
- {1467, 3, &rule66},
- {1470, 1, &rule2},
- {1471, 1, &rule66},
- {1472, 1, &rule2},
- {1473, 2, &rule66},
- {1475, 1, &rule2},
- {1476, 1, &rule66},
- {1488, 27, &rule43},
- {1520, 3, &rule43},
- {1523, 2, &rule2},
- {1536, 4, &rule16},
- {1548, 2, &rule2},
- {1550, 2, &rule13},
- {1552, 6, &rule66},
- {1563, 1, &rule2},
- {1567, 1, &rule2},
- {1569, 26, &rule43},
- {1600, 1, &rule65},
- {1601, 10, &rule43},
- {1611, 14, &rule66},
- {1632, 10, &rule8},
- {1642, 4, &rule2},
- {1646, 2, &rule43},
- {1648, 1, &rule66},
- {1649, 99, &rule43},
- {1748, 1, &rule2},
- {1749, 1, &rule43},
- {1750, 7, &rule66},
- {1757, 1, &rule16},
- {1758, 1, &rule89},
- {1759, 6, &rule66},
- {1765, 2, &rule65},
- {1767, 2, &rule66},
- {1769, 1, &rule13},
- {1770, 4, &rule66},
- {1774, 2, &rule43},
- {1776, 10, &rule8},
- {1786, 3, &rule43},
- {1789, 2, &rule13},
- {1791, 1, &rule43},
- {1792, 14, &rule2},
- {1807, 1, &rule16},
- {1808, 1, &rule43},
- {1809, 1, &rule66},
- {1810, 30, &rule43},
- {1840, 27, &rule66},
- {1869, 3, &rule43},
- {1920, 38, &rule43},
- {1958, 11, &rule66},
- {1969, 1, &rule43},
- {2305, 2, &rule66},
- {2307, 1, &rule92},
- {2308, 54, &rule43},
- {2364, 1, &rule66},
- {2365, 1, &rule43},
- {2366, 3, &rule92},
- {2369, 8, &rule66},
- {2377, 4, &rule92},
- {2381, 1, &rule66},
- {2384, 1, &rule43},
- {2385, 4, &rule66},
- {2392, 10, &rule43},
- {2402, 2, &rule66},
- {2404, 2, &rule2},
- {2406, 10, &rule8},
- {2416, 1, &rule2},
- {2433, 1, &rule66},
- {2434, 2, &rule92},
- {2437, 8, &rule43},
- {2447, 2, &rule43},
- {2451, 22, &rule43},
- {2474, 7, &rule43},
- {2482, 1, &rule43},
- {2486, 4, &rule43},
- {2492, 1, &rule66},
- {2493, 1, &rule43},
- {2494, 3, &rule92},
- {2497, 4, &rule66},
- {2503, 2, &rule92},
- {2507, 2, &rule92},
- {2509, 1, &rule66},
- {2519, 1, &rule92},
- {2524, 2, &rule43},
- {2527, 3, &rule43},
- {2530, 2, &rule66},
- {2534, 10, &rule8},
- {2544, 2, &rule43},
- {2546, 2, &rule3},
- {2548, 6, &rule17},
- {2554, 1, &rule13},
- {2561, 2, &rule66},
- {2563, 1, &rule92},
- {2565, 6, &rule43},
- {2575, 2, &rule43},
- {2579, 22, &rule43},
- {2602, 7, &rule43},
- {2610, 2, &rule43},
- {2613, 2, &rule43},
- {2616, 2, &rule43},
- {2620, 1, &rule66},
- {2622, 3, &rule92},
- {2625, 2, &rule66},
- {2631, 2, &rule66},
- {2635, 3, &rule66},
- {2649, 4, &rule43},
- {2654, 1, &rule43},
- {2662, 10, &rule8},
- {2672, 2, &rule66},
- {2674, 3, &rule43},
- {2689, 2, &rule66},
- {2691, 1, &rule92},
- {2693, 9, &rule43},
- {2703, 3, &rule43},
- {2707, 22, &rule43},
- {2730, 7, &rule43},
- {2738, 2, &rule43},
- {2741, 5, &rule43},
- {2748, 1, &rule66},
- {2749, 1, &rule43},
- {2750, 3, &rule92},
- {2753, 5, &rule66},
- {2759, 2, &rule66},
- {2761, 1, &rule92},
- {2763, 2, &rule92},
- {2765, 1, &rule66},
- {2768, 1, &rule43},
- {2784, 2, &rule43},
- {2786, 2, &rule66},
- {2790, 10, &rule8},
- {2801, 1, &rule3},
- {2817, 1, &rule66},
- {2818, 2, &rule92},
- {2821, 8, &rule43},
- {2831, 2, &rule43},
- {2835, 22, &rule43},
- {2858, 7, &rule43},
- {2866, 2, &rule43},
- {2869, 5, &rule43},
- {2876, 1, &rule66},
- {2877, 1, &rule43},
- {2878, 1, &rule92},
- {2879, 1, &rule66},
- {2880, 1, &rule92},
- {2881, 3, &rule66},
- {2887, 2, &rule92},
- {2891, 2, &rule92},
- {2893, 1, &rule66},
- {2902, 1, &rule66},
- {2903, 1, &rule92},
- {2908, 2, &rule43},
- {2911, 3, &rule43},
- {2918, 10, &rule8},
- {2928, 1, &rule13},
- {2929, 1, &rule43},
- {2946, 1, &rule66},
- {2947, 1, &rule43},
- {2949, 6, &rule43},
- {2958, 3, &rule43},
- {2962, 4, &rule43},
- {2969, 2, &rule43},
- {2972, 1, &rule43},
- {2974, 2, &rule43},
- {2979, 2, &rule43},
- {2984, 3, &rule43},
- {2990, 8, &rule43},
- {2999, 3, &rule43},
- {3006, 2, &rule92},
- {3008, 1, &rule66},
- {3009, 2, &rule92},
- {3014, 3, &rule92},
- {3018, 3, &rule92},
- {3021, 1, &rule66},
- {3031, 1, &rule92},
- {3047, 9, &rule8},
- {3056, 3, &rule17},
- {3059, 6, &rule13},
- {3065, 1, &rule3},
- {3066, 1, &rule13},
- {3073, 3, &rule92},
- {3077, 8, &rule43},
- {3086, 3, &rule43},
- {3090, 23, &rule43},
- {3114, 10, &rule43},
- {3125, 5, &rule43},
- {3134, 3, &rule66},
- {3137, 4, &rule92},
- {3142, 3, &rule66},
- {3146, 4, &rule66},
- {3157, 2, &rule66},
- {3168, 2, &rule43},
- {3174, 10, &rule8},
- {3202, 2, &rule92},
- {3205, 8, &rule43},
- {3214, 3, &rule43},
- {3218, 23, &rule43},
- {3242, 10, &rule43},
- {3253, 5, &rule43},
- {3260, 1, &rule66},
- {3261, 1, &rule43},
- {3262, 1, &rule92},
- {3263, 1, &rule66},
- {3264, 5, &rule92},
- {3270, 1, &rule66},
- {3271, 2, &rule92},
- {3274, 2, &rule92},
- {3276, 2, &rule66},
- {3285, 2, &rule92},
- {3294, 1, &rule43},
- {3296, 2, &rule43},
- {3302, 10, &rule8},
- {3330, 2, &rule92},
- {3333, 8, &rule43},
- {3342, 3, &rule43},
- {3346, 23, &rule43},
- {3370, 16, &rule43},
- {3390, 3, &rule92},
- {3393, 3, &rule66},
- {3398, 3, &rule92},
- {3402, 3, &rule92},
- {3405, 1, &rule66},
- {3415, 1, &rule92},
- {3424, 2, &rule43},
- {3430, 10, &rule8},
- {3458, 2, &rule92},
- {3461, 18, &rule43},
- {3482, 24, &rule43},
- {3507, 9, &rule43},
- {3517, 1, &rule43},
- {3520, 7, &rule43},
- {3530, 1, &rule66},
- {3535, 3, &rule92},
- {3538, 3, &rule66},
- {3542, 1, &rule66},
- {3544, 8, &rule92},
- {3570, 2, &rule92},
- {3572, 1, &rule2},
- {3585, 48, &rule43},
- {3633, 1, &rule66},
- {3634, 2, &rule43},
- {3636, 7, &rule66},
- {3647, 1, &rule3},
- {3648, 6, &rule43},
- {3654, 1, &rule65},
- {3655, 8, &rule66},
- {3663, 1, &rule2},
- {3664, 10, &rule8},
- {3674, 2, &rule2},
- {3713, 2, &rule43},
- {3716, 1, &rule43},
- {3719, 2, &rule43},
- {3722, 1, &rule43},
- {3725, 1, &rule43},
- {3732, 4, &rule43},
- {3737, 7, &rule43},
- {3745, 3, &rule43},
- {3749, 1, &rule43},
- {3751, 1, &rule43},
- {3754, 2, &rule43},
- {3757, 4, &rule43},
- {3761, 1, &rule66},
- {3762, 2, &rule43},
- {3764, 6, &rule66},
- {3771, 2, &rule66},
- {3773, 1, &rule43},
- {3776, 5, &rule43},
- {3782, 1, &rule65},
- {3784, 6, &rule66},
- {3792, 10, &rule8},
- {3804, 2, &rule43},
- {3840, 1, &rule43},
- {3841, 3, &rule13},
- {3844, 15, &rule2},
- {3859, 5, &rule13},
- {3864, 2, &rule66},
- {3866, 6, &rule13},
- {3872, 10, &rule8},
- {3882, 10, &rule17},
- {3892, 1, &rule13},
- {3893, 1, &rule66},
- {3894, 1, &rule13},
- {3895, 1, &rule66},
- {3896, 1, &rule13},
- {3897, 1, &rule66},
- {3898, 1, &rule4},
- {3899, 1, &rule5},
- {3900, 1, &rule4},
- {3901, 1, &rule5},
- {3902, 2, &rule92},
- {3904, 8, &rule43},
- {3913, 34, &rule43},
- {3953, 14, &rule66},
- {3967, 1, &rule92},
- {3968, 5, &rule66},
- {3973, 1, &rule2},
- {3974, 2, &rule66},
- {3976, 4, &rule43},
- {3984, 8, &rule66},
- {3993, 36, &rule66},
- {4030, 8, &rule13},
- {4038, 1, &rule66},
- {4039, 6, &rule13},
- {4047, 1, &rule13},
- {4096, 34, &rule43},
- {4131, 5, &rule43},
- {4137, 2, &rule43},
- {4140, 1, &rule92},
- {4141, 4, &rule66},
- {4145, 1, &rule92},
- {4146, 1, &rule66},
- {4150, 2, &rule66},
- {4152, 1, &rule92},
- {4153, 1, &rule66},
- {4160, 10, &rule8},
- {4170, 6, &rule2},
- {4176, 6, &rule43},
- {4182, 2, &rule92},
- {4184, 2, &rule66},
- {4256, 38, &rule79},
- {4304, 41, &rule43},
- {4347, 1, &rule2},
- {4352, 90, &rule43},
- {4447, 68, &rule43},
- {4520, 82, &rule43},
- {4608, 7, &rule43},
- {4616, 63, &rule43},
- {4680, 1, &rule43},
- {4682, 4, &rule43},
- {4688, 7, &rule43},
- {4696, 1, &rule43},
- {4698, 4, &rule43},
- {4704, 39, &rule43},
- {4744, 1, &rule43},
- {4746, 4, &rule43},
- {4752, 31, &rule43},
- {4784, 1, &rule43},
- {4786, 4, &rule43},
- {4792, 7, &rule43},
- {4800, 1, &rule43},
- {4802, 4, &rule43},
- {4808, 7, &rule43},
- {4816, 7, &rule43},
- {4824, 23, &rule43},
- {4848, 31, &rule43},
- {4880, 1, &rule43},
- {4882, 4, &rule43},
- {4888, 7, &rule43},
- {4896, 39, &rule43},
- {4936, 19, &rule43},
- {4961, 8, &rule2},
- {4969, 9, &rule8},
- {4978, 11, &rule17},
- {5024, 85, &rule43},
- {5121, 620, &rule43},
- {5741, 2, &rule2},
- {5743, 8, &rule43},
- {5760, 1, &rule1},
- {5761, 26, &rule43},
- {5787, 1, &rule4},
- {5788, 1, &rule5},
- {5792, 75, &rule43},
- {5867, 3, &rule2},
- {5870, 3, &rule93},
- {5888, 13, &rule43},
- {5902, 4, &rule43},
- {5906, 3, &rule66},
- {5920, 18, &rule43},
- {5938, 3, &rule66},
- {5941, 2, &rule2},
- {5952, 18, &rule43},
- {5970, 2, &rule66},
- {5984, 13, &rule43},
- {5998, 3, &rule43},
- {6002, 2, &rule66},
- {6016, 52, &rule43},
- {6068, 2, &rule16},
- {6070, 1, &rule92},
- {6071, 7, &rule66},
- {6078, 8, &rule92},
- {6086, 1, &rule66},
- {6087, 2, &rule92},
- {6089, 11, &rule66},
- {6100, 3, &rule2},
- {6103, 1, &rule65},
- {6104, 3, &rule2},
- {6107, 1, &rule3},
- {6108, 1, &rule43},
- {6109, 1, &rule66},
- {6112, 10, &rule8},
- {6128, 10, &rule17},
- {6144, 6, &rule2},
- {6150, 1, &rule7},
- {6151, 4, &rule2},
- {6155, 3, &rule66},
- {6158, 1, &rule1},
- {6160, 10, &rule8},
- {6176, 35, &rule43},
- {6211, 1, &rule65},
- {6212, 52, &rule43},
- {6272, 41, &rule43},
- {6313, 1, &rule66},
- {6400, 29, &rule43},
- {6432, 3, &rule66},
- {6435, 4, &rule92},
- {6439, 2, &rule66},
- {6441, 3, &rule92},
- {6448, 2, &rule92},
- {6450, 1, &rule66},
- {6451, 6, &rule92},
- {6457, 3, &rule66},
- {6464, 1, &rule13},
- {6468, 2, &rule2},
- {6470, 10, &rule8},
- {6480, 30, &rule43},
- {6512, 5, &rule43},
- {6624, 32, &rule13},
- {7424, 44, &rule14},
- {7468, 54, &rule65},
- {7522, 10, &rule14},
- {7680, 1, &rule21},
- {7681, 1, &rule22},
- {7682, 1, &rule21},
- {7683, 1, &rule22},
- {7684, 1, &rule21},
- {7685, 1, &rule22},
- {7686, 1, &rule21},
- {7687, 1, &rule22},
- {7688, 1, &rule21},
- {7689, 1, &rule22},
- {7690, 1, &rule21},
- {7691, 1, &rule22},
- {7692, 1, &rule21},
- {7693, 1, &rule22},
- {7694, 1, &rule21},
- {7695, 1, &rule22},
- {7696, 1, &rule21},
- {7697, 1, &rule22},
- {7698, 1, &rule21},
- {7699, 1, &rule22},
- {7700, 1, &rule21},
- {7701, 1, &rule22},
- {7702, 1, &rule21},
- {7703, 1, &rule22},
- {7704, 1, &rule21},
- {7705, 1, &rule22},
- {7706, 1, &rule21},
- {7707, 1, &rule22},
- {7708, 1, &rule21},
- {7709, 1, &rule22},
- {7710, 1, &rule21},
- {7711, 1, &rule22},
- {7712, 1, &rule21},
- {7713, 1, &rule22},
- {7714, 1, &rule21},
- {7715, 1, &rule22},
- {7716, 1, &rule21},
- {7717, 1, &rule22},
- {7718, 1, &rule21},
- {7719, 1, &rule22},
- {7720, 1, &rule21},
- {7721, 1, &rule22},
- {7722, 1, &rule21},
- {7723, 1, &rule22},
- {7724, 1, &rule21},
- {7725, 1, &rule22},
- {7726, 1, &rule21},
- {7727, 1, &rule22},
- {7728, 1, &rule21},
- {7729, 1, &rule22},
- {7730, 1, &rule21},
- {7731, 1, &rule22},
- {7732, 1, &rule21},
- {7733, 1, &rule22},
- {7734, 1, &rule21},
- {7735, 1, &rule22},
- {7736, 1, &rule21},
- {7737, 1, &rule22},
- {7738, 1, &rule21},
- {7739, 1, &rule22},
- {7740, 1, &rule21},
- {7741, 1, &rule22},
- {7742, 1, &rule21},
- {7743, 1, &rule22},
- {7744, 1, &rule21},
- {7745, 1, &rule22},
- {7746, 1, &rule21},
- {7747, 1, &rule22},
- {7748, 1, &rule21},
- {7749, 1, &rule22},
- {7750, 1, &rule21},
- {7751, 1, &rule22},
- {7752, 1, &rule21},
- {7753, 1, &rule22},
- {7754, 1, &rule21},
- {7755, 1, &rule22},
- {7756, 1, &rule21},
- {7757, 1, &rule22},
- {7758, 1, &rule21},
- {7759, 1, &rule22},
- {7760, 1, &rule21},
- {7761, 1, &rule22},
- {7762, 1, &rule21},
- {7763, 1, &rule22},
- {7764, 1, &rule21},
- {7765, 1, &rule22},
- {7766, 1, &rule21},
- {7767, 1, &rule22},
- {7768, 1, &rule21},
- {7769, 1, &rule22},
- {7770, 1, &rule21},
- {7771, 1, &rule22},
- {7772, 1, &rule21},
- {7773, 1, &rule22},
- {7774, 1, &rule21},
- {7775, 1, &rule22},
- {7776, 1, &rule21},
- {7777, 1, &rule22},
- {7778, 1, &rule21},
- {7779, 1, &rule22},
- {7780, 1, &rule21},
- {7781, 1, &rule22},
- {7782, 1, &rule21},
- {7783, 1, &rule22},
- {7784, 1, &rule21},
- {7785, 1, &rule22},
- {7786, 1, &rule21},
- {7787, 1, &rule22},
- {7788, 1, &rule21},
- {7789, 1, &rule22},
- {7790, 1, &rule21},
- {7791, 1, &rule22},
- {7792, 1, &rule21},
- {7793, 1, &rule22},
- {7794, 1, &rule21},
- {7795, 1, &rule22},
- {7796, 1, &rule21},
- {7797, 1, &rule22},
- {7798, 1, &rule21},
- {7799, 1, &rule22},
- {7800, 1, &rule21},
- {7801, 1, &rule22},
- {7802, 1, &rule21},
- {7803, 1, &rule22},
- {7804, 1, &rule21},
- {7805, 1, &rule22},
- {7806, 1, &rule21},
- {7807, 1, &rule22},
- {7808, 1, &rule21},
- {7809, 1, &rule22},
- {7810, 1, &rule21},
- {7811, 1, &rule22},
- {7812, 1, &rule21},
- {7813, 1, &rule22},
- {7814, 1, &rule21},
- {7815, 1, &rule22},
- {7816, 1, &rule21},
- {7817, 1, &rule22},
- {7818, 1, &rule21},
- {7819, 1, &rule22},
- {7820, 1, &rule21},
- {7821, 1, &rule22},
- {7822, 1, &rule21},
- {7823, 1, &rule22},
- {7824, 1, &rule21},
- {7825, 1, &rule22},
- {7826, 1, &rule21},
- {7827, 1, &rule22},
- {7828, 1, &rule21},
- {7829, 1, &rule22},
- {7830, 5, &rule14},
- {7835, 1, &rule94},
- {7840, 1, &rule21},
- {7841, 1, &rule22},
- {7842, 1, &rule21},
- {7843, 1, &rule22},
- {7844, 1, &rule21},
- {7845, 1, &rule22},
- {7846, 1, &rule21},
- {7847, 1, &rule22},
- {7848, 1, &rule21},
- {7849, 1, &rule22},
- {7850, 1, &rule21},
- {7851, 1, &rule22},
- {7852, 1, &rule21},
- {7853, 1, &rule22},
- {7854, 1, &rule21},
- {7855, 1, &rule22},
- {7856, 1, &rule21},
- {7857, 1, &rule22},
- {7858, 1, &rule21},
- {7859, 1, &rule22},
- {7860, 1, &rule21},
- {7861, 1, &rule22},
- {7862, 1, &rule21},
- {7863, 1, &rule22},
- {7864, 1, &rule21},
- {7865, 1, &rule22},
- {7866, 1, &rule21},
- {7867, 1, &rule22},
- {7868, 1, &rule21},
- {7869, 1, &rule22},
- {7870, 1, &rule21},
- {7871, 1, &rule22},
- {7872, 1, &rule21},
- {7873, 1, &rule22},
- {7874, 1, &rule21},
- {7875, 1, &rule22},
- {7876, 1, &rule21},
- {7877, 1, &rule22},
- {7878, 1, &rule21},
- {7879, 1, &rule22},
- {7880, 1, &rule21},
- {7881, 1, &rule22},
- {7882, 1, &rule21},
- {7883, 1, &rule22},
- {7884, 1, &rule21},
- {7885, 1, &rule22},
- {7886, 1, &rule21},
- {7887, 1, &rule22},
- {7888, 1, &rule21},
- {7889, 1, &rule22},
- {7890, 1, &rule21},
- {7891, 1, &rule22},
- {7892, 1, &rule21},
- {7893, 1, &rule22},
- {7894, 1, &rule21},
- {7895, 1, &rule22},
- {7896, 1, &rule21},
- {7897, 1, &rule22},
- {7898, 1, &rule21},
- {7899, 1, &rule22},
- {7900, 1, &rule21},
- {7901, 1, &rule22},
- {7902, 1, &rule21},
- {7903, 1, &rule22},
- {7904, 1, &rule21},
- {7905, 1, &rule22},
- {7906, 1, &rule21},
- {7907, 1, &rule22},
- {7908, 1, &rule21},
- {7909, 1, &rule22},
- {7910, 1, &rule21},
- {7911, 1, &rule22},
- {7912, 1, &rule21},
- {7913, 1, &rule22},
- {7914, 1, &rule21},
- {7915, 1, &rule22},
- {7916, 1, &rule21},
- {7917, 1, &rule22},
- {7918, 1, &rule21},
- {7919, 1, &rule22},
- {7920, 1, &rule21},
- {7921, 1, &rule22},
- {7922, 1, &rule21},
- {7923, 1, &rule22},
- {7924, 1, &rule21},
- {7925, 1, &rule22},
- {7926, 1, &rule21},
- {7927, 1, &rule22},
- {7928, 1, &rule21},
- {7929, 1, &rule22},
- {7936, 8, &rule95},
- {7944, 8, &rule96},
- {7952, 6, &rule95},
- {7960, 6, &rule96},
- {7968, 8, &rule95},
- {7976, 8, &rule96},
- {7984, 8, &rule95},
- {7992, 8, &rule96},
- {8000, 6, &rule95},
- {8008, 6, &rule96},
- {8016, 1, &rule14},
- {8017, 1, &rule95},
- {8018, 1, &rule14},
- {8019, 1, &rule95},
- {8020, 1, &rule14},
- {8021, 1, &rule95},
- {8022, 1, &rule14},
- {8023, 1, &rule95},
- {8025, 1, &rule96},
- {8027, 1, &rule96},
- {8029, 1, &rule96},
- {8031, 1, &rule96},
- {8032, 8, &rule95},
- {8040, 8, &rule96},
- {8048, 2, &rule97},
- {8050, 4, &rule98},
- {8054, 2, &rule99},
- {8056, 2, &rule100},
- {8058, 2, &rule101},
- {8060, 2, &rule102},
- {8064, 8, &rule95},
- {8072, 8, &rule103},
- {8080, 8, &rule95},
- {8088, 8, &rule103},
- {8096, 8, &rule95},
- {8104, 8, &rule103},
- {8112, 2, &rule95},
- {8114, 1, &rule14},
- {8115, 1, &rule104},
- {8116, 1, &rule14},
- {8118, 2, &rule14},
- {8120, 2, &rule96},
- {8122, 2, &rule105},
- {8124, 1, &rule106},
- {8125, 1, &rule10},
- {8126, 1, &rule107},
- {8127, 3, &rule10},
- {8130, 1, &rule14},
- {8131, 1, &rule104},
- {8132, 1, &rule14},
- {8134, 2, &rule14},
- {8136, 4, &rule108},
- {8140, 1, &rule106},
- {8141, 3, &rule10},
- {8144, 2, &rule95},
- {8146, 2, &rule14},
- {8150, 2, &rule14},
- {8152, 2, &rule96},
- {8154, 2, &rule109},
- {8157, 3, &rule10},
- {8160, 2, &rule95},
- {8162, 3, &rule14},
- {8165, 1, &rule84},
- {8166, 2, &rule14},
- {8168, 2, &rule96},
- {8170, 2, &rule110},
- {8172, 1, &rule87},
- {8173, 3, &rule10},
- {8178, 1, &rule14},
- {8179, 1, &rule104},
- {8180, 1, &rule14},
- {8182, 2, &rule14},
- {8184, 2, &rule111},
- {8186, 2, &rule112},
- {8188, 1, &rule106},
- {8189, 2, &rule10},
- {8192, 12, &rule1},
- {8204, 4, &rule16},
- {8208, 6, &rule7},
- {8214, 2, &rule2},
- {8216, 1, &rule15},
- {8217, 1, &rule19},
- {8218, 1, &rule4},
- {8219, 2, &rule15},
- {8221, 1, &rule19},
- {8222, 1, &rule4},
- {8223, 1, &rule15},
- {8224, 8, &rule2},
- {8232, 1, &rule113},
- {8233, 1, &rule114},
- {8234, 5, &rule16},
- {8239, 1, &rule1},
- {8240, 9, &rule2},
- {8249, 1, &rule15},
- {8250, 1, &rule19},
- {8251, 4, &rule2},
- {8255, 2, &rule11},
- {8257, 3, &rule2},
- {8260, 1, &rule6},
- {8261, 1, &rule4},
- {8262, 1, &rule5},
- {8263, 11, &rule2},
- {8274, 1, &rule6},
- {8275, 1, &rule2},
- {8276, 1, &rule11},
- {8279, 1, &rule2},
- {8287, 1, &rule1},
- {8288, 4, &rule16},
- {8298, 6, &rule16},
- {8304, 1, &rule17},
- {8305, 1, &rule14},
- {8308, 6, &rule17},
- {8314, 3, &rule6},
- {8317, 1, &rule4},
- {8318, 1, &rule5},
- {8319, 1, &rule14},
- {8320, 10, &rule17},
- {8330, 3, &rule6},
- {8333, 1, &rule4},
- {8334, 1, &rule5},
- {8352, 18, &rule3},
- {8400, 13, &rule66},
- {8413, 4, &rule89},
- {8417, 1, &rule66},
- {8418, 3, &rule89},
- {8421, 6, &rule66},
- {8448, 2, &rule13},
- {8450, 1, &rule79},
- {8451, 4, &rule13},
- {8455, 1, &rule79},
- {8456, 2, &rule13},
- {8458, 1, &rule14},
- {8459, 3, &rule79},
- {8462, 2, &rule14},
- {8464, 3, &rule79},
- {8467, 1, &rule14},
- {8468, 1, &rule13},
- {8469, 1, &rule79},
- {8470, 3, &rule13},
- {8473, 5, &rule79},
- {8478, 6, &rule13},
- {8484, 1, &rule79},
- {8485, 1, &rule13},
- {8486, 1, &rule115},
- {8487, 1, &rule13},
- {8488, 1, &rule79},
- {8489, 1, &rule13},
- {8490, 1, &rule116},
- {8491, 1, &rule117},
- {8492, 2, &rule79},
- {8494, 1, &rule13},
- {8495, 1, &rule14},
- {8496, 2, &rule79},
- {8498, 1, &rule13},
- {8499, 1, &rule79},
- {8500, 1, &rule14},
- {8501, 4, &rule43},
- {8505, 1, &rule14},
- {8506, 2, &rule13},
- {8509, 1, &rule14},
- {8510, 2, &rule79},
- {8512, 5, &rule6},
- {8517, 1, &rule79},
- {8518, 4, &rule14},
- {8522, 1, &rule13},
- {8523, 1, &rule6},
- {8531, 13, &rule17},
- {8544, 16, &rule118},
- {8560, 16, &rule119},
- {8576, 4, &rule93},
- {8592, 5, &rule6},
- {8597, 5, &rule13},
- {8602, 2, &rule6},
- {8604, 4, &rule13},
- {8608, 1, &rule6},
- {8609, 2, &rule13},
- {8611, 1, &rule6},
- {8612, 2, &rule13},
- {8614, 1, &rule6},
- {8615, 7, &rule13},
- {8622, 1, &rule6},
- {8623, 31, &rule13},
- {8654, 2, &rule6},
- {8656, 2, &rule13},
- {8658, 1, &rule6},
- {8659, 1, &rule13},
- {8660, 1, &rule6},
- {8661, 31, &rule13},
- {8692, 268, &rule6},
- {8960, 8, &rule13},
- {8968, 4, &rule6},
- {8972, 20, &rule13},
- {8992, 2, &rule6},
- {8994, 7, &rule13},
- {9001, 1, &rule4},
- {9002, 1, &rule5},
- {9003, 81, &rule13},
- {9084, 1, &rule6},
- {9085, 30, &rule13},
- {9115, 25, &rule6},
- {9140, 1, &rule4},
- {9141, 1, &rule5},
- {9142, 1, &rule2},
- {9143, 26, &rule13},
- {9216, 39, &rule13},
- {9280, 11, &rule13},
- {9312, 60, &rule17},
- {9372, 26, &rule13},
- {9398, 26, &rule120},
- {9424, 26, &rule121},
- {9450, 22, &rule17},
- {9472, 183, &rule13},
- {9655, 1, &rule6},
- {9656, 9, &rule13},
- {9665, 1, &rule6},
- {9666, 54, &rule13},
- {9720, 8, &rule6},
- {9728, 24, &rule13},
- {9753, 86, &rule13},
- {9839, 1, &rule6},
- {9840, 14, &rule13},
- {9856, 18, &rule13},
- {9888, 2, &rule13},
- {9985, 4, &rule13},
- {9990, 4, &rule13},
- {9996, 28, &rule13},
- {10025, 35, &rule13},
- {10061, 1, &rule13},
- {10063, 4, &rule13},
- {10070, 1, &rule13},
- {10072, 7, &rule13},
- {10081, 7, &rule13},
- {10088, 1, &rule4},
- {10089, 1, &rule5},
- {10090, 1, &rule4},
- {10091, 1, &rule5},
- {10092, 1, &rule4},
- {10093, 1, &rule5},
- {10094, 1, &rule4},
- {10095, 1, &rule5},
- {10096, 1, &rule4},
- {10097, 1, &rule5},
- {10098, 1, &rule4},
- {10099, 1, &rule5},
- {10100, 1, &rule4},
- {10101, 1, &rule5},
- {10102, 30, &rule17},
- {10132, 1, &rule13},
- {10136, 24, &rule13},
- {10161, 14, &rule13},
- {10192, 22, &rule6},
- {10214, 1, &rule4},
- {10215, 1, &rule5},
- {10216, 1, &rule4},
- {10217, 1, &rule5},
- {10218, 1, &rule4},
- {10219, 1, &rule5},
- {10224, 16, &rule6},
- {10240, 256, &rule13},
- {10496, 131, &rule6},
- {10627, 1, &rule4},
- {10628, 1, &rule5},
- {10629, 1, &rule4},
- {10630, 1, &rule5},
- {10631, 1, &rule4},
- {10632, 1, &rule5},
- {10633, 1, &rule4},
- {10634, 1, &rule5},
- {10635, 1, &rule4},
- {10636, 1, &rule5},
- {10637, 1, &rule4},
- {10638, 1, &rule5},
- {10639, 1, &rule4},
- {10640, 1, &rule5},
- {10641, 1, &rule4},
- {10642, 1, &rule5},
- {10643, 1, &rule4},
- {10644, 1, &rule5},
- {10645, 1, &rule4},
- {10646, 1, &rule5},
- {10647, 1, &rule4},
- {10648, 1, &rule5},
- {10649, 63, &rule6},
- {10712, 1, &rule4},
- {10713, 1, &rule5},
- {10714, 1, &rule4},
- {10715, 1, &rule5},
- {10716, 32, &rule6},
- {10748, 1, &rule4},
- {10749, 1, &rule5},
- {10750, 258, &rule6},
- {11008, 14, &rule13},
- {11904, 26, &rule13},
- {11931, 89, &rule13},
- {12032, 214, &rule13},
- {12272, 12, &rule13},
- {12288, 1, &rule1},
- {12289, 3, &rule2},
- {12292, 1, &rule13},
- {12293, 1, &rule65},
- {12294, 1, &rule43},
- {12295, 1, &rule93},
- {12296, 1, &rule4},
- {12297, 1, &rule5},
- {12298, 1, &rule4},
- {12299, 1, &rule5},
- {12300, 1, &rule4},
- {12301, 1, &rule5},
- {12302, 1, &rule4},
- {12303, 1, &rule5},
- {12304, 1, &rule4},
- {12305, 1, &rule5},
- {12306, 2, &rule13},
- {12308, 1, &rule4},
- {12309, 1, &rule5},
- {12310, 1, &rule4},
- {12311, 1, &rule5},
- {12312, 1, &rule4},
- {12313, 1, &rule5},
- {12314, 1, &rule4},
- {12315, 1, &rule5},
- {12316, 1, &rule7},
- {12317, 1, &rule4},
- {12318, 2, &rule5},
- {12320, 1, &rule13},
- {12321, 9, &rule93},
- {12330, 6, &rule66},
- {12336, 1, &rule7},
- {12337, 5, &rule65},
- {12342, 2, &rule13},
- {12344, 3, &rule93},
- {12347, 1, &rule65},
- {12348, 1, &rule43},
- {12349, 1, &rule2},
- {12350, 2, &rule13},
- {12353, 86, &rule43},
- {12441, 2, &rule66},
- {12443, 2, &rule10},
- {12445, 2, &rule65},
- {12447, 1, &rule43},
- {12448, 1, &rule7},
- {12449, 90, &rule43},
- {12539, 1, &rule11},
- {12540, 3, &rule65},
- {12543, 1, &rule43},
- {12549, 40, &rule43},
- {12593, 94, &rule43},
- {12688, 2, &rule13},
- {12690, 4, &rule17},
- {12694, 10, &rule13},
- {12704, 24, &rule43},
- {12784, 16, &rule43},
- {12800, 31, &rule13},
- {12832, 10, &rule17},
- {12842, 26, &rule13},
- {12880, 1, &rule13},
- {12881, 15, &rule17},
- {12896, 30, &rule13},
- {12927, 1, &rule13},
- {12928, 10, &rule17},
- {12938, 39, &rule13},
- {12977, 15, &rule17},
- {12992, 63, &rule13},
- {13056, 256, &rule13},
- {13312, 6582, &rule43},
- {19904, 64, &rule13},
- {19968, 20902, &rule43},
- {40960, 1165, &rule43},
- {42128, 55, &rule13},
- {44032, 11172, &rule43},
- {55296, 896, &rule122},
- {56192, 128, &rule122},
- {56320, 1024, &rule122},
- {57344, 6400, &rule123},
- {63744, 302, &rule43},
- {64048, 59, &rule43},
- {64256, 7, &rule14},
- {64275, 5, &rule14},
- {64285, 1, &rule43},
- {64286, 1, &rule66},
- {64287, 10, &rule43},
- {64297, 1, &rule6},
- {64298, 13, &rule43},
- {64312, 5, &rule43},
- {64318, 1, &rule43},
- {64320, 2, &rule43},
- {64323, 2, &rule43},
- {64326, 108, &rule43},
- {64467, 363, &rule43},
- {64830, 1, &rule4},
- {64831, 1, &rule5},
- {64848, 64, &rule43},
- {64914, 54, &rule43},
- {65008, 12, &rule43},
- {65020, 1, &rule3},
- {65021, 1, &rule13},
- {65024, 16, &rule66},
- {65056, 4, &rule66},
- {65072, 1, &rule2},
- {65073, 2, &rule7},
- {65075, 2, &rule11},
- {65077, 1, &rule4},
- {65078, 1, &rule5},
- {65079, 1, &rule4},
- {65080, 1, &rule5},
- {65081, 1, &rule4},
- {65082, 1, &rule5},
- {65083, 1, &rule4},
- {65084, 1, &rule5},
- {65085, 1, &rule4},
- {65086, 1, &rule5},
- {65087, 1, &rule4},
- {65088, 1, &rule5},
- {65089, 1, &rule4},
- {65090, 1, &rule5},
- {65091, 1, &rule4},
- {65092, 1, &rule5},
- {65093, 2, &rule2},
- {65095, 1, &rule4},
- {65096, 1, &rule5},
- {65097, 4, &rule2},
- {65101, 3, &rule11},
- {65104, 3, &rule2},
- {65108, 4, &rule2},
- {65112, 1, &rule7},
- {65113, 1, &rule4},
- {65114, 1, &rule5},
- {65115, 1, &rule4},
- {65116, 1, &rule5},
- {65117, 1, &rule4},
- {65118, 1, &rule5},
- {65119, 3, &rule2},
- {65122, 1, &rule6},
- {65123, 1, &rule7},
- {65124, 3, &rule6},
- {65128, 1, &rule2},
- {65129, 1, &rule3},
- {65130, 2, &rule2},
- {65136, 5, &rule43},
- {65142, 135, &rule43},
- {65279, 1, &rule16},
- {65281, 3, &rule2},
- {65284, 1, &rule3},
- {65285, 3, &rule2},
- {65288, 1, &rule4},
- {65289, 1, &rule5},
- {65290, 1, &rule2},
- {65291, 1, &rule6},
- {65292, 1, &rule2},
- {65293, 1, &rule7},
- {65294, 2, &rule2},
- {65296, 10, &rule8},
- {65306, 2, &rule2},
- {65308, 3, &rule6},
- {65311, 2, &rule2},
- {65313, 26, &rule9},
- {65339, 1, &rule4},
- {65340, 1, &rule2},
- {65341, 1, &rule5},
- {65342, 1, &rule10},
- {65343, 1, &rule11},
- {65344, 1, &rule10},
- {65345, 26, &rule12},
- {65371, 1, &rule4},
- {65372, 1, &rule6},
- {65373, 1, &rule5},
- {65374, 1, &rule6},
- {65375, 1, &rule4},
- {65376, 1, &rule5},
- {65377, 1, &rule2},
- {65378, 1, &rule4},
- {65379, 1, &rule5},
- {65380, 1, &rule2},
- {65381, 1, &rule11},
- {65382, 10, &rule43},
- {65392, 1, &rule65},
- {65393, 45, &rule43},
- {65438, 2, &rule65},
- {65440, 31, &rule43},
- {65474, 6, &rule43},
- {65482, 6, &rule43},
- {65490, 6, &rule43},
- {65498, 3, &rule43},
- {65504, 2, &rule3},
- {65506, 1, &rule6},
- {65507, 1, &rule10},
- {65508, 1, &rule13},
- {65509, 2, &rule3},
- {65512, 1, &rule13},
- {65513, 4, &rule6},
- {65517, 2, &rule13},
- {65529, 3, &rule16},
- {65532, 2, &rule13},
- {65536, 12, &rule43},
- {65549, 26, &rule43},
- {65576, 19, &rule43},
- {65596, 2, &rule43},
- {65599, 15, &rule43},
- {65616, 14, &rule43},
- {65664, 123, &rule43},
- {65792, 2, &rule2},
- {65794, 1, &rule13},
- {65799, 45, &rule17},
- {65847, 9, &rule13},
- {66304, 31, &rule43},
- {66336, 4, &rule17},
- {66352, 26, &rule43},
- {66378, 1, &rule93},
- {66432, 30, &rule43},
- {66463, 1, &rule2},
- {66560, 40, &rule124},
- {66600, 40, &rule125},
- {66640, 78, &rule43},
- {66720, 10, &rule8},
- {67584, 6, &rule43},
- {67592, 1, &rule43},
- {67594, 44, &rule43},
- {67639, 2, &rule43},
- {67644, 1, &rule43},
- {67647, 1, &rule43},
- {118784, 246, &rule13},
- {119040, 39, &rule13},
- {119082, 59, &rule13},
- {119141, 2, &rule92},
- {119143, 3, &rule66},
- {119146, 3, &rule13},
- {119149, 6, &rule92},
- {119155, 8, &rule16},
- {119163, 8, &rule66},
- {119171, 2, &rule13},
- {119173, 7, &rule66},
- {119180, 30, &rule13},
- {119210, 4, &rule66},
- {119214, 48, &rule13},
- {119552, 87, &rule13},
- {119808, 26, &rule79},
- {119834, 26, &rule14},
- {119860, 26, &rule79},
- {119886, 7, &rule14},
- {119894, 18, &rule14},
- {119912, 26, &rule79},
- {119938, 26, &rule14},
- {119964, 1, &rule79},
- {119966, 2, &rule79},
- {119970, 1, &rule79},
- {119973, 2, &rule79},
- {119977, 4, &rule79},
- {119982, 8, &rule79},
- {119990, 4, &rule14},
- {119995, 1, &rule14},
- {119997, 7, &rule14},
- {120005, 11, &rule14},
- {120016, 26, &rule79},
- {120042, 26, &rule14},
- {120068, 2, &rule79},
- {120071, 4, &rule79},
- {120077, 8, &rule79},
- {120086, 7, &rule79},
- {120094, 26, &rule14},
- {120120, 2, &rule79},
- {120123, 4, &rule79},
- {120128, 5, &rule79},
- {120134, 1, &rule79},
- {120138, 7, &rule79},
- {120146, 26, &rule14},
- {120172, 26, &rule79},
- {120198, 26, &rule14},
- {120224, 26, &rule79},
- {120250, 26, &rule14},
- {120276, 26, &rule79},
- {120302, 26, &rule14},
- {120328, 26, &rule79},
- {120354, 26, &rule14},
- {120380, 26, &rule79},
- {120406, 26, &rule14},
- {120432, 26, &rule79},
- {120458, 26, &rule14},
- {120488, 25, &rule79},
- {120513, 1, &rule6},
- {120514, 25, &rule14},
- {120539, 1, &rule6},
- {120540, 6, &rule14},
- {120546, 25, &rule79},
- {120571, 1, &rule6},
- {120572, 25, &rule14},
- {120597, 1, &rule6},
- {120598, 6, &rule14},
- {120604, 25, &rule79},
- {120629, 1, &rule6},
- {120630, 25, &rule14},
- {120655, 1, &rule6},
- {120656, 6, &rule14},
- {120662, 25, &rule79},
- {120687, 1, &rule6},
- {120688, 25, &rule14},
- {120713, 1, &rule6},
- {120714, 6, &rule14},
- {120720, 25, &rule79},
- {120745, 1, &rule6},
- {120746, 25, &rule14},
- {120771, 1, &rule6},
- {120772, 6, &rule14},
- {120782, 50, &rule8},
- {131072, 42711, &rule43},
- {194560, 542, &rule43},
- {917505, 1, &rule16},
- {917536, 96, &rule16},
- {917760, 240, &rule66},
- {983040, 65534, &rule123},
- {1048576, 65534, &rule123}
-};
-static const struct _charblock_ convchars[]={
- {65, 26, &rule9},
- {97, 26, &rule12},
- {181, 1, &rule18},
- {192, 23, &rule9},
- {216, 7, &rule9},
- {224, 23, &rule12},
- {248, 7, &rule12},
- {255, 1, &rule20},
- {256, 1, &rule21},
- {257, 1, &rule22},
- {258, 1, &rule21},
- {259, 1, &rule22},
- {260, 1, &rule21},
- {261, 1, &rule22},
- {262, 1, &rule21},
- {263, 1, &rule22},
- {264, 1, &rule21},
- {265, 1, &rule22},
- {266, 1, &rule21},
- {267, 1, &rule22},
- {268, 1, &rule21},
- {269, 1, &rule22},
- {270, 1, &rule21},
- {271, 1, &rule22},
- {272, 1, &rule21},
- {273, 1, &rule22},
- {274, 1, &rule21},
- {275, 1, &rule22},
- {276, 1, &rule21},
- {277, 1, &rule22},
- {278, 1, &rule21},
- {279, 1, &rule22},
- {280, 1, &rule21},
- {281, 1, &rule22},
- {282, 1, &rule21},
- {283, 1, &rule22},
- {284, 1, &rule21},
- {285, 1, &rule22},
- {286, 1, &rule21},
- {287, 1, &rule22},
- {288, 1, &rule21},
- {289, 1, &rule22},
- {290, 1, &rule21},
- {291, 1, &rule22},
- {292, 1, &rule21},
- {293, 1, &rule22},
- {294, 1, &rule21},
- {295, 1, &rule22},
- {296, 1, &rule21},
- {297, 1, &rule22},
- {298, 1, &rule21},
- {299, 1, &rule22},
- {300, 1, &rule21},
- {301, 1, &rule22},
- {302, 1, &rule21},
- {303, 1, &rule22},
- {304, 1, &rule23},
- {305, 1, &rule24},
- {306, 1, &rule21},
- {307, 1, &rule22},
- {308, 1, &rule21},
- {309, 1, &rule22},
- {310, 1, &rule21},
- {311, 1, &rule22},
- {313, 1, &rule21},
- {314, 1, &rule22},
- {315, 1, &rule21},
- {316, 1, &rule22},
- {317, 1, &rule21},
- {318, 1, &rule22},
- {319, 1, &rule21},
- {320, 1, &rule22},
- {321, 1, &rule21},
- {322, 1, &rule22},
- {323, 1, &rule21},
- {324, 1, &rule22},
- {325, 1, &rule21},
- {326, 1, &rule22},
- {327, 1, &rule21},
- {328, 1, &rule22},
- {330, 1, &rule21},
- {331, 1, &rule22},
- {332, 1, &rule21},
- {333, 1, &rule22},
- {334, 1, &rule21},
- {335, 1, &rule22},
- {336, 1, &rule21},
- {337, 1, &rule22},
- {338, 1, &rule21},
- {339, 1, &rule22},
- {340, 1, &rule21},
- {341, 1, &rule22},
- {342, 1, &rule21},
- {343, 1, &rule22},
- {344, 1, &rule21},
- {345, 1, &rule22},
- {346, 1, &rule21},
- {347, 1, &rule22},
- {348, 1, &rule21},
- {349, 1, &rule22},
- {350, 1, &rule21},
- {351, 1, &rule22},
- {352, 1, &rule21},
- {353, 1, &rule22},
- {354, 1, &rule21},
- {355, 1, &rule22},
- {356, 1, &rule21},
- {357, 1, &rule22},
- {358, 1, &rule21},
- {359, 1, &rule22},
- {360, 1, &rule21},
- {361, 1, &rule22},
- {362, 1, &rule21},
- {363, 1, &rule22},
- {364, 1, &rule21},
- {365, 1, &rule22},
- {366, 1, &rule21},
- {367, 1, &rule22},
- {368, 1, &rule21},
- {369, 1, &rule22},
- {370, 1, &rule21},
- {371, 1, &rule22},
- {372, 1, &rule21},
- {373, 1, &rule22},
- {374, 1, &rule21},
- {375, 1, &rule22},
- {376, 1, &rule25},
- {377, 1, &rule21},
- {378, 1, &rule22},
- {379, 1, &rule21},
- {380, 1, &rule22},
- {381, 1, &rule21},
- {382, 1, &rule22},
- {383, 1, &rule26},
- {385, 1, &rule27},
- {386, 1, &rule21},
- {387, 1, &rule22},
- {388, 1, &rule21},
- {389, 1, &rule22},
- {390, 1, &rule28},
- {391, 1, &rule21},
- {392, 1, &rule22},
- {393, 2, &rule29},
- {395, 1, &rule21},
- {396, 1, &rule22},
- {398, 1, &rule30},
- {399, 1, &rule31},
- {400, 1, &rule32},
- {401, 1, &rule21},
- {402, 1, &rule22},
- {403, 1, &rule29},
- {404, 1, &rule33},
- {405, 1, &rule34},
- {406, 1, &rule35},
- {407, 1, &rule36},
- {408, 1, &rule21},
- {409, 1, &rule22},
- {412, 1, &rule35},
- {413, 1, &rule37},
- {414, 1, &rule38},
- {415, 1, &rule39},
- {416, 1, &rule21},
- {417, 1, &rule22},
- {418, 1, &rule21},
- {419, 1, &rule22},
- {420, 1, &rule21},
- {421, 1, &rule22},
- {422, 1, &rule40},
- {423, 1, &rule21},
- {424, 1, &rule22},
- {425, 1, &rule40},
- {428, 1, &rule21},
- {429, 1, &rule22},
- {430, 1, &rule40},
- {431, 1, &rule21},
- {432, 1, &rule22},
- {433, 2, &rule41},
- {435, 1, &rule21},
- {436, 1, &rule22},
- {437, 1, &rule21},
- {438, 1, &rule22},
- {439, 1, &rule42},
- {440, 1, &rule21},
- {441, 1, &rule22},
- {444, 1, &rule21},
- {445, 1, &rule22},
- {447, 1, &rule44},
- {452, 1, &rule45},
- {453, 1, &rule46},
- {454, 1, &rule47},
- {455, 1, &rule45},
- {456, 1, &rule46},
- {457, 1, &rule47},
- {458, 1, &rule45},
- {459, 1, &rule46},
- {460, 1, &rule47},
- {461, 1, &rule21},
- {462, 1, &rule22},
- {463, 1, &rule21},
- {464, 1, &rule22},
- {465, 1, &rule21},
- {466, 1, &rule22},
- {467, 1, &rule21},
- {468, 1, &rule22},
- {469, 1, &rule21},
- {470, 1, &rule22},
- {471, 1, &rule21},
- {472, 1, &rule22},
- {473, 1, &rule21},
- {474, 1, &rule22},
- {475, 1, &rule21},
- {476, 1, &rule22},
- {477, 1, &rule48},
- {478, 1, &rule21},
- {479, 1, &rule22},
- {480, 1, &rule21},
- {481, 1, &rule22},
- {482, 1, &rule21},
- {483, 1, &rule22},
- {484, 1, &rule21},
- {485, 1, &rule22},
- {486, 1, &rule21},
- {487, 1, &rule22},
- {488, 1, &rule21},
- {489, 1, &rule22},
- {490, 1, &rule21},
- {491, 1, &rule22},
- {492, 1, &rule21},
- {493, 1, &rule22},
- {494, 1, &rule21},
- {495, 1, &rule22},
- {497, 1, &rule45},
- {498, 1, &rule46},
- {499, 1, &rule47},
- {500, 1, &rule21},
- {501, 1, &rule22},
- {502, 1, &rule49},
- {503, 1, &rule50},
- {504, 1, &rule21},
- {505, 1, &rule22},
- {506, 1, &rule21},
- {507, 1, &rule22},
- {508, 1, &rule21},
- {509, 1, &rule22},
- {510, 1, &rule21},
- {511, 1, &rule22},
- {512, 1, &rule21},
- {513, 1, &rule22},
- {514, 1, &rule21},
- {515, 1, &rule22},
- {516, 1, &rule21},
- {517, 1, &rule22},
- {518, 1, &rule21},
- {519, 1, &rule22},
- {520, 1, &rule21},
- {521, 1, &rule22},
- {522, 1, &rule21},
- {523, 1, &rule22},
- {524, 1, &rule21},
- {525, 1, &rule22},
- {526, 1, &rule21},
- {527, 1, &rule22},
- {528, 1, &rule21},
- {529, 1, &rule22},
- {530, 1, &rule21},
- {531, 1, &rule22},
- {532, 1, &rule21},
- {533, 1, &rule22},
- {534, 1, &rule21},
- {535, 1, &rule22},
- {536, 1, &rule21},
- {537, 1, &rule22},
- {538, 1, &rule21},
- {539, 1, &rule22},
- {540, 1, &rule21},
- {541, 1, &rule22},
- {542, 1, &rule21},
- {543, 1, &rule22},
- {544, 1, &rule51},
- {546, 1, &rule21},
- {547, 1, &rule22},
- {548, 1, &rule21},
- {549, 1, &rule22},
- {550, 1, &rule21},
- {551, 1, &rule22},
- {552, 1, &rule21},
- {553, 1, &rule22},
- {554, 1, &rule21},
- {555, 1, &rule22},
- {556, 1, &rule21},
- {557, 1, &rule22},
- {558, 1, &rule21},
- {559, 1, &rule22},
- {560, 1, &rule21},
- {561, 1, &rule22},
- {562, 1, &rule21},
- {563, 1, &rule22},
- {595, 1, &rule52},
- {596, 1, &rule53},
- {598, 2, &rule54},
- {601, 1, &rule55},
- {603, 1, &rule56},
- {608, 1, &rule54},
- {611, 1, &rule57},
- {616, 1, &rule58},
- {617, 1, &rule59},
- {623, 1, &rule59},
- {626, 1, &rule60},
- {629, 1, &rule61},
- {640, 1, &rule62},
- {643, 1, &rule62},
- {648, 1, &rule62},
- {650, 2, &rule63},
- {658, 1, &rule64},
- {837, 1, &rule67},
- {902, 1, &rule68},
- {904, 3, &rule69},
- {908, 1, &rule70},
- {910, 2, &rule71},
- {913, 17, &rule9},
- {931, 9, &rule9},
- {940, 1, &rule72},
- {941, 3, &rule73},
- {945, 17, &rule12},
- {962, 1, &rule74},
- {963, 9, &rule12},
- {972, 1, &rule75},
- {973, 2, &rule76},
- {976, 1, &rule77},
- {977, 1, &rule78},
- {981, 1, &rule80},
- {982, 1, &rule81},
- {984, 1, &rule21},
- {985, 1, &rule22},
- {986, 1, &rule21},
- {987, 1, &rule22},
- {988, 1, &rule21},
- {989, 1, &rule22},
- {990, 1, &rule21},
- {991, 1, &rule22},
- {992, 1, &rule21},
- {993, 1, &rule22},
- {994, 1, &rule21},
- {995, 1, &rule22},
- {996, 1, &rule21},
- {997, 1, &rule22},
- {998, 1, &rule21},
- {999, 1, &rule22},
- {1000, 1, &rule21},
- {1001, 1, &rule22},
- {1002, 1, &rule21},
- {1003, 1, &rule22},
- {1004, 1, &rule21},
- {1005, 1, &rule22},
- {1006, 1, &rule21},
- {1007, 1, &rule22},
- {1008, 1, &rule82},
- {1009, 1, &rule83},
- {1010, 1, &rule84},
- {1012, 1, &rule85},
- {1013, 1, &rule86},
- {1015, 1, &rule21},
- {1016, 1, &rule22},
- {1017, 1, &rule87},
- {1018, 1, &rule21},
- {1019, 1, &rule22},
- {1024, 16, &rule88},
- {1040, 32, &rule9},
- {1072, 32, &rule12},
- {1104, 16, &rule83},
- {1120, 1, &rule21},
- {1121, 1, &rule22},
- {1122, 1, &rule21},
- {1123, 1, &rule22},
- {1124, 1, &rule21},
- {1125, 1, &rule22},
- {1126, 1, &rule21},
- {1127, 1, &rule22},
- {1128, 1, &rule21},
- {1129, 1, &rule22},
- {1130, 1, &rule21},
- {1131, 1, &rule22},
- {1132, 1, &rule21},
- {1133, 1, &rule22},
- {1134, 1, &rule21},
- {1135, 1, &rule22},
- {1136, 1, &rule21},
- {1137, 1, &rule22},
- {1138, 1, &rule21},
- {1139, 1, &rule22},
- {1140, 1, &rule21},
- {1141, 1, &rule22},
- {1142, 1, &rule21},
- {1143, 1, &rule22},
- {1144, 1, &rule21},
- {1145, 1, &rule22},
- {1146, 1, &rule21},
- {1147, 1, &rule22},
- {1148, 1, &rule21},
- {1149, 1, &rule22},
- {1150, 1, &rule21},
- {1151, 1, &rule22},
- {1152, 1, &rule21},
- {1153, 1, &rule22},
- {1162, 1, &rule21},
- {1163, 1, &rule22},
- {1164, 1, &rule21},
- {1165, 1, &rule22},
- {1166, 1, &rule21},
- {1167, 1, &rule22},
- {1168, 1, &rule21},
- {1169, 1, &rule22},
- {1170, 1, &rule21},
- {1171, 1, &rule22},
- {1172, 1, &rule21},
- {1173, 1, &rule22},
- {1174, 1, &rule21},
- {1175, 1, &rule22},
- {1176, 1, &rule21},
- {1177, 1, &rule22},
- {1178, 1, &rule21},
- {1179, 1, &rule22},
- {1180, 1, &rule21},
- {1181, 1, &rule22},
- {1182, 1, &rule21},
- {1183, 1, &rule22},
- {1184, 1, &rule21},
- {1185, 1, &rule22},
- {1186, 1, &rule21},
- {1187, 1, &rule22},
- {1188, 1, &rule21},
- {1189, 1, &rule22},
- {1190, 1, &rule21},
- {1191, 1, &rule22},
- {1192, 1, &rule21},
- {1193, 1, &rule22},
- {1194, 1, &rule21},
- {1195, 1, &rule22},
- {1196, 1, &rule21},
- {1197, 1, &rule22},
- {1198, 1, &rule21},
- {1199, 1, &rule22},
- {1200, 1, &rule21},
- {1201, 1, &rule22},
- {1202, 1, &rule21},
- {1203, 1, &rule22},
- {1204, 1, &rule21},
- {1205, 1, &rule22},
- {1206, 1, &rule21},
- {1207, 1, &rule22},
- {1208, 1, &rule21},
- {1209, 1, &rule22},
- {1210, 1, &rule21},
- {1211, 1, &rule22},
- {1212, 1, &rule21},
- {1213, 1, &rule22},
- {1214, 1, &rule21},
- {1215, 1, &rule22},
- {1217, 1, &rule21},
- {1218, 1, &rule22},
- {1219, 1, &rule21},
- {1220, 1, &rule22},
- {1221, 1, &rule21},
- {1222, 1, &rule22},
- {1223, 1, &rule21},
- {1224, 1, &rule22},
- {1225, 1, &rule21},
- {1226, 1, &rule22},
- {1227, 1, &rule21},
- {1228, 1, &rule22},
- {1229, 1, &rule21},
- {1230, 1, &rule22},
- {1232, 1, &rule21},
- {1233, 1, &rule22},
- {1234, 1, &rule21},
- {1235, 1, &rule22},
- {1236, 1, &rule21},
- {1237, 1, &rule22},
- {1238, 1, &rule21},
- {1239, 1, &rule22},
- {1240, 1, &rule21},
- {1241, 1, &rule22},
- {1242, 1, &rule21},
- {1243, 1, &rule22},
- {1244, 1, &rule21},
- {1245, 1, &rule22},
- {1246, 1, &rule21},
- {1247, 1, &rule22},
- {1248, 1, &rule21},
- {1249, 1, &rule22},
- {1250, 1, &rule21},
- {1251, 1, &rule22},
- {1252, 1, &rule21},
- {1253, 1, &rule22},
- {1254, 1, &rule21},
- {1255, 1, &rule22},
- {1256, 1, &rule21},
- {1257, 1, &rule22},
- {1258, 1, &rule21},
- {1259, 1, &rule22},
- {1260, 1, &rule21},
- {1261, 1, &rule22},
- {1262, 1, &rule21},
- {1263, 1, &rule22},
- {1264, 1, &rule21},
- {1265, 1, &rule22},
- {1266, 1, &rule21},
- {1267, 1, &rule22},
- {1268, 1, &rule21},
- {1269, 1, &rule22},
- {1272, 1, &rule21},
- {1273, 1, &rule22},
- {1280, 1, &rule21},
- {1281, 1, &rule22},
- {1282, 1, &rule21},
- {1283, 1, &rule22},
- {1284, 1, &rule21},
- {1285, 1, &rule22},
- {1286, 1, &rule21},
- {1287, 1, &rule22},
- {1288, 1, &rule21},
- {1289, 1, &rule22},
- {1290, 1, &rule21},
- {1291, 1, &rule22},
- {1292, 1, &rule21},
- {1293, 1, &rule22},
- {1294, 1, &rule21},
- {1295, 1, &rule22},
- {1329, 38, &rule90},
- {1377, 38, &rule91},
- {7680, 1, &rule21},
- {7681, 1, &rule22},
- {7682, 1, &rule21},
- {7683, 1, &rule22},
- {7684, 1, &rule21},
- {7685, 1, &rule22},
- {7686, 1, &rule21},
- {7687, 1, &rule22},
- {7688, 1, &rule21},
- {7689, 1, &rule22},
- {7690, 1, &rule21},
- {7691, 1, &rule22},
- {7692, 1, &rule21},
- {7693, 1, &rule22},
- {7694, 1, &rule21},
- {7695, 1, &rule22},
- {7696, 1, &rule21},
- {7697, 1, &rule22},
- {7698, 1, &rule21},
- {7699, 1, &rule22},
- {7700, 1, &rule21},
- {7701, 1, &rule22},
- {7702, 1, &rule21},
- {7703, 1, &rule22},
- {7704, 1, &rule21},
- {7705, 1, &rule22},
- {7706, 1, &rule21},
- {7707, 1, &rule22},
- {7708, 1, &rule21},
- {7709, 1, &rule22},
- {7710, 1, &rule21},
- {7711, 1, &rule22},
- {7712, 1, &rule21},
- {7713, 1, &rule22},
- {7714, 1, &rule21},
- {7715, 1, &rule22},
- {7716, 1, &rule21},
- {7717, 1, &rule22},
- {7718, 1, &rule21},
- {7719, 1, &rule22},
- {7720, 1, &rule21},
- {7721, 1, &rule22},
- {7722, 1, &rule21},
- {7723, 1, &rule22},
- {7724, 1, &rule21},
- {7725, 1, &rule22},
- {7726, 1, &rule21},
- {7727, 1, &rule22},
- {7728, 1, &rule21},
- {7729, 1, &rule22},
- {7730, 1, &rule21},
- {7731, 1, &rule22},
- {7732, 1, &rule21},
- {7733, 1, &rule22},
- {7734, 1, &rule21},
- {7735, 1, &rule22},
- {7736, 1, &rule21},
- {7737, 1, &rule22},
- {7738, 1, &rule21},
- {7739, 1, &rule22},
- {7740, 1, &rule21},
- {7741, 1, &rule22},
- {7742, 1, &rule21},
- {7743, 1, &rule22},
- {7744, 1, &rule21},
- {7745, 1, &rule22},
- {7746, 1, &rule21},
- {7747, 1, &rule22},
- {7748, 1, &rule21},
- {7749, 1, &rule22},
- {7750, 1, &rule21},
- {7751, 1, &rule22},
- {7752, 1, &rule21},
- {7753, 1, &rule22},
- {7754, 1, &rule21},
- {7755, 1, &rule22},
- {7756, 1, &rule21},
- {7757, 1, &rule22},
- {7758, 1, &rule21},
- {7759, 1, &rule22},
- {7760, 1, &rule21},
- {7761, 1, &rule22},
- {7762, 1, &rule21},
- {7763, 1, &rule22},
- {7764, 1, &rule21},
- {7765, 1, &rule22},
- {7766, 1, &rule21},
- {7767, 1, &rule22},
- {7768, 1, &rule21},
- {7769, 1, &rule22},
- {7770, 1, &rule21},
- {7771, 1, &rule22},
- {7772, 1, &rule21},
- {7773, 1, &rule22},
- {7774, 1, &rule21},
- {7775, 1, &rule22},
- {7776, 1, &rule21},
- {7777, 1, &rule22},
- {7778, 1, &rule21},
- {7779, 1, &rule22},
- {7780, 1, &rule21},
- {7781, 1, &rule22},
- {7782, 1, &rule21},
- {7783, 1, &rule22},
- {7784, 1, &rule21},
- {7785, 1, &rule22},
- {7786, 1, &rule21},
- {7787, 1, &rule22},
- {7788, 1, &rule21},
- {7789, 1, &rule22},
- {7790, 1, &rule21},
- {7791, 1, &rule22},
- {7792, 1, &rule21},
- {7793, 1, &rule22},
- {7794, 1, &rule21},
- {7795, 1, &rule22},
- {7796, 1, &rule21},
- {7797, 1, &rule22},
- {7798, 1, &rule21},
- {7799, 1, &rule22},
- {7800, 1, &rule21},
- {7801, 1, &rule22},
- {7802, 1, &rule21},
- {7803, 1, &rule22},
- {7804, 1, &rule21},
- {7805, 1, &rule22},
- {7806, 1, &rule21},
- {7807, 1, &rule22},
- {7808, 1, &rule21},
- {7809, 1, &rule22},
- {7810, 1, &rule21},
- {7811, 1, &rule22},
- {7812, 1, &rule21},
- {7813, 1, &rule22},
- {7814, 1, &rule21},
- {7815, 1, &rule22},
- {7816, 1, &rule21},
- {7817, 1, &rule22},
- {7818, 1, &rule21},
- {7819, 1, &rule22},
- {7820, 1, &rule21},
- {7821, 1, &rule22},
- {7822, 1, &rule21},
- {7823, 1, &rule22},
- {7824, 1, &rule21},
- {7825, 1, &rule22},
- {7826, 1, &rule21},
- {7827, 1, &rule22},
- {7828, 1, &rule21},
- {7829, 1, &rule22},
- {7835, 1, &rule94},
- {7840, 1, &rule21},
- {7841, 1, &rule22},
- {7842, 1, &rule21},
- {7843, 1, &rule22},
- {7844, 1, &rule21},
- {7845, 1, &rule22},
- {7846, 1, &rule21},
- {7847, 1, &rule22},
- {7848, 1, &rule21},
- {7849, 1, &rule22},
- {7850, 1, &rule21},
- {7851, 1, &rule22},
- {7852, 1, &rule21},
- {7853, 1, &rule22},
- {7854, 1, &rule21},
- {7855, 1, &rule22},
- {7856, 1, &rule21},
- {7857, 1, &rule22},
- {7858, 1, &rule21},
- {7859, 1, &rule22},
- {7860, 1, &rule21},
- {7861, 1, &rule22},
- {7862, 1, &rule21},
- {7863, 1, &rule22},
- {7864, 1, &rule21},
- {7865, 1, &rule22},
- {7866, 1, &rule21},
- {7867, 1, &rule22},
- {7868, 1, &rule21},
- {7869, 1, &rule22},
- {7870, 1, &rule21},
- {7871, 1, &rule22},
- {7872, 1, &rule21},
- {7873, 1, &rule22},
- {7874, 1, &rule21},
- {7875, 1, &rule22},
- {7876, 1, &rule21},
- {7877, 1, &rule22},
- {7878, 1, &rule21},
- {7879, 1, &rule22},
- {7880, 1, &rule21},
- {7881, 1, &rule22},
- {7882, 1, &rule21},
- {7883, 1, &rule22},
- {7884, 1, &rule21},
- {7885, 1, &rule22},
- {7886, 1, &rule21},
- {7887, 1, &rule22},
- {7888, 1, &rule21},
- {7889, 1, &rule22},
- {7890, 1, &rule21},
- {7891, 1, &rule22},
- {7892, 1, &rule21},
- {7893, 1, &rule22},
- {7894, 1, &rule21},
- {7895, 1, &rule22},
- {7896, 1, &rule21},
- {7897, 1, &rule22},
- {7898, 1, &rule21},
- {7899, 1, &rule22},
- {7900, 1, &rule21},
- {7901, 1, &rule22},
- {7902, 1, &rule21},
- {7903, 1, &rule22},
- {7904, 1, &rule21},
- {7905, 1, &rule22},
- {7906, 1, &rule21},
- {7907, 1, &rule22},
- {7908, 1, &rule21},
- {7909, 1, &rule22},
- {7910, 1, &rule21},
- {7911, 1, &rule22},
- {7912, 1, &rule21},
- {7913, 1, &rule22},
- {7914, 1, &rule21},
- {7915, 1, &rule22},
- {7916, 1, &rule21},
- {7917, 1, &rule22},
- {7918, 1, &rule21},
- {7919, 1, &rule22},
- {7920, 1, &rule21},
- {7921, 1, &rule22},
- {7922, 1, &rule21},
- {7923, 1, &rule22},
- {7924, 1, &rule21},
- {7925, 1, &rule22},
- {7926, 1, &rule21},
- {7927, 1, &rule22},
- {7928, 1, &rule21},
- {7929, 1, &rule22},
- {7936, 8, &rule95},
- {7944, 8, &rule96},
- {7952, 6, &rule95},
- {7960, 6, &rule96},
- {7968, 8, &rule95},
- {7976, 8, &rule96},
- {7984, 8, &rule95},
- {7992, 8, &rule96},
- {8000, 6, &rule95},
- {8008, 6, &rule96},
- {8017, 1, &rule95},
- {8019, 1, &rule95},
- {8021, 1, &rule95},
- {8023, 1, &rule95},
- {8025, 1, &rule96},
- {8027, 1, &rule96},
- {8029, 1, &rule96},
- {8031, 1, &rule96},
- {8032, 8, &rule95},
- {8040, 8, &rule96},
- {8048, 2, &rule97},
- {8050, 4, &rule98},
- {8054, 2, &rule99},
- {8056, 2, &rule100},
- {8058, 2, &rule101},
- {8060, 2, &rule102},
- {8064, 8, &rule95},
- {8072, 8, &rule103},
- {8080, 8, &rule95},
- {8088, 8, &rule103},
- {8096, 8, &rule95},
- {8104, 8, &rule103},
- {8112, 2, &rule95},
- {8115, 1, &rule104},
- {8120, 2, &rule96},
- {8122, 2, &rule105},
- {8124, 1, &rule106},
- {8126, 1, &rule107},
- {8131, 1, &rule104},
- {8136, 4, &rule108},
- {8140, 1, &rule106},
- {8144, 2, &rule95},
- {8152, 2, &rule96},
- {8154, 2, &rule109},
- {8160, 2, &rule95},
- {8165, 1, &rule84},
- {8168, 2, &rule96},
- {8170, 2, &rule110},
- {8172, 1, &rule87},
- {8179, 1, &rule104},
- {8184, 2, &rule111},
- {8186, 2, &rule112},
- {8188, 1, &rule106},
- {8486, 1, &rule115},
- {8490, 1, &rule116},
- {8491, 1, &rule117},
- {8544, 16, &rule118},
- {8560, 16, &rule119},
- {9398, 26, &rule120},
- {9424, 26, &rule121},
- {65313, 26, &rule9},
- {65345, 26, &rule12},
- {66560, 40, &rule124},
- {66600, 40, &rule125}
-};
-static const struct _charblock_ spacechars[]={
- {32, 1, &rule1},
- {160, 1, &rule1},
- {5760, 1, &rule1},
- {6158, 1, &rule1},
- {8192, 12, &rule1},
- {8239, 1, &rule1},
- {8287, 1, &rule1},
- {12288, 1, &rule1}
-};
-
-/*
- Obtain the reference to character rule by doing
- binary search over the specified array of blocks.
- To make checkattr shorter, the address of
- nullrule is returned if the search fails:
- this rule defines no category and no conversion
- distances. The compare function returns 0 when
- key->start is within the block. Otherwise
- result of comparison of key->start and start of the
- current block is returned as usual.
-*/
-
-static const struct _convrule_ nullrule={0,NUMCAT_CN,0,0,0,0};
-
-static int blkcmp(const void *vk,const void *vb)
-{
- const struct _charblock_ *key,*cur;
- key=vk;
- cur=vb;
- if((key->start>=cur->start)&&(key->start<(cur->start+cur->length)))
- {
- return 0;
- }
- if(key->start>cur->start) return 1;
- return -1;
-}
-
-static const struct _convrule_ *getrule(
- const struct _charblock_ *blocks,
- int numblocks,
- int unichar)
-{
- struct _charblock_ key={unichar,1,(void *)0};
- struct _charblock_ *cb=bsearch(&key,blocks,numblocks,sizeof(key),blkcmp);
- if(cb==(void *)0) return &nullrule;
- return cb->rule;
-}
-
-
-
-/*
- Check whether a character (internal code) has certain attributes.
- Attributes (category flags) may be ORed. The function ANDs
- character category flags and the mask and returns the result.
- If the character belongs to one of the categories requested,
- the result will be nonzero.
-*/
-
-inline static int checkattr(int c,unsigned int catmask)
-{
- return (catmask & (getrule(allchars,(c<256)?NUM_LAT1BLOCKS:NUM_BLOCKS,c)->category));
-}
-
-inline static int checkattr_s(int c,unsigned int catmask)
-{
- return (catmask & (getrule(spacechars,NUM_SPACEBLOCKS,c)->category));
-}
-
-/*
- Define predicate functions for some combinations of categories.
-*/
-
-#define unipred(p,m) \
-int p(int c) \
-{ \
- return checkattr(c,m); \
-}
-
-#define unipred_s(p,m) \
-int p(int c) \
-{ \
- return checkattr_s(c,m); \
-}
-
-/*
- Make these rules as close to Hugs as possible.
-*/
-
-unipred(u_iswcntrl,GENCAT_CC)
-unipred(u_iswprint, \
-(GENCAT_MC | GENCAT_NO | GENCAT_SK | GENCAT_ME | GENCAT_ND | \
- GENCAT_PO | GENCAT_LT | GENCAT_PC | GENCAT_SM | GENCAT_ZS | \
- GENCAT_LU | GENCAT_PD | GENCAT_SO | GENCAT_PE | GENCAT_PF | \
- GENCAT_PS | GENCAT_SC | GENCAT_LL | GENCAT_LM | GENCAT_PI | \
- GENCAT_NL | GENCAT_MN | GENCAT_LO))
-unipred_s(u_iswspace,GENCAT_ZS)
-unipred(u_iswupper,(GENCAT_LU|GENCAT_LT))
-unipred(u_iswlower,GENCAT_LL)
-unipred(u_iswalpha,(GENCAT_LL|GENCAT_LU|GENCAT_LT|GENCAT_LM|GENCAT_LO))
-
-unipred(u_iswalnum,(GENCAT_LT|GENCAT_LU|GENCAT_LL|GENCAT_LM|GENCAT_LO|
- GENCAT_MC|GENCAT_ME|GENCAT_MN|
- GENCAT_NO|GENCAT_ND|GENCAT_NL))
-
-#define caseconv(p,to) \
-int p(int c) \
-{ \
- const struct _convrule_ *rule=getrule(convchars,NUM_CONVBLOCKS,c);\
- if(rule==&nullrule) return c;\
- return c+rule->to;\
-}
-
-caseconv(u_towupper,updist)
-caseconv(u_towlower,lowdist)
-caseconv(u_towtitle,titledist)
-
-int u_gencat(int c)
-{
- return getrule(allchars,NUM_BLOCKS,c)->catnumber;
-}
-
+++ /dev/null
-/* ----------------------------------------------------------------------------
- (c) The University of Glasgow 2006
-
- Useful Win32 bits
- ------------------------------------------------------------------------- */
-
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
-
-#include "HsBase.h"
-
-/* This is the error table that defines the mapping between OS error
- codes and errno values */
-
-struct errentry {
- unsigned long oscode; /* OS return value */
- int errnocode; /* System V error code */
-};
-
-static struct errentry errtable[] = {
- { ERROR_INVALID_FUNCTION, EINVAL }, /* 1 */
- { ERROR_FILE_NOT_FOUND, ENOENT }, /* 2 */
- { ERROR_PATH_NOT_FOUND, ENOENT }, /* 3 */
- { ERROR_TOO_MANY_OPEN_FILES, EMFILE }, /* 4 */
- { ERROR_ACCESS_DENIED, EACCES }, /* 5 */
- { ERROR_INVALID_HANDLE, EBADF }, /* 6 */
- { ERROR_ARENA_TRASHED, ENOMEM }, /* 7 */
- { ERROR_NOT_ENOUGH_MEMORY, ENOMEM }, /* 8 */
- { ERROR_INVALID_BLOCK, ENOMEM }, /* 9 */
- { ERROR_BAD_ENVIRONMENT, E2BIG }, /* 10 */
- { ERROR_BAD_FORMAT, ENOEXEC }, /* 11 */
- { ERROR_INVALID_ACCESS, EINVAL }, /* 12 */
- { ERROR_INVALID_DATA, EINVAL }, /* 13 */
- { ERROR_INVALID_DRIVE, ENOENT }, /* 15 */
- { ERROR_CURRENT_DIRECTORY, EACCES }, /* 16 */
- { ERROR_NOT_SAME_DEVICE, EXDEV }, /* 17 */
- { ERROR_NO_MORE_FILES, ENOENT }, /* 18 */
- { ERROR_LOCK_VIOLATION, EACCES }, /* 33 */
- { ERROR_BAD_NETPATH, ENOENT }, /* 53 */
- { ERROR_NETWORK_ACCESS_DENIED, EACCES }, /* 65 */
- { ERROR_BAD_NET_NAME, ENOENT }, /* 67 */
- { ERROR_FILE_EXISTS, EEXIST }, /* 80 */
- { ERROR_CANNOT_MAKE, EACCES }, /* 82 */
- { ERROR_FAIL_I24, EACCES }, /* 83 */
- { ERROR_INVALID_PARAMETER, EINVAL }, /* 87 */
- { ERROR_NO_PROC_SLOTS, EAGAIN }, /* 89 */
- { ERROR_DRIVE_LOCKED, EACCES }, /* 108 */
- { ERROR_BROKEN_PIPE, EPIPE }, /* 109 */
- { ERROR_DISK_FULL, ENOSPC }, /* 112 */
- { ERROR_INVALID_TARGET_HANDLE, EBADF }, /* 114 */
- { ERROR_INVALID_HANDLE, EINVAL }, /* 124 */
- { ERROR_WAIT_NO_CHILDREN, ECHILD }, /* 128 */
- { ERROR_CHILD_NOT_COMPLETE, ECHILD }, /* 129 */
- { ERROR_DIRECT_ACCESS_HANDLE, EBADF }, /* 130 */
- { ERROR_NEGATIVE_SEEK, EINVAL }, /* 131 */
- { ERROR_SEEK_ON_DEVICE, EACCES }, /* 132 */
- { ERROR_DIR_NOT_EMPTY, ENOTEMPTY }, /* 145 */
- { ERROR_NOT_LOCKED, EACCES }, /* 158 */
- { ERROR_BAD_PATHNAME, ENOENT }, /* 161 */
- { ERROR_MAX_THRDS_REACHED, EAGAIN }, /* 164 */
- { ERROR_LOCK_FAILED, EACCES }, /* 167 */
- { ERROR_ALREADY_EXISTS, EEXIST }, /* 183 */
- { ERROR_FILENAME_EXCED_RANGE, ENOENT }, /* 206 */
- { ERROR_NESTING_NOT_ALLOWED, EAGAIN }, /* 215 */
- { ERROR_NOT_ENOUGH_QUOTA, ENOMEM } /* 1816 */
-};
-
-/* size of the table */
-#define ERRTABLESIZE (sizeof(errtable)/sizeof(errtable[0]))
-
-/* The following two constants must be the minimum and maximum
- values in the (contiguous) range of Exec Failure errors. */
-#define MIN_EXEC_ERROR ERROR_INVALID_STARTING_CODESEG
-#define MAX_EXEC_ERROR ERROR_INFLOOP_IN_RELOC_CHAIN
-
-/* These are the low and high value in the range of errors that are
- access violations */
-#define MIN_EACCES_RANGE ERROR_WRITE_PROTECT
-#define MAX_EACCES_RANGE ERROR_SHARING_BUFFER_EXCEEDED
-
-void maperrno (void)
-{
- int i;
- DWORD dwErrorCode;
-
- dwErrorCode = GetLastError();
-
- /* check the table for the OS error code */
- for (i = 0; i < ERRTABLESIZE; ++i)
- {
- if (dwErrorCode == errtable[i].oscode)
- {
- errno = errtable[i].errnocode;
- return;
- }
- }
-
- /* The error code wasn't in the table. We check for a range of */
- /* EACCES errors or exec failure errors (ENOEXEC). Otherwise */
- /* EINVAL is returned. */
-
- if (dwErrorCode >= MIN_EACCES_RANGE && dwErrorCode <= MAX_EACCES_RANGE)
- errno = EACCES;
- else
- if (dwErrorCode >= MIN_EXEC_ERROR && dwErrorCode <= MAX_EXEC_ERROR)
- errno = ENOEXEC;
- else
- errno = EINVAL;
-}
-
-HsWord64 getUSecOfDay(void)
-{
- HsWord64 t;
- FILETIME ft;
- GetSystemTimeAsFileTime(&ft);
- t = ((HsWord64)ft.dwHighDateTime << 32) | ft.dwLowDateTime;
- t = t / 10LL;
- /* FILETIMES are in units of 100ns,
- so we divide by 10 to get microseconds */
- return t;
-}
-
-#endif
-
+++ /dev/null
-/*
- * (c) The University of Glasgow 2002
- *
- * Win32 Console API support
- */
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) || defined(__CYGWIN__)
-/* to the end */
-
-#include "consUtils.h"
-#include <windows.h>
-#include <io.h>
-
-#if defined(__CYGWIN__)
-#define _get_osfhandle get_osfhandle
-#endif
-
-int
-set_console_buffering__(int fd, int cooked)
-{
- HANDLE h;
- DWORD st;
- /* According to GetConsoleMode() docs, it is not possible to
- leave ECHO_INPUT enabled without also having LINE_INPUT,
- so we have to turn both off here. */
- DWORD flgs = ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT;
-
- if ( (h = (HANDLE)_get_osfhandle(fd)) != INVALID_HANDLE_VALUE ) {
- if ( GetConsoleMode(h,&st) &&
- SetConsoleMode(h, cooked ? (st | ENABLE_LINE_INPUT) : st & ~flgs) ) {
- return 0;
- }
- }
- return -1;
-}
-
-int
-set_console_echo__(int fd, int on)
-{
- HANDLE h;
- DWORD st;
- DWORD flgs = ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT;
-
- if ( (h = (HANDLE)_get_osfhandle(fd)) != INVALID_HANDLE_VALUE ) {
- if ( GetConsoleMode(h,&st) &&
- SetConsoleMode(h,( on ? (st | flgs) : (st & ~ENABLE_ECHO_INPUT))) ) {
- return 0;
- }
- }
- return -1;
-}
-
-int
-get_console_echo__(int fd)
-{
- HANDLE h;
- DWORD st;
-
- if ( (h = (HANDLE)_get_osfhandle(fd)) != INVALID_HANDLE_VALUE ) {
- if ( GetConsoleMode(h,&st) ) {
- return (st & ENABLE_ECHO_INPUT ? 1 : 0);
- }
- }
- return -1;
-}
-
-int
-flush_input_console__(int fd)
-{
- HANDLE h = (HANDLE)_get_osfhandle(fd);
-
- if ( h != INVALID_HANDLE_VALUE ) {
- /* If the 'fd' isn't connected to a console; treat the flush
- * operation as a NOP.
- */
- DWORD unused;
- if ( !GetConsoleMode(h,&unused) &&
- GetLastError() == ERROR_INVALID_HANDLE ) {
- return 0;
- }
- if ( FlushConsoleInputBuffer(h) ) {
- return 0;
- }
- }
- /* ToDo: translate GetLastError() into something errno-friendly */
- return -1;
-}
-
-#endif /* defined(__MINGW32__) || ... */
+++ /dev/null
-/*
- * (c) The University of Glasgow 2002
- *
- * Directory Runtime Support
- */
-
-/* needed only for solaris2_HOST_OS */
-#include "ghcconfig.h"
-
-// The following is required on Solaris to force the POSIX versions of
-// the various _r functions instead of the Solaris versions.
-#ifdef solaris2_HOST_OS
-#define _POSIX_PTHREAD_SEMANTICS
-#endif
-
-#include "HsBase.h"
-
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
-#include <windows.h>
-
-static
-int
-toErrno(DWORD rc)
-{
- switch (rc) {
- case ERROR_FILE_NOT_FOUND: return ENOENT;
- case ERROR_PATH_NOT_FOUND: return ENOENT;
- case ERROR_TOO_MANY_OPEN_FILES: return EMFILE;
- case ERROR_ACCESS_DENIED: return EACCES;
- case ERROR_INVALID_HANDLE: return EBADF; /* kinda sorta */
- case ERROR_NOT_ENOUGH_MEMORY: return ENOMEM;
- case ERROR_INVALID_ACCESS: return EINVAL;
- case ERROR_INVALID_DATA: return EINVAL;
- case ERROR_OUTOFMEMORY: return ENOMEM;
- case ERROR_SHARING_VIOLATION: return EACCES;
- case ERROR_LOCK_VIOLATION: return EACCES;
- case ERROR_ALREADY_EXISTS: return EEXIST;
- case ERROR_BUSY: return EBUSY;
- case ERROR_BROKEN_PIPE: return EPIPE;
- case ERROR_PIPE_CONNECTED: return EBUSY;
- case ERROR_PIPE_LISTENING: return EBUSY;
- case ERROR_NOT_CONNECTED: return EINVAL;
-
- case ERROR_NOT_OWNER: return EPERM;
- case ERROR_DIRECTORY: return ENOTDIR;
- case ERROR_FILE_INVALID: return EACCES;
- case ERROR_FILE_EXISTS: return EEXIST;
-
- default:
- return rc;
- }
-}
-#endif
-
-
-/*
- * read an entry from the directory stream; opt for the
- * re-entrant friendly way of doing this, if available.
- */
-int
-__hscore_readdir( DIR *dirPtr, struct dirent **pDirEnt )
-{
-#if HAVE_READDIR_R
- struct dirent* p;
- int res;
- static unsigned int nm_max = (unsigned int)-1;
-
- if (pDirEnt == NULL) {
- return -1;
- }
- if (nm_max == (unsigned int)-1) {
-#ifdef NAME_MAX
- nm_max = NAME_MAX + 1;
-#else
- nm_max = pathconf(".", _PC_NAME_MAX);
- if (nm_max == -1) { nm_max = 255; }
- nm_max++;
-#endif
- }
- p = (struct dirent*)malloc(sizeof(struct dirent) + nm_max);
- if (p == NULL) return -1;
- res = readdir_r(dirPtr, p, pDirEnt);
- if (res != 0) {
- *pDirEnt = NULL;
- free(p);
- }
- else if (*pDirEnt == NULL) {
- // end of stream
- free(p);
- }
- return res;
-#else
-
- if (pDirEnt == NULL) {
- return -1;
- }
-
- *pDirEnt = readdir(dirPtr);
- if (*pDirEnt == NULL) {
- return -1;
- } else {
- return 0;
- }
-#endif
-}
-
-/*
- * Function: __hscore_renameFile()
- *
- * Provide Haskell98's semantics for renaming files and directories.
- * It mirrors that of POSIX.1's behaviour for rename() by overwriting
- * the target if it exists (the MS CRT implementation of rename() returns
- * an error
- *
- */
-int
-__hscore_renameFile( char *src, char *dest)
-{
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
- static int forNT = -1;
-
- /* ToDo: propagate error codes back */
- if (MoveFileA(src, dest)) {
- return 0;
- } else {
- ;
- }
-
- /* Failed...it could be because the target already existed. */
- if ( !GetFileAttributes(dest) ) {
- /* No, it's not there - just fail. */
- errno = toErrno(GetLastError());
- return (-1);
- }
-
- if (forNT == -1) {
- OSVERSIONINFO ovi;
- ovi.dwOSVersionInfoSize = sizeof(ovi);
- if ( !GetVersionEx(&ovi) ) {
- errno = toErrno(GetLastError());
- return (-1);
- }
- forNT = ((ovi.dwPlatformId & VER_PLATFORM_WIN32_NT) != 0);
- }
-
- if (forNT) {
- /* Easy, go for MoveFileEx() */
- if ( MoveFileExA(src, dest, MOVEFILE_REPLACE_EXISTING) ) {
- return 0;
- } else {
- errno = toErrno(GetLastError());
- return (-1);
- }
- }
-
- /* No MoveFileEx() for Win9x, try deleting the target. */
- /* Similarly, if the MoveFile*() ops didn't work out under NT */
- if (DeleteFileA(dest)) {
- if (MoveFileA(src,dest)) {
- return 0;
- } else {
- errno = toErrno(GetLastError());
- return (-1);
- }
- } else {
- errno = toErrno(GetLastError());
- return (-1);
- }
-#else
- return rename(src,dest);
-#endif
-}
-
-/*
- * Function: __hscore_getFolderPath()
- *
- * Late-bound version of SHGetFolderPath(), coping with OS versions
- * that have shell32's lacking that particular API.
- *
- */
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
-typedef HRESULT (*HSCORE_GETAPPFOLDERFUNTY)(HWND,int,HANDLE,DWORD,char*);
-int
-__hscore_getFolderPath(HWND hwndOwner,
- int nFolder,
- HANDLE hToken,
- DWORD dwFlags,
- char* pszPath)
-{
- static int loaded_dll = 0;
- static HMODULE hMod = (HMODULE)NULL;
- static HSCORE_GETAPPFOLDERFUNTY funcPtr = NULL;
- /* The DLLs to try loading entry point from */
- char* dlls[] = { "shell32.dll", "shfolder.dll" };
-
- if (loaded_dll < 0) {
- return (-1);
- } else if (loaded_dll == 0) {
- int i;
- for(i=0;i < sizeof(dlls); i++) {
- hMod = LoadLibrary(dlls[i]);
- if ( hMod != NULL &&
- (funcPtr = (HSCORE_GETAPPFOLDERFUNTY)GetProcAddress(hMod, "SHGetFolderPathA")) ) {
- loaded_dll = 1;
- break;
- }
- }
- if (loaded_dll == 0) {
- loaded_dll = (-1);
- return (-1);
- }
- }
- /* OK, if we got this far the function has been bound */
- return (int)funcPtr(hwndOwner,nFolder,hToken,dwFlags,pszPath);
- /* ToDo: unload the DLL on shutdown? */
-}
-#endif
--- /dev/null
+/*
+ * (c) The University of Glasgow 2002
+ *
+ */
+
+#define INLINE
+#include "HsDirectory.h"
+
+/*
+ * Function: __hscore_getFolderPath()
+ *
+ * Late-bound version of SHGetFolderPath(), coping with OS versions
+ * that have shell32's lacking that particular API.
+ *
+ */
+#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
+typedef HRESULT (*HSCORE_GETAPPFOLDERFUNTY)(HWND,int,HANDLE,DWORD,char*);
+int
+__hscore_getFolderPath(HWND hwndOwner,
+ int nFolder,
+ HANDLE hToken,
+ DWORD dwFlags,
+ char* pszPath)
+{
+ static int loaded_dll = 0;
+ static HMODULE hMod = (HMODULE)NULL;
+ static HSCORE_GETAPPFOLDERFUNTY funcPtr = NULL;
+ /* The DLLs to try loading entry point from */
+ char* dlls[] = { "shell32.dll", "shfolder.dll" };
+
+ if (loaded_dll < 0) {
+ return (-1);
+ } else if (loaded_dll == 0) {
+ int i;
+ for(i=0;i < sizeof(dlls); i++) {
+ hMod = LoadLibrary(dlls[i]);
+ if ( hMod != NULL &&
+ (funcPtr = (HSCORE_GETAPPFOLDERFUNTY)GetProcAddress(hMod, "SHGetFolderPathA")) ) {
+ loaded_dll = 1;
+ break;
+ }
+ }
+ if (loaded_dll == 0) {
+ loaded_dll = (-1);
+ return (-1);
+ }
+ }
+ /* OK, if we got this far the function has been bound */
+ return (int)funcPtr(hwndOwner,nFolder,hToken,dwFlags,pszPath);
+ /* ToDo: unload the DLL on shutdown? */
+}
+#endif
+
+++ /dev/null
-/* -----------------------------------------------------------------------------
- (c) The University of Glasgow 1995-2004
-
- Our low-level exec() variant.
- -------------------------------------------------------------------------- */
-#include "HsBase.h"
-
-#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) /* to the end */
-
-/* Evidently non-Posix. */
-/* #include "PosixSource.h" */
-
-#include <unistd.h>
-#include <sys/time.h>
-#include <stdlib.h>
-#include <string.h>
-#include <errno.h>
-
-/*
- * We want the search semantics of execvp, but we want to provide our
- * own environment, like execve. The following copyright applies to
- * this code, as it is a derivative of execvp:
- *-
- * Copyright (c) 1991 The Regents of the University of California.
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- * 3. All advertising materials mentioning features or use of this software
- * must display the following acknowledgement:
- * This product includes software developed by the University of
- * California, Berkeley and its contributors.
- * 4. Neither the name of the University nor the names of its contributors
- * may be used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
- * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
- * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
- * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
- * SUCH DAMAGE.
- */
-
-int
-execvpe(char *name, char *const argv[], char **envp)
-{
- register int lp, ln;
- register char *p;
- int eacces=0, etxtbsy=0;
- char *bp, *cur, *path, *buf = 0;
-
- /* If it's an absolute or relative path name, it's easy. */
- if (strchr(name, '/')) {
- bp = (char *) name;
- cur = path = buf = NULL;
- goto retry;
- }
-
- /* Get the path we're searching. */
- if (!(path = getenv("PATH"))) {
-#ifdef HAVE_CONFSTR
- ln = confstr(_CS_PATH, NULL, 0);
- if ((cur = path = malloc(ln + 1)) != NULL) {
- path[0] = ':';
- (void) confstr (_CS_PATH, path + 1, ln);
- }
-#else
- if ((cur = path = malloc(1 + 1)) != NULL) {
- path[0] = ':';
- path[1] = '\0';
- }
-#endif
- } else
- cur = path = strdup(path);
-
- if (path == NULL || (bp = buf = malloc(strlen(path)+strlen(name)+2)) == NULL)
- goto done;
-
- while (cur != NULL) {
- p = cur;
- if ((cur = strchr(cur, ':')) != NULL)
- *cur++ = '\0';
-
- /*
- * It's a SHELL path -- double, leading and trailing colons mean the current
- * directory.
- */
- if (!*p) {
- p = ".";
- lp = 1;
- } else
- lp = strlen(p);
- ln = strlen(name);
-
- memcpy(buf, p, lp);
- buf[lp] = '/';
- memcpy(buf + lp + 1, name, ln);
- buf[lp + ln + 1] = '\0';
-
- retry:
- (void) execve(bp, argv, envp);
- switch (errno) {
- case EACCES:
- eacces = 1;
- break;
- case ENOENT:
- break;
- case ENOEXEC:
- {
- register size_t cnt;
- register char **ap;
-
- for (cnt = 0, ap = (char **) argv; *ap; ++ap, ++cnt)
- ;
- if ((ap = malloc((cnt + 2) * sizeof(char *))) != NULL) {
- memcpy(ap + 2, argv + 1, cnt * sizeof(char *));
-
- ap[0] = "sh";
- ap[1] = bp;
- (void) execve("/bin/sh", ap, envp);
- free(ap);
- }
- goto done;
- }
- case ETXTBSY:
- if (etxtbsy < 3)
- (void) sleep(++etxtbsy);
- goto retry;
- default:
- goto done;
- }
- }
- if (eacces)
- errno = EACCES;
- else if (!errno)
- errno = ENOENT;
- done:
- if (path)
- free(path);
- if (buf)
- free(buf);
- return (-1);
-}
-
-
-/* Copied verbatim from ghc/lib/std/cbits/system.c. */
-void pPrPr_disableITimers (void)
-{
-# ifdef HAVE_SETITIMER
- /* Reset the itimers in the child, so it doesn't get plagued
- * by SIGVTALRM interrupts.
- */
- struct timeval tv_null = { 0, 0 };
- struct itimerval itv;
- itv.it_interval = tv_null;
- itv.it_value = tv_null;
- setitimer(ITIMER_REAL, &itv, NULL);
- setitimer(ITIMER_VIRTUAL, &itv, NULL);
- setitimer(ITIMER_PROF, &itv, NULL);
-# endif
-}
-
-#endif
+++ /dev/null
-/*
- * Copyright (c) 2003 David Roundy
- * Copyright (c) 2005-6 Don Stewart
- *
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- * 3. Neither the names of the authors or the names of any contributors
- * may be used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
- * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
- * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
- * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
- * SUCH DAMAGE.
- */
-
-#include "fpstring.h"
-
-/* copy a string in reverse */
-void fps_reverse(unsigned char *q, unsigned char *p, unsigned long n) {
- p += n-1;
- while (n-- != 0)
- *q++ = *p--;
-}
-
-/* duplicate a string, interspersing the character through the elements
- of the duplicated string */
-void fps_intersperse(unsigned char *q,
- unsigned char *p,
- unsigned long n,
- unsigned char c) {
-
- while (n > 1) {
- *q++ = *p++;
- *q++ = c;
- n--;
- }
- if (n == 1)
- *q = *p;
-}
-
-/* find maximum char in a packed string */
-unsigned char fps_maximum(unsigned char *p, unsigned long len) {
- unsigned char *q, c = *p;
- for (q = p; q < p + len; q++)
- if (*q > c)
- c = *q;
- return c;
-}
-
-/* find minimum char in a packed string */
-unsigned char fps_minimum(unsigned char *p, unsigned long len) {
- unsigned char *q, c = *p;
- for (q = p; q < p + len; q++)
- if (*q < c)
- c = *q;
- return c;
-}
-
-/* count the number of occurences of a char in a string */
-unsigned long fps_count(unsigned char *p, unsigned long len, unsigned char w) {
- unsigned long c;
- for (c = 0; len-- != 0; ++p)
- if (*p == w)
- ++c;
- return c;
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-2002
- *
- * hWaitForInput Runtime Support
- */
-
-/* select and supporting types is not Posix */
-/* #include "PosixSource.h" */
-#include "HsBase.h"
-
-/*
- * inputReady(fd) checks to see whether input is available on the file
- * descriptor 'fd'. Input meaning 'can I safely read at least a
- * *character* from this file object without blocking?'
- */
-int
-fdReady(int fd, int write, int msecs, int isSock)
-{
- if
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
- ( isSock ) {
-#else
- ( 1 ) {
-#endif
- int maxfd, ready;
- fd_set rfd, wfd;
- struct timeval tv;
-
- FD_ZERO(&rfd);
- FD_ZERO(&wfd);
- if (write) {
- FD_SET(fd, &wfd);
- } else {
- FD_SET(fd, &rfd);
- }
-
- /* select() will consider the descriptor set in the range of 0 to
- * (maxfd-1)
- */
- maxfd = fd + 1;
- tv.tv_sec = msecs / 1000;
- tv.tv_usec = (msecs % 1000) * 1000;
-
- while ((ready = select(maxfd, &rfd, &wfd, NULL, &tv)) < 0 ) {
- if (errno != EINTR ) {
- return -1;
- }
- }
-
- /* 1 => Input ready, 0 => not ready, -1 => error */
- return (ready);
- }
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
- else {
- DWORD rc;
- HANDLE hFile = (HANDLE)_get_osfhandle(fd);
- DWORD avail;
-
- // WaitForMultipleObjects() works for Console input, but it
- // doesn't work for pipes (it always returns WAIT_OBJECT_0
- // even when no data is available). There doesn't seem to be
- // an easy way to distinguish the two kinds of HANDLE, so we
- // try to detect pipe input first, and if that fails we try
- // WaitForMultipleObjects().
- //
- rc = PeekNamedPipe( hFile, NULL, 0, NULL, &avail, NULL );
- if (rc != 0) {
- if (avail != 0) {
- return 1;
- } else {
- return 0;
- }
- } else {
- rc = GetLastError();
- if (rc == ERROR_BROKEN_PIPE) {
- return 1; // this is probably what we want
- }
- if (rc != ERROR_INVALID_HANDLE) {
- return -1;
- }
- }
-
- rc = WaitForMultipleObjects( 1,
- &hFile,
- TRUE, /* wait all */
- msecs); /*millisecs*/
-
- /* 1 => Input ready, 0 => not ready, -1 => error */
- switch (rc) {
- case WAIT_TIMEOUT: return 0;
- case WAIT_OBJECT_0: return 1;
- default: return -1;
- }
- }
-#endif
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-2004
- *
- * $Id: lockFile.c,v 1.5 2005/01/28 13:36:32 simonmar Exp $
- *
- * stdin/stout/stderr Runtime Support
- */
-
-#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32))
-
-#include "HsBase.h"
-#include "Rts.h"
-#include "RtsUtils.h"
-
-typedef struct {
- dev_t device;
- ino_t inode;
- int fd;
-} Lock;
-
-static Lock readLock[FD_SETSIZE];
-static Lock writeLock[FD_SETSIZE];
-
-static int readLocks = 0;
-static int writeLocks = 0;
-
-int
-lockFile(int fd, int for_writing, int exclusive)
-{
- struct stat sb;
- int i;
-
- if (fd > FD_SETSIZE) {
- barf("lockFile: fd out of range");
- }
-
- while (fstat(fd, &sb) < 0) {
- if (errno != EINTR)
- return -1;
- }
-
- if (for_writing) {
- /* opening a file for writing, check to see whether
- we don't have any read locks on it already.. */
- for (i = 0; i < readLocks; i++) {
- if (readLock[i].inode == sb.st_ino && readLock[i].device == sb.st_dev)
- return -1;
- }
- /* If we're determined that there is only a single
- writer to the file, check to see whether the file
- hasn't already been opened for writing..
- */
- if (exclusive) {
- for (i = 0; i < writeLocks; i++) {
- if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev) {
- return -1;
- }
- }
- }
- /* OK, everything is cool lock-wise, record it and leave. */
- i = writeLocks++;
- writeLock[i].device = sb.st_dev;
- writeLock[i].inode = sb.st_ino;
- writeLock[i].fd = fd;
- return 0;
- } else {
- /* For reading, it's simpler - just check to see
- that there's no-one writing to the underlying file. */
- for (i = 0; i < writeLocks; i++) {
- if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev)
- return -1;
- }
- /* Fit in new entry, reusing an existing table entry, if possible. */
- for (i = 0; i < readLocks; i++) {
- if (readLock[i].inode == sb.st_ino && readLock[i].device == sb.st_dev) {
- return 0;
- }
- }
- i = readLocks++;
- readLock[i].device = sb.st_dev;
- readLock[i].inode = sb.st_ino;
- readLock[i].fd = fd;
- return 0;
- }
-
-}
-
-int
-unlockFile(int fd)
-{
- int i;
-
- for (i = 0; i < readLocks; i++)
- if (readLock[i].fd == fd) {
- while (++i < readLocks)
- readLock[i - 1] = readLock[i];
- readLocks--;
- return 0;
- }
-
- for (i = 0; i < writeLocks; i++)
- if (writeLock[i].fd == fd) {
- while (++i < writeLocks)
- writeLock[i - 1] = writeLock[i];
- writeLocks--;
- return 0;
- }
- /* Signal that we did not find an entry */
- return 1;
-}
-
-#endif
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: longlong.c,v 1.4 2002/12/13 14:23:42 simonmar Exp $
- *
- * (c) The GHC Team, 1998-1999
- *
- * Primitive operations over (64-bit) long longs
- * (only used on 32-bit platforms.)
- *
- * ---------------------------------------------------------------------------*/
-
-
-/*
-Miscellaneous primitive operations on HsInt64 and HsWord64s.
-N.B. These are not primops!
-
-Instead of going the normal (boring) route of making the list
-of primitive operations even longer to cope with operations
-over 64-bit entities, we implement them instead 'out-of-line'.
-
-The primitive ops get their own routine (in C) that implements
-the operation, requiring the caller to _ccall_ out. This has
-performance implications of course, but we currently don't
-expect intensive use of either Int64 or Word64 types.
-
-The exceptions to the rule are primops that cast to and from
-64-bit entities (these are defined in PrimOps.h)
-*/
-
-#include "Rts.h"
-
-#ifdef SUPPORT_LONG_LONGS
-
-/* Relational operators */
-
-static inline HsBool mkBool(int b) { return b ? HS_BOOL_TRUE : HS_BOOL_FALSE; }
-
-HsBool hs_gtWord64 (HsWord64 a, HsWord64 b) {return mkBool(a > b);}
-HsBool hs_geWord64 (HsWord64 a, HsWord64 b) {return mkBool(a >= b);}
-HsBool hs_eqWord64 (HsWord64 a, HsWord64 b) {return mkBool(a == b);}
-HsBool hs_neWord64 (HsWord64 a, HsWord64 b) {return mkBool(a != b);}
-HsBool hs_ltWord64 (HsWord64 a, HsWord64 b) {return mkBool(a < b);}
-HsBool hs_leWord64 (HsWord64 a, HsWord64 b) {return mkBool(a <= b);}
-
-HsBool hs_gtInt64 (HsInt64 a, HsInt64 b) {return mkBool(a > b);}
-HsBool hs_geInt64 (HsInt64 a, HsInt64 b) {return mkBool(a >= b);}
-HsBool hs_eqInt64 (HsInt64 a, HsInt64 b) {return mkBool(a == b);}
-HsBool hs_neInt64 (HsInt64 a, HsInt64 b) {return mkBool(a != b);}
-HsBool hs_ltInt64 (HsInt64 a, HsInt64 b) {return mkBool(a < b);}
-HsBool hs_leInt64 (HsInt64 a, HsInt64 b) {return mkBool(a <= b);}
-
-/* Arithmetic operators */
-
-HsWord64 hs_remWord64 (HsWord64 a, HsWord64 b) {return a % b;}
-HsWord64 hs_quotWord64 (HsWord64 a, HsWord64 b) {return a / b;}
-
-HsInt64 hs_remInt64 (HsInt64 a, HsInt64 b) {return a % b;}
-HsInt64 hs_quotInt64 (HsInt64 a, HsInt64 b) {return a / b;}
-HsInt64 hs_negateInt64 (HsInt64 a) {return -a;}
-HsInt64 hs_plusInt64 (HsInt64 a, HsInt64 b) {return a + b;}
-HsInt64 hs_minusInt64 (HsInt64 a, HsInt64 b) {return a - b;}
-HsInt64 hs_timesInt64 (HsInt64 a, HsInt64 b) {return a * b;}
-
-/* Logical operators: */
-
-HsWord64 hs_and64 (HsWord64 a, HsWord64 b) {return a & b;}
-HsWord64 hs_or64 (HsWord64 a, HsWord64 b) {return a | b;}
-HsWord64 hs_xor64 (HsWord64 a, HsWord64 b) {return a ^ b;}
-HsWord64 hs_not64 (HsWord64 a) {return ~a;}
-
-HsWord64 hs_uncheckedShiftL64 (HsWord64 a, HsInt b) {return a << b;}
-HsWord64 hs_uncheckedShiftRL64 (HsWord64 a, HsInt b) {return a >> b;}
-/* Right shifting of signed quantities is not portable in C, so
- the behaviour you'll get from using these primops depends
- on the whatever your C compiler is doing. ToDo: fix. -- sof 8/98
-*/
-HsInt64 hs_uncheckedIShiftL64 (HsInt64 a, HsInt b) {return a << b;}
-HsInt64 hs_uncheckedIShiftRA64 (HsInt64 a, HsInt b) {return a >> b;}
-HsInt64 hs_uncheckedIShiftRL64 (HsInt64 a, HsInt b)
- {return (HsInt64) ((HsWord64) a >> b);}
-
-/* Casting between longs and longer longs.
- (the primops that cast from long longs to Integers
- expressed as macros, since these may cause some heap allocation).
-*/
-
-HsInt64 hs_intToInt64 (HsInt i) {return (HsInt64) i;}
-HsInt hs_int64ToInt (HsInt64 i) {return (HsInt) i;}
-HsWord64 hs_int64ToWord64 (HsInt64 i) {return (HsWord64) i;}
-HsWord64 hs_wordToWord64 (HsWord w) {return (HsWord64) w;}
-HsWord hs_word64ToWord (HsWord64 w) {return (HsWord) w;}
-HsInt64 hs_word64ToInt64 (HsWord64 w) {return (HsInt64) w;}
-
-HsWord64 hs_integerToWord64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da)
-{
- mp_limb_t* d;
- HsInt s;
- HsWord64 res;
- d = (mp_limb_t *)da;
- s = sa;
- switch (s) {
- case 0: res = 0; break;
- case 1: res = d[0]; break;
- case -1: res = -(HsWord64)d[0]; break;
- default:
- res = (HsWord64)d[0] + ((HsWord64)d[1] << (BITS_IN (mp_limb_t)));
- if (s < 0) res = -res;
- }
- return res;
-}
-
-HsInt64 hs_integerToInt64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da)
-{
- mp_limb_t* d;
- HsInt s;
- HsInt64 res;
- d = (mp_limb_t *)da;
- s = (sa);
- switch (s) {
- case 0: res = 0; break;
- case 1: res = d[0]; break;
- case -1: res = -(HsInt64)d[0]; break;
- default:
- res = (HsInt64)d[0] + ((HsWord64)d[1] << (BITS_IN (mp_limb_t)));
- if (s < 0) res = -res;
- }
- return res;
-}
-
-#endif /* SUPPORT_LONG_LONGS */
+++ /dev/null
-/* ----------------------------------------------------------------------------
- (c) The University of Glasgow 2004
-
- Support for System.Process
- ------------------------------------------------------------------------- */
-
-#include "HsBase.h"
-
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
-#include <windows.h>
-#include <stdlib.h>
-#endif
-
-#ifdef HAVE_VFORK_H
-#include <vfork.h>
-#endif
-
-#ifdef HAVE_VFORK
-#define fork vfork
-#endif
-
-#ifdef HAVE_SIGNAL_H
-#include <signal.h>
-#endif
-
-#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32))
-/* ----------------------------------------------------------------------------
- UNIX versions
- ------------------------------------------------------------------------- */
-
-ProcHandle
-runProcess (char *const args[], char *workingDirectory, char **environment,
- int fdStdInput, int fdStdOutput, int fdStdError,
- int set_inthandler, long inthandler,
- int set_quithandler, long quithandler)
-{
- int pid;
- struct sigaction dfl;
-
- switch(pid = fork())
- {
- case -1:
- return -1;
-
- case 0:
- {
- pPrPr_disableITimers();
-
- if (workingDirectory) {
- if (chdir (workingDirectory) < 0) {
- return -1;
- }
- }
-
- /* Set the SIGINT/SIGQUIT signal handlers in the child, if requested
- */
- (void)sigemptyset(&dfl.sa_mask);
- dfl.sa_flags = 0;
- if (set_inthandler) {
- dfl.sa_handler = (void *)inthandler;
- (void)sigaction(SIGINT, &dfl, NULL);
- }
- if (set_quithandler) {
- dfl.sa_handler = (void *)quithandler;
- (void)sigaction(SIGQUIT, &dfl, NULL);
- }
-
- dup2 (fdStdInput, STDIN_FILENO);
- dup2 (fdStdOutput, STDOUT_FILENO);
- dup2 (fdStdError, STDERR_FILENO);
-
- if (environment) {
- execvpe(args[0], args, environment);
- } else {
- execvp(args[0], args);
- }
- }
- _exit(127);
- }
-
- return pid;
-}
-
-ProcHandle
-runInteractiveProcess (char *const args[],
- char *workingDirectory, char **environment,
- int *pfdStdInput, int *pfdStdOutput, int *pfdStdError)
-{
- int pid;
- int fdStdInput[2], fdStdOutput[2], fdStdError[2];
-
- pipe(fdStdInput);
- pipe(fdStdOutput);
- pipe(fdStdError);
-
- switch(pid = fork())
- {
- case -1:
- close(fdStdInput[0]);
- close(fdStdInput[1]);
- close(fdStdOutput[0]);
- close(fdStdOutput[1]);
- close(fdStdError[0]);
- close(fdStdError[1]);
- return -1;
-
- case 0:
- {
- pPrPr_disableITimers();
-
- if (workingDirectory) {
- if (chdir (workingDirectory) < 0) {
- return -1;
- }
- }
-
- if (fdStdInput[0] != STDIN_FILENO) {
- dup2 (fdStdInput[0], STDIN_FILENO);
- close(fdStdInput[0]);
- }
-
- if (fdStdOutput[1] != STDOUT_FILENO) {
- dup2 (fdStdOutput[1], STDOUT_FILENO);
- close(fdStdOutput[1]);
- }
-
- if (fdStdError[1] != STDERR_FILENO) {
- dup2 (fdStdError[1], STDERR_FILENO);
- close(fdStdError[1]);
- }
-
- close(fdStdInput[1]);
- close(fdStdOutput[0]);
- close(fdStdError[0]);
-
- /* the child */
- if (environment) {
- execvpe(args[0], args, environment);
- } else {
- execvp(args[0], args);
- }
- }
- _exit(127);
-
- default:
- close(fdStdInput[0]);
- close(fdStdOutput[1]);
- close(fdStdError[1]);
-
- *pfdStdInput = fdStdInput[1];
- *pfdStdOutput = fdStdOutput[0];
- *pfdStdError = fdStdError[0];
- break;
- }
-
- return pid;
-}
-
-int
-terminateProcess (ProcHandle handle)
-{
- return (kill(handle, SIGTERM) == 0);
-}
-
-int
-getProcessExitCode (ProcHandle handle, int *pExitCode)
-{
- int wstat, res;
-
- *pExitCode = 0;
-
- if ((res = waitpid(handle, &wstat, WNOHANG)) > 0)
- {
- if (WIFEXITED(wstat))
- {
- *pExitCode = WEXITSTATUS(wstat);
- return 1;
- }
- else
- if (WIFSIGNALED(wstat))
- {
- errno = EINTR;
- return -1;
- }
- else
- {
- /* This should never happen */
- }
- }
-
- if (res == 0) return 0;
-
- if (errno == ECHILD)
- {
- *pExitCode = 0;
- return 1;
- }
-
- return -1;
-}
-
-int waitForProcess (ProcHandle handle)
-{
- int wstat;
-
- while (waitpid(handle, &wstat, 0) < 0)
- {
- if (errno != EINTR)
- {
- return -1;
- }
- }
-
- if (WIFEXITED(wstat))
- return WEXITSTATUS(wstat);
- else
- if (WIFSIGNALED(wstat))
- {
- return wstat;
- }
- else
- {
- /* This should never happen */
- }
-
- return -1;
-}
-
-#else
-/* ----------------------------------------------------------------------------
- Win32 versions
- ------------------------------------------------------------------------- */
-
-/* -------------------- WINDOWS VERSION --------------------- */
-
-/*
- * Function: mkAnonPipe
- *
- * Purpose: create an anonymous pipe with read and write ends being
- * optionally (non-)inheritable.
- */
-static BOOL
-mkAnonPipe (HANDLE* pHandleIn, BOOL isInheritableIn,
- HANDLE* pHandleOut, BOOL isInheritableOut)
-{
- HANDLE hTemporaryIn = NULL;
- HANDLE hTemporaryOut = NULL;
- BOOL status;
- SECURITY_ATTRIBUTES sec_attrs;
-
- /* Create inheritable security attributes */
- sec_attrs.nLength = sizeof(SECURITY_ATTRIBUTES);
- sec_attrs.lpSecurityDescriptor = NULL;
- sec_attrs.bInheritHandle = TRUE;
-
- /* Create the anon pipe with both ends inheritable */
- if (!CreatePipe(&hTemporaryIn, &hTemporaryOut, &sec_attrs, 0))
- {
- maperrno();
- *pHandleIn = NULL;
- *pHandleOut = NULL;
- return FALSE;
- }
-
- if (isInheritableIn)
- *pHandleIn = hTemporaryIn;
- else
- {
- /* Make the read end non-inheritable */
- status = DuplicateHandle(GetCurrentProcess(), hTemporaryIn,
- GetCurrentProcess(), pHandleIn,
- 0,
- FALSE, /* non-inheritable */
- DUPLICATE_SAME_ACCESS);
- CloseHandle(hTemporaryIn);
- if (!status)
- {
- maperrno();
- *pHandleIn = NULL;
- *pHandleOut = NULL;
- CloseHandle(hTemporaryOut);
- return FALSE;
- }
- }
-
- if (isInheritableOut)
- *pHandleOut = hTemporaryOut;
- else
- {
- /* Make the write end non-inheritable */
- status = DuplicateHandle(GetCurrentProcess(), hTemporaryOut,
- GetCurrentProcess(), pHandleOut,
- 0,
- FALSE, /* non-inheritable */
- DUPLICATE_SAME_ACCESS);
- CloseHandle(hTemporaryOut);
- if (!status)
- {
- maperrno();
- *pHandleIn = NULL;
- *pHandleOut = NULL;
- CloseHandle(*pHandleIn);
- return FALSE;
- }
- }
-
- return TRUE;
-}
-
-ProcHandle
-runProcess (char *cmd, char *workingDirectory, void *environment,
- int fdStdInput, int fdStdOutput, int fdStdError)
-{
- STARTUPINFO sInfo;
- PROCESS_INFORMATION pInfo;
- DWORD flags;
-
- ZeroMemory(&sInfo, sizeof(sInfo));
- sInfo.cb = sizeof(sInfo);
- sInfo.hStdInput = (HANDLE) _get_osfhandle(fdStdInput);
- sInfo.hStdOutput= (HANDLE) _get_osfhandle(fdStdOutput);
- sInfo.hStdError = (HANDLE) _get_osfhandle(fdStdError);
-
- if (sInfo.hStdInput == INVALID_HANDLE_VALUE)
- sInfo.hStdInput = NULL;
- if (sInfo.hStdOutput == INVALID_HANDLE_VALUE)
- sInfo.hStdOutput = NULL;
- if (sInfo.hStdError == INVALID_HANDLE_VALUE)
- sInfo.hStdError = NULL;
-
- if (sInfo.hStdInput || sInfo.hStdOutput || sInfo.hStdError)
- sInfo.dwFlags = STARTF_USESTDHANDLES;
-
- if (sInfo.hStdInput != GetStdHandle(STD_INPUT_HANDLE) &&
- sInfo.hStdOutput != GetStdHandle(STD_OUTPUT_HANDLE) &&
- sInfo.hStdError != GetStdHandle(STD_ERROR_HANDLE))
- flags = CREATE_NO_WINDOW; // Run without console window only when both output and error are redirected
- else
- flags = 0;
-
- if (!CreateProcess(NULL, cmd, NULL, NULL, TRUE, flags, environment, workingDirectory, &sInfo, &pInfo))
- {
- maperrno();
- return -1;
- }
-
- CloseHandle(pInfo.hThread);
- return (ProcHandle)pInfo.hProcess;
-}
-
-ProcHandle
-runInteractiveProcess (char *cmd, char *workingDirectory, void *environment,
- int *pfdStdInput, int *pfdStdOutput, int *pfdStdError)
-{
- STARTUPINFO sInfo;
- PROCESS_INFORMATION pInfo;
- HANDLE hStdInputRead, hStdInputWrite;
- HANDLE hStdOutputRead, hStdOutputWrite;
- HANDLE hStdErrorRead, hStdErrorWrite;
-
- if (!mkAnonPipe(&hStdInputRead, TRUE, &hStdInputWrite, FALSE))
- return -1;
-
- if (!mkAnonPipe(&hStdOutputRead, FALSE, &hStdOutputWrite, TRUE))
- {
- CloseHandle(hStdInputRead);
- CloseHandle(hStdInputWrite);
- return -1;
- }
-
- if (!mkAnonPipe(&hStdErrorRead, FALSE, &hStdErrorWrite, TRUE))
- {
- CloseHandle(hStdInputRead);
- CloseHandle(hStdInputWrite);
- CloseHandle(hStdOutputRead);
- CloseHandle(hStdOutputWrite);
- return -1;
- }
-
- ZeroMemory(&sInfo, sizeof(sInfo));
- sInfo.cb = sizeof(sInfo);
- sInfo.dwFlags = STARTF_USESTDHANDLES;
- sInfo.hStdInput = hStdInputRead;
- sInfo.hStdOutput= hStdOutputWrite;
- sInfo.hStdError = hStdErrorWrite;
-
- if (!CreateProcess(NULL, cmd, NULL, NULL, TRUE, CREATE_NO_WINDOW, environment, workingDirectory, &sInfo, &pInfo))
- {
- maperrno();
- CloseHandle(hStdInputRead);
- CloseHandle(hStdInputWrite);
- CloseHandle(hStdOutputRead);
- CloseHandle(hStdOutputWrite);
- CloseHandle(hStdErrorRead);
- CloseHandle(hStdErrorWrite);
- return -1;
- }
- CloseHandle(pInfo.hThread);
-
- // Close the ends of the pipes that were inherited by the
- // child process. This is important, otherwise we won't see
- // EOF on these pipes when the child process exits.
- CloseHandle(hStdInputRead);
- CloseHandle(hStdOutputWrite);
- CloseHandle(hStdErrorWrite);
-
- *pfdStdInput = _open_osfhandle((intptr_t) hStdInputWrite, _O_WRONLY);
- *pfdStdOutput = _open_osfhandle((intptr_t) hStdOutputRead, _O_RDONLY);
- *pfdStdError = _open_osfhandle((intptr_t) hStdErrorRead, _O_RDONLY);
-
- return (int) pInfo.hProcess;
-}
-
-int
-terminateProcess (ProcHandle handle)
-{
- if (!TerminateProcess((HANDLE) handle, 1)) {
- maperrno();
- return -1;
- }
- return 0;
-}
-
-int
-getProcessExitCode (ProcHandle handle, int *pExitCode)
-{
- *pExitCode = 0;
-
- if (WaitForSingleObject((HANDLE) handle, 1) == WAIT_OBJECT_0)
- {
- if (GetExitCodeProcess((HANDLE) handle, (DWORD *) pExitCode) == 0)
- {
- maperrno();
- return -1;
- }
- return 1;
- }
-
- return 0;
-}
-
-int
-waitForProcess (ProcHandle handle)
-{
- DWORD retCode;
-
- if (WaitForSingleObject((HANDLE) handle, INFINITE) == WAIT_OBJECT_0)
- {
- if (GetExitCodeProcess((HANDLE) handle, &retCode) == 0)
- {
- maperrno();
- return -1;
- }
- return retCode;
- }
-
- maperrno();
- return -1;
-}
-
-#endif /* Win32 */
+++ /dev/null
-
-#include "HsBase.h"
-void hsFD_ZERO(fd_set *fds) { FD_ZERO(fds); }
+++ /dev/null
-/*
- * (c) The University of Glasgow 2002
- *
- * Time Runtime Support
- */
-#include "HsBase.h"
-
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) /* to the end */
-
-long *__hscore_timezone( void )
-{ return &_timezone; }
-
-char **__hscore_tzname( void )
-{ return _tzname; }
-#endif
+++ /dev/null
-#!/bin/sh
-
-# --------------------------------------------------------------------------
-# This is the script to create the unicode chars property table
-# Written by Dimitry Golubovsky (dimitry@golubovsky.org) as part
-# of the Partial Unicode Support patch
-#
-# Adopted for use with GHC.
-# License: see libraries/base/LICENSE
-#
-# -------------------------------------------------------------------------
-
-# The script reads the file from the standard input,
-# and outputs C code into the standard output.
-# The C code contains the chars property table, and basic functions
-# to access properties.
-
-# Output the file header
-
-echo "/*-------------------------------------------------------------------------"
-echo "This is an automatically generated file: do not edit"
-echo "Generated by `basename $0` at `date`"
-echo "-------------------------------------------------------------------------*/"
-echo
-echo "#include \"WCsubst.h\""
-
-# Define structures
-
-cat <<EOF
-
-/* Unicode general categories, listed in the same order as in the Unicode
- * standard -- this must be the same order as in GHC.Unicode.
- */
-
-enum {
- NUMCAT_LU, /* Letter, Uppercase */
- NUMCAT_LL, /* Letter, Lowercase */
- NUMCAT_LT, /* Letter, Titlecase */
- NUMCAT_LM, /* Letter, Modifier */
- NUMCAT_LO, /* Letter, Other */
- NUMCAT_MN, /* Mark, Non-Spacing */
- NUMCAT_MC, /* Mark, Spacing Combining */
- NUMCAT_ME, /* Mark, Enclosing */
- NUMCAT_ND, /* Number, Decimal */
- NUMCAT_NL, /* Number, Letter */
- NUMCAT_NO, /* Number, Other */
- NUMCAT_PC, /* Punctuation, Connector */
- NUMCAT_PD, /* Punctuation, Dash */
- NUMCAT_PS, /* Punctuation, Open */
- NUMCAT_PE, /* Punctuation, Close */
- NUMCAT_PI, /* Punctuation, Initial quote */
- NUMCAT_PF, /* Punctuation, Final quote */
- NUMCAT_PO, /* Punctuation, Other */
- NUMCAT_SM, /* Symbol, Math */
- NUMCAT_SC, /* Symbol, Currency */
- NUMCAT_SK, /* Symbol, Modifier */
- NUMCAT_SO, /* Symbol, Other */
- NUMCAT_ZS, /* Separator, Space */
- NUMCAT_ZL, /* Separator, Line */
- NUMCAT_ZP, /* Separator, Paragraph */
- NUMCAT_CC, /* Other, Control */
- NUMCAT_CF, /* Other, Format */
- NUMCAT_CS, /* Other, Surrogate */
- NUMCAT_CO, /* Other, Private Use */
- NUMCAT_CN /* Other, Not Assigned */
-};
-
-struct _convrule_
-{
- unsigned int category;
- unsigned int catnumber;
- int possible;
- int updist;
- int lowdist;
- int titledist;
-};
-
-struct _charblock_
-{
- int start;
- int length;
- const struct _convrule_ *rule;
-};
-
-EOF
-
-# Convert the stdin file to the C table
-
-awk '
-BEGIN {
- FS=";"
- catidx=0
- rulidx=0
- blockidx=0
- cblckidx=0
- sblckidx=0
- blockb=-1
- blockl=0
- digs="0123456789ABCDEF"
- for(i=0;i<16;i++)
- {
- hex[substr(digs,i+1,1)]=i;
- }
-}
-function em1(a)
-{
- if(a=="") return "-1"
- return "0x"a
-}
-function h2d(a)
-{
- l=length(a)
- acc=0
- for(i=1;i<=l;i++)
- {
- acc=acc*16+hex[substr(a,i,1)];
- }
- return acc
-}
-function dumpblock()
-{
- blkd=blockb ", " blockl ", &rule" rules[blockr]
- blocks[blockidx]=blkd
- blockidx++
- if(blockb<=256) lat1idx++
- split(blockr,rsp,",")
- if(substr(rsp[3],2,1)=="1")
- {
- cblcks[cblckidx]=blkd
- cblckidx++
- }
- if(rsp[1]=="GENCAT_ZS")
- {
- sblcks[sblckidx]=blkd
- sblckidx++
- }
- blockb=self
- blockl=1
- blockr=rule
-}
-{
- name=$2
- cat=toupper($3)
- self=h2d($1)
- up=h2d($13)
- low=h2d($14)
- title=h2d($15)
- convpos=1
- if((up==0)&&(low==0)&&(title==0)) convpos=0
- if(up==0) up=self
- if(low==0) low=self
- if(title==0) title=self
- updist=up-self
- lowdist=low-self
- titledist=title-self
- rule="GENCAT_"cat", NUMCAT_"cat", "((convpos==1)?
- ("1, " updist ", " lowdist ", " titledist):
- ("0, 0, 0, 0"))
- if(cats[cat]=="")
- {
- cats[cat]=(2^catidx);
- catidx++;
- }
- if(rules[rule]=="")
- {
- rules[rule]=rulidx;
- rulidx++;
- }
- if(blockb==-1)
- {
- blockb=self
- blockl=1
- blockr=rule
- }
- else
- {
- if (index(name,"First>")!=0)
- {
- dumpblock()
- }
- else if (index(name,"Last>")!=0)
- {
- blockl+=(self-blockb)
- }
- else if((self==blockb+blockl)&&(rule==blockr)) blockl++
- else
- {
- dumpblock()
- }
- }
-}
-END {
- dumpblock()
- for(c in cats) print "#define GENCAT_"c" "cats[c]
- print "#define MAX_UNI_CHAR " self
- print "#define NUM_BLOCKS " blockidx
- print "#define NUM_CONVBLOCKS " cblckidx
- print "#define NUM_SPACEBLOCKS " sblckidx
- print "#define NUM_LAT1BLOCKS " lat1idx
- print "#define NUM_RULES " rulidx
- for(r in rules)
- {
- printf "static const struct _convrule_ rule" rules[r] "={" r "};\n"
- }
- print "static const struct _charblock_ allchars[]={"
- for(i=0;i<blockidx;i++)
- {
- printf "\t{" blocks[i] "}"
- print (i<(blockidx-1))?",":""
- }
- print "};"
- print "static const struct _charblock_ convchars[]={"
- for(i=0;i<cblckidx;i++)
- {
- printf "\t{" cblcks[i] "}"
- print (i<(cblckidx-1))?",":""
- }
- print "};"
- print "static const struct _charblock_ spacechars[]={"
- for(i=0;i<sblckidx;i++)
- {
- printf "\t{" sblcks[i] "}"
- print (i<(sblckidx-1))?",":""
- }
- print "};"
-}
-'
-# Output the C procedures code
-
-cat <<EOF
-
-/*
- Obtain the reference to character rule by doing
- binary search over the specified array of blocks.
- To make checkattr shorter, the address of
- nullrule is returned if the search fails:
- this rule defines no category and no conversion
- distances. The compare function returns 0 when
- key->start is within the block. Otherwise
- result of comparison of key->start and start of the
- current block is returned as usual.
-*/
-
-static const struct _convrule_ nullrule={0,NUMCAT_CN,0,0,0,0};
-
-int blkcmp(const void *vk,const void *vb)
-{
- const struct _charblock_ *key,*cur;
- key=vk;
- cur=vb;
- if((key->start>=cur->start)&&(key->start<(cur->start+cur->length)))
- {
- return 0;
- }
- if(key->start>cur->start) return 1;
- return -1;
-}
-
-static const struct _convrule_ *getrule(
- const struct _charblock_ *blocks,
- int numblocks,
- int unichar)
-{
- struct _charblock_ key={unichar,1,(void *)0};
- struct _charblock_ *cb=bsearch(&key,blocks,numblocks,sizeof(key),blkcmp);
- if(cb==(void *)0) return &nullrule;
- return cb->rule;
-}
-
-
-
-/*
- Check whether a character (internal code) has certain attributes.
- Attributes (category flags) may be ORed. The function ANDs
- character category flags and the mask and returns the result.
- If the character belongs to one of the categories requested,
- the result will be nonzero.
-*/
-
-inline static int checkattr(int c,unsigned int catmask)
-{
- return (catmask & (getrule(allchars,(c<256)?NUM_LAT1BLOCKS:NUM_BLOCKS,c)->category));
-}
-
-inline static int checkattr_s(int c,unsigned int catmask)
-{
- return (catmask & (getrule(spacechars,NUM_SPACEBLOCKS,c)->category));
-}
-
-/*
- Define predicate functions for some combinations of categories.
-*/
-
-#define unipred(p,m) \\
-int p(int c) \\
-{ \\
- return checkattr(c,m); \\
-}
-
-#define unipred_s(p,m) \\
-int p(int c) \\
-{ \\
- return checkattr_s(c,m); \\
-}
-
-/*
- Make these rules as close to Hugs as possible.
-*/
-
-unipred(u_iswcntrl,GENCAT_CC)
-unipred(u_iswprint, \
-(GENCAT_MC | GENCAT_NO | GENCAT_SK | GENCAT_ME | GENCAT_ND | \
- GENCAT_PO | GENCAT_LT | GENCAT_PC | GENCAT_SM | GENCAT_ZS | \
- GENCAT_LU | GENCAT_PD | GENCAT_SO | GENCAT_PE | GENCAT_PF | \
- GENCAT_PS | GENCAT_SC | GENCAT_LL | GENCAT_LM | GENCAT_PI | \
- GENCAT_NL | GENCAT_MN | GENCAT_LO))
-unipred_s(u_iswspace,GENCAT_ZS)
-unipred(u_iswupper,(GENCAT_LU|GENCAT_LT))
-unipred(u_iswlower,GENCAT_LL)
-unipred(u_iswalpha,(GENCAT_LL|GENCAT_LU|GENCAT_LT|GENCAT_LM|GENCAT_LO))
-unipred(u_iswdigit,GENCAT_ND)
-
-unipred(u_iswalnum,(GENCAT_LT|GENCAT_LU|GENCAT_LL|GENCAT_LM|GENCAT_LO|
- GENCAT_MC|GENCAT_ME|GENCAT_MN|
- GENCAT_NO|GENCAT_ND|GENCAT_NL))
-
-#define caseconv(p,to) \\
-int p(int c) \\
-{ \\
- const struct _convrule_ *rule=getrule(convchars,NUM_CONVBLOCKS,c);\\
- if(rule==&nullrule) return c;\\
- return c+rule->##to;\\
-}
-
-caseconv(u_towupper,updist)
-caseconv(u_towlower,lowdist)
-caseconv(u_towtitle,titledist)
-
-int u_gencat(int c)
-{
- return getrule(allchars,NUM_BLOCKS,c)->catnumber;
-}
-
-EOF
+++ /dev/null
-AC_INIT([Haskell base package], [1.0], [libraries@haskell.org], [base])
-
-# Safety check: Ensure that we are in the correct source directory.
-AC_CONFIG_SRCDIR([include/HsBase.h])
-
-AC_CONFIG_HEADERS([include/HsBaseConfig.h])
-
-AC_ARG_WITH([cc],
- [C compiler],
- [CC=$withval])
-AC_PROG_CC()
-
-# do we have long longs?
-AC_CHECK_TYPES([long long])
-
-dnl ** Working vfork?
-AC_FUNC_FORK
-
-dnl ** determine whether or not const works
-AC_C_CONST
-
-dnl ** check for full ANSI header (.h) files
-AC_HEADER_STDC
-
-# check for specific header (.h) files that we are interested in
-AC_CHECK_HEADERS([ctype.h dirent.h errno.h fcntl.h limits.h signal.h sys/resource.h sys/select.h sys/syscall.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/utsname.h sys/wait.h termios.h time.h utime.h windows.h winsock.h])
-
-# Enable large file support. Do this before testing the types ino_t, off_t, and
-# rlim_t, because it will affect the result of that test.
-AC_SYS_LARGEFILE
-
-dnl ** check for wide-char classifications
-dnl FreeBSD has an emtpy wctype.h, so test one of the affected
-dnl functions if it's really there.
-AC_CHECK_HEADERS([wctype.h], [AC_CHECK_FUNCS(iswspace)])
-
-AC_CHECK_FUNCS([ftime gmtime_r localtime_r lstat readdir_r])
-AC_CHECK_FUNCS([getclock getrusage gettimeofday setitimer times])
-AC_CHECK_FUNCS([_chsize ftruncate])
-
-dnl ** check if it is safe to include both <time.h> and <sys/time.h>
-AC_HEADER_TIME
-
-dnl ** how do we get a timezone name, and UTC offset ?
-AC_STRUCT_TIMEZONE
-
-dnl ** do we have altzone?
-FP_DECL_ALTZONE
-
-# map standard C types and ISO types to Haskell types
-FPTOOLS_CHECK_HTYPE(char)
-FPTOOLS_CHECK_HTYPE(signed char)
-FPTOOLS_CHECK_HTYPE(unsigned char)
-FPTOOLS_CHECK_HTYPE(short)
-FPTOOLS_CHECK_HTYPE(unsigned short)
-FPTOOLS_CHECK_HTYPE(int)
-FPTOOLS_CHECK_HTYPE(unsigned int)
-FPTOOLS_CHECK_HTYPE(long)
-FPTOOLS_CHECK_HTYPE(unsigned long)
-if test "$ac_cv_type_long_long" = yes; then
-FPTOOLS_CHECK_HTYPE(long long)
-FPTOOLS_CHECK_HTYPE(unsigned long long)
-fi
-FPTOOLS_CHECK_HTYPE(float)
-FPTOOLS_CHECK_HTYPE(double)
-FPTOOLS_CHECK_HTYPE(ptrdiff_t)
-FPTOOLS_CHECK_HTYPE(size_t)
-FPTOOLS_CHECK_HTYPE(wchar_t)
-# Int32 is a HACK for non-ISO C compilers
-FPTOOLS_CHECK_HTYPE(sig_atomic_t, Int32)
-FPTOOLS_CHECK_HTYPE(clock_t)
-FPTOOLS_CHECK_HTYPE(time_t)
-FPTOOLS_CHECK_HTYPE(dev_t, Word32)
-FPTOOLS_CHECK_HTYPE(ino_t)
-FPTOOLS_CHECK_HTYPE(mode_t)
-FPTOOLS_CHECK_HTYPE(off_t)
-FPTOOLS_CHECK_HTYPE(pid_t)
-FPTOOLS_CHECK_HTYPE(gid_t)
-FPTOOLS_CHECK_HTYPE(uid_t)
-FPTOOLS_CHECK_HTYPE(cc_t)
-FPTOOLS_CHECK_HTYPE(speed_t)
-FPTOOLS_CHECK_HTYPE(tcflag_t)
-FPTOOLS_CHECK_HTYPE(nlink_t)
-FPTOOLS_CHECK_HTYPE(ssize_t)
-FPTOOLS_CHECK_HTYPE(rlim_t)
-FPTOOLS_CHECK_HTYPE(wint_t)
-
-FPTOOLS_CHECK_HTYPE(intptr_t)
-FPTOOLS_CHECK_HTYPE(uintptr_t)
-# Workaround for OSes that don't have intmax_t and uintmax_t, e.g. OpenBSD.
-if test "$ac_cv_type_long_long" = yes; then
- fptools_cv_default_htype_intmax=$fptools_cv_htype_long_long
- fptools_cv_default_htype_uintmax=$fptools_cv_htype_unsigned_long_long
-else
- fptools_cv_default_htype_intmax=$fptools_cv_htype_long
- fptools_cv_default_htype_uintmax=$fptools_cv_htype_unsigned_long
-fi
-FPTOOLS_CHECK_HTYPE(intmax_t, $fptools_cv_default_htype_intmax)
-FPTOOLS_CHECK_HTYPE(uintmax_t, $fptools_cv_default_htype_uintmax)
-
-# test errno values
-FP_CHECK_CONSTS([E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EADV EAFNOSUPPORT EAGAIN EALREADY EBADF EBADMSG EBADRPC EBUSY ECHILD ECOMM ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDIRTY EDOM EDQUOT EEXIST EFAULT EFBIG EFTYPE EHOSTDOWN EHOSTUNREACH EIDRM EILSEQ EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE EMULTIHOP ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS ENODATA ENODEV ENOENT ENOEXEC ENOLCK ENOLINK ENOMEM ENOMSG ENONET ENOPROTOOPT ENOSPC ENOSR ENOSTR ENOSYS ENOTBLK ENOTCONN ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT EPIPE EPROCLIM EPROCUNAVAIL EPROGMISMATCH EPROGUNAVAIL EPROTO EPROTONOSUPPORT EPROTOTYPE ERANGE EREMCHG EREMOTE EROFS ERPCMISMATCH ERREMOTE ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESRMNT ESTALE ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV ENOCIGAR], [#include <stdio.h>
-#include <errno.h>])
-
-FP_CHECK_CONSTS([SIGABRT SIGALRM SIGBUS SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 SIGPOLL SIGPROF SIGSYS SIGTRAP SIGURG SIGVTALRM SIGXCPU SIGXFSZ SIG_BLOCK SIG_SETMASK SIG_UNBLOCK SIG_DFL SIG_IGN SIG_ERR], [
-#if HAVE_SIGNAL_H
-#include <signal.h>
-#endif])
-
-dnl ** can we open files in binary mode?
-FP_CHECK_CONST([O_BINARY], [#include <fcntl.h>], [0])
-
-# Check for idiosyncracies in some mingw impls of directory handling.
-FP_READDIR_EOF_ERRNO
-
-AC_OUTPUT
--- /dev/null
+name: directory
+version: 1.0
+license: BSD3
+license-file: LICENSE
+maintainer: libraries@haskell.org
+synopsis: library for directory handling
+description:
+ This package provides a library for handling directories.
+exposed-modules:
+ System.Directory
+ System.Directory.Internals
+c-sources:
+ cbits/directory.c
+include-dirs: include
+includes: HsDirectory.h
+install-includes: HsDirectory.h
+extensions: CPP, ForeignFunctionInterface
+build-depends: base, old-time
+
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * Dirty CPP hackery for CTypes/CTypesISO
- *
- * (c) The FFI task force, 2000
- * -------------------------------------------------------------------------- */
-
-#ifndef CTYPES__H
-#define CTYPES__H
-
-#include "Typeable.h"
-
-/* As long as there is no automatic derivation of classes for newtypes we resort
- to extremely dirty cpp-hackery. :-P Some care has to be taken when the
- macros below are modified, otherwise the layout rule will bite you. */
-
-/* A hacked version for GHC follows the Haskell 98 version... */
-#ifndef __GLASGOW_HASKELL__
-
-#define ARITHMETIC_TYPE(T,C,S,B) \
-newtype T = T B deriving (Eq, Ord) ; \
-INSTANCE_NUM(T) ; \
-INSTANCE_REAL(T) ; \
-INSTANCE_READ(T,B) ; \
-INSTANCE_SHOW(T,B) ; \
-INSTANCE_ENUM(T) ; \
-INSTANCE_STORABLE(T) ; \
-INSTANCE_TYPEABLE0(T,C,S) ;
-
-#define INTEGRAL_TYPE(T,C,S,B) \
-ARITHMETIC_TYPE(T,C,S,B) ; \
-INSTANCE_BOUNDED(T) ; \
-INSTANCE_INTEGRAL(T) ; \
-INSTANCE_BITS(T)
-
-#define FLOATING_TYPE(T,C,S,B) \
-ARITHMETIC_TYPE(T,C,S,B) ; \
-INSTANCE_FRACTIONAL(T) ; \
-INSTANCE_FLOATING(T) ; \
-INSTANCE_REALFRAC(T) ; \
-INSTANCE_REALFLOAT(T)
-
-#ifndef __GLASGOW_HASKELL__
-#define fakeMap map
-#endif
-
-#define INSTANCE_READ(T,B) \
-instance Read T where { \
- readsPrec p s = fakeMap (\(x, t) -> (T x, t)) (readsPrec p s) }
-
-#define INSTANCE_SHOW(T,B) \
-instance Show T where { \
- showsPrec p (T x) = showsPrec p x }
-
-#define INSTANCE_NUM(T) \
-instance Num T where { \
- (T i) + (T j) = T (i + j) ; \
- (T i) - (T j) = T (i - j) ; \
- (T i) * (T j) = T (i * j) ; \
- negate (T i) = T (negate i) ; \
- abs (T i) = T (abs i) ; \
- signum (T i) = T (signum i) ; \
- fromInteger x = T (fromInteger x) }
-
-#define INSTANCE_BOUNDED(T) \
-instance Bounded T where { \
- minBound = T minBound ; \
- maxBound = T maxBound }
-
-#define INSTANCE_ENUM(T) \
-instance Enum T where { \
- succ (T i) = T (succ i) ; \
- pred (T i) = T (pred i) ; \
- toEnum x = T (toEnum x) ; \
- fromEnum (T i) = fromEnum i ; \
- enumFrom (T i) = fakeMap T (enumFrom i) ; \
- enumFromThen (T i) (T j) = fakeMap T (enumFromThen i j) ; \
- enumFromTo (T i) (T j) = fakeMap T (enumFromTo i j) ; \
- enumFromThenTo (T i) (T j) (T k) = fakeMap T (enumFromThenTo i j k) }
-
-#define INSTANCE_REAL(T) \
-instance Real T where { \
- toRational (T i) = toRational i }
-
-#define INSTANCE_INTEGRAL(T) \
-instance Integral T where { \
- (T i) `quot` (T j) = T (i `quot` j) ; \
- (T i) `rem` (T j) = T (i `rem` j) ; \
- (T i) `div` (T j) = T (i `div` j) ; \
- (T i) `mod` (T j) = T (i `mod` j) ; \
- (T i) `quotRem` (T j) = let (q,r) = i `quotRem` j in (T q, T r) ; \
- (T i) `divMod` (T j) = let (d,m) = i `divMod` j in (T d, T m) ; \
- toInteger (T i) = toInteger i }
-
-#define INSTANCE_BITS(T) \
-instance Bits T where { \
- (T x) .&. (T y) = T (x .&. y) ; \
- (T x) .|. (T y) = T (x .|. y) ; \
- (T x) `xor` (T y) = T (x `xor` y) ; \
- complement (T x) = T (complement x) ; \
- shift (T x) n = T (shift x n) ; \
- rotate (T x) n = T (rotate x n) ; \
- bit n = T (bit n) ; \
- setBit (T x) n = T (setBit x n) ; \
- clearBit (T x) n = T (clearBit x n) ; \
- complementBit (T x) n = T (complementBit x n) ; \
- testBit (T x) n = testBit x n ; \
- bitSize (T x) = bitSize x ; \
- isSigned (T x) = isSigned x }
-
-#define INSTANCE_FRACTIONAL(T) \
-instance Fractional T where { \
- (T x) / (T y) = T (x / y) ; \
- recip (T x) = T (recip x) ; \
- fromRational r = T (fromRational r) }
-
-#define INSTANCE_FLOATING(T) \
-instance Floating T where { \
- pi = pi ; \
- exp (T x) = T (exp x) ; \
- log (T x) = T (log x) ; \
- sqrt (T x) = T (sqrt x) ; \
- (T x) ** (T y) = T (x ** y) ; \
- (T x) `logBase` (T y) = T (x `logBase` y) ; \
- sin (T x) = T (sin x) ; \
- cos (T x) = T (cos x) ; \
- tan (T x) = T (tan x) ; \
- asin (T x) = T (asin x) ; \
- acos (T x) = T (acos x) ; \
- atan (T x) = T (atan x) ; \
- sinh (T x) = T (sinh x) ; \
- cosh (T x) = T (cosh x) ; \
- tanh (T x) = T (tanh x) ; \
- asinh (T x) = T (asinh x) ; \
- acosh (T x) = T (acosh x) ; \
- atanh (T x) = T (atanh x) }
-
-#define INSTANCE_REALFRAC(T) \
-instance RealFrac T where { \
- properFraction (T x) = let (m,y) = properFraction x in (m, T y) ; \
- truncate (T x) = truncate x ; \
- round (T x) = round x ; \
- ceiling (T x) = ceiling x ; \
- floor (T x) = floor x }
-
-#define INSTANCE_REALFLOAT(T) \
-instance RealFloat T where { \
- floatRadix (T x) = floatRadix x ; \
- floatDigits (T x) = floatDigits x ; \
- floatRange (T x) = floatRange x ; \
- decodeFloat (T x) = decodeFloat x ; \
- encodeFloat m n = T (encodeFloat m n) ; \
- exponent (T x) = exponent x ; \
- significand (T x) = T (significand x) ; \
- scaleFloat n (T x) = T (scaleFloat n x) ; \
- isNaN (T x) = isNaN x ; \
- isInfinite (T x) = isInfinite x ; \
- isDenormalized (T x) = isDenormalized x ; \
- isNegativeZero (T x) = isNegativeZero x ; \
- isIEEE (T x) = isIEEE x ; \
- (T x) `atan2` (T y) = T (x `atan2` y) }
-
-#define INSTANCE_STORABLE(T) \
-instance Storable T where { \
- sizeOf (T x) = sizeOf x ; \
- alignment (T x) = alignment x ; \
- peekElemOff a i = liftM T (peekElemOff (castPtr a) i) ; \
- pokeElemOff a i (T x) = pokeElemOff (castPtr a) i x }
-
-#else /* __GLASGOW_HASKELL__ */
-
-/* GHC can derive any class for a newtype, so we make use of that
- * here...
- */
-
-#define ARITHMETIC_CLASSES Eq,Ord,Num,Enum,Storable,Real
-#define INTEGRAL_CLASSES Bounded,Integral,Bits
-#define FLOATING_CLASSES Fractional,Floating,RealFrac,RealFloat
-
-#define ARITHMETIC_TYPE(T,C,S,B) \
-newtype T = T B deriving (ARITHMETIC_CLASSES); \
-INSTANCE_READ(T,B); \
-INSTANCE_SHOW(T,B); \
-INSTANCE_TYPEABLE0(T,C,S) ;
-
-#define INTEGRAL_TYPE(T,C,S,B) \
-newtype T = T B deriving (ARITHMETIC_CLASSES, INTEGRAL_CLASSES); \
-INSTANCE_READ(T,B); \
-INSTANCE_SHOW(T,B); \
-INSTANCE_TYPEABLE0(T,C,S) ;
-
-#define FLOATING_TYPE(T,C,S,B) \
-newtype T = T B deriving (ARITHMETIC_CLASSES, FLOATING_CLASSES); \
-INSTANCE_READ(T,B); \
-INSTANCE_SHOW(T,B); \
-INSTANCE_TYPEABLE0(T,C,S) ;
-
-#define INSTANCE_READ(T,B) \
-instance Read T where { \
- readsPrec = unsafeCoerce# (readsPrec :: Int -> ReadS B); \
- readList = unsafeCoerce# (readList :: ReadS [B]); }
-
-#define INSTANCE_SHOW(T,B) \
-instance Show T where { \
- showsPrec = unsafeCoerce# (showsPrec :: Int -> B -> ShowS); \
- show = unsafeCoerce# (show :: B -> String); \
- showList = unsafeCoerce# (showList :: [B] -> ShowS); }
-
-#endif /* __GLASGOW_HASKELL__ */
-
-#endif
+++ /dev/null
-/* -----------------------------------------------------------------------------
- *
- * (c) The University of Glasgow 2001-2004
- *
- * Definitions for package `base' which are visible in Haskell land.
- *
- * ---------------------------------------------------------------------------*/
-
-#ifndef __HSBASE_H__
-#define __HSBASE_H__
-
-#include "HsBaseConfig.h"
-
-/* ultra-evil... */
-#undef PACKAGE_BUGREPORT
-#undef PACKAGE_NAME
-#undef PACKAGE_STRING
-#undef PACKAGE_TARNAME
-#undef PACKAGE_VERSION
-
-/* Needed to get the macro version of errno on some OSs (eg. Solaris).
- We must do this, because these libs are only compiled once, but
- must work in both single-threaded and multi-threaded programs. */
-#define _REENTRANT 1
-
-#include "HsFFI.h"
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <math.h>
-
-#if HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-#if HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-#if HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-#if HAVE_FCNTL_H
-# include <fcntl.h>
-#endif
-#if HAVE_TERMIOS_H
-#include <termios.h>
-#endif
-#if HAVE_SIGNAL_H
-#include <signal.h>
-/* Ultra-ugly: OpenBSD uses broken macros for sigemptyset and sigfillset (missing casts) */
-#if __OpenBSD__
-#undef sigemptyset
-#undef sigfillset
-#endif
-#endif
-#if HAVE_ERRNO_H
-#include <errno.h>
-#endif
-#if HAVE_STRING_H
-#include <string.h>
-#endif
-#if HAVE_DIRENT_H
-#include <dirent.h>
-#endif
-#if HAVE_UTIME_H
-#include <utime.h>
-#endif
-#if HAVE_SYS_UTSNAME_H
-#include <sys/utsname.h>
-#endif
-#if HAVE_GETTIMEOFDAY
-# if HAVE_SYS_TIME_H
-# include <sys/time.h>
-# endif
-#elif HAVE_GETCLOCK
-# if HAVE_SYS_TIMERS_H
-# define POSIX_4D9 1
-# include <sys/timers.h>
-# endif
-#endif
-#if HAVE_TIME_H
-#include <time.h>
-#endif
-#if HAVE_SYS_TIMEB_H
-#include <sys/timeb.h>
-#endif
-#if HAVE_WINDOWS_H
-#include <windows.h>
-#endif
-#if HAVE_SYS_TIMES_H
-#include <sys/times.h>
-#endif
-#if HAVE_WINSOCK_H && defined(__MINGW32__)
-#include <winsock.h>
-#endif
-#if HAVE_LIMITS_H
-#include <limits.h>
-#endif
-#if HAVE_WCTYPE_H
-#include <wctype.h>
-#endif
-#if HAVE_INTTYPES_H
-# include <inttypes.h>
-#elif HAVE_STDINT_H
-# include <stdint.h>
-#endif
-
-#if !defined(__MINGW32__) && !defined(irix_HOST_OS)
-# if HAVE_SYS_RESOURCE_H
-# include <sys/resource.h>
-# endif
-#endif
-
-#if !HAVE_GETRUSAGE && HAVE_SYS_SYSCALL_H
-# include <sys/syscall.h>
-# if defined(SYS_GETRUSAGE) /* hpux_HOST_OS */
-# define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b)
-# define HAVE_GETRUSAGE 1
-# endif
-#endif
-
-/* For System */
-#if HAVE_SYS_WAIT_H
-#include <sys/wait.h>
-#endif
-#if HAVE_VFORK_H
-#include <vfork.h>
-#endif
-#include "lockFile.h"
-#include "dirUtils.h"
-#include "WCsubst.h"
-
-#include "runProcess.h"
-
-#if defined(__MINGW32__)
-/* in Win32Utils.c */
-extern void maperrno (void);
-extern HsWord64 getUSecOfDay(void);
-#endif
-
-#if defined(__MINGW32__)
-#include <io.h>
-#include <fcntl.h>
-#include "timeUtils.h"
-#include <shlobj.h>
-#include <share.h>
-#endif
-
-#if HAVE_SYS_SELECT_H
-#include <sys/select.h>
-#endif
-
-/* in inputReady.c */
-int inputReady(int fd, int msecs, int isSock);
-
-/* in Signals.c */
-extern HsInt nocldstop;
-
-#if !defined(_MSC_VER) && !defined(__MINGW32__) && !defined(_WIN32)
-/* in execvpe.c */
-extern int execvpe(char *name, char *const argv[], char **envp);
-extern void pPrPr_disableITimers (void);
-#endif
-
-/* -----------------------------------------------------------------------------
- 64-bit operations, defined in longlong.c
- -------------------------------------------------------------------------- */
-
-#ifdef SUPPORT_LONG_LONGS
-
-HsBool hs_gtWord64 (HsWord64, HsWord64);
-HsBool hs_geWord64 (HsWord64, HsWord64);
-HsBool hs_eqWord64 (HsWord64, HsWord64);
-HsBool hs_neWord64 (HsWord64, HsWord64);
-HsBool hs_ltWord64 (HsWord64, HsWord64);
-HsBool hs_leWord64 (HsWord64, HsWord64);
-
-HsBool hs_gtInt64 (HsInt64, HsInt64);
-HsBool hs_geInt64 (HsInt64, HsInt64);
-HsBool hs_eqInt64 (HsInt64, HsInt64);
-HsBool hs_neInt64 (HsInt64, HsInt64);
-HsBool hs_ltInt64 (HsInt64, HsInt64);
-HsBool hs_leInt64 (HsInt64, HsInt64);
-
-HsWord64 hs_remWord64 (HsWord64, HsWord64);
-HsWord64 hs_quotWord64 (HsWord64, HsWord64);
-
-HsInt64 hs_remInt64 (HsInt64, HsInt64);
-HsInt64 hs_quotInt64 (HsInt64, HsInt64);
-HsInt64 hs_negateInt64 (HsInt64);
-HsInt64 hs_plusInt64 (HsInt64, HsInt64);
-HsInt64 hs_minusInt64 (HsInt64, HsInt64);
-HsInt64 hs_timesInt64 (HsInt64, HsInt64);
-
-HsWord64 hs_and64 (HsWord64, HsWord64);
-HsWord64 hs_or64 (HsWord64, HsWord64);
-HsWord64 hs_xor64 (HsWord64, HsWord64);
-HsWord64 hs_not64 (HsWord64);
-
-HsWord64 hs_uncheckedShiftL64 (HsWord64, HsInt);
-HsWord64 hs_uncheckedShiftRL64 (HsWord64, HsInt);
-HsInt64 hs_uncheckedIShiftL64 (HsInt64, HsInt);
-HsInt64 hs_uncheckedIShiftRA64 (HsInt64, HsInt);
-HsInt64 hs_uncheckedIShiftRL64 (HsInt64, HsInt);
-
-HsInt64 hs_intToInt64 (HsInt);
-HsInt hs_int64ToInt (HsInt64);
-HsWord64 hs_int64ToWord64 (HsInt64);
-HsWord64 hs_wordToWord64 (HsWord);
-HsWord hs_word64ToWord (HsWord64);
-HsInt64 hs_word64ToInt64 (HsWord64);
-
-HsWord64 hs_integerToWord64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da);
-HsInt64 hs_integerToInt64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da);
-
-#endif /* SUPPORT_LONG_LONGS */
-
-/* -----------------------------------------------------------------------------
- INLINE functions.
-
- These functions are given as inlines here for when compiling via C,
- but we also generate static versions into the cbits library for
- when compiling to native code.
- -------------------------------------------------------------------------- */
-
-#ifndef INLINE
-# if defined(_MSC_VER)
-# define INLINE extern __inline
-# else
-# define INLINE static inline
-# endif
-#endif
-
-INLINE int __hscore_get_errno(void) { return errno; }
-INLINE void __hscore_set_errno(int e) { errno = e; }
-
-#if !defined(_MSC_VER)
-INLINE int __hscore_s_isreg(mode_t m) { return S_ISREG(m); }
-INLINE int __hscore_s_isdir(mode_t m) { return S_ISDIR(m); }
-INLINE int __hscore_s_isfifo(mode_t m) { return S_ISFIFO(m); }
-INLINE int __hscore_s_isblk(mode_t m) { return S_ISBLK(m); }
-INLINE int __hscore_s_ischr(mode_t m) { return S_ISCHR(m); }
-#ifdef S_ISSOCK
-INLINE int __hscore_s_issock(mode_t m) { return S_ISSOCK(m); }
-#endif
-#endif
-
-#if !defined(_MSC_VER) && !defined(__MINGW32__) && !defined(_WIN32)
-INLINE int
-__hscore_sigemptyset( sigset_t *set )
-{ return sigemptyset(set); }
-
-INLINE int
-__hscore_sigfillset( sigset_t *set )
-{ return sigfillset(set); }
-
-INLINE int
-__hscore_sigaddset( sigset_t * set, int s )
-{ return sigaddset(set,s); }
-
-INLINE int
-__hscore_sigdelset( sigset_t * set, int s )
-{ return sigdelset(set,s); }
-
-INLINE int
-__hscore_sigismember( sigset_t * set, int s )
-{ return sigismember(set,s); }
-#endif
-
-INLINE void *
-__hscore_memcpy_dst_off( char *dst, int dst_off, char *src, size_t sz )
-{ return memcpy(dst+dst_off, src, sz); }
-
-INLINE void *
-__hscore_memcpy_src_off( char *dst, char *src, int src_off, size_t sz )
-{ return memcpy(dst, src+src_off, sz); }
-
-INLINE HsBool
-__hscore_supportsTextMode()
-{
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
- return HS_BOOL_FALSE;
-#else
- return HS_BOOL_TRUE;
-#endif
-}
-
-INLINE HsInt
-__hscore_bufsiz()
-{
- return BUFSIZ;
-}
-
-INLINE int
-__hscore_seek_cur()
-{
- return SEEK_CUR;
-}
-
-INLINE int
-__hscore_o_binary()
-{
-#if defined(_MSC_VER)
- return O_BINARY;
-#else
- return CONST_O_BINARY;
-#endif
-}
-
-INLINE int
-__hscore_o_rdonly()
-{
-#ifdef O_RDONLY
- return O_RDONLY;
-#else
- return 0;
-#endif
-}
-
-INLINE int
-__hscore_o_wronly( void )
-{
-#ifdef O_WRONLY
- return O_WRONLY;
-#else
- return 0;
-#endif
-}
-
-INLINE int
-__hscore_o_rdwr( void )
-{
-#ifdef O_RDWR
- return O_RDWR;
-#else
- return 0;
-#endif
-}
-
-INLINE int
-__hscore_o_append( void )
-{
-#ifdef O_APPEND
- return O_APPEND;
-#else
- return 0;
-#endif
-}
-
-INLINE int
-__hscore_o_creat( void )
-{
-#ifdef O_CREAT
- return O_CREAT;
-#else
- return 0;
-#endif
-}
-
-INLINE int
-__hscore_o_excl( void )
-{
-#ifdef O_EXCL
- return O_EXCL;
-#else
- return 0;
-#endif
-}
-
-INLINE int
-__hscore_o_trunc( void )
-{
-#ifdef O_TRUNC
- return O_TRUNC;
-#else
- return 0;
-#endif
-}
-
-INLINE int
-__hscore_o_noctty( void )
-{
-#ifdef O_NOCTTY
- return O_NOCTTY;
-#else
- return 0;
-#endif
-}
-
-INLINE int
-__hscore_o_nonblock( void )
-{
-#ifdef O_NONBLOCK
- return O_NONBLOCK;
-#else
- return 0;
-#endif
-}
-
-INLINE int
-__hscore_seek_set( void )
-{
- return SEEK_SET;
-}
-
-INLINE int
-__hscore_seek_end( void )
-{
- return SEEK_END;
-}
-
-INLINE int
-__hscore_ftruncate( int fd, off_t where )
-{
-#if defined(HAVE_FTRUNCATE)
- return ftruncate(fd,where);
-#elif defined(HAVE__CHSIZE)
- return _chsize(fd,where);
-#else
-#error at least ftruncate or _chsize functions are required to build
-#endif
-}
-
-INLINE int
-__hscore_setmode( int fd, HsBool toBin )
-{
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
- return setmode(fd,(toBin == HS_BOOL_TRUE) ? _O_BINARY : _O_TEXT);
-#else
- return 0;
-#endif
-}
-
-#if __GLASGOW_HASKELL__
-
-INLINE int
-__hscore_PrelHandle_write( int fd, void *ptr, HsInt off, int sz )
-{
- return write(fd,(char *)ptr + off, sz);
-}
-
-INLINE int
-__hscore_PrelHandle_read( int fd, void *ptr, HsInt off, int sz )
-{
- return read(fd,(char *)ptr + off, sz);
-
-}
-
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
-INLINE int
-__hscore_PrelHandle_send( int fd, void *ptr, HsInt off, int sz )
-{
- return send(fd,(char *)ptr + off, sz, 0);
-}
-
-INLINE int
-__hscore_PrelHandle_recv( int fd, void *ptr, HsInt off, int sz )
-{
- return recv(fd,(char *)ptr + off, sz, 0);
-}
-#endif
-
-#endif /* __GLASGOW_HASKELL__ */
-
-INLINE int
-__hscore_mkdir( char *pathName, int mode )
-{
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
- return mkdir(pathName);
-#else
- return mkdir(pathName,mode);
-#endif
-}
-
-INLINE int
-__hscore_lstat( const char *fname, struct stat *st )
-{
-#if HAVE_LSTAT
- return lstat(fname, st);
-#else
- return stat(fname, st);
-#endif
-}
-
-#ifdef PATH_MAX
-/* A size that will contain many path names, but not necessarily all
- * (PATH_MAX is not defined on systems with unlimited path length,
- * e.g. the Hurd).
- */
-INLINE HsInt __hscore_long_path_size() { return PATH_MAX; }
-#else
-INLINE HsInt __hscore_long_path_size() { return 4096; }
-#endif
-
-#ifdef R_OK
-INLINE int __hscore_R_OK() { return R_OK; }
-#endif
-#ifdef W_OK
-INLINE int __hscore_W_OK() { return W_OK; }
-#endif
-#ifdef X_OK
-INLINE int __hscore_X_OK() { return X_OK; }
-#endif
-
-#ifdef S_IRUSR
-INLINE mode_t __hscore_S_IRUSR() { return S_IRUSR; }
-#endif
-#ifdef S_IWUSR
-INLINE mode_t __hscore_S_IWUSR() { return S_IWUSR; }
-#endif
-#ifdef S_IXUSR
-INLINE mode_t __hscore_S_IXUSR() { return S_IXUSR; }
-#endif
-
-INLINE char *
-__hscore_d_name( struct dirent* d )
-{
- return (d->d_name);
-}
-
-INLINE int
-__hscore_end_of_dir( void )
-{
- return READDIR_ERRNO_EOF;
-}
-
-INLINE void
-__hscore_free_dirent(struct dirent *dEnt)
-{
-#if HAVE_READDIR_R
- free(dEnt);
-#endif
-}
-
-INLINE HsInt
-__hscore_sizeof_stat( void )
-{
- return sizeof(struct stat);
-}
-
-INLINE time_t __hscore_st_mtime ( struct stat* st ) { return st->st_mtime; }
-INLINE off_t __hscore_st_size ( struct stat* st ) { return st->st_size; }
-#if !defined(_MSC_VER)
-INLINE mode_t __hscore_st_mode ( struct stat* st ) { return st->st_mode; }
-#endif
-
-#if HAVE_TERMIOS_H
-INLINE tcflag_t __hscore_lflag( struct termios* ts ) { return ts->c_lflag; }
-
-INLINE void
-__hscore_poke_lflag( struct termios* ts, tcflag_t t ) { ts->c_lflag = t; }
-
-INLINE unsigned char*
-__hscore_ptr_c_cc( struct termios* ts )
-{ return (unsigned char*) &ts->c_cc; }
-
-INLINE HsInt
-__hscore_sizeof_termios( void )
-{
-#ifndef __MINGW32__
- return sizeof(struct termios);
-#else
- return 0;
-#endif
-}
-#endif
-
-#if !defined(_MSC_VER) && !defined(__MINGW32__) && !defined(_WIN32)
-INLINE HsInt
-__hscore_sizeof_sigset_t( void )
-{
- return sizeof(sigset_t);
-}
-#endif
-
-INLINE int
-__hscore_echo( void )
-{
-#ifdef ECHO
- return ECHO;
-#else
- return 0;
-#endif
-
-}
-
-INLINE int
-__hscore_tcsanow( void )
-{
-#ifdef TCSANOW
- return TCSANOW;
-#else
- return 0;
-#endif
-
-}
-
-INLINE int
-__hscore_icanon( void )
-{
-#ifdef ICANON
- return ICANON;
-#else
- return 0;
-#endif
-}
-
-INLINE int __hscore_vmin( void )
-{
-#ifdef VMIN
- return VMIN;
-#else
- return 0;
-#endif
-}
-
-INLINE int __hscore_vtime( void )
-{
-#ifdef VTIME
- return VTIME;
-#else
- return 0;
-#endif
-}
-
-INLINE int __hscore_sigttou( void )
-{
-#ifdef SIGTTOU
- return SIGTTOU;
-#else
- return 0;
-#endif
-}
-
-INLINE int __hscore_sig_block( void )
-{
-#ifdef SIG_BLOCK
- return SIG_BLOCK;
-#else
- return 0;
-#endif
-}
-
-INLINE int __hscore_sig_setmask( void )
-{
-#ifdef SIG_SETMASK
- return SIG_SETMASK;
-#else
- return 0;
-#endif
-}
-
-INLINE int
-__hscore_f_getfl( void )
-{
-#ifdef F_GETFL
- return F_GETFL;
-#else
- return 0;
-#endif
-}
-
-INLINE int
-__hscore_f_setfl( void )
-{
-#ifdef F_SETFL
- return F_SETFL;
-#else
- return 0;
-#endif
-}
-
-// defined in rts/RtsStartup.c.
-extern void* __hscore_get_saved_termios(int fd);
-extern void __hscore_set_saved_termios(int fd, void* ts);
-
-INLINE int __hscore_hs_fileno (FILE *f) { return fileno (f); }
-
-INLINE int __hscore_open(char *file, int how, mode_t mode) {
-#ifdef __MINGW32__
- if ((how & O_WRONLY) || (how & O_RDWR) || (how & O_APPEND))
- return _sopen(file,how,_SH_DENYRW,mode);
- else
- return _sopen(file,how,_SH_DENYWR,mode);
-#else
- return open(file,how,mode);
-#endif
-}
-
-// These are wrapped because on some OSs (eg. Linux) they are
-// macros which redirect to the 64-bit-off_t versions when large file
-// support is enabled.
-//
-INLINE off_t __hscore_lseek(int fd, off_t off, int whence) {
- return (lseek(fd,off,whence));
-}
-
-INLINE int __hscore_stat(char *file, struct stat *buf) {
- return (stat(file,buf));
-}
-
-INLINE int __hscore_fstat(int fd, struct stat *buf) {
- return (fstat(fd,buf));
-}
-
-// select-related stuff
-
-#if !defined(__MINGW32__)
-INLINE int hsFD_SETSIZE(void) { return FD_SETSIZE; }
-INLINE void hsFD_CLR(int fd, fd_set *fds) { FD_CLR(fd, fds); }
-INLINE int hsFD_ISSET(int fd, fd_set *fds) { return FD_ISSET(fd, fds); }
-INLINE void hsFD_SET(int fd, fd_set *fds) { FD_SET(fd, fds); }
-INLINE HsInt sizeof_fd_set(void) { return sizeof(fd_set); }
-extern void hsFD_ZERO(fd_set *fds);
-#endif
-
-// gettimeofday()-related
-
-#if !defined(__MINGW32__)
-
-INLINE HsInt sizeofTimeVal(void) { return sizeof(struct timeval); }
-
-INLINE HsWord64 getUSecOfDay(void)
-{
- struct timeval tv;
- gettimeofday(&tv, (struct timezone *) NULL);
- // Don't forget to cast *before* doing the arithmetic, otherwise
- // the arithmetic happens at the type of tv_sec, which is probably
- // only 'int'.
- return ((HsWord64)tv.tv_sec * 1000000 + (HsWord64)tv.tv_usec);
-}
-
-INLINE void setTimevalTicks(struct timeval *p, HsWord64 usecs)
-{
- p->tv_sec = usecs / 1000000;
- p->tv_usec = usecs % 1000000;
-}
-#endif /* !defined(__MINGW32__) */
-
-// Directory-related
-
-#if defined(__MINGW32__)
-
-/* Make sure we've got the reqd CSIDL_ constants in scope;
- * w32api header files are lagging a bit in defining the full set.
- */
-#if !defined(CSIDL_APPDATA)
-#define CSIDL_APPDATA 0x001a
-#endif
-#if !defined(CSIDL_PERSONAL)
-#define CSIDL_PERSONAL 0x0005
-#endif
-#if !defined(CSIDL_PROFILE)
-#define CSIDL_PROFILE 0x0028
-#endif
-#if !defined(CSIDL_WINDOWS)
-#define CSIDL_WINDOWS 0x0024
-#endif
-
-INLINE int __hscore_CSIDL_PROFILE() { return CSIDL_PROFILE; }
-INLINE int __hscore_CSIDL_APPDATA() { return CSIDL_APPDATA; }
-INLINE int __hscore_CSIDL_WINDOWS() { return CSIDL_WINDOWS; }
-INLINE int __hscore_CSIDL_PERSONAL() { return CSIDL_PERSONAL; }
-#endif
-
-#if defined(__MINGW32__)
-INLINE unsigned int __hscore_get_osver(void) { return _osver; }
-#endif
-
-/* ToDo: write a feature test that doesn't assume 'environ' to
- * be in scope at link-time. */
-extern char** environ;
-INLINE char **__hscore_environ() { return environ; }
-
-/* lossless conversions between pointers and integral types */
-INLINE void * __hscore_from_uintptr(uintptr_t n) { return (void *)n; }
-INLINE void * __hscore_from_intptr (intptr_t n) { return (void *)n; }
-INLINE uintptr_t __hscore_to_uintptr (void *p) { return (uintptr_t)p; }
-INLINE intptr_t __hscore_to_intptr (void *p) { return (intptr_t)p; }
-
-#endif /* __HSBASE_H__ */
-
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2001-2004
+ *
+ * Definitions for package `directory' which are visible in Haskell land.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef __HSDIRECTORY_H__
+#define __HSDIRECTORY_H__
+
+#include "HsDirectoryConfig.h"
+
+#if HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+#if HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#if HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+#include "HsFFI.h"
+
+#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
+extern int __hscore_getFolderPath(HWND hwndOwner,
+ int nFolder,
+ HANDLE hToken,
+ DWORD dwFlags,
+ char* pszPath);
+#endif
+
+/* -----------------------------------------------------------------------------
+ INLINE functions.
+
+ These functions are given as inlines here for when compiling via C,
+ but we also generate static versions into the cbits library for
+ when compiling to native code.
+ -------------------------------------------------------------------------- */
+
+#ifndef INLINE
+# if defined(_MSC_VER)
+# define INLINE extern __inline
+# else
+# define INLINE static inline
+# endif
+#endif
+
+#ifdef PATH_MAX
+/* A size that will contain many path names, but not necessarily all
+ * (PATH_MAX is not defined on systems with unlimited path length,
+ * e.g. the Hurd).
+ */
+INLINE HsInt __hscore_long_path_size() { return PATH_MAX; }
+#else
+INLINE HsInt __hscore_long_path_size() { return 4096; }
+#endif
+
+#ifdef R_OK
+INLINE int __hscore_R_OK() { return R_OK; }
+#endif
+#ifdef W_OK
+INLINE int __hscore_W_OK() { return W_OK; }
+#endif
+#ifdef X_OK
+INLINE int __hscore_X_OK() { return X_OK; }
+#endif
+
+#ifdef S_IRUSR
+INLINE mode_t __hscore_S_IRUSR() { return S_IRUSR; }
+#endif
+#ifdef S_IWUSR
+INLINE mode_t __hscore_S_IWUSR() { return S_IWUSR; }
+#endif
+#ifdef S_IXUSR
+INLINE mode_t __hscore_S_IXUSR() { return S_IXUSR; }
+#endif
+
+#if defined(__MINGW32__)
+
+/* Make sure we've got the reqd CSIDL_ constants in scope;
+ * w32api header files are lagging a bit in defining the full set.
+ */
+#if !defined(CSIDL_APPDATA)
+#define CSIDL_APPDATA 0x001a
+#endif
+#if !defined(CSIDL_PERSONAL)
+#define CSIDL_PERSONAL 0x0005
+#endif
+#if !defined(CSIDL_PROFILE)
+#define CSIDL_PROFILE 0x0028
+#endif
+#if !defined(CSIDL_WINDOWS)
+#define CSIDL_WINDOWS 0x0024
+#endif
+
+INLINE int __hscore_CSIDL_PROFILE() { return CSIDL_PROFILE; }
+INLINE int __hscore_CSIDL_APPDATA() { return CSIDL_APPDATA; }
+INLINE int __hscore_CSIDL_WINDOWS() { return CSIDL_WINDOWS; }
+INLINE int __hscore_CSIDL_PERSONAL() { return CSIDL_PERSONAL; }
+#endif
+
+#endif /* __HSDIRECTORY_H__ */
+
+++ /dev/null
-# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.6 2005/03/02 16:39:57 ross Exp $
-
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-H_FILES = $(wildcard *.h)
-
-includedir = $(libdir)/include
-INSTALL_INCLUDES = $(H_FILES)
-
-DIST_CLEAN_FILES += HsBaseConfig.h
-
-include $(TOP)/mk/target.mk
+++ /dev/null
-/* ----------------------------------------------------------------------------
- * Macros to help make Typeable instances.
- *
- * INSTANCE_TYPEABLEn(tc,tcname,"tc") defines
- *
- * instance Typeable/n/ tc
- * instance Typeable a => Typeable/n-1/ (tc a)
- * instance (Typeable a, Typeable b) => Typeable/n-2/ (tc a b)
- * ...
- * instance (Typeable a1, ..., Typeable an) => Typeable (tc a1 ... an)
- * -------------------------------------------------------------------------- */
-
-#ifndef TYPEABLE_H
-#define TYPEABLE_H
-
-#define INSTANCE_TYPEABLE0(tycon,tcname,str) \
-tcname = mkTyCon str; \
-instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] }
-
-#ifdef __GLASGOW_HASKELL__
-
-/* For GHC, the extra instances follow from general instance declarations
- * defined in Data.Typeable. */
-
-#define INSTANCE_TYPEABLE1(tycon,tcname,str) \
-tcname = mkTyCon str; \
-instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }
-
-#define INSTANCE_TYPEABLE2(tycon,tcname,str) \
-tcname = mkTyCon str; \
-instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }
-
-#define INSTANCE_TYPEABLE3(tycon,tcname,str) \
-tcname = mkTyCon str; \
-instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }
-
-#else /* !__GLASGOW_HASKELL__ */
-
-#define INSTANCE_TYPEABLE1(tycon,tcname,str) \
-tcname = mkTyCon str; \
-instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \
-instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault }
-
-#define INSTANCE_TYPEABLE2(tycon,tcname,str) \
-tcname = mkTyCon str; \
-instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \
-instance Typeable a => Typeable1 (tycon a) where { \
- typeOf1 = typeOf1Default }; \
-instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \
- typeOf = typeOfDefault }
-
-#define INSTANCE_TYPEABLE3(tycon,tcname,str) \
-tcname = mkTyCon str; \
-instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \
-instance Typeable a => Typeable2 (tycon a) where { \
- typeOf2 = typeOf2Default }; \
-instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \
- typeOf1 = typeOf1Default }; \
-instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \
- typeOf = typeOfDefault }
-
-#endif /* !__GLASGOW_HASKELL__ */
-
-#endif
+++ /dev/null
-#ifndef WCSUBST_INCL
-
-#define WCSUBST_INCL
-
-#include <stdlib.h>
-
-int u_iswupper(int wc);
-int u_iswdigit(int wc);
-int u_iswalpha(int wc);
-int u_iswcntrl(int wc);
-int u_iswspace(int wc);
-int u_iswprint(int wc);
-int u_iswlower(int wc);
-
-int u_iswalnum(int wc);
-
-int u_towlower(int wc);
-int u_towupper(int wc);
-int u_towtitle(int wc);
-
-int u_gencat(int wc);
-
-#endif
-
+++ /dev/null
-/*
- * (c) The University of Glasgow, 2000-2002
- *
- * Win32 Console API helpers.
- */
-#ifndef __CONSUTILS_H__
-#define __CONSUTILS_H__
-extern int set_console_buffering__(int fd, int cooked);
-extern int set_console_echo__(int fd, int on);
-extern int get_console_echo__(int fd);
-extern int flush_input_console__ (int fd);
-#endif
+++ /dev/null
-/*
- * (c) The University of Glasgow 2002
- *
- * Directory Runtime Support
- */
-#ifndef __DIRUTILS_H__
-#define __DIRUTILS_H__
-
-extern int __hscore_readdir(DIR *dirPtr, struct dirent **pDirEnt);
-extern int __hscore_renameFile(char *src, char *dest);
-
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
-extern int __hscore_getFolderPath(HWND hwndOwner,
- int nFolder,
- HANDLE hToken,
- DWORD dwFlags,
- char* pszPath);
-#endif
-
-#endif /* __DIRUTILS_H__ */
+++ /dev/null
-
-void fps_reverse(unsigned char *dest, unsigned char *from, unsigned long len);
-void fps_intersperse(unsigned char *dest, unsigned char *from, unsigned long len, unsigned char c);
-unsigned char fps_maximum(unsigned char *p, unsigned long len);
-unsigned char fps_minimum(unsigned char *p, unsigned long len);
-unsigned long fps_count(unsigned char *p, unsigned long len, unsigned char w);
+++ /dev/null
-/*
- * (c) The University of Glasgow 2001
- *
- * $Id: lockFile.h,v 1.3 2005/01/28 13:36:34 simonmar Exp $
- *
- * lockFile header
- */
-
-#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32))
-
-int lockFile(int fd, int for_writing, int exclusive);
-int unlockFile(int fd);
-
-#endif
+++ /dev/null
-/* ----------------------------------------------------------------------------
- (c) The University of Glasgow 2004
-
- Interface for code in runProcess.c (providing support for System.Process)
- ------------------------------------------------------------------------- */
-
-#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32))
-typedef pid_t ProcHandle;
-#else
-// Should really be intptr_t, but we don't have that type on the Haskell side
-typedef long ProcHandle;
-#endif
-
-#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32))
-
-extern ProcHandle runProcess( char *const args[],
- char *workingDirectory, char **environment,
- int fdStdInput, int fdStdOutput, int fdStdError,
- int set_inthandler, long inthandler,
- int set_quithandler, long quithandler);
-
-extern ProcHandle runInteractiveProcess( char *const args[],
- char *workingDirectory,
- char **environment,
- int *pfdStdInput,
- int *pfdStdOutput,
- int *pfdStdError);
-
-#else
-
-extern ProcHandle runProcess( char *cmd,
- char *workingDirectory, void *environment,
- int fdStdInput, int fdStdOutput, int fdStdError);
-
-extern ProcHandle runInteractiveProcess( char *cmd,
- char *workingDirectory,
- void *environment,
- int *pfdStdInput,
- int *pfdStdOutput,
- int *pfdStdError);
-
-#endif
-
-extern int terminateProcess( ProcHandle handle );
-extern int getProcessExitCode( ProcHandle handle, int *pExitCode );
-extern int waitForProcess( ProcHandle handle );
+++ /dev/null
-/*
- * (c) The University of Glasgow 2002
- *
- * Time Runtime Support
- */
-#ifndef __TIMEUTILS_H__
-#define __TIMEUTILS_H__
-
-extern long *__hscore_timezone( void );
-extern char **__hscore_tzname( void );
-
-#endif /* __DIRUTILS_H__ */
+++ /dev/null
-#include "ghcconfig.h"
-
-name: PACKAGE
-version: VERSION
-license: BSD3
-maintainer: libraries@haskell.org
-exposed: True
-
-exposed-modules:
- Control.Applicative,
- Control.Arrow,
- Control.Concurrent,
- Control.Concurrent.Chan,
- Control.Concurrent.MVar,
- Control.Concurrent.QSem,
- Control.Concurrent.QSemN,
- Control.Concurrent.SampleVar,
- Control.Exception,
- Control.Monad,
- Control.Monad.Fix,
- Control.Monad.Instances,
- Control.Monad.ST,
- Control.Monad.ST.Lazy,
- Control.Monad.ST.Strict,
- Control.Parallel,
- Control.Parallel.Strategies,
- Data.Array,
- Data.Array.Base,
- Data.Array.Diff,
- Data.Array.IArray,
- Data.Array.IO,
- Data.Array.MArray,
- Data.Array.ST,
- Data.Array.Storable,
- Data.Array.Unboxed,
- Data.Bits,
- Data.Bool,
- Data.ByteString,
- Data.ByteString.Char8,
- Data.ByteString.Lazy
- Data.ByteString.Lazy.Char8
- Data.ByteString.Base
- Data.ByteString.Fusion
- Data.Char,
- Data.Complex,
- Data.Dynamic,
- Data.Either,
- Data.Eq,
- Data.Fixed,
- Data.Foldable,
- Data.Function,
- Data.Generics,
- Data.Generics.Aliases,
- Data.Generics.Basics,
- Data.Generics.Instances,
- Data.Generics.Schemes,
- Data.Generics.Text,
- Data.Generics.Twins,
- Data.Graph,
- Data.HashTable,
- Data.IORef,
- Data.Int,
- Data.IntMap,
- Data.IntSet,
- Data.Ix,
- Data.List,
- Data.Maybe,
- Data.Map,
- Data.Monoid,
- Data.Ord,
- Data.PackedString,
- Data.Ratio,
- Data.STRef,
- Data.STRef.Lazy,
- Data.STRef.Strict,
- Data.Sequence,
- Data.Set,
- Data.String,
- Data.Traversable,
- Data.Tree,
- Data.Tuple,
- Data.Typeable,
- Data.Unique,
- Data.Version,
- Data.Word,
- Debug.Trace,
- Foreign,
- Foreign.C,
- Foreign.C.Error,
- Foreign.C.String,
- Foreign.C.Types,
- Foreign.Concurrent,
- Foreign.ForeignPtr,
- Foreign.Marshal,
- Foreign.Marshal.Alloc,
- Foreign.Marshal.Array,
- Foreign.Marshal.Error,
- Foreign.Marshal.Pool,
- Foreign.Marshal.Utils,
- Foreign.Ptr,
- Foreign.StablePtr,
- Foreign.Storable,
- GHC.ConsoleHandler,
- GHC.Dotnet,
- GHC.Dynamic,
- GHC.Exts,
- GHC.ForeignPtr,
- GHC.Handle,
- GHC.IO,
- GHC.Int,
- GHC.PArr,
- GHC.PrimopWrappers,
- GHC.Unicode,
- GHC.Word,
- Numeric,
- Prelude,
- System.Cmd,
- System.Console.GetOpt,
- System.CPUTime,
- System.Directory,
- System.Directory.Internals,
- System.Environment,
- System.Exit,
- System.IO,
- System.IO.Error,
- System.IO.Unsafe,
- System.Info,
- System.Locale,
- System.Mem,
- System.Mem.StableName,
- System.Mem.Weak,
- System.Posix.Internals,
- System.Posix.Signals,
- System.Posix.Types,
- System.Process,
- System.Process.Internals,
- System.Random,
- System.Time,
- Text.ParserCombinators.ReadP,
- Text.ParserCombinators.ReadPrec,
- Text.PrettyPrint,
- Text.PrettyPrint.HughesPJ,
- Text.Printf,
- Text.Read,
- Text.Read.Lex,
- Text.Show,
- Text.Show.Functions,
- Unsafe.Coerce,
- GHC.Arr,
- GHC.Base,
- GHC.Conc,
- GHC.Enum,
- GHC.Err,
- GHC.Exception,
- GHC.Float,
- GHC.IOBase,
- GHC.List,
- GHC.Num,
- GHC.Pack,
- GHC.Prim,
- GHC.Ptr,
- GHC.Read,
- GHC.Real,
- GHC.ST,
- GHC.STRef,
- GHC.Show,
- GHC.Stable,
- GHC.Storable,
- GHC.TopHandler,
- GHC.Weak
-
-hidden-modules:
- Data.Array.IO.Internals
-
-import-dirs: IMPORT_DIR
-
-library-dirs: LIB_DIR
-#ifndef INSTALLING
- , LIB_DIR"/cbits"
-#endif
-
-hs-libraries: "HSbase"
-
-extra-libraries: "HSbase_cbits"
-#if defined(mingw32_HOST_OS) || defined(__MINGW32__) || defined(_MSC_VER)
- , "wsock32", "msvcrt", "kernel32", "user32", "shell32"
-#endif
-
-include-dirs: INCLUDE_DIR
-includes: HsBase.h
-depends: rts
-hugs-options:
-cc-options:
-ld-options:
-framework-dirs:
-frameworks:
-haddock-interfaces: HADDOCK_IFACE
-haddock-html: HTML_DIR
-This package contains the @Prelude@ and its support libraries, and a large
-collection of useful libraries ranging from data structures to parsing
-combinators and debugging utilities.
+This package provides a library for handling directories.
projects / haskell-directory.git / commitdiff